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 SubAddToPowerClip 方法将形状范围添加到指定的 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 SubShapeRange.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
以下代码示例用红色填充放置在 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 © 版权声明
文章版权归作者所有，未经允许请勿转载。
THE END
喜欢就支持一下吧
请登录后发表评论
注册