update list of donors

UI/Toolbar.bas

@@ -12,11 +12,11 @@ Attribute VB_GlobalNameSpace = False
 Attribute VB_Creatable = False
 Attribute VB_PredeclaredId = True
 Attribute VB_Exposed = False
-
-
 '// This is free and unencumbered software released into the public domain.
 '// For more information, please refer to  https://github.com/hongwenjun
 
+Private Const Github_Version = 1
+
 #If VBA7 Then
     Private Declare PtrSafe Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hWnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
     Private Declare PtrSafe Function DrawMenuBar Lib "user32" (ByVal hWnd As Long) As Long
@@ -35,6 +35,7 @@ Attribute VB_Exposed = False
     Private Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
     Private Declare Function SetLayeredWindowAttributes Lib "user32" (ByVal hWnd As Long, ByVal crKey As Long, ByVal bAlpha As Byte, ByVal dwFlags As Long) As Long
 #End If
+
 Private Const GWL_STYLE As Long = (-16)
 Private Const GWL_EXSTYLE = (-20)
 Private Const WS_CAPTION As Long = &HC00000
@@ -281,9 +282,12 @@ Private Sub UI_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal
     ClipbRectangle.Build_Rectangle
     
   ElseIf Abs(X - pos_x(2)) < 14 And Abs(Y - pos_y(0)) < 14 Then
-    '// 单线条转裁切线 - 放置到页面四边
-    CutLines.SelectLine_to_Cropline
-    
+    If Github_Version = 1 Then
+      Woodman.Show 0
+    Else
+      '// 单线条转裁切线 - 放置到页面四边
+      CutLines.SelectLine_to_Cropline
+    End If
   ElseIf Abs(X - pos_x(3)) < 14 And Abs(Y - pos_y(0)) < 14 Then
     '// 拼版.Arrange
     Arrange.Arrange
@@ -511,8 +515,6 @@ Private Sub Batch_Combine_MouseDown(ByVal Button As Integer, ByVal Shift As Inte
   Else
     Create_Tolerance
   End If
-
-  Speak_Msg "智能拆字"
 End Sub
 
 '''////  简单一刀切  ////'''
@@ -524,29 +526,27 @@ Private Sub Single_Line_MouseDown(ByVal Button As Integer, ByVal Shift As Intege
   Else
     Tools.Single_Line_LastNode
   End If
-  
-  Speak_Msg "简单一刀切"
 End Sub
 
 '''////  傻瓜火车排列  ////'''
 Private Sub TOP_ALIGN_BT_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
   If Button = 2 Then
-    Tools.傻瓜火车排列 3#
+    Tools.Simple_Train_Arrangement 3#
   ElseIf Shift = fmCtrlMask Then
-    Tools.傻瓜火车排列 0#
+    Tools.Simple_Train_Arrangement 0#
   Else
-    Tools.傻瓜火车排列 Set_Space_Width
+    Tools.Simple_Train_Arrangement Set_Space_Width
   End If
 End Sub
 
 '''////  傻瓜阶梯排列  ////'''
 Private Sub LEFT_ALIGN_BT_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
   If Button = 2 Then
-    Tools.傻瓜阶梯排列 3#
+    Tools.Simple_Ladder_Arrangement 3#
   ElseIf Shift = fmCtrlMask Then
-    Tools.傻瓜阶梯排列 0#
+    Tools.Simple_Ladder_Arrangement 0#
   Else
-    Tools.傻瓜阶梯排列 Set_Space_Width
+    Tools.Simple_Ladder_Arrangement Set_Space_Width
   End If
 End Sub
 
@@ -554,10 +554,9 @@ End Sub
 '''////  左键-多页合并一页工具   右键-批量多页居中 ////'''
 Private Sub UniteOne_BT_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
   If Button = 2 Then
-    Tools.批量多页居中
+    Tools.Batch_Align_Page_Center
   ElseIf Shift = fmCtrlMask Then
     UniteOne.Show 0
-    Speak_Msg "多页合并一页"
   Else
     ' Ctrl + 鼠标  空
   End If
@@ -566,7 +565,7 @@ End Sub
 '''////  Adobe AI EPS INDD PDF和CorelDRAW 缩略图工具  ////'''
 Private Sub AdobeThumbnail_Click()
     Dim h As Long, r As Long
-    mypath = Path & "GMS\262235.xyz\"
+    mypath = Path & "GMS\LYVBA\"
     App = mypath & "GuiAdobeThumbnail.exe"
     
     h = FindWindow(vbNullString, "CorelVBA 青年节 By 蘭雅sRGB")
@@ -625,23 +624,23 @@ Private Sub btn_corners_off_Click()
 End Sub
 
 Private Sub SortCount_Click()
-  Tools.按面积排列 30
+  Tools.Count_byArea 30
 End Sub
 
 Private Sub LevelRuler_Click()
-  Tools.角度转平
+  Tools.Angle_to_Horizon
 End Sub
 
 Private Sub MirrorLine_Click()
-  Tools.参考线镜像
+  Tools.Mirror_ByGuide
 End Sub
 
 Private Sub AutoRotate_Click()
-  Tools.自动旋转角度
+  Tools.Auto_Rotation_Angle
 End Sub
 
 Private Sub SwapShape_Click()
-  Tools.交换对象
+  Tools.Exchange_Object
 End Sub
 
 

UI/Woodman.bas

@@ -1,10 +1,10 @@
 VERSION 5.00
 Begin {C62A69F0-16DC-11CE-9E98-00AA00574A4F} Woodman 
-   Caption         =   "批量标注尺寸节点"
-   ClientHeight    =   1980
+   Caption         =   "Batch Dimension Nodes"
+   ClientHeight    =   1995
    ClientLeft      =   45
    ClientTop       =   330
-   ClientWidth     =   3960
+   ClientWidth     =   3930
    OleObjectBlob   =   "Woodman.frx":0000
    StartUpPosition =   1  '所有者中心
 End
@@ -13,8 +13,73 @@ Attribute VB_GlobalNameSpace = False
 Attribute VB_Creatable = False
 Attribute VB_PredeclaredId = True
 Attribute VB_Exposed = False
+'// This is free and unencumbered software released into the public domain.
+'// For more information, please refer to  https://github.com/hongwenjun
 
+#If VBA7 Then
+    Private Declare PtrSafe Function DrawMenuBar Lib "user32" (ByVal hWnd As Long) As Long
+    Private Declare PtrSafe Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long) As Long
+    Private Declare PtrSafe Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
+    Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
+    Private Declare PtrSafe Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
+    
+#Else
+    Private Declare Function DrawMenuBar Lib "user32" (ByVal hWnd As Long) As Long
+    Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long) As Long
+    Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
+    Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
+    Private Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
+#End If
+Private Const GWL_STYLE As Long = (-16)
+Private Const GWL_EXSTYLE = (-20)
+Private Const WS_CAPTION As Long = &HC00000
+Private Const WS_EX_DLGMODALFRAME = &H1&
+
+Private Sub chkOpposite_Click()
+  MiniForm
+End Sub
+
+'// Minimizes the window and retains dimensioning functionality   '// 最小化窗口并保留标注尺寸功能
+Private Function MiniForm()
 
+  Dim IStyle As Long
+  Dim hWnd As Long
+  
+  hWnd = FindWindow("ThunderDFrame", Woodman.Caption)
+
+  IStyle = GetWindowLong(hWnd, GWL_STYLE)
+  IStyle = IStyle And Not WS_CAPTION
+  SetWindowLong hWnd, GWL_STYLE, IStyle
+  DrawMenuBar hWnd
+  IStyle = GetWindowLong(hWnd, GWL_EXSTYLE) And Not WS_EX_DLGMODALFRAME
+  SetWindowLong hWnd, GWL_EXSTYLE, IStyle
+
+  Dim ctl As Control
+  For Each ctl In Woodman.Controls
+      ctl.Visible = False
+      ctl.Top = 2
+  Next ctl
+  
+  With Woodman
+    .StartUpPosition = 0
+    .Left = Val(GetSetting("LYVBA", "Settings", "Left", "400")) + 318
+    .Top = Val(GetSetting("LYVBA", "Settings", "Top", "55")) - 2
+    .Height = 30
+    .Width = 100
+    
+    .MarkLines_Makesize.Visible = True
+    .btn_Makesizes.Visible = True
+    .Manual_Makesize.Visible = True
+    .chkOpposite.Visible = True
+    .X_EXIT.Visible = True
+    
+    .MarkLines_Makesize.Left = 0
+    .btn_Makesizes.Left = 25
+    .Manual_Makesize.Left = 50
+    .chkOpposite.Left = 75: .chkOpposite.Top = 14
+    .X_EXIT.Left = 85: .X_EXIT.Top = 0
+  End With
+End Function
 
 Private Sub btn_square_hi_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
     ActiveDocument.BeginCommandGroup:  Application.Optimization = True
@@ -43,7 +108,7 @@ Private Sub btn_square_wi_MouseUp(ByVal Button As Integer, ByVal Shift As Intege
     ActiveWindow.Refresh:    Application.Refresh
 End Sub
 
-Private Sub btn_makesizes_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
+Private Sub btn_Makesizes_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
     Dim os As ShapeRange
     Dim s As Shape
     Dim sr As ShapeRange
@@ -74,9 +139,9 @@ Private Sub btn_makesizes_MouseUp(ByVal Button As Integer, ByVal Shift As Intege
         On Error Resume Next
         Set os = ActiveSelectionRange
         For Each s In os.Shapes
-            If s.Type = cdrLinearDimensionShape Then sr.Add s
+            If s.Type = cdrLinearDimensionShape Then s.Delete
         Next s
-          If sr.Count > 0 Then
+          If os.Count > 0 Then
             os.Shapes.FindShapes(Query:="@name ='DMKLine'").CreateSelection
             ActiveSelectionRange.Delete
           End If
@@ -114,7 +179,7 @@ Private Sub btn_sizes_btw_ri_MouseUp(ByVal Button As Integer, ByVal Shift As Int
     make_sizes_sep "rib", Shift
 End Sub
 
-Sub make_sizes_sep(dr, Optional shft = 0)
+Sub make_sizes_sep(dr, Optional shft = 0, Optional ByVal mirror As Boolean = False)
     Set doc = ActiveDocument
     Dim s As Shape
     Dim pts As New SnapPoint, pte As New SnapPoint
@@ -136,7 +201,7 @@ Sub make_sizes_sep(dr, Optional shft = 0)
     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 chkOpposite.value Then border = Array(cdrTopRight, cdrTopLeft, os.BottomY - Line_len, os.BottomY - 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)
    
         
@@ -262,81 +327,6 @@ Sub make_sizes(Optional shft = 0)
     doc.Unit = un
 End Sub
 
-Public Function make_selection(Optional mode = "fcolor", Optional sel = True, Optional OSS As ShapeRange = Nothing, Optional colr = Nothing) As ShapeRange
-    Dim s As Shape, lst As Shape
-    Dim sr As ShapeRange
-    'Dim os As ShapeRange
-    Set doc = ActiveDocument
-    doc.Unit = cdrTenthMicron
-    
-    If OSS Is Nothing Then
-        If toolspanel.num_list.value Or mode = "locked" Then
-            Set os = ActivePage
-        Else
-            Set os = ActiveSelectionRange
-        End If
-    Else
-        Set os = OSS
-    End If
-    Set sr = ActiveSelectionRange
-    sr.RemoveAll
-    If sel Then ActiveDocument.ClearSelection
-    Set lst = os.Shapes.First
-    For Each s In os.Shapes
-        Select Case mode
-            Case "ocolor": If s.Outline.Type <> cdrNoOutline And s.Shapes.Count = 0 And s.Outline.Color.HexValue = colr.HexValue Then sr.Add s
-            Case "fcolor": If s.Fill.Type <> cdrNoFill And s.Shapes.Count = 0 And s.Fill.UniformColor.HexValue = colr.HexValue Then sr.Add s
-            Case "nofil": If s.Fill.Type = cdrNoFill And s.Shapes.Count = 0 Then sr.Add s
-            Case "fil": If s.Fill.Type <> cdrNoFill And s.Shapes.Count = 0 Then sr.Add s
-            Case "abr": If s.Outline.Type <> cdrNoOutline And s.Shapes.Count = 0 Then sr.Add s
-            Case "noabr": If s.Outline.Type = cdrNoOutline And s.Shapes.Count = 0 Then sr.Add s
-            Case "open": If Not s.DisplayCurve Is Nothing Then If Not s.DisplayCurve.Closed Then sr.Add s
-            Case "closed": If Not s.DisplayCurve Is Nothing Then If s.DisplayCurve.Closed Then sr.Add s
-            Case "single": If s.Shapes.Count = 0 Then sr.Add s
-            Case "dashed": If s.Outline.Style.DashCount > 0 Then sr.Add s
-            Case "groups": If s.Shapes.Count > 0 And s.Effect Is Nothing Then sr.Add s
-            Case "text": If s.Shapes.Count = 0 And s.Type = cdrTextShape Then sr.Add s
-            Case "notext": If s.Shapes.Count = 0 And s.Type <> cdrTextShape Then sr.Add s
-            Case "images": If s.Type = cdrBitmapShape Then sr.Add s
-            Case "locked": If s.Locked Then sr.Add s
-            Case "effects": If s.Effects.Count > 0 Or Not s.Effect Is Nothing Then sr.Add s
-            Case "noeffects": If s.Effects.Count = 0 And s.Effect Is Nothing Then sr.Add s
-            Case "bigger":
-                arelst = lst.SizeHeight * lst.SizeWidth
-                ares = s.SizeHeight * s.SizeWidth
-                If ares >= arelst Then
-                    are = one_shape_area(lst)
-                    If one_shape_area(s) >= are Then sr.Add s
-                End If
-            Case "smaller":
-                arelst = lst.SizeHeight * lst.SizeWidth
-                ares = s.SizeHeight * s.SizeWidth
-                If ares <= arelst Then
-                    are = one_shape_area(lst)
-                    If one_shape_area(s) <= are Then sr.Add s
-                End If
-            Case "last":
-                If lst.Fill.Type = cdrNoFill Then
-                    's.CreateSelection
-                    If s.Outline.Type <> cdrNoOutline Then If s.Outline.Color.HexValue = lst.Outline.Color.HexValue Then sr.Add s
-                Else
-                    If s.Fill.UniformColor.HexValue = lst.Fill.UniformColor.HexValue Then sr.Add s
-                End If
-        End Select
-    Next s
-    
-    If sr.Shapes.Count > 0 And sel Then sr.CreateSelection
-    Set make_selection = sr
-    
-    Application.Refresh
-    ActiveWindow.Activate
-End Function
-
-Public Function get_events(btn As String, Optional shft = 0, Optional click = 1)
-    out = "ok"
-    get_events = out
-End Function
-
 Private Sub btn_join_nodes_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
     ActiveSelection.CustomCommand "ConvertTo", "JoinCurves"
     Application.Refresh
@@ -364,25 +354,35 @@ ErrorHandler:
   MsgBox "s.Curve.AutoReduceNodes 只有高版本才支持本API"
 End Sub
 
-'// 使用标记线批量建立尺寸标注
+'// 使用标记线批量建立尺寸标注:   左键上标注，右键右标注
 Private Sub MarkLines_Makesize_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
   Dim sr As ShapeRange
   Set sr = ActiveSelectionRange
+  
+  '// 右键
   If Button = 2 Then
-    CutLines.Dimension_MarkLines cdrAlignLeft, chkOpposite.value
-    make_sizes_sep "lfbx", Shift
-  Else
-    CutLines.Dimension_MarkLines cdrAlignTop, chkOpposite.value
-    Label_Makesizes.Caption = "试试右键"
-    make_sizes_sep "upbx", Shift
+    If chkOpposite.value = True Then
+        CutLines.Dimension_MarkLines cdrAlignTop, True
+        make_sizes_sep "upbx", Shift, True
+    Else
+      CutLines.Dimension_MarkLines cdrAlignLeft, True
+      make_sizes_sep "lfbx", Shift, True
+    End If
+  
+  '// 左键
+  ElseIf Button = 1 Then
+    If chkOpposite.value = True Then
+      CutLines.Dimension_MarkLines cdrAlignLeft, False
+      make_sizes_sep "lfbx", Shift, False
+    Else
+        CutLines.Dimension_MarkLines cdrAlignTop, False
+        make_sizes_sep "upbx", Shift, False
+    End If
   End If
+  
   sr.CreateSelection
 End Sub
 
-Private Sub chkOpposite_Click()
-'  Debug.Print chkOpposite.value
-End Sub
-
 '// 使用手工选节点建立尺寸标注，使用Ctrl分离尺寸标注
 Private Sub Manual_Makesize_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
   If Button = 2 Then
@@ -482,3 +482,6 @@ Private Function Slanted_Sort_Make(shs As ShapeRange)
   API.EndOpt
 End Function
 
+Private Sub X_EXIT_Click()
+  Unload Me    '// EXIT
+End Sub

donate.md

@@ -44,8 +44,10 @@ a-嘉盟
 幼儿园最亮的仔
 舞
 方华广告
+肥崽很忙
 ```
 
+
 ### 会员群福利: 
 ```
 1. 本工具免费开源，捐赠会员有得到最新内测版软件，和有限技术支持

module/CorelVBA.bas

@@ -0,0 +1,8 @@
+Attribute VB_Name = "CORELVBA"
+Public Sub Start()
+  Toolbar.Show 0
+'  CorelVBA.show 0
+'  MsgBox "请给我支持!" & vbNewLine & "您的支持，我才能有动力添加更多功能." & vbNewLine & "蘭雅CorelVBA中秋节版" & vbNewLine & "coreldrawvba插件交流群  8531411"
+'  Speak_Msg "感谢您使用 蘭雅VBA工具"
+End Sub
+

module/Launcher.bas

@@ -55,10 +55,10 @@ End Function
 
 '// 找字体 https://www.myfonts.com/pages/whatthefont
 Public Function START_whatthefont()
-  Weburl "https://www.myfonts.com/pages/whatthefont"
+ '// Weburl "https://www.myfonts.com/pages/whatthefont"
 End Function
 
 
 Function Weburl(url As String)
-  API.WebHelp url
+ '// API.WebHelp url
 End Function

module/Tools.bas

@@ -150,7 +150,8 @@ End Function
 Public Function Align_Page_Center()
   If 0 = ActiveSelectionRange.Count Then Exit Function
   '// 实践应用: 选择物件群组,页面设置物件大小,物件页面居中
-  ActiveDocument.Unit = cdrMillimeter
+  API.BeginOpt
+  
   Dim OrigSelection As ShapeRange, sh As Shape
   Set OrigSelection = ActiveSelectionRange
   Set sh = OrigSelection.Group
@@ -163,6 +164,8 @@ Public Function Align_Page_Center()
 #Else
   sh.AlignToPageCenter cdrAlignHCenter + cdrAlignVCenter
 #End If
+
+  API.EndOpt
 End Function