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