CorelDRAW VBA 学习代码分享 2025.02.23

蘭雅

Sub CreateShapes()
    Dim rect As Shape
    Dim ellipse As Shape
    Dim polygon As Shape
    
    ' 创建矩形
    Set rect = ActiveLayer.CreateRectangle(0, 0, 100, 50)
    
    ' 创建椭圆
    Set ellipse = ActiveLayer.CreateEllipse2(150, 0, 50, 25)
    
    ' 创建多边形
    Set polygon = ActiveLayer.CreatePolygon(0, 3, 3, 0, 5, 1, 1, True)
End Sub


Sub ModifyShapeProperties()
    Dim sh As Shape
    
    ' 获取当前选中的形状
    Set sh = ActiveSelectionRange(1)
    
    ' 修改填充颜色为红色
    sh.Fill.UniformColor.RGBAssign 255, 0, 0
    
    ' 修改轮廓颜色为蓝色
    sh.Outline.SetProperties Color:=CreateRGBColor(0, 0, 255), Width:=2
    
    ' 旋转形状45度
    sh.RotationAngle = 45
End Sub


Sub ListAllShapes()
    Dim sh As Shape
    
    ' 遍历页面上的所有形状
    For Each sh In ActivePage.Shapes
        Debug.Print "Shape Name: " & sh.Name & ", Type: " & sh.Type
    Next sh
End Sub

Sub CreateText()
    Dim text As Shape
    
    ' 创建艺术字文本
    Set text = ActiveLayer.CreateArtisticText(50, 50, "Hello, CorelDRAW!")

End Sub


Sub 绘制范围线()
    ' 声明变量
    Dim s As Shape ' 用于存储创建的形状
    Dim sr As ShapeRange ' 用于存储选定的形状范围
    Dim x As Double, y As Double, w As Double, h As Double ' 用于存储边界框的坐标和尺寸

    ' 设置文档单位为毫米
    ActiveDocument.Unit = cdrMillimeter

    ' 获取当前活动选择的形状范围
    Set sr = ActiveSelectionRange
    ' 获取选定形状的边界框坐标和尺寸
    sr.GetBoundingBox x, y, w, h

    ' 在活动层中创建一个矩形，位于边界框的起始坐标，宽度和高度为边界框的尺寸
    Set s = ActiveLayer.CreateRectangle2(x, y, w, h)

    ' 注释掉的代码：应用无填充（可以选择性启用）
    ' s.Fill.ApplyNoFill

    ' 设置矩形的轮廓属性：线宽0.2，样式为默认样式，颜色为绿色（RGB: 0, 255, 0）
    s.Outline.SetProperties 0.2, OutlineStyles(0), CreateRGBColor(0, 255, 0)

    ' 设置文档的参考点为中心
    ActiveDocument.ReferencePoint = cdrCenter
    ' 将矩形的尺寸设置为原尺寸加上14毫米（宽度）和3毫米（高度）
    s.SetSize w + 14#, h + 3#

    ' 获得s物件的范围
   ' s.GetBoundingBox x, y, w, h
   ' Set s1 = ActiveLayer.CreateEllipse2(x, y, w / 2, h / 2)
   
    x = s.CenterX: y = s.BottomY
    sw = s.SizeWidth: sh = s.SizeHeight
    
    text = Int(sw) & "x" & Int(sh) & "mm"
    Set s = ActiveLayer.CreateArtisticText(0, 0, text)
    s.CenterX = x: s.TopY = y - 10
    s.Fill.UniformColor.CMYKAssign 0, 100, 100, 0

End Sub


' 设置 MarkerLine.cdr 文件物件名称
Sub SetName_Marker()
    Set sr = ActiveSelectionRange
    sr(1).Name = "TargetLine"
    sr(2).Name = "MarkerBlock"
    sr(3).Name = "CenterLine"
End Sub


Sub Test()
 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

Sub TestAbsoluteIndex()
    Dim s As Shape          ' 定义变量 s 为 Shape 对象
    Dim sp As SubPath       ' 定义变量 sp 为 SubPath 对象
    Dim seg As Segment      ' 定义变量 seg 为 Segment 对象
    
    Set s = ActiveShape     ' 将当前活动形状赋值给变量 s
    
    ' 检查当前形状是否为曲线类型
    If s.Type = cdrCurveShape Then
        ' 遍历曲线中的每个子路径
        For Each sp In s.Curve.SubPaths
            ' 遍历子路径中的每个段
            For Each seg In sp.Segments
                ' 在即时窗口中打印段的 Index 和 AbsoluteIndex 属性值
                Debug.Print seg.Index, seg.AbsoluteIndex
            Next seg
        Next sp
    End If
End Sub
zry2

谢谢分享
盛邦广告

感谢分享，学习
稻草人

感谢分享