Ada kalanya kita didalam desain membuat desain sertifikat dan menginput banyak nama di sertifikat tersebut. Setelah kita automate input nama sertifikat di coreldraw kita juga harus meng convert text di coreldraw tersebut agar waktu kita kirim sertifikat ke vendor, text tersebut tidak missing font.
Berikut script macro untuk cara cepat yang bisa kita lakukan untuk convert to curves text disemua page coreldraw:
Sub TextToCurves()
Dim srQ As ShapeRange, sr As ShapeRange, sr2 As ShapeRange, sh As Shape, _
i&, curP As Page, bAll%, bDigPClip%
On Error Resume Next
If ActiveDocument Is Nothing Then Exit Sub
Set curP = ActiveLayer.Page
Set sr = New ShapeRange: Set sr2 = New ShapeRange: Set srQ = New ShapeRange
bAll = (ActiveSelectionRange.Count = 0)
bDigPClip = (VersionMajor > 11)
For i = 1 To ActiveDocument.Pages.Count
With ActiveDocument.Pages(i)
If bAll Or .Index = curP.Index Then
If bDigPClip Then
If bAll Then sr.AddRange .FindShapes _
Else: sr.AddRange ActiveSelection.Shapes.FindShapes
Do
For Each sh In sr
If sh.Type = cdrTextShape Then srQ.Add sh
If Not sh.PowerClip Is Nothing Then sr2.AddRange sh.PowerClip.Shapes.FindShapes
Next
sr.RemoveAll: sr.AddRange sr2: sr2.RemoveAll
Loop Until sr.Count = 0
Else
If bAll Then srQ.AddRange .FindShapes(, cdrTextShape, True) _
Else: srQ.AddRange ActiveSelection.Shapes.FindShapes(, cdrTextShape, True)
End If
End If
End With
Next
srQ.CreateSelection
num = (srQ.Count)
If num = 1 Then
srQ.ConvertToCurves
MsgBox (num & " Objeto de texto convertido a Curvas") '& vbTab &
srQ.AddToSelection
ElseIf num > 1 Then
srQ.ConvertToCurves
MsgBox (num & " Objetos de texto convertidos a Curvas") '& vbTab &
srQ.AddToSelection
Else
MsgBox ("No se encontró ningún objeto de texto en la selección o el Documento"), vbInformation '& vbTab &
End If
'srQ.CreateSelection 'JRM 2014
End Sub
Credit Script :
http://www.grafisin.com/2014/12/convert-semua-text-tulisan-di-semua-halaman-coreldraw.html
https://www.blogger.com/profile/15462555602408236889
Credit Image :
https://www.deconetwork.com
