TextToCurve_Coreldraw_VBA_Macros By Teacher Alexander Markaryants

TextToCurve_Coreldraw_VBA_Macros By Teacher Alexander Markaryants

Option Explicit

Sub TextToCurve()
    ActiveDocument.Unit = cdrMillimeter
    Application.Optimization = True
    
    Dim s1 As Shape
    Dim SR As ShapeRange
    Dim grp1 As ShapeRange
    Set SR = ActiveSelectionRange
    
    If SR.Count < 1 Then
        MsgBox "No object selected for transformation"
        Application.Optimization = False: Application.Refresh
        Exit Sub
    End If
    
    SR.ConvertToCurves
    Set grp1 = SR.UngroupAllEx
    grp1.CreateSelection
    Set s1 = grp1.Combine
    Set SR = s1.BreakApartEx

    'Creating working arrays
    Dim shapes() As Shape
        ReDim shapes(1 To SR.Count)
    Dim toProcess() As Boolean
        ReDim toProcess(1 To SR.Count)
    
    ' Initialization
    Dim i As Long, j As Long
    For i = 1 To SR.Count
        Set shapes(i) = SR(i)
        toProcess(i) = True
    Next i
    
    ' Main loop
    Dim changed As Boolean
    Do
        changed = False
        
        For i = 1 To UBound(shapes)
            If toProcess(i) And Not shapes(i) Is Nothing Then
                For j = UBound(shapes) To i + 1 Step -1
                    If toProcess(j) And Not shapes(j) Is Nothing Then
                        ' Investment check
                        If BoundingBoxComparison(shapes(i), shapes(j)) Then
                        
                            ' Merge and delete the originals
                            Dim Combines As Shape
                                shapes(i).CreateSelection
                                    shapes(j).AddToSelection
                                    
                            Set Combines = ActiveSelection.Combine
                            
                            ' We replace one of the figures with the combined one
                            Set shapes(i) = Combines
                            toProcess(j) = False 'The second figure is no longer processed
                            
                            changed = True
                            Exit For
                        End If
                    End If
                Next j
            End If
        Next i
    Loop While changed
    
    ActiveDocument.ClearSelection
    
Application.Optimization = False: Application.Refresh
MsgBox "Finish"
End Sub

'Investment check
Function BoundingBoxComparison(sh1 As Shape, sh2 As Shape) As Boolean
    Dim X As Double, Y As Double, W As Double, H As Double
    Dim x1 As Double, y1 As Double, w1 As Double, h1 As Double
    
    sh1.GetBoundingBox X, Y, W, H: sh2.GetBoundingBox x1, y1, w1, h1
    
    BoundingBoxComparison = (x1 >= X And y1 >= Y And (x1 + w1) <= (X + W) And (y1 + h1) <= (Y + H)) Or _
                            (X >= x1 And Y >= y1 And (X + W) <= (x1 + w1) And (Y + H) <= (y1 + h1))

End Function