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

【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