ALGO.bas 3.0 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104
  1. Attribute VB_Name = "ALGO"
  2. '// This is free and unencumbered software released into the public domain.
  3. '// For more information, please refer to https://github.com/hongwenjun
  4. '// Algorithm 模块
  5. #If VBA7 Then
  6. '// For CorelDRAW X6-2023 62bit
  7. '// Private Declare PtrSafe Function sort_byitem Lib "C:\TSP\lyvba.dll" (ByRef sr_Array As ShapeProperties, ByVal size As Long, _
  8. '// ByVal Sort_By As SortItem, ByRef ret_Array As Long) As Long
  9. #Else
  10. '// For CorelDRAW X4 32bit
  11. Declare Function sort_byitem Lib "C:\TSP\lyvba32.dll" (ByRef sr_Array As ShapeProperties, ByVal size As Long, _
  12. ByVal Sort_By As SortItem, ByRef ret_Array As Long) As Long
  13. #End If
  14. Type ShapeProperties
  15. Item As Long '// ShapeRange.Item
  16. StaticID As Long '// Shape.StaticID
  17. lx As Double: rx As Double '// s.LeftX s.RightX s.BottomY s.TopY
  18. by As Double: ty As Double
  19. cx As Double: cy As Double '// s.CenterX s.CenterY s.SizeWidth s.SizeHeight
  20. sw As Double: sh As Double
  21. End Type
  22. Enum SortItem
  23. stlx
  24. strx
  25. stby
  26. stty
  27. stcx
  28. stcy
  29. stsw
  30. stsh
  31. Area
  32. topWt_left
  33. End Enum
  34. Private Sub Test_Sort_ShapeRange()
  35. API.BeginOpt
  36. Dim sr As ShapeRange, ssr As ShapeRange
  37. Dim s As Shape
  38. Set sr = ActiveSelectionRange
  39. Set ssr = ShapeRange_To_Sort_Array(sr, topWt_left)
  40. '// s 调整次序
  41. For Each s In ssr
  42. s.OrderToFront
  43. Next s
  44. MsgBox "ShapeRange_SortItem:" & " " & topWt_left & " 枚举值"
  45. API.EndOpt
  46. End Sub
  47. Public Function X4_Sort_ShapeRange(ByRef sr As ShapeRange, ByRef Sort_By As SortItem) As ShapeRange
  48. Set X4_Sort_ShapeRange = ShapeRange_To_Sort_Array(sr, Sort_By)
  49. End Function
  50. '// 映射 ShapeRange 到 Array 然后调用 DLL库排序
  51. Private Function ShapeRange_To_Sort_Array(ByRef sr As ShapeRange, ByRef Sort_By As SortItem) As ShapeRange
  52. ' On Error GoTo ErrorHandler
  53. Dim sp As ShapeProperties
  54. Dim size As Long, ret As Long
  55. Dim s As Shape
  56. size = sr.Count
  57. Dim sr_Array() As ShapeProperties
  58. Dim ret_Array() As Long
  59. ReDim ret_Array(1 To size)
  60. ReDim sr_Array(1 To size)
  61. For Each s In sr
  62. sp.Item = sr.IndexOf(s)
  63. sp.StaticID = s.StaticID
  64. sp.lx = s.LeftX: sp.rx = s.RightX
  65. sp.by = s.BottomY: sp.ty = s.topY
  66. sp.cx = s.CenterX: sp.cy = s.CenterY
  67. sp.sw = s.SizeWidth: sp.sh = s.SizeHeight
  68. sr_Array(sp.Item) = sp
  69. Next s
  70. '// 在VBA中数组的索引从1开始, 将数组的地址传递给函数需要Arr(1)方式
  71. '// C/C++ 函数定义 int __stdcall SortByItem(ShapeProperties* sr_Array, int size, SortItem Sort_By, int* ret_Array)
  72. '// sr_Array首地址,size 长度, Sort_By 排序方式, 返回数组 ret_Array
  73. ret = sort_byitem(sr_Array(1), size, Sort_By, ret_Array(1))
  74. Debug.Print ret, size
  75. If ret = size Then
  76. Dim srcp As New ShapeRange, i As Integer
  77. For i = 1 To size
  78. srcp.Add sr(ret_Array(i))
  79. ' Debug.Print i
  80. Next i
  81. Set ShapeRange_To_Sort_Array = srcp
  82. End If
  83. ErrorHandler:
  84. End Function