Advertisement
Not a member of Pastebin yet?
Sign Up,
it unlocks many cool features!
- Private Sub CommandButton13_Click()
- ' Recorded 2022-03-18
- Dim sh As shape
- Dim sr As ShapeRange
- Dim i As Integer
- Dim p As Page
- Dim s1 As ShapeRange
- Dim X As Double
- Dim Y As Double
- Dim s As shape
- Dim sOriginal As shape
- Dim sDuplicate As shape
- Dim sr_from_contour As ShapeRange
- Dim e As Effect
- Set sOriginal = ActiveShape
- Dim srTemp As ShapeRange
- Dim sContourCurve_1 As shape
- Dim sContourCurve_2 As shape
- Dim shapesss As shape
- ActiveDocument.Unit = cdrMillimeter
- Set sr = ActivePage.Shapes.FindShapes(Type:=cdrTextShape)
- Set sh = sr.Shapes(1)
- sh.Text.Story.Font = "khalil liss font"
- X = 0
- Y = 0
- Set e = sh.CreateContour(cdrContourOutside, ConvertUnits(0.26, cdrMillimeter, ActiveDocument.Unit), , , , , , , , , 2)
- sh.GetSize X, Y
- 'sh.SetSize 38, 38 * y / x
- sh.Text.FontPropertiesInRange(1, 1, cdrWordIndexing).RangeKerning = 100
- 'sh.Text.FontPropertiesInRange(1, 1, cdrWordIndexing).RangeKerning = 0
- Set srTemp = e.Separate
- Set sContourCurve_2 = srTemp(2)
- sContourCurve_2.Delete
- ' get alphabet close to each other
- srTemp(1).BreakApart
- 'Dim sh As Shape
- Dim prevvX As Double
- Dim prevvY As Double
- Dim nexttX As Double
- Dim nexttY As Double
- Dim prevvX2 As Double
- Dim prevvY2 As Double
- Dim nextXt2 As Double
- Dim nexttY2 As Double
- Dim combineshapes(20, 20) As Variant
- Dim starttab As Integer
- starttab = 2
- Dim j As Integer
- Dim ss As Shapes
- Dim kk As Integer
- Set ss = ActiveLayer.Shapes
- kk = 1
- Dim lengthh As Integer
- ' fill the matrice with zero
- lengthh = ss.count
- 'For i = 1 To lengthh
- ' For j = 1 To lengthh
- '
- ' combineshapes(i, j) = 0
- '
- ' Next
- 'Next
- For i = 1 To ss.count
- starttab = 2
- ss(i).GetPositionEx cdrMiddleRight, prevvX, prevvY
- ss(i).GetPositionEx cdrMiddleLeft, nexttX, nexttY
- For j = 1 To ss.count
- If i <> j Then
- ss(j).GetPositionEx cdrMiddleRight, prevvX2, prevvY2
- ss(j).GetPositionEx cdrMiddleLeft, nextXt2, nexttY2
- If (prevvX > prevvX2) And (nexttX < nextXt2) Then
- 'ActiveDocument.CreateSelection ss(i), ss(j)
- 'ActiveSelection.Group
- 'combineshapes(i, 1) = ss(i).StaticID
- If (IsInArray(ss(i).StaticID, combineshapes)) = False Then
- combineshapes(i, 1) = ss(i).StaticID
- ss(i).Outline.width = 0.1 * i
- End If
- If (IsInArray(ss(j).StaticID, combineshapes)) = False Then
- combineshapes(i, starttab) = ss(j).StaticID
- ss(j).Outline.width = 0.1 * i
- starttab = starttab + 1
- End If
- End If
- End If
- Next
- 'ss(i).SetPosition i * 10, i * 10
- starttab = 2
- kk = kk + 1
- Next
- Dim G As Integer
- Dim d As Integer
- Set ss = ActiveLayer.Shapes
- ss.All.BreakApart
- Dim w As Integer
- lengthh = ss.count
- Dim shapeToCombine As shape
- Dim ShapeRangeTocombine As ShapeRange
- Set shapeToCombine = ss.First
- 'For w = 1 To lengthh
- ' For g = 1 To lengthh
- '
- ' If Not combineshapes(w, g) = Empty Then
- '' shapeToCombine = ActivePage.FindShape(StaticID:=combineshapes(w, g))
- '' ShapeRangeTocombine.Add shapeToCombine
- ' ActiveDocument.ActivePage.FindShape(StaticID:=combineshapes(w, g)).Move 0#, 20
- ' MsgBox (combineshapes(w, g))
- '
- '
- ' End If
- '
- '
- ' Next
- '' If Not ShapeRangeTocombine Is Nothing Then
- '' ShapeRangeTocombine.CreateSelection
- '' ShapeRangeTocombine.Move 10, 0#
- ''
- '' End If
- '
- '
- ' Dim s2 As Shape
- '' 'ssss.CreateSelection
- ' Set s2 = ActiveSelection.Combine
- 'Next
- Dim done As Boolean
- done = False
- For w = 1 To lengthh
- If done = False Then
- If w = 1 Then
- done = True
- End If
- ActiveDocument.CreateSelection ActivePage.FindShape(StaticID:=combineshapes(w, 1))
- End If
- If w > 1 Then
- ActiveDocument.CreateSelection ActivePage.FindShape(StaticID:=combineshapes(w, 1))
- End If
- For G = 1 To lengthh
- If combineshapes(w, G) > 0 Then
- ActiveDocument.AddToSelection ActivePage.FindShape(StaticID:=combineshapes(w, G))
- End If
- Next
- If ActivePage.SelectableShapes.count > 1 Then
- ActiveSelection.Combine
- End If
- ActiveSelectionRange.RemoveFromSelection
- Next
- 'For w = 1 To lengthh
- '' If w = 3 Then
- '' If combineshapes(w, 1) <> 0 Then
- '' 'ActiveDocument.CreateSelection ActivePage.FindShape(StaticID:=combineshapes(w, 1))
- ''' Set sss = ActivePage.FindShape(StaticID:=combineshapes(w, 1))
- ''' sss.CreateSelection
- '' ActiveDocument.CreateSelection ActivePage.FindShape(StaticID:=combineshapes(w, 1))
- ''
- '' End If
- '' Else
- ' 'If ActivePage.FindShape(StaticID:=combineshapes(w, 1)).IsSimpleShape Or combineshapes(w, 1) > 0 Then
- ' 'If combineshapes(w, 1) > 0 Then
- ' 'Set shapeToCombine = ActivePage.FindShape(StaticID:=combineshapes(w, 1))
- ' 'ActivePage.FindShape(StaticID:=combineshapes(w, 1)).CreateSelection
- ' 'ActiveDocument.CreateSelection ActivePage.FindShape(StaticID:=combineshapes(w, 1))
- ' 'shapeToCombine.CreateSelection
- '
- ' Dim srs As New ShapeRange
- ' srs.Add ActivePage.FindShape(StaticID:=combineshapes(w, 1))
- ' 'End If
- '' End If
- '
- '
- ' For g = 1 To ss.count
- ' If combineshapes(w, g + 1) > 0 Then
- '
- ' 'ActiveDocument.RemoveFromSelection
- '
- ' ''ActiveDocument.AddToSelection ActivePage.FindShape(StaticID:=combineshapes(w, g + 1))
- '
- ' srs.Add ActivePage.FindShape(StaticID:=combineshapes(w, g + 1))
- ' 'For d = 2 To 8
- '
- '
- ' 'ActiveDocument.CreateSelection ActivePage.FindShape(StaticID:=combineshapes(i, g))
- '
- ' End If
- ' 'ActivePage.FindShape(StaticID:=combineshapes(i, g)).Move 0#, i * 1
- '
- '' Set sss = ActivePage.FindShape(StaticID:=combineshapes(i, g))
- '' If Not sss Is Nothing Then ssss.Add ssss
- '
- '
- '
- '
- '
- '
- '
- '
- ' 'ActiveSelection.Combine
- ' 'ActivePage.FindShape(StaticID:=combineshapes(i, g)).Move 0#, i * 10
- '
- '
- '
- ' Next
- ' Dim s2 As Shape
- ' 'ssss.CreateSelection
- ' Set s2 = ActiveSelection.Combine
- 'Next
- ''srTemp(1).SetSize 38, 38 * y / x
- ''get Contour Curve 2 as a shape
- 'make all the shapes in table
- Dim length As Integer
- length = ss.count
- Dim arrayorder(20) As Integer
- Dim shtreat As shape
- Dim ii As Integer
- ii = 0
- Set ss = ActiveLayer.Shapes
- For Each shtreat In ss
- arrayorder(ii) = shtreat.StaticID
- ii = ii + 1
- Next shtreat
- Dim Test As Integer
- ' test if alphabet ordered in right manner
- Dim min As Integer
- 'order the shapes
- For i = 0 To ii - 1
- For j = i + 1 To ii
- If ActivePage.FindShape(StaticID:=arrayorder(i)).PositionX > ActivePage.FindShape(StaticID:=arrayorder(j)).PositionX Then
- Test = arrayorder(i)
- arrayorder(i) = arrayorder(j)
- arrayorder(j) = Test
- End If
- Next j
- Next i
- Dim incr As Integer
- 'get shapes close to each other
- 'Dim combinedShape As Shape
- 'Set ss = ActiveLayer.Shapes
- 'ActiveDocument.CreateSelection ActivePage.FindShape(StaticID:=arrayorder(0))
- 'Set combinedShape = ActiveDocument.ActiveShape
- '
- 'Dim maxsteps As Integer
- '
- 'For i = 0 To (UBound(arrayorder) - LBound(arrayorder)) - 1
- '
- ''for loop
- ' For incr = 0 To 50
- '
- ' If Not (combinedShape.DisplayCurve.IntersectsWith(ActivePage.FindShape(StaticID:=arrayorder(i + 1)).DisplayCurve)) Then
- ' combinedShape.Move 0.3, 0#
- ' Else
- ' Exit For
- ' End If
- '
- ' Next
- '
- ' Do While Not (combinedShape.DisplayCurve.IntersectsWith(ActivePage.FindShape(StaticID:=arrayorder(i + 1)).DisplayCurve)) ' And (maxsteps < 10)
- '
- ' combinedShape.Move 0.3, 0#
- ' maxsteps = maxsteps + 1
- '
- ' Loop
- ' For maxsteps = 0 To 10
- ' If Not combinedShape.DisplayCurve.IntersectsWith(ActivePage.FindShape(StaticID:=arrayorder(i + 1)).DisplayCurve) Then
- ' combinedShape.Move 0.3, 0#
- '
- ' End If
- '
- ' Next maxsteps
- 'combinedShape.Move 0.2, 0#
- 'Set combinedShape = combinedShape.Weld(ActivePage.FindShape(StaticID:=arrayorder(i + 1)), False, False)
- 'ActiveDocument.CreateSelection combinedShape, ActivePage.FindShape(StaticID:=arrayorder(i + 1))
- 'Set combinedShape = ActiveSelection.Combine
- 'ActivePage.FindShape(StaticID:=arrayorder(i)).SetPosition i * 10, i * 10
- 'Next i
- Dim shape As shape
- End Sub
Advertisement
Add Comment
Please, Sign In to add comment
Advertisement