corelvba/module/ALGO.bas

Attribute VB_Name = "ALGO"
'// Algorithm 模块
#If VBA7 Then
'// For CorelDRAW X6-2023  62bit
Public Declare PtrSafe Function i18n Lib "C:\TSP\lyvba.dll" (ByVal str As String, ByVal code As Long) As String
Private Declare PtrSafe Function sort_byitem Lib "C:\TSP\lyvba.dll" (ByRef sr_Array As ShapeProperties, ByVal size As Long, _
                      ByVal Sort_By As SortItem, ByRef ret_Array As Long) As Long
#Else
'// For CorelDRAW X4  32bit
Declare Function i18n Lib "C:\TSP\lyvba32.dll" (ByVal str As String, ByVal code As Long) As String
Declare Function sort_byitem Lib "C:\TSP\lyvba32.dll" (ByRef sr_Array As ShapeProperties, ByVal size As Long, _
                      ByVal Sort_By As SortItem, ByRef ret_Array As Long) As Long
#End If

Type ShapeProperties
  Item As Long                 '// ShapeRange.Item
  StaticID As Long             '// Shape.StaticID
  lx As Double: rx As Double   '// s.LeftX  s.RightX  s.BottomY  s.TopY
  by As Double: ty As Double
  cx As Double: cy As Double   '// s.CenterX  s.CenterY s.SizeWidth s.SizeHeight
  sw As Double: sh As Double
End Type

Enum SortItem
  stlx
  strx
  stby
  stty
  stcx
  stcy
  stsw
  stsh
  Area
  topWt_left
End Enum

Public LNG_CODE As Long

Private Sub Test_Sort_ShapeRange()
  API.BeginOpt
  Dim sr As ShapeRange, ssr As ShapeRange
  Dim s As Shape
  Set sr = ActiveSelectionRange
  Set ssr = ShapeRange_To_Sort_Array(sr, topWt_left)

  '// s 调整次序
  For Each s In ssr
    s.OrderToFront
  Next s

  MsgBox "ShapeRange_SortItem:" & " " & topWt_left & "  枚举值"
  API.EndOpt
End Sub

Public Function X4_Sort_ShapeRange(ByRef sr As ShapeRange, ByRef Sort_By As SortItem) As ShapeRange
  Set X4_Sort_ShapeRange = ShapeRange_To_Sort_Array(sr, Sort_By)
End Function

Public Function sorted(ByRef sr As ShapeRange, ByRef Sort_By As SortItem) As ShapeRange
  Set sorted = ShapeRange_To_Sort_Array(sr, Sort_By)
End Function

'// 映射 ShapeRange 到 Array 然后调用 DLL库排序
Private Function ShapeRange_To_Sort_Array(ByRef sr As ShapeRange, ByRef Sort_By As SortItem) As ShapeRange
  On Error GoTo ErrorHandler
  Dim sp As ShapeProperties
  Dim size As Long, ret As Long
  Dim s As Shape
  size = sr.Count
  
  Dim sr_Array() As ShapeProperties
  Dim ret_Array() As Long
  ReDim ret_Array(1 To size)
  ReDim sr_Array(1 To size)
  
  For Each s In sr
    sp.Item = sr.IndexOf(s)
    sp.StaticID = s.StaticID
    sp.lx = s.LeftX: sp.rx = s.RightX
    sp.by = s.BottomY: sp.ty = s.TopY
    sp.cx = s.CenterX: sp.cy = s.CenterY
    sp.sw = s.SizeWidth: sp.sh = s.SizeHeight
    sr_Array(sp.Item) = sp
  Next s

  '// 在VBA中数组的索引从1开始, 将数组的地址传递给函数需要Arr(1)方式
  '// C/C++ 函数定义 int __stdcall SortByItem(ShapeProperties* sr_Array, int size, SortItem Sort_By, int* ret_Array)
  '// sr_Array首地址，size 长度， Sort_By 排序方式, 返回数组 ret_Array
  ret = sort_byitem(sr_Array(1), size, Sort_By, ret_Array(1))
  
'  Debug.Print ret, size
  If ret = size Then
    Dim srcp As New ShapeRange, i As Integer
    For i = 1 To size
      srcp.Add sr(ret_Array(i))
'     Debug.Print i
    Next i
    
    Set ShapeRange_To_Sort_Array = srcp
  End If
  
ErrorHandler:

End Function


Private Sub Test_i18n()
  MsgBox i18n("Nodes", 2052)
  MsgBox i18n("Nodes", 1033)
  MsgBox i18n("Preset Property", 2052)
End Sub


Public Function Init_Translations(frm As UserForm, code As Long)
    Dim ctl As Variant: Dim en As String
    LNG_CODE = code
    
    For Each ctl In frm.Controls
    If TypeOf ctl Is MSForms.Label Or TypeOf ctl Is MSForms.CommandButton Or TypeOf ctl Is MSForms.ToggleButton Or TypeOf ctl Is MSForms.CheckBox Then
        If Not IsNull(ctl.Caption) And ctl.Caption <> "" Then
          en = ctl.Caption
          ctl.Caption = i18n(en, LNG_CODE)
        End If
        If Not IsNull(ctl.ControlTipText) And ctl.ControlTipText <> "" Then
          en = ctl.ControlTipText
          ctl.ControlTipText = i18n(en, LNG_CODE)
        End If
    End If
  Next ctl
  
End Function