Le forum de Gdmath Index du Forum Le forum de Gdmath
Un forum pour échanger sur Gdmath
 
 FAQFAQ   RechercherRechercher   Liste des MembresListe des Membres   Groupes d'utilisateursGroupes d'utilisateurs   S'enregistrerS'enregistrer 
 ProfilProfil   Se connecter pour vérifier ses messages privésSe connecter pour vérifier ses messages privés   ConnexionConnexion 

Conversion de formes, découpages

 
Poster un nouveau sujet   Répondre au sujet    Le forum de Gdmath Index du Forum -> Améliorations
Voir le sujet précédent :: Voir le sujet suivant  
Auteur Message
blob
Invité





MessagePosté le: Sam Juin 19, 2004 13:57 pm    Sujet du message: Conversion de formes, découpages Répondre en citant

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
Revenir en haut de page
Montrer les messages depuis:   
Poster un nouveau sujet   Répondre au sujet    Le forum de Gdmath Index du Forum -> Améliorations Toutes les heures sont au format GMT
Page 1 sur 1

 
Sauter vers:  
Vous ne pouvez pas poster de nouveaux sujets dans ce forum
Vous ne pouvez pas répondre aux sujets dans ce forum
Vous ne pouvez pas éditer vos messages dans ce forum
Vous ne pouvez pas supprimer vos messages dans ce forum
Vous ne pouvez pas voter dans les sondages de ce forum


Powered by phpBB © 2001, 2005 phpBB Group
Traduction par : phpBB-fr.com

Anti Bot Question MOD - phpBB MOD against Spam Bots
Inscriptions bloqués / messages: 30529 / 0