CorelDRAW X4 批量标注功能修复可用

CDR_X4.webp

【CorelDRAW_X4 批量标注功能修复可用 需要Lanya排序算法库-哔哩哔哩】

https://b23.tv/IVimzaw

CorelDRAW X4 和 X6等高版本 使用VBA 编程标注尺寸,代码上有些不同,下面的代码示例写了不同的分支

#If VBA7 Then
  sr.Sort "@shape1.left < @shape2.left"
#Else
  Set sr = X4_Sort_ShapeRange(sr, stlx)
#End If
  For i = 1 To sr.Count - 1
    x1 = sr(i + 1).CenterX
    y1 = sr(i + 1).CenterY
    x2 = sr(i).CenterX
    y2 = sr(i).CenterY
    
    Set pts = CreateSnapPoint(x1, y1)
    Set pte = CreateSnapPoint(x2, y2)
#If VBA7 Then
    Set sh = ActiveLayer.CreateLinearDimension(cdrDimensionSlanted, pts, pte, True, x1 - 20, y1 + 20, cdrDimensionStyleEngineering)
#Else
' X4  There is a difference
    Set sh = ActiveLayer.CreateLinearDimension(cdrDimensionSlanted, pts, pte, True, (x1 + x2) / 2, (y1 + y2) / 2, cdrDimensionStyleEngineering, Textsize:=18)
#End If
    Dimension_SetProperty sh, PresetProperty.value
  Next i

CorelDRAW X4 和高版本不同,没有 ShapeRange 的排序,所以自己使用C++写了一个通用排序库给 CorelDRAW用

  • X4_Sort_ShapeRange(os, stlx) 就是调用 lyvba32.dll 的排序的

    Sub make_sizes_sep(dr, Optional shft = 0, Optional ByVal mirror As Boolean = False)
    On Error GoTo ErrorHandler
    API.BeginOpt "Make Size"
    Set doc = ActiveDocument
    Dim s As Shape, sh As Shape
    Dim pts As New SnapPoint, pte As New SnapPoint
    Dim os As ShapeRange
    
    Set os = ActiveSelectionRange
    
    Dim border As Variant
    Dim Line_len As Double
    If shft > 1 Then
      Line_len = API.Set_Space_Width  '// 设置文字空间间隙
    Else
      Line_len = API.Set_Space_Width(True)  '// 只读文字空间间隙
    End If
    
    border = Array(cdrBottomRight, cdrBottomLeft, os.TopY + Line_len, os.TopY + 2 * Line_len, _
    cdrBottomRight, cdrTopRight, os.LeftX - Line_len, os.LeftX - 2 * Line_len)
    
    If mirror = True Then border = Array(cdrTopRight, cdrTopLeft, os.BottomY - Line_len, os.BottomY - 2 * Line_len, _
    cdrBottomLeft, cdrTopLeft, os.RightX + Line_len, os.RightX + 2 * Line_len)
    
    #If VBA7 Then
    If dr = "upbx" Or dr = "upb" Or dr = "dnb" Or dr = "up" Or dr = "dn" Then os.Sort "@shape1.left < @shape2.left"
    If dr = "lfbx" Or dr = "lfb" Or dr = "rib" Or dr = "lf" Or dr = "ri" Then os.Sort "@shape1.top > @shape2.top"
    #Else
    If dr = "upbx" Or dr = "upb" Or dr = "dnb" Or dr = "up" Or dr = "dn" Then Set os = X4_Sort_ShapeRange(os, stlx)
    If dr = "lfbx" Or dr = "lfb" Or dr = "rib" Or dr = "lf" Or dr = "ri" Then Set os = X4_Sort_ShapeRange(os, stty).ReverseRange
    #End If
    
    
    If os.Count > 0 Then
      If os.Count > 1 And Len(dr) > 2 And os.Shapes.Count > 1 Then
        For i = 1 To os.Shapes.Count - 1
          Select Case dr
            Case "upbx"
    #If VBA7 Then
              Set pts = os.Shapes(i).SnapPoints.BBox(border(0))
              Set pte = os.Shapes(i + 1).SnapPoints.BBox(border(1))
              Set sh = ActiveLayer.CreateLinearDimension(cdrDimensionHorizontal, pts, pte, True, 0, border(2), cdrDimensionStyleEngineering)
              
              If shft > 0 And i = 1 Then
                Dimension_SetProperty sh, PresetProperty.value
                Set pts = os.FirstShape.SnapPoints.BBox(border(0))
                Set pte = os.LastShape.SnapPoints.BBox(border(1))
                Set sh = ActiveLayer.CreateLinearDimension(cdrDimensionHorizontal, pts, pte, True, 0, border(3), cdrDimensionStyleEngineering)
              End If
            
            Case "lfbx"
              Set pts = os.Shapes(i).SnapPoints.BBox(border(4))
              Set pte = os.Shapes(i + 1).SnapPoints.BBox(border(5))
              Set sh = ActiveLayer.CreateLinearDimension(cdrDimensionVertical, pts, pte, True, border(6), 0, cdrDimensionStyleEngineering)
              
              If shft > 0 And i = 1 Then
                Dimension_SetProperty sh, PresetProperty.value
                Set pts = os.FirstShape.SnapPoints.BBox(border(4))
                Set pte = os.LastShape.SnapPoints.BBox(border(5))
                Set sh = ActiveLayer.CreateLinearDimension(cdrDimensionVertical, pts, pte, True, border(7), 0, cdrDimensionStyleEngineering)
              End If
    #Else
    ' X4  There is a difference
              Set pts = CreateSnapPoint(os.Shapes(i).CenterX, os.Shapes(i).CenterY)
              Set pte = CreateSnapPoint(os.Shapes(i + 1).CenterX, os.Shapes(i + 1).CenterY)
              Set sh = ActiveLayer.CreateLinearDimension(cdrDimensionHorizontal, pts, pte, True, 0, border(2), Textsize:=18)
              
            Case "lfbx"
              Set pts = CreateSnapPoint(os.Shapes(i).CenterX, os.Shapes(i).CenterY)
              Set pte = CreateSnapPoint(os.Shapes(i + 1).CenterX, os.Shapes(i + 1).CenterY)
              Set sh = ActiveLayer.CreateLinearDimension(cdrDimensionVertical, pts, pte, True, border(6), 0, Textsize:=18)
    #End If
© 版权声明
THE END
喜欢就支持一下吧
点赞0
分享
评论 抢沙发

请登录后发表评论