blob Invité
|
Posté le: Sam Juin 19, 2004 13:57 pm Sujet du message: Conversion de formes, découpages |
|
|
Bonjour,
J’ai posté quelques messages précédemment dans lesquels il était question, entre autres, de scinder un rectangle (forme automatique de Word ou forme libre).
En réponse, voici deux fonctions (Word 2000) qui permettent, pour la première, de convertir une forme automatique de Word (formes de base : rectangle, parallélogramme, losange, trapèze, ...) en une forme libre et, pour la seconde, de scinder une forme libre en segments.
Blob
-------------------------------------------------------------------------------------
Sub FillArray(a() As Single, ParamArray b())
ReDim a(1 To b(0), 1 To 2) 'b(0) : nb de noeuds
For i = 1 To b(0)
For j = 1 To 2
a(i, j) = b(i * 2 + j - 2)
Next j
Next i
End Sub
--------------------------------------------------------------------------------------
Sub ConvertToFreeForm() 'Convertit une forme auto. en forme libre
Dim NodesArray() As Single
Dim CreateFreeShape As Boolean
CreateFreeShape = False
If Selection.Type = wdSelectionShape Then
Set MyShape = Selection.ShapeRange(1)
If MyShape.Type = msoAutoShape Then
x1 = MyShape.Left
y1 = MyShape.Top
w = MyShape.Width
h = MyShape.Height
Select Case MyShape.AutoShapeType
Case msoShapeRectangle, msoShapeParallelogram
If MyShape.AutoShapeType = msoShapeParallelogram Then
a = MyShape.Adjustments.Item(1)
Else
a = 0
End If
If a = 1 Then 'parallélog. aplati
FillArray NodesArray, 2, x1, y1 + h, x1 + w, y1
Else
FillArray NodesArray, 5, x1 + a * w, y1, x1 + w, y1, _
x1 + (1 - a) * w, y1 + h, x1, y1 + h, x1 + a * w, y1
End If
CreateFreeShape = True
Case msoShapeTrapezoid
a = MyShape.Adjustments.Item(1)
If a = 0.5 Then 'triangle
FillArray NodesArray, 4, x1, y1, x1 + w, y1, x1 + 0.5 * w, _
y1 + h, x1, y1
Else
FillArray NodesArray, 5, x1, y1, x1 + w, y1, x1 + (1 - a) * w, _
y1 + h, x1 + a * w, y1 + h, x1, y1
End If
CreateFreeShape = True
Case msoShapeDiamond 'Losange
FillArray NodesArray, 5, x1 + 0.5 * w, y1, x1 + w, y1 + 0.5 * h, _
x1 + 0.5 * w, y1 + h, x1, y1 + 0.5 * h, x1 + 0.5 * w, y1
CreateFreeShape = True
Case msoShapeOctagon
a = MyShape.Adjustments.Item(1)
If a = 0 Then 'rectangle
FillArray NodesArray, 5, x1, y1, x1 + w, y1, _
x1 + w, y1 + h, x1, y1 + h, x1, y1
Else
If w < h Then b = w Else b = h
If a = 0.5 Then
If w = h Then 'losange
FillArray NodesArray, 5, x1 + 0.5 * w, y1, x1 + w, y1 + 0.5 * h, _
x1 + 0.5 * w, y1 + h, x1, y1 + 0.5 * h, x1 + 0.5 * w, y1
Else 'hexagone
If w > h Then
FillArray NodesArray, 7, x1 + a * b, y1, x1 + w - a * b, y1, _
x1 + w, y1 + a * b, x1 + w - a * b, y1 + h, x1 + a * b, y1 + h, _
x1, y1 + a * b, x1 + a * b, y1
Else
FillArray NodesArray, 7, x1 + a * b, y1, x1 + w, y1 + a * b, _
x1 + w, y1 + h - a * b, x1 + a * b, y1 + h, x1, y1 + h - a * b, _
x1, y1 + a * b, x1 + a * b, y1
End If
End If
Else
FillArray NodesArray, 9, x1 + a * b, y1, x1 + w - a * b, y1, _
x1 + w, y1 + a * b, x1 + w, y1 + h - a * b, x1 + w - a * b, y1 + h, _
x1 + a * b, y1 + h, x1, y1 + h - a * b, x1, y1 + a * b, x1 + a * b, y1
End If
End If
CreateFreeShape = True
Case msoShapeIsoscelesTriangle
a = MyShape.Adjustments.Item(1)
FillArray NodesArray, 4, x1 + a * w, y1, x1 + w, y1 + h, _
x1, y1 + h, x1 + a * w, y1
CreateFreeShape = True
Case msoShapeRightTriangle 'triangle rectangle
FillArray NodesArray, 4, x1, y1, x1 + w, y1 + h, _
x1, y1 + h, x1, y1
CreateFreeShape = True
Case msoShapeHexagon
a = MyShape.Adjustments.Item(1)
If a = 0 Then 'rectangle
FillArray NodesArray, 5, x1, y1, x1 + w, y1, _
x1 + w, y1 + h, x1, y1 + h, x1, y1
Else
If a = 0.5 Then 'losange
FillArray NodesArray, 5, x1 + 0.5 * w, y1, x1 + w, y1 + 0.5 * h, _
x1 + 0.5 * w, y1 + h, x1, y1 + 0.5 * h, x1 + 0.5 * w, y1
Else
FillArray NodesArray, 7, x1 + a * w, y1, x1 + (1 - a) * w, y1, _
x1 + w, y1 + 0.5 * h, x1 + (1 - a) * w, y1 + h, x1 + a * w, y1 + h, _
x1, y1 + 0.5 * h, x1 + a * w, y1
End If
End If
CreateFreeShape = True
Case msoShapeRegularPentagon
a = 0.191
b = 0.382
FillArray NodesArray, 6, x1 + 0.5 * w, y1, x1 + w, y1 + b * h, _
x1 + (1 - a) * w, y1 + h, x1 + a * w, y1 + h, x1, y1 + b * h, _
x1 + 0.5 * w, y1
CreateFreeShape = True
End Select
If CreateFreeShape Then
Set MyFreeShape = ActiveDocument.Shapes.AddPolyline(NodesArray, MyShape.Anchor)
MyFreeShape.Select
Selection.ShapeRange(1).Rotation = MyShape.Rotation
MyShape.Delete
End If
End If
End If
End Sub
--------------------------------------------------------------------------------------
Sub Divide() ' Scinde un polygone (forme libre) en segments
Dim LineArray() As Variant
If Selection.Type = wdSelectionShape Then
Set MyShape = Selection.ShapeRange(1)
If MyShape.Type = msoFreeform Then
With MyShape.Nodes
ReDim LineArray(.Count - 1)
For i = 1 To .Count
PointsArray = .Item(i).Points
x1 = PointsArray(1, 1)
y1 = PointsArray(1, 2)
If i = .Count Then
PointsArray = .Item(1).Points
Else
PointsArray = .Item(i + 1).Points
End If
x2 = PointsArray(1, 1)
y2 = PointsArray(1, 2)
Set MyLine = ActiveDocument.Shapes.AddLine(x1, y1, x2, y2)
LineArray(i - 1) = i + 1
Next i
End With
ActiveDocument.Shapes.Range(LineArray).Group.Select
MyShape.Delete
End If
End If
End Sub |
|