CorelDRAW VBA 建立自己的工具-剪贴板尺寸建立矩形

github 源码分享 https://github.com/hongwenjun/corelvba

功能演示

完善工具

Sub start()
    '// 建立矩形 Width  x Height 单位 mm
    ' Rectangle 101, 151

    ' setRectangle 200, 200

    Dim Str, arr, n
    Str = GetClipBoardString

    ' 替换 mm x * 换行为空格
    Str = VBA.Replace(Str, "mm", " ")
    Str = VBA.Replace(Str, "x", " ")
    Str = VBA.Replace(Str, "*", " ")
    Str = VBA.Replace(Str, Chr(10), " ")

    Do While InStr(Str, "  ") '多个空格换成一个空格
        Str = VBA.Replace(Str, "  ", " ")
    Loop

    arr = Split(Str)

    Dim x As Double
    Dim y As Double
    For n = LBound(arr) To UBound(arr) - 1 Step 2
        ' MsgBox arr(n)
        x = Val(arr(n))
        y = Val(arr(n + 1))

        If x > 0 And y > 0 Then
            Rectangle x, y
        End If

    Next

End Sub

基本程序

Sub start()
    Dim Str, arr, n
    Str = GetClipBoardString
    arr = Split(Str)
    For n = LBound(arr) To UBound(arr)
       MsgBox arr(n)
    Next
End Sub

Function Rectangle(Width As Double, Height As Double)

    ActiveDocument.Unit = cdrMillimeter
    Dim size As Shape
    Dim d As Document
    Dim s1 As Shape

    '// 建立矩形 Width  x Height 单位 mm
    Set s1 = ActiveLayer.CreateRectangle(0, 0, Width, Height)

    '// 填充颜色无，轮廓颜色 K100，线条粗细0.3mm
    s1.Fill.ApplyNoFill
    s1.Outline.SetProperties 0.3, OutlineStyles(0), CreateCMYKColor(0, 100, 0, 0), ArrowHeads(0), ArrowHeads(0), cdrFalse, cdrFalse, cdrOutlineButtLineCaps, cdrOutlineMiterLineJoin, 0#, 100, MiterLimit:=5#

    sw = s1.SizeWidth
    sh = s1.SizeHeight

    Text = "建立矩形:" + Str(sw) + " x" + Str(sh) + "mm"
    MsgBox Text

    Text = Trim(Str(sw)) + "x" + Trim(Str(sh)) + "mm"
    Set d = ActiveDocument
    Set size = d.ActiveLayer.CreateArtisticText(0, 0, Text)
    size.Fill.UniformColor.CMYKAssign 0, 100, 100, 0

End Function

Function setRectangle(Width As Double, Height As Double)

    Dim s1 As Shape
    Set s1 = ActiveSelection
    ActiveDocument.Unit = cdrMillimeter
    '// 物件中心基准, 先把宽度设定为
    ActiveDocument.ReferencePoint = cdrCenter
    s1.SetSize Height, Height

    '// 物件旋转 30度，轮廓线1mm ,轮廓颜色 M100Y100
    s1.Rotate 30#
    s1.Outline.SetProperties 1#
    s1.Outline.SetProperties Color:=CreateCMYKColor(0, 100, 100, 0)

End Function

Sub DoIt()
    MsgBox GetClipBoardString
End Sub

Private Function GetClipBoardString() As String
    On Error Resume Next
    Dim MyData As New DataObject
    GetClipBoardString = ""
    MyData.GetFromClipboard
    GetClipBoardString = MyData.GetText
    Set MyData = Nothing
End Function