蘭雅sRGB 个人笔记 https://262235.xyz
提供编程和电脑应用视频教程,工具和源代码
C, C++, Python Programming, Source Code, Video

旧Hexo博客 | Github | IP定位WebAPI | Docker Hub
编程中文文档 | 网盘分享 | 中文Linux命令

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 方法将范围内的所有形状添加到当前选择。 相关 CreateSelectionRemoveFromSelection

' 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

以下代码示例用红色填充放置在 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 
本原创文章自由转载,转载请注明本博来源及网址 | 当前页面:兰雅sRGB个人笔记 » CorelDRAW VBA 编写最简单的文本转曲脚本,你可以学到很多