CorelDRAW VBA 编写最简单的文本转曲脚本，你可以学到很多

CorelDRAW中的文字转曲主要针对所做设计字体进行的冻结操作，是为了方便在不同电脑打开CDR文件以正常显示。一般情况下，印刷品都需要转曲，转曲后的文件相当于一张图片，不可以再编辑。而且它是一个不可逆的过程，一般我们都会在所有排版完成后保存一份副本，然后再进一步转曲存为转曲文件，以方便后续的操作，本文将介绍怎么优雅的写一个文本转曲脚本。

Shape.ConvertToCurves 方法将形状转换为曲线。

• 文档链接 https://262235.xyz/vba/IDH_Shape_ConvertToCurves.html

• 文档中有个示例源码: 演示了建立文本和设置字体，然后转成曲线

  Sub Test_建立文本和转曲() 
   Dim s As Shape, n As Node 
   Set s = ActiveLayer.CreateArtisticText(0, 0, "Jagged") 
   With s.Text.FontProperties 
  .Name = "Arial" 
  .Style = cdrBoldFontStyle 
  .Size = 140 
   End With 
   s.ConvertToCurves 
  End Sub 

实际文档中符合我们批量文本最好的示例源码是下面文档，只需要删除几行

Text.ConvertToArtistic 方法将段落文本更改为美术字。

• 文档链接 https://262235.xyz/vba/IDH_Text_ConvertToArtistic.html

• 以下代码示例将所有段落文本对象转换为曲线，方法是先将它们转换为艺术文本，然后再将它们转换为曲线：

  Sub Test_把段落文本转曲() 
   Dim s As Shape 
   For Each s In ActivePage.FindShapes(, cdrTextShape) 
  If s.Text.Type = cdrParagraphText Then 
   s.Text.ConvertToArtistic 
   s.ConvertToCurves 
  End If 
   Next s 
  End Sub 

CorelDRAW VBA 段落文本可以直接转曲线，把上面代码，删除段落文本转美术文本部分，一个最简单的文本转曲代码就出来

'// 文本转曲精简版
Sub TextConvertToCurves()
Dim s As Shape
  For Each s In ActivePage.FindShapes(, cdrTextShape)
    s.ConvertToCurves
Next s
End Sub

代码 ActivePage.FindShapes(, cdrTextShape) 方法查找文本属性的所有形状, 它返回一个包含所有找到的形状的 ShapeRange 对象。 也可以使用定义一个 ShapeRange 变量，使用 Type:=cdrTextShape 做为参数

Dim sr As ShapeRange 
Set sr = ActivePage.FindShapes(Type:=cdrTextShape)

接下来我们学习 ShapeRange 类, 请查看文档 Properties-属性 ◆ Methods-方法

ShapeRange 类表示 Shape 对象的动态数组。 特定于形状的属性和方法可以应用于数组（范围）的每个形状。您可以使用 Visual Basic 中的 New 关键字来创建 ShapeRange 对象。

• 文档中的简单示例源码和注释

  ShapeRange.Add 方法将指定的形状添加到范围

  ' ShapeRange.Add  子添加（形状为形状）
  ' Add 方法将指定的形状添加到范围
  ' 下面的代码示例创建一个由圆形和两条线组成的注册标记，将对象分组，然后将它们移动到页面中心：
  
  Sub ShapeRange_Add()
  Dim sGroup As Shape
  Dim sr As New ShapeRange
  sr.Add ActiveLayer.CreateEllipse2(0, 0, 0.25)
  sr.Add ActiveLayer.CreateLineSegment(-0.5, 0, 0.5, 0)
  sr.Add ActiveLayer.CreateLineSegment(0, -0.5, 0, 0.5)
  sr.SetOutlineProperties 0.03
  Set sGroup = sr.Group
  sGroup.Move ActivePage.SizeWidth / 2, ActivePage.SizeHeight / 2
  End Sub

AddToPowerClip 方法将形状范围添加到指定的 PowerClip 容器

'// AddToPowerClip 方法将形状范围添加到指定的 PowerClip 容器。
Sub ShapeRange_AddToPowerClip()
  Dim sr As New ShapeRange
  Dim s As Shape, n As Long

  '// 随机绘制 150个彩色圆形
  For n = 1 To 150
    Set s = ActiveLayer.CreateEllipse2(Rnd() * 4, Rnd() * 2, Rnd() * 0.3)
    s.Fill.UniformColor.RGBAssign Rnd() * 255, Rnd() * 255, Rnd() * 255
    sr.Add s
  Next n
  '// 绘制矩形, 坐标0,0 尺寸3x2in矩形当作图框精确剪裁
  Set s = ActiveLayer.CreateRectangle2(0, 0, 3, 2)
  sr.AddToPowerClip s
End Sub

ShapeRange.AddToSelection 方法将范围内的所有形状添加到当前选择。 相关 CreateSelection 和 RemoveFromSelection

' ShapeRange.AddToSelection  方法将范围内的所有形状添加到当前选择。
' 另请参阅 CreateSelection 和 RemoveFromSelection 方法
' 代码示例选择当前页面上的所有椭圆和矩形：
Sub ShapeRange_AddToSelection()
  ActivePage.FindShapes(Type:=cdrEllipseShape).CreateSelection
  ActivePage.FindShapes(Type:=cdrRectangleShape).AddToSelection

  '// 第一个和最后一个物件移除选择
  Dim ssr As ShapeRange
  Set ssr = ActiveSelectionRange
  ssr.FirstShape.RemoveFromSelection
  ssr.LastShape.RemoveFromSelection
End Sub

实际CDR文件会把文本不小心放到图框剪裁 PowerClip 容器中，搞懂以上代码以后，我们来写支持支持图框精确剪裁的代码。

使用 Google 搜索一个 FindAllShapes 的函数，查到代码大体如下，代码使用CQL搜索图框剪裁 PowerClip 容器，把容器中的所有物件添加到ShapeRange范围中。

Function FindAllShapes() As ShapeRange
    Dim s As Shape
    Dim srPowerClipped As New ShapeRange
    Dim sr As ShapeRange, srAll As New ShapeRange
    
    If ActiveSelection.Shapes.Count > 0 Then
        Set sr = ActiveSelection.Shapes.FindShapes()
    Else
        Set sr = ActivePage.Shapes.FindShapes()
    End If
    
    Do
        For Each s In sr.Shapes.FindShapes(Query:="[email protected]")
            srPowerClipped.AddRange s.PowerClip.Shapes.FindShapes()
        Next s
        srAll.AddRange sr
        sr.RemoveAll
        sr.AddRange srPowerClipped
        srPowerClipped.RemoveAll
    Loop Until sr.Count = 0
    
    Set FindAllShapes = srAll
End Function

最精简支持图框精确剪裁文本转曲版完成，只需要把 ActivePage 改成 FindAllShapes.Shapes

Sub TextShapes_ConvertToCurves()
  Dim s As Shape
  For Each s In FindAllShapes.Shapes.FindShapes(Type:=cdrTextShape)
    s.ConvertToCurves
  Next s
End Sub

我们也可以这样来写支持图框精确剪裁的文本转曲线

'// 支持一级图框精确剪裁的文本转曲线
Sub TextShape_ConvertToCurves()
  Dim s As Shape
  For Each s In ActivePage.FindShapes(Type:=cdrTextShape)
    s.ConvertToCurves
  Next s

  '// 图框精确剪裁文本转曲线
  Dim pwc As PowerClip
  For Each s In ActivePage.Shapes
    Set pwc = Nothing
    On Error Resume Next
    Set pwc = s.PowerClip
    On Error GoTo 0
    
    If Not pwc Is Nothing Then
      s.PowerClip.Shapes.All.ConvertToCurves
    End If
  Next s
  
End Sub

关于图框精确剪 PowerClip

Shape.AddToPowerClip 方法将当前形状对象添加到 PowerClip 容器

以下代码示例创建一个矩形和一个椭圆，然后将椭圆放在矩形内：

Sub Test_AddToPowerClip()  
 Dim rect As Shape, ell As Shape  
 Set rect = ActiveLayer.CreateRectangle(0, 0, 4, 3)  
 rect.Fill.UniformColor.RGBAssign 255, 0, 0  
 Set ell = ActiveLayer.CreateEllipse(2, 1, 5, 4)  
 ell.Fill.UniformColor.RGBAssign 255, 255, 0  
 ell.AddToPowerClip rect  
End Sub 

PowerClip.Shapes 属性返回包含 PowerClip 中所有形状 的Shapes

• https://262235.xyz/vba/IDH_PowerClip_Shapes.html

以下代码示例用红色填充放置在 PowerClip 内的所有矩形：

Sub Test_PowerClip()  
 Dim s As Shape, sp As Shape  
 Dim pwc As PowerClip  
 For Each s In ActivePage.Shapes  
  Set pwc = Nothing  
  On Error Resume Next  
  Set pwc = s.PowerClip  
  On Error GoTo 0  
  If not pwc is nothing then  
   for each sp In pwc.Shapes  
    If sp.Type = cdrRectangleShape Then  
     sp.Fill.UniformColor.RGBAssign 255, 0, 0  
    End If  
   Next sp  
  End If  
 Next s  
End Sub 

以下代码示例为页面上的每个 PowerClip 添加20条垂直线

Sub Test_PowerClip2() 
 Const NumLines As Long = 20 
 Dim s As Shape 
 Dim pwc As PowerClip 
 Dim x As Double, y As Double, sx As Double, sy As Double 
 Dim xx As Double 
 Dim n As Long 
 For Each s In ActivePage.Shapes 
  Set pwc = Nothing 
  On Error Resume Next 
  Set pwc = s.PowerClip 
  On Error GoTo 0 
  If Not pwc Is Nothing Then 
   s.CreateSelection 
   s.GetBoundingBox x, y, sx, sy 
   pwc.EnterEditMode 
   For n = 1 To NumLines 
    xx = x + n * sx / (NumLines + 1) 
    ActiveLayer.CreateLineSegment xx, y, xx, y + sy 
   Next n 
   pwc.LeaveEditMode 
  End If 
 Next s 
End Sub