[Solved] Draw: Cut PolyLine(s) to drawing area

Creating a macro - Writing a Script - Using the API

[Solved] Draw: Cut PolyLine(s) to drawing area

Postby jep » Tue Oct 29, 2019 5:36 pm

I've created a script to adjust imported PDF from a drawing application.
It has to cut off lines that extend beyond the edge of the drawing area/paper.
I want to cut them down to the paper size minus paper margins.

Just as the menu option "Intersect" that you can find in Draw under Modify->Shapes->Insersect

How can this be achieved?

Code: Select all   Expand viewCollapse view
Type Insets
   left As Integer
   bottom as Integer
   right As Integer
   top As Integer
End Type

Sub Main
   Dim pageSize As New com.sun.star.awt.Size
   Dim margins As New Insets
   pageSize.Width = 297 * 100
   pageSize.Height = 210 * 100
   margins.left = 10 * 100
   margins.bottom = 10 * 100
   margins.right = 10 * 100
   margins.top = 10 * 100
   CleanUp( pageSize, margins )
End Sub

Sub PageSetup( drawPage As Object, pageSize As New com.sun.star.awt.Size, margins As Insets )

   If drawPage.Orientation = com.sun.star.view.PaperOrientation.LANDSCAPE Then
      drawPage.Width = pageSize.Height
      drawPage.Height = pageSize.Width
   Else
      drawPage.Width = pageSize.Width
      drawPage.Height = pageSize.Height
   End If
   If Not isNUll( margins.top ) Then
      drawPage.BorderTop = margins.top
   End If
   If Not isNUll( margins.bottom ) Then
      drawPage.BorderBottom = margins.bottom
   End If
   If Not isNUll( margins.left ) Then
      drawPage.BorderLeft = margins.left
   End If
   If Not isNUll( margins.right ) Then
      drawPage.BorderRight = margins.right
   End If
End Sub

Sub AddRectangle( drawPage As Object, rectangle As New com.sun.star.awt.Rectangle )
   Dim RectangelShape As Object
   Dim Point As New com.sun.star.awt.Point
   Dim Size As New com.sun.star.awt.Size
   Point.x = rectangle.X
   Point.y = rectangle.Y
   Size.Width = rectangle.Width
   Size.Height = rectangle.Height
   RectangleShape = ThisComponent.createInstance( "com.sun.star.drawing.RectangleShape" )
   'RectangleShape.Size = rectangle
   'RectangleShape.Position = rectangle
   RectangleShape.Size = Size
   RectangleShape.Position = Point
   drawPage.add( RectangleShape )
End Sub

Sub CleanUp( pageSize As New com.sun.star.awt.Size, margins As Insets )
   Dim Doc As Object
   Dim drawObject as Object
   Dim oDrawPage as Object   
   Dim rectangle As New com.sun.star.awt.Rectangle
   Dim c As Long
   Dim i As Long

   rectangle.X = margins.Top
   rectangle.Y = margins.Left
   rectangle.Width = pageSize.Width - margins.Left - margins.Right
   rectangle.Height = pageSize.Height - margins.Top - margins.Bottom
   Doc = ThisComponent
   For i = 0 to Doc.getDrawPages().Count - 1       
      oDrawPage = Doc.getDrawPages().getByIndex( i )
      PageSetup( oDrawPage, pageSize, margins )
      c = oDrawPage.count
      i = c
      Do While i >= 1
         drawobject = oDrawPage( i - 1 )
         if drawobject.ShapeType = "com.sun.star.drawing.LineShape" or drawobject.ShapeType = "com.sun.star.drawing.PolyLineShape" Then
            'if drawobject.Text.LineColor = RGB( 0, 0, 0 ) Then
            '    drawobject.LineColor = RGB( 158, 164, 255 )
            'else
            if drawobject.Text.LineColor = RGB( 0, 255, 255 ) Then
               drawobject.LineStyle = 1
               drawobject.LineWidth = 100
               drawobject.LineColor = 255
            elseif drawobject.Text.LineColor = RGB( 174, 6, 182 ) Then
               drawobject.LineDashName = "Fine Dashed (var)"
               drawobject.LineWidth = 80
            elseif drawobject.Text.LineColor = RGB( 158, 164, 255 ) Then
               oDrawPage.remove( drawObject )
               c = i
            endif
            AddRectangle( oDrawPage, rectangle )
         elseif drawobject.ShapeType = "com.sun.star.drawing.GraphicObjectShape" then
            'This part is also a problem as Bitmap images appear in black while "Transparent Bitmap" appear as they should except one Transparent Bitmap that show up as "Bitmap", strange.
            if drawobject.FillColor = 13625333 And drawobject.UINameSingular = "Bitmap" And c - i < 6 Then
               oDrawPage.remove( drawObject )
               c = i
            endif
         endif
         i = i - 1
      Loop
   Next i
End Sub

Sub getRGB( lRGB As Long ) As String
   lColors = lRGB \ 256
   lRed = lColors \ 256
   lGreen = lColors - lRed * 256
   lBlue = lRGB - 256 * lColors
   getRGB = lRed & ", " & lGreen & ", " & lBlue
End Sub
Last edited by jep on Wed Oct 30, 2019 2:31 pm, edited 1 time in total.
OpenOffice 4.1.3 on eComStation v2.2 / ArcaOS 5.0
jep
 
Posts: 14
Joined: Wed Sep 29, 2010 4:53 pm

[Solved] Draw: Cut PolyLine(s) to drawing area

Postby jep » Wed Oct 30, 2019 2:30 pm

And here is the code... for now.

Code: Select all   Expand viewCollapse view
Type Insets
   left As Long
   bottom as Long
   right As Long
   top As Long
End Type

Sub Main
   'Globalscope.BasicLibraries.LoadLibrary( "MRILib" )
   Dim pageSize As New com.sun.star.awt.Size
   Dim margins As New Insets
   pageSize.Width = 297 * 100
   pageSize.Height = 210 * 100
   margins.left = 4.2 * 100
   margins.bottom = 4.4 * 100
   margins.right = 4.4 * 100
   margins.top = 4.2 * 100
   CleanUp( pageSize, margins )
End Sub

Sub PageSetup( drawPage As Object, pageSize As New com.sun.star.awt.Size, margins As Insets )

   If pageSize.Width < pageSize.Height And drawPage.Orientation = com.sun.star.view.PaperOrientation.LANDSCAPE Then
      Dim lTemp As Long
      lTemp = pageSize.Height
      pageSize.Height = pageSize.Width
      pageSize.Width = lTemp
   EndIf
   
   drawPage.Width = pageSize.Width
   drawPage.Height = pageSize.Height
   'End If
   If Not isNUll( margins.top ) Then
      drawPage.BorderTop = margins.top
   End If
   If Not isNUll( margins.bottom ) Then
      drawPage.BorderBottom = margins.bottom
   End If
   If Not isNUll( margins.left ) Then
      drawPage.BorderLeft = margins.left
   End If
   If Not isNUll( margins.right ) Then
      drawPage.BorderRight = margins.right
   End If
End Sub

Sub AddRectangle( drawPage As Object, rectangle As New com.sun.star.awt.Rectangle ) As Object
   Dim RectangelShape As Object
   Dim Point As New com.sun.star.awt.Point
   Dim Size As New com.sun.star.awt.Size
   Point.x = rectangle.X
   Point.y = rectangle.Y
   Size.Width = rectangle.Width
   Size.Height = rectangle.Height
   RectangleShape = ThisComponent.createInstance( "com.sun.star.drawing.RectangleShape" )
   RectangleShape.Size = Size
   RectangleShape.Position = Point
   RectangleShape.FillStyle = com.sun.star.drawing.FillStyle.SOLID
   RectangleShape.FillTransparence = 100
   RectangleShape.FillColor = RGB( 0, 0, 0 )
   drawPage.add( RectangleShape )   
   AddRectangle = RectangleShape
End Sub

Sub BooleanSubtract( oDrawDoc As Object, oShape As Object )
   ' Conversion into polygons and dissociation of objects with the dispatcher.
   dispatcher = createUnoService( "com.sun.star.frame.DispatchHelper" )
   oDrawDoc.currentController.select( oShape )                         ' Visible selection.
   dispatcher.executeDispatch( oDrawDoc.currentController.Frame, ".uno:Intersect", "", 0, array() )
End Sub

Sub CleanUp( pageSize As New com.sun.star.awt.Size, margins As Insets )
   Dim drawObject as Object
   Dim oDrawPage as Object
   Dim oRectangle as Object
   Dim rectangle As New com.sun.star.awt.Rectangle
   Dim c As Long
   Dim i As Long
   
         

   rectangle.X = margins.Top
   rectangle.Y = margins.Left
   rectangle.Width = pageSize.Width - margins.Left - margins.Right
   rectangle.Height = pageSize.Height - margins.Top - margins.Bottom
   For i = 0 to ThisComponent.getDrawPages().Count - 1       
      oDrawPage = ThisComponent.getDrawPages().getByIndex( i )
      PageSetup( oDrawPage, pageSize, margins )
      i = oDrawPage.count
      Do While i >= 1
         drawobject = oDrawPage( i - 1 )
         If drawobject.ShapeType = "com.sun.star.drawing.LineShape" Or drawobject.ShapeType = "com.sun.star.drawing.PolyLineShape" Then
            If drawobject.Text.LineColor = RGB( 158, 164, 255 ) Then
               oDrawPage.remove( drawObject )
            Else
               If drawobject.Text.LineColor = RGB( 0, 255, 255 ) Then
                  drawobject.LineStyle = 1
                  drawobject.LineWidth = 100
                  drawobject.LineColor = 255
               ElseIf drawobject.Text.LineColor = RGB( 174, 6, 182 ) Then
                  drawobject.LineDashName = "Fine Dashed (var)"
                  drawobject.LineWidth = 80
               EndIf
               Shapes = createUnoService("com.sun.star.drawing.ShapeCollection")
            Shapes.add( AddRectangle( oDrawPage, rectangle ) )
               Shapes.add( drawobject )
              BooleanSubtract( ThisComponent, Shapes )
            If Shapes.Count = 2 Then
                 oDrawPage.remove( Shapes.getByIndex( 1 ) )
             EndIf
            EndIf
         ElseIf drawobject.ShapeType = "com.sun.star.drawing.GraphicObjectShape" Then
            'This part is also a problem as Bitmap images appear in black while "Transparent Bitmap" appear as they should except one Transparent Bitmap that show up as "Bitmap", strange.
            If drawobject.FillColor = RGB( 207, 231, 245 ) And drawobject.UINameSingular = "Bitmap" Then
               Dim bmp() As Byte
               bmp = drawobject.GraphicObjectFillBitmap.getDIB()
            If 0 = bmp( LBound( bmp ) + 1078 ) Then
                  oDrawPage.remove( drawObject )
               EndIf
               c = i
            EndIf
         EndIf
         i = i - 1
      Loop
   Next i
End Sub

Sub getRGB( lRGB As Long ) As String
   lColors = lRGB \ 256
   lRed = lColors \ 256
   lGreen = lColors - lRed * 256
   lBlue = lRGB - 256 * lColors
   getRGB = lRed & ", " & lGreen & ", " & lBlue
End Sub
OpenOffice 4.1.3 on eComStation v2.2 / ArcaOS 5.0
jep
 
Posts: 14
Joined: Wed Sep 29, 2010 4:53 pm


Return to Macros and UNO API

Who is online

Users browsing this forum: No registered users and 8 guests