OOoBasic/Draw/CustomShape

Sub customshape_1
 oDoc = ThisComponent
 oShape = oDoc.createInstance("com.sun.star.drawing.CustomShape")
 oDrawPage = oDoc.getCurrentController().getCurrentPage()

 aPoint = CreateUnoStruct("com.sun.star.awt.Point")
 aSize = CreateUnoStruct("com.sun.star.awt.Size")
 aPoint.X = 0
 aPoint.Y = 0
 aSize.Width = 2500
 aSize.Height = 2500
 oShape.setPosition(aPoint)
 oShape.setSize(aSize)

 oDrawPage.add(oShape)

 ' call after the shape addition to the page
 oShape.createCustomShapeDefaults("octagon")
End Sub

以下のドキュメントは古くなっています。

いまのところマクロなどからカスタムシェープを簡単に作成する方法はないようです。

これらの図形は CustomShapeGeometry プロパティを持っており、形状を決定しています。このプロパティ値を設定すれば同じ図形が描写できます。しかし、このプロパティ値は非常に複雑です。そこで、この値を返す関数として書き出します。

カスタムシェープ

使用方法

新しいドキュメントを一つ作成します。
以下のコードをコピーして Basic のモジュールに貼り付けます。
カスタムシェープの図形描写オブジェクトを描き、選択します。
GetGeomInfo を実行します。
Writer ドキュメントが作成されて何か書き込まれます。
コピーして Basic のモジュールに貼り付けます。

カスタムシェープの作成

カスタムシェープの作成方法です。カスタムシェープの geometry とサイズは独立しています。

Sub CreateCustomShape_1
  oDoc = ThisComponent
  
  oShape = oDoc.createInstance( _
      "com.sun.star.drawing.CustomShape")
  
  aPoint = CreateUnoStruct("com.sun.star.awt.Point")
  aSize = CreateUnoStruct("com.sun.star.awt.Size")
  aPoint.X = 0
  aPoint.Y = 0
  aSize.Width = 2500
  aSize.Height = 2500
  oShape.setPosition(aPoint)
  oShape.setSize(aSize)
  
  oDrawPage = oDoc.getDrawPages().getByIndex(0)
  oDrawPage.add(oShape)
  
  ' set geometry after the addition to the page
  aGeom = getGeom_smiley
 
  oShape.CustomShapeGeometry = aGeom
End Sub

一例

ニコちゃんマークで試して作成されたコードです。

' create smiley geometry
Function getGeom_smiley
 
aGluePoints = CreateParameterPairs( Array( _
Array(10800, 0, 0, 0), Array(3160, 0, 3160, 0), _
Array(0, 0, 10800, 0), Array(3160, 0, 18440, 0), _
Array(10800, 0, 21600, 0), Array(18440, 0, 18440, 0), _
Array(21600, 0, 10800, 0), Array(18440, 0, 3160, 0), _
 _
) )
 
aTextFrames = CreatTextFrames( Array( _
Array(3200, 0, 3200, 0, 18400, 0, 18400, 0) _
) )
 
aCoords = CreateParameterPairs( Array( _
Array(10800, 0, 10800, 0), Array(10800, 0, 10800, 0), _
Array(0, 0, 23592960, 0), Array(7305, 0, 7515, 0), _
Array(1165, 0, 1165, 0), Array(0, 0, 23592960, 0), _
Array(14295, 0, 7515, 0), Array(1165, 0, 1165, 0), _
Array(0, 0, 23592960, 0), Array(4870, 0, 1, 1), _
Array(8680, 0, 2, 1), Array(12920, 0, 2, 1), _
Array(16730, 0, 1, 1) _
) )
 
aSegments = CreateSegments( Array( _
Array(9, 1), Array(4, 0), _
Array(5, 0), Array(9, 1), _
Array(4, 0), Array(5, 0), _
Array(9, 1), Array(4, 0), _
Array(5, 0), Array(1, 1), _
Array(3, 1), Array(6, 0), _
Array(5, 0) _
) )
 
Dim aPath(3) As New com.sun.star.beans.PropertyValue
aPath(0).Name = "GluePoints"
aPath(0).Value = aGluePoints
aPath(1).Name = "TextFrames"
aPath(1).Value = aTextFrames
aPath(2).Name = "Coordinates"
aPath(2).Value = aCoords
aPath(3).Name = "Segments"
aPath(3).Value = aSegments
 
sEquations = Array( _
"$0 -15510", "17520-?0 ", "15510+?0 " _
)
aPosition = CreateParameterPair( Array(10800, 0, 0, 2) )
 
 
Dim aHandle0(2) As New com.sun.star.beans.PropertyValue
aHandle0(0).Name = "Position"
aHandle0(0).Value = aPosition
 
 
Dim aG(5) As New com.sun.star.beans.PropertyValue
aG(0).Name = "ViewBox"
aG(0).Value = CreateRectangle(0, 0, 21600, 21600)
aG(1).Name = "Type"
aG(1).Value = "smiley"
aG(2).Name = "AdjustmentValues"
aG(2).Value = Array( CreateECSAdValue(17520, 0) )
aG(3).Name = "Path"
aG(3).Value = aPath
aG(4).Name = "Equations"
aG(4).Value = sEquations
aG(5).Name = "Handles"
aG(5).Value = Array(aHandle0)
getGeom_smiley = aG
End Function

情報取得

カスタムシェープの CustomShapeGeometry を取得、情報を書き出すコードです。

Dim oOutText As Object
 
Sub GetGeomInfo
  oDoc = ThisComponent
  oCurrentSelection = ThisComponent.getCurrentSelection()
  If IsNull(oCurrentSelection) Then
    msgbox "select a drawing object."
    Exit Sub
  End Sub
  oObj1 = oCurrentSelection.getByIndex(0)
  
  If NOT oObj1.supportsService( _
      "com.sun.star.drawing.CustomShape" ) Then  Exit Sub
  
  oOutDoc = StarDesktop.loadComponentFromURL( _
      "private:factory/swriter", "_blank", 0, Array() )
  oOutText = oOutDoc.getText()
  
  aGeom = oObj1.CustomShapeGeometry
  
  n = UBound( aGeom )
  Dim sTxt( n ) As String
  Dim sTxt2( n ) As String
  Dim sShapeTypeName As String
  
  pf = "aG"
  sdq = chr(34)
  slf = chr(10)
  
  For i = 0 To n Step 1
    sName = aGeom(i).Name
    
    Select Case sName
    Case "Type"
      sShapeTypeName = aGeom(i).Value
      sTxt(i) = mk_pv_str( pf, i, "Type", sdq & aGeom(i).Value & sdq )
 
    Case "AdjustmentValues"
      sTxt(i) = mk_pv_str( pf, i, "AdjustmentValues", _
          Get_AdjustmentValues( aGeom(i).Value ) )
      'Txt2 Get_AdjustmentValues( aGeom(i).Value )
      
    Case "ViewBox"
      sTxt(i) = mk_pv_str( pf, i, "ViewBox", _
          Get_ViewBoxValue( aGeom(i).Value ) )
      
    Case "Path"
      sTxt(i) = mk_pv_str( pf, i, "Path", _
          "aPath" )
          Get_PathValue( aGeom(i).Value )
      
    Case "Equations"
      sTxt(i) = mk_pv_str( pf, i, "Equations", _
          "sEquations" )
          Get_Equations( aGeom(i).Value )
      
    Case "Handles"
      sTxt(i) = mk_pv_str( pf, i, "Handles", _
          Get_HandlesValue( aGeom(i).Value ) )
      
    End Select
    
  Next
  
  Out_Put( "Dim " & pf & "(" & CStr(n) & ")" & _
    " As New com.sun.star.beans.PropertyValue" )
  Out_Put( join(sTxt, slf) )
  
  sShapeTypeName = ReplaceHiphen( sShapeTypeName )
  sComments = "' create " & sShapeTypeName & _
       " geometry"
  sfnName = "getGeom_" & sShapeTypeName
  sHeader = sComments & slf & "Function " & sfnName & slf & slf
  
  Out_Put(sfnName & " = " & pf & slf & _
      "End Function" & slf)
  
  NewLine()
  oCursor = oOutText.createTextCursorByRange( oOutText.getStart() )
  oCursor.setString( sHeader )
  oOutDoc.setModified(False)
End Sub
 
 
Function Out_Put( sTxt As String )
  oOutText.appendTextPortion( sTxt & chr(10), Array() )
End Function
 
Function NewLine()
  oOutText.insertControlCharacter( _
    oOutText.getEnd(), 1, False)
End Function
 
 
Function mk_pv_str( prefix, num, vType, value )
  sdq = chr(34)
  slf = chr(10)
  pre = prefix & "(" & cstr(num)
  mk_pv_str = _
      pre & ").Name = " & sdq & vType & sdq & slf & _
      pre & ").Value = " & value
End Function
 
 
Function Get_ParameterPairs( aPairs )
  sFnName = "CreateParameterPairs"
  slf = chr(10)
  
  n = UBound( aPairs )
  Dim sTxt(n) As String
  
  For i = 0 To n Step 1
    aPair = aPairs(i)
    aFirst = aPair.First
    aSecond = aPair.Second
    
    sTxt(i) = "Array(" & _
        CStr(aFirst.Value) & ", " & CStr(aFirst.Type) & ", " & _
        CStr(aSecond.Value) & ", " & CStr(aSecond.Type) & _
        ")"
  Next
  s = ""
  for i = 0 To n Step 1
    if (i mod 2) = 0 Then
      s = s & sTxt(i)
    Else
      s = s & ", " & sTxt(i) & ", _" & slf
    End If
  next
  Get_ParameterPairs = sFnName & "( " & "Array( _" & slf & _
      s & " _" & slf & ") )"
  'Get_ParameterPairs = sFnName & "( " & "Array( _" & slf & _
  '    join(sTxt, ", _" & slf) & " _" & slf & ") )"
End Function
 
 
Function Get_Segments( aSegments )
  sfnName = "CreateSegments"
  slf = chr(10)
  
  n = UBound( aSegments )
  Dim sTxt(n) As String
  
  For i = 0 To n Step 1
    aSegment = aSegments(i)
    
    sTxt(i) = "Array(" & CStr(aSegment.Command) & ", " & _
        CStr(aSegment.Count) & ")"
  Next
  s = ""
  for i = 0 To n Step 1
    if (i mod 2) = 0 Then
      s = s & sTxt(i)
    Else
      s = s & ", " & sTxt(i) & ", _" & slf
    End If
  next
  Get_Segments = sfnName & "( " & "Array( _" & slf & _
      s & " _" & slf & ") )"
  'Get_Segments = sfnName & "( " & "Array( _" & slf & _
  '    join(sTxt, ", _" & slf) & " _" & slf & ") )"
End Function
 
 
Function Get_PathValue( oPath )
  n = UBound( oPath )
  Dim sTxt(n) As String
  pf = "aPath"
  
  For i = 0 To n Step 1
    sName = oPath(i).Name
    
    Select Case sName
    Case "Coordinates"
       sTxt(i) = mk_pv_str( pf, i, "Coordinates", "aCoords" )
           Out_Put( "aCoords = " & _
             Get_ParameterPairs( oPath(i).Value ) )
       
    Case "TextFrames"
       sTxt(i) = mk_pv_str( pf, i, "TextFrames", "aTextFrames" )
          Out_Put( "aTextFrames = " & _
              Get_TextFrame( oPath(i).Value ) )
       
    Case "Segments"
      sTxt(i) = mk_pv_str( pf, i, "Segments", "aSegments" )
        Out_Put( "aSegments = " & _
            Get_Segments( oPath(i).Value ) )
      
    Case "GluePoints"
      sTxt(i) = mk_pv_str( pf, i, "GluePoints", "aGluePoints" )
          Out_Put( "aGluePoints = " & _
              Get_ParameterPairs( oPath(i).Value ) )
    
    End Select
    NewLine()
  Next
  
  Out_Put("Dim " & pf & "(" & CStr(n) & ")" & _
    " As New com.sun.star.beans.PropertyValue" )
  Out_Put( join( sTxt, chr(10) ) )
  NewLine()
End Function
 
 
Function Get_TextFrame( Frames )
  sfnName = "CreatTextFrames"
  slf = chr(10)
  n = UBound( Frames )
  Dim sTxt(n) As String
  For i = 0 To n Step 1
    frame = Frames(i)
    sTxt(i) = "Array(" & Get_FrameValue( frame ) & ")"
  Next
  
  Get_TextFrame = sfnName & "( " & "Array( _" & slf & _
      join(sTxt, ", _" & slf) & " _" & slf & ") )"
End Function
 
 
Function Get_FrameValue( Frame )
  aTopLeft = Frame.TopLeft
  aBottomRight = Frame.BottomRight
  aTLFirst = aTopLeft.First
  aTLSecond = aTopLeft.Second
  aBRFirst = aBottomRight.First
  aBRSecond = aBottomRight.Second
  
  Get_FrameValue = join( Array( _
      aTLFirst.Value, aTLFirst.Type, aTLSecond.Value, aTLSecond.Type, _
      aBRFirst.Value, aBRFirst.Type, aBRSecond.Value, aBRSecond.Type ), _
      ", " )
End Function
 
 
Function Get_HandlesValue( Handles )
  n = UBound( Handles )
  Dim sTxt(n)
  
  For i = 0 To n Step 1
    sTxt(i) = "aHandle" & CStr(i)
    Get_HandleValue( Handles(i), i )
  Next
  Get_HandlesValue = "Array(" & join(sTxt, ", ") & ")"
End Function
 
 
Function Get_HandleValue( Handle, num )
  n = UBound( Handle )
  Dim sTxt(n) As String
  For i = 0 To n Step 1
    sName = Handle(i).Name
    
    hd = "aHandle"
    pf = "aHandle" & CStr(num)
    
    Select Case sName
    Case "Position"
      sTxt(i) = mk_pv_str( pf, i, "Position", "aPosition" )
        Out_Put( "aPosition = " & Get_Position( Handle(i).Value ) )
      
    Case "RangeXMinimum"
      sTxt(i) = mk_pv_str( pf, i, "RangeXMinimum", "aRangeXMinimum" )
        Out_Put( "aRangeXMinimum = " & Get_Parameter( Handle(i).Value ) )
      
    Case "RangeXMaximum"
      sTxt(i) = mk_pv_str( pf, i, "RangeXMaximum", "aRangeXMaximum" )
         Out_Put( "aRangeXMaximum = " & Get_Parameter( Handle(i).Value ) )
      
    End Select
    NewLine()
  Next
  Out_Put("Dim " & hd & CStr(num) & "(" & Cstr(n) & ")" & _
    " As New com.sun.star.beans.PropertyValue" )
  Out_Put(join(sTxt, chr(10)))
  NewLine()
End Function
 
 
Function Get_Parameter( aPair )
  sFnName = "CreateECSParameter"
  
  Get_Parameter = sFnName & "(" & _
      CStr(aPair.Value) & ", " & CStr(aPair.Type) & ")"
End Function
 
 
Function Get_Position( aPos )
  sFnName = "CreateParameterPair"
  
  aFirst = aPos.First
  aSecond = aPos.Second
  
  v = IIf( IsEmpty(aSecond.Value), "None", CStr(aSecond.Value) )
    
  
  Get_Position = sFnName & "( " & _
      "Array(" & CStr(aFirst.Value) & ", " & CStr(aFirst.Type) & ", " & _
      v & ", " & CStr(aSecond.Type) & ") )"
End Function
 
 
Function Get_ViewBoxValue( aRect )
  sFnName = "CreateRectangle"
  Get_ViewBoxValue = sFnName & "(" & _
      CStr(aRect.X) & ", " & CStr(aRect.Y) & ", " & _
      CStr(aRect.Width) & ", " & CStr(aRect.Height) & ")"
End Function
 
 
Function Get_AdjustmentValues( aECSAdValues )
  sFnName = "CreateECSAdValue"
  slf = chr(10)
  n = UBound( aECSAdValues )
  If n > -1 Then
  Dim sTxt(n) As String
  
  For i = 0 To n step 1
    sTxt(i) = sFnName & "(" & CStr(aECSAdValues(i).Value) & _
        ", " & CStr(aECSAdValues(i).State) & ")"
  Next
  
  Get_AdjustmentValues = "Array( " & _
      join(sTxt, ", _" & chr(10)) & " )"
  Else
    Get_AdjustmentValues = "None"
  End If
End Function
 
 
Function Get_Equations( sEqs ) As String
  sdq = chr(34)
  slf = chr(10)
  s = sdq & sEqs(0) & sdq & ", "
  
  For i = 1 To UBound( sEqs ) step 1
    If i mod 5 = 4 Then
      s = s & sdq & sEqs(i) & sdq & ", _" & slf
    Else
      s = s & sdq & sEqs(i) & sdq & ", "
    End If
  Next
 
  Out_Put( _
      "sEquations = Array( _" & slf & _
      Mid(s,1,Len(s) -2) & " _" & slf & ")" )
End Function
 
 
Function ReplaceHiphen( ByVal sTxt ) As String
  n = InStr(sTxt, "-")
  While n > 0
    sTxt = Mid(sTxt,1,n -1) & "_" & Mid(sTxt,n +1)
    n = InStr(sTxt,"-")
  WEnd
  ReplaceHiphen = sTxt
End Function

関数群

上記のコードで生成されたコードを実行するときに必要になる関数たちです。

Function CreateECSParameterPair( _
    aFirst As com.sun.star.drawing.EnhancedCustomShapeParameter, _
    aSecond As com.sun.star.drawing.EnhancedCustomShapeParameter ) As _
    com.sun.star.drawing.EnhancedCustomShapeParameterPair
  
  aPair = CreateUnoStruct( _
      "com.sun.star.drawing.EnhancedCustomShapeParameterPair")
  
  aPair.First = aFirst
  aPair.Second = aSecond
  CreateECSParameterPair = aPair
End Function
 
 
Function CreateECSParameter( _
    nValue As Long, nType As Integer ) As _
    com.sun.star.drawing.EnhancedCustomShapeParameter
  
  aParam = CreateUnoStruct( _
      "com.sun.star.drawing.EnhancedCustomShapeParameter")
  
  aParam.Value = nValue
  aParam.Type = nType
  CreateECsParameter = aParam
End Function
 
 
Function CreateECSAdValue( _
    vValue As Variant, nState As Long ) As _
    com.sun.star.drawing.EnhancedCustomShapeAdjustmentValue
  aAdjustment = CreateUnoStruct( _
      "com.sun.star.drawing.EnhancedCustomShapeAdjustmentValue")
  aAdjustment.Value = vValue
  aAdjustment.State = nState
  CreateECSAdValue = aAdjustment
End Function
 
 
Function CreateRectangle( _
    nX As Long, nY As Long, nWidth As Long, nHeight As Long ) As _
    com.sun.star.awt.Rectangle
  aRect = CreateUnoStruct( _
      "com.sun.star.awt.Rectangle")
  aRect.X = nX
  aRect.Y = nY
  aRect.Width = nWidth
  aRect.Height = nHeight
  CreateRectangle = aRect
End Function
 
 
Function CreateParameterPair( nPair ) As Object
  
  Dim aPair As New com.sun.star.drawing.EnhancedCustomShapeParameterPair
  
  aPair.First = CreateECsParameter( nPair(0), nPair(1) )
  aPair.Second = CreateECsParameter( nPair(2), nPair(3) )
  CreateParameterPair = aPair
End Function
 
 
Function CreateParameterPairs( nPairs ) As Object
  n = UBound( nPairs )
  Dim aPairs(n) As New com.sun.star.drawing.EnhancedCustomShapeParameterPair
  
  For i = 0 To n Step 1
    nPair = nPairs(i)
    
    aPairs(i).First = CreateECsParameter( nPair(0), nPair(1) )
    aPairs(i).Second = CreateECsParameter( nPair(2), nPair(3) )
  Next
  CreateParameterPairs = aPairs
End Function
 
 
Function CreatTextFrames( nPositions )As Object
  n = UBound( nPositions )
  Dim aTextFrames(n) As New com.sun.star.drawing.EnhancedCustomShapeTextFrame
  
  For i = 0 To n Step 1
    nCoord = nPositions(i)
    
    aTextFrames(i).TopLeft = _
        CreateECSParameterPair( _
            CreateECsParameter( nCoord(0), nCoord(1) ), _
            CreateECsParameter( nCoord(2), nCoord(3) ) )
    aTextFrames(i).BottomRight = _
        CreateECSParameterPair( _
            CreateECsParameter( nCoord(4), nCoord(5) ), _
            CreateECsParameter( nCoord(6), nCoord(7) ) )
  Next
  CreatTextFrames = aTextFrames
End Function
 
 
Function CreateSegments( nSegments ) As Object
  n = UBound( nSegments )
  Dim aSegments(n) As New com.sun.star.drawing.EnhancedCustomShapeSegment
  
  For i = 0 To n Step 1
    nSeg = nSegments(i)
    
    aSegments(i).Command = nSeg(0)
    aSegments(i).Count = nSeg(1)
  Next
  CreateSegments = aSegments
End Function

OOoBasic/Draw/CustomShape

Menu

Search

recent(15)

カスタムシェープ

使用方法

カスタムシェープの作成

一例

情報取得

関数群