*カスタムシェープ [#ye8f7885]
[[図形>OOoBasic/Draw/Shapes]]で取り上げている以外の図形描写オブジェクトはカスタムシェープ com.sun.star.drawing.CustomShape サービスで描かれています。
次のようにすると作成できます。利用できるカスタムシェープの種類はバージョンに依存します。com.sun.star.drawing.XEnhancedCustomShapeDefaulter インターフェースの説明に利用できるカスタムシェープ名が列挙されています。
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 プロパティを持っており、形状を決定しています。このプロパティ値を設定すれば同じ図形が描写できます。しかし、このプロパティ値は非常に複雑です。そこで、この値を返す関数として書き出します。
#contents
**使用方法 [#t50aae1a]
+新しいドキュメントを一つ作成します。
+以下のコードをコピーして Basic のモジュールに貼り付けます。
+カスタムシェープの図形描写オブジェクトを描き、選択します。
+GetGeomInfo を実行します。
+Writer ドキュメントが作成されて何か書き込まれます。
+コピーして Basic のモジュールに貼り付けます。
**カスタムシェープの作成 [#s2de28c9]
カスタムシェープの作成方法です。カスタムシェープの geometry とサイズは独立しています。
#code(ob){{
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
}}
**一例 [#a28c7fc9]
ニコちゃんマークで試して作成されたコードです。
#code(ob){{
' 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
}}
**情報取得 [#t428933d]
カスタムシェープの CustomShapeGeometry を取得、情報を書き出すコードです。
#code(ob){{
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
}}
**関数群 [#c3c21fd9]
上記のコードで生成されたコードを実行するときに必要になる関数たちです。
#code(ob){{
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
}}
