更新

README.md

@@ -8,6 +8,16 @@
 ![](https://raw.githubusercontent.com/hongwenjun/img/master/VBA/002.gif)
 
 
+# 零基础CorelVBA教程 合集  2022.12.14 源码更新
+
+## [【Part01_CorelDRAW软件安装和GMS文件简单使用】](https://www.bilibili.com/video/BV16G4y1o7u4/?share_source=copy_web&vd_source=8e94edd08d369c0c217cdec8f041fd18)
+
+## [【Part02_CorelDRAW_GMS插件安装和设置_批量多页居中功能演示】](https://www.bilibili.com/video/BV1TD4y1a7Mb/?share_source=copy_web&vd_source=8e94edd08d369c0c217cdec8f041fd18)
+
+## [【Part03_CorelDRAW_GMS插件设置快捷键】](https://www.bilibili.com/video/BV13A41197H2/?share_source=copy_web&vd_source=8e94edd08d369c0c217cdec8f041fd18)
+
+## [【Part04_CorelDRAW_敏捷化编程编写功能自动旋转角度】](https://www.bilibili.com/video/BV1F8411p7TY/?share_source=copy_web&vd_source=8e94edd08d369c0c217cdec8f041fd18)
+
 
 ### [捐赠 蘭雅CorelVBA工具 开源软件](https://github.com/hongwenjun/corelvba/blob/main/donate.md)
 # [CorelDRAW VBA](https://262235.xyz/index.php/tag/vba/)

Tools.bas

@@ -11,6 +11,7 @@ End Function
 
 Public Sub 填入居中文字(str)
   Dim s As Shape
+<<<<<<< HEAD
   Dim x As Double, y As Double, Shift As Long
   Dim b As Boolean
   b = ActiveDocument.GetUserClick(x, y, Shift, 10, False, cdrCursorIntersectSingle)
@@ -20,17 +21,35 @@ Public Sub
   Set s = ActiveLayer.CreateArtisticText(0, 0, str)
   s.CenterX = x
   s.CenterY = y
+=======
+  Set s = ActiveSelection
+  X = s.CenterX
+  Y = s.CenterY
+  
+  Set s = ActiveLayer.CreateArtisticText(0, 0, Str)
+  s.CenterX = X
+  s.CenterY = Y
+>>>>>>> 556e97d494ce938408287776a3528f332486766c
 End Sub
 
 Public Sub 尺寸标注()
   ActiveDocument.Unit = cdrMillimeter
   Set s = ActiveSelection
+<<<<<<< HEAD
   x = s.CenterX: y = s.TopY
   sw = s.SizeWidth: sh = s.SizeHeight
         
   text = Int(sw) & "x" & Int(sh) & "mm"
   Set s = ActiveLayer.CreateArtisticText(0, 0, text)
   s.CenterX = x: s.BottomY = y + 5
+=======
+  X = s.CenterX: Y = s.TopY
+  sw = s.SizeWidth: sh = s.SizeHeight
+        
+  Text = Int(sw) & "x" & Int(sh) & "mm"
+  Set s = ActiveLayer.CreateArtisticText(0, 0, Text)
+  s.CenterX = X: s.BottomY = Y + 5
+>>>>>>> 556e97d494ce938408287776a3528f332486766c
 End Sub
 
 Public Sub 批量居中文字(str)
@@ -38,10 +57,17 @@ Public Sub
   Set sr = ActiveSelectionRange
   
   For Each s In sr.Shapes
+<<<<<<< HEAD
     x = s.CenterX: y = s.CenterY
     
     Set s = ActiveLayer.CreateArtisticText(0, 0, str)
     s.CenterX = x: s.CenterY = y
+=======
+    X = s.CenterX: Y = s.CenterY
+    
+    Set s = ActiveLayer.CreateArtisticText(0, 0, Str)
+    s.CenterX = X: s.CenterY = Y
+>>>>>>> 556e97d494ce938408287776a3528f332486766c
   Next
 End Sub
 
@@ -50,12 +76,21 @@ Public Sub
   Set sr = ActiveSelectionRange
   
   For Each s In sr.Shapes
+<<<<<<< HEAD
     x = s.CenterX: y = s.TopY
     sw = s.SizeWidth: sh = s.SizeHeight
           
     text = Int(sw + 0.5) & "x" & Int(sh + 0.5) & "mm"
     Set s = ActiveLayer.CreateArtisticText(0, 0, text)
     s.CenterX = x: s.BottomY = y + 5
+=======
+    X = s.CenterX: Y = s.TopY
+    sw = s.SizeWidth: sh = s.SizeHeight
+          
+    Text = Int(sw + 0.5) & "x" & Int(sh + 0.5) & "mm"
+    Set s = ActiveLayer.CreateArtisticText(0, 0, Text)
+    s.CenterX = X: s.BottomY = Y + 5
+>>>>>>> 556e97d494ce938408287776a3528f332486766c
   Next
 End Sub
 
@@ -210,9 +245,15 @@ Public Function
 
   Dim s1 As Shape
 ' Set s1 = ActiveLayer.CreateParagraphText(0, 0, 100, 150, Str, Font:="华文中宋")
+<<<<<<< HEAD
   x = ssr.FirstShape.LeftX - 100
   y = ssr.FirstShape.TopY
   Set s1 = ActiveLayer.CreateParagraphText(x, y, x + 90, y - 150, str, Font:="华文中宋")
+=======
+  X = ssr.FirstShape.LeftX - 100
+  Y = ssr.FirstShape.TopY
+  Set s1 = ActiveLayer.CreateParagraphText(X, Y, X + 90, Y - 150, Str, Font:="华文中宋")
+>>>>>>> 556e97d494ce938408287776a3528f332486766c
 End Function
  
 '// 实现Excel里分类汇总功能
@@ -428,7 +469,18 @@ Public Function collect_arr(arr, ci, ki)
 End Function
 
 
+' 两个端点的坐标,为(x1,y1)和(x2,y2) 那么其角度a的tan值: tana=(y2-y1)/(x2-x1)
+' 所以计算arctan(y2-y1)/(x2-x1), 得到其角度值a
+' VB中用atn(), 返回值是弧度，需要 乘以 PI /180
+Private Function lineangle(x1, y1, x2, y2) As Double
+  pi = 4 * VBA.Atn(1) ' 计算圆周率
+  If x2 = x1 Then
+    lineangle = 90: Exit Function
+  End If
+  lineangle = VBA.Atn((y2 - y1) / (x2 - x1)) / pi * 180
+End Function
 
+<<<<<<< HEAD
 Sub Make_Sizes()
     ActiveDocument.Unit = cdrMillimeter
     Set os = ActiveSelectionRange
@@ -834,3 +886,281 @@ Public Function GetClipBoardString() As String
   GetClipBoardString = MyData.GetText
   Set MyData = Nothing
 End Function
+=======
+Public Function 角度转平()
+  On Error GoTo ErrorHandler
+'  ActiveDocument.ReferencePoint = cdrCenter
+  Set sr = ActiveSelectionRange
+  Set nr = sr.LastShape.DisplayCurve.Nodes.All
+
+  If nr.Count = 2 Then
+    x1 = nr.FirstNode.PositionX: y1 = nr.FirstNode.PositionY
+    x2 = nr.LastNode.PositionX: y2 = nr.LastNode.PositionY
+    a = lineangle(x1, y1, x2, y2): sr.Rotate -a
+    ' sr.LastShape.Delete   '// 删除参考线
+  End If
+ErrorHandler:
+End Function
+
+Public Function 自动旋转角度()
+  On Error GoTo ErrorHandler
+'  ActiveDocument.ReferencePoint = cdrCenter
+  Set sr = ActiveSelectionRange
+  Set nr = sr.LastShape.DisplayCurve.Nodes.All
+
+  If nr.Count = 2 Then
+    x1 = nr.FirstNode.PositionX: y1 = nr.FirstNode.PositionY
+    x2 = nr.LastNode.PositionX: y2 = nr.LastNode.PositionY
+    a = lineangle(x1, y1, x2, y2): sr.Rotate 90 + a
+    sr.LastShape.Delete   '// 删除参考线
+  End If
+ErrorHandler:
+End Function
+
+
+Public Function 交换对象()
+  Set sr = ActiveSelectionRange
+  If sr.Count = 2 Then
+    X = sr.LastShape.CenterX: Y = sr.LastShape.CenterY
+    sr.LastShape.CenterX = sr.FirstShape.CenterX: sr.LastShape.CenterY = sr.FirstShape.CenterY
+    sr.FirstShape.CenterX = X: sr.FirstShape.CenterY = Y
+  End If
+End Function
+
+
+'//  ===================================================
+Private Sub btn_autoalign_byrow_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
+    If get_events("btn_autoalign_byrow", Shift, Button) = "exit" Then Exit Sub
+    autogroup("group_lines", 16 + Shift).CreateSelection
+End Sub
+Private Sub btn_autoalign_bycolumn_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
+    If get_events("btn_autoalign_bycolumn", Shift, Button) = "exit" Then Exit Sub
+    autogroup("group_lines", 13 + Shift).CreateSelection
+End Sub
+Private Sub btn_autogroup_byrow_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
+    If get_events("btn_autogroup_byrow", Shift, Button) = "exit" Then Exit Sub
+    autogroup("group_lines", 6).CreateSelection
+End Sub
+Private Sub btn_autogroup_bycolumn_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
+    If get_events("btn_autogroup_bycolumn", Shift, Button) = "exit" Then Exit Sub
+    autogroup("group_lines", 3).CreateSelection
+End Sub
+Private Sub btn_autogroup_bysquare_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
+    If get_events("btn_autogroup_bysquare", Shift, Button) = "exit" Then Exit Sub
+    autogroup("group").CreateSelection
+End Sub
+Private Sub btn_autogroup_byshape_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
+    If get_events("btn_autogroup_byshape", Shift, Button) = "exit" Then Exit Sub
+    autogroup("group", 1).CreateSelection
+End Sub
+
+Public Sub begin_func(Optional undoname = "nul", Optional units = cdrMillimeter, Optional undogroup = True, Optional optimize = True, Optional sett = "before")
+        ActiveDocument.SaveSettings sett
+        ActiveDocument.Unit = units
+        If undogroup Then ActiveDocument.BeginCommandGroup undoname
+        Application.Optimization = optimize
+        EventsEnabled = Not optimize
+End Sub
+
+Public Sub end_func(Optional undogroup = True, Optional sett = "before")
+    cure_app undogroup
+    ActiveDocument.RestoreSettings sett
+End Sub
+
+Sub cure_app(Optional undogroup = True)
+    EventsEnabled = True
+    Application.Optimization = False
+    Application.Refresh
+    DoEvents
+    If undogroup Then ActiveDocument.EndCommandGroup
+End Sub
+
+Public Function collect_arr(arr, ci, ki)
+    lim = UBound(arr)
+    For k = 1 To lim
+        If arr(ki, k) > 0 Then
+            arr(ci, k) = k
+            If ki <> ci Then arr(ki, k) = Empty
+            If ci <> k And ki <> k Then arr = collect_arr(arr, ci, k)
+        End If
+    Next k
+    'If ki <> ci Then arr(ki, ki) = Empty
+    collect_arr = arr
+End Function
+
+Public Function autogroup(Optional group As String = "group", Optional shft = 0, Optional sss As Shapes = Nothing, Optional undogroup = True) As ShapeRange
+    Dim sr As ShapeRange, sr_all As ShapeRange, os As ShapeRange
+    Dim sp As SubPaths
+    Dim arr()
+    Dim s As Shape
+    If sss Is Nothing Then Set os = ActiveSelectionRange Else Set os = sss.All
+'On Error GoTo errn
+    If ActiveSelection.Shapes.Count > 0 Then
+        begin_func "autogroup" & group, cdrMillimeter, undogroup
+        gcnt = os.Shapes.Count
+        ReDim arr(1 To gcnt, 1 To gcnt)
+        Set sr_all = ActiveSelectionRange
+        sr_all.RemoveAll
+        If group = "group_lines" Then
+            For i = 1 To gcnt
+                If shft = 3 Or shft = 13 Or shft = 14 Then
+                    coord = Int(os.Shapes(i).CenterX)
+                Else
+                    coord = Int(os.Shapes(i).CenterY)
+                End If
+                fnd = False
+                For k = 1 To gcnt
+                    If arr(k, 1) > 0 Then
+                        If arr(k, 2) = coord Then
+                            arr(k, 1) = arr(k, 1) + 1
+                            arr(k, 2 + arr(k, 1)) = i
+                            fnd = True
+                            Exit For
+                        End If
+                    Else
+                        Exit For
+                    End If
+                Next k
+                If Not fnd Then
+                    arr(k, 1) = 1
+                    arr(k, 2) = coord
+                    arr(k, 3) = i
+                End If
+            Next i
+            Set sr = ActiveSelectionRange
+            For i = 1 To gcnt
+                If arr(i, 1) > 0 Then
+                    sr.RemoveAll
+                    For k = 3 To gcnt
+                        If arr(i, k) > 0 Then sr.Add os.Shapes(arr(i, k))
+                    Next k
+                    If sr.Shapes.Count > 0 Then
+                        sr.CreateSelection
+                        If shft = 13 Then
+                            sr.AlignAndDistribute cdrAlignDistributeHNone, cdrAlignDistributeVDistributeSpacing
+                        ElseIf shft = 14 Then
+                            sr.AlignAndDistribute cdrAlignDistributeHNone, cdrAlignDistributeVDistributeCenter
+                        ElseIf shft = 16 Then
+                            sr.AlignAndDistribute cdrAlignDistributeHDistributeSpacing, cdrAlignDistributeVNone
+                        ElseIf shft = 17 Then
+                            sr.AlignAndDistribute cdrAlignDistributeHDistributeCenter, cdrAlignDistributeVNone
+                        Else
+                            sr.group
+                        End If
+                        sr_all.AddRange sr
+                    End If
+                End If
+            Next i
+        Else
+            ReDim arr(1 To gcnt, 1 To gcnt)
+            ActiveDocument.Unit = cdrTenthMicron
+            sgap = 10
+            If shft = 2 Or shft = 3 Or shft = 6 Or shft = 7 Then
+                os.RemoveAll
+                For Each s In ActiveSelectionRange.Shapes
+                    os.Add ActivePage.SelectShapesFromRectangle(s.LeftX - sgap, s.BottomY - sgap, s.RightX + sgap, s.TopY + sgap, True)
+                Next s
+            End If
+            
+            For i = 1 To os.Shapes.Count
+                Set s1 = os.Shapes(i)
+                arr(i, i) = i
+                For j = 1 To os.Shapes.Count
+                    Set s2 = os.Shapes(j)
+                    If s2.LeftX < s1.RightX + sgap And s2.RightX > s1.LeftX - sgap And s2.BottomY < s1.TopY + sgap And s2.TopY > s1.BottomY - sgap Then
+                        If shft = 1 Or shft = 3 Or shft = 5 Or shft = 7 Then
+                            Set isec = s1.Intersect(s2)
+                            If Not isec Is Nothing Then
+                                arr(i, j) = j
+                                isec.CreateSelection
+                                isec.Delete
+                            End If
+                        Else
+                            arr(i, j) = j
+                        End If
+                    End If
+                Next j
+            Next i
+            
+            For i = 1 To gcnt
+                arr = collect_arr(arr, i, i)
+            Next i
+            
+            Set sr = ActiveSelectionRange
+
+            For i = 1 To gcnt
+                sr.RemoveAll
+                inar = 0
+                For j = 1 To gcnt
+                    If arr(i, j) > 0 Then
+                        sr.Add os.Shapes(j)
+                        inar = inar + 1
+                    End If
+                Next j
+                If inar > 1 Then
+                    If group = "group" Then
+                        If shft < 4 Then sr_all.Add sr.group
+                    Else
+                        If group = "front" Then
+                            sr.Sort "@shape1.com.zOrder > @shape2.com.zOrder"
+                        ElseIf group = "back" Then
+                            sr.Sort "@shape1.com.zOrder < @shape2.com.zOrder"
+                        Else
+                            sr.Sort "@shape1.width*@shape1.height < @shape2.width*@shape2.height"
+                        End If
+                        Set fs = sr.FirstShape
+                        Set ls = sr.LastShape
+                        For Each s In sr.Shapes
+                            If Not s Is ls And Not s Is fs Then
+                                If group = "autocut" Then
+                                    Set isec = ls.Intersect(s)
+                                    If Not isec Is Nothing Then
+                                        If isec.Curve.Area = s.Curve.Area Then
+                                            Set ls = fs.Trim(ls, False)
+                                        Else
+                                            Set ls = fs.Weld(ls, False)
+                                        End If
+                                        isec.Delete
+                                    End If
+                                Else
+                                    Set fs = s.Weld(fs, False, False)
+                                End If
+                            End If
+                        Next s
+                        If group = "weld" Then
+                            Set ls = fs.Weld(ls, False)
+                        Else
+                            Set ls = fs.Trim(ls, False)
+                        End If
+                        sr_all.Add ls
+                    End If
+                Else
+                    If sr.Shapes.Count > 0 Then sr_all.AddRange sr
+                End If
+            Next i
+        End If
+        Set autogroup = sr_all
+    End If
+errn:
+    end_func undogroup
+End Function
+
+Sub auto_cut()
+    autogroup("autocut").CreateSelection
+End Sub
+Sub auto_big_small()
+    autogroup("big").CreateSelection
+End Sub
+Sub auto_group()
+    autogroup.CreateSelection
+End Sub
+Sub auto_weld()
+    autogroup("weld").CreateSelection
+End Sub
+Sub auto_group_lines()
+    autogroup("group_lines", 6).CreateSelection
+End Sub
+Sub auto_group_columns()
+    autogroup("group_lines", 3).CreateSelection
+End Sub
+>>>>>>> 556e97d494ce938408287776a3528f332486766c

VBA_FORM.frm

@@ -4,7 +4,11 @@ Begin {C62A69F0-16DC-11CE-9E98-00AA00574A4F} VBA_FORM
    ClientHeight    =   7800
    ClientLeft      =   45
    ClientTop       =   390
+<<<<<<< HEAD
    ClientWidth     =   6345
+=======
+   ClientWidth     =   5415
+>>>>>>> 556e97d494ce938408287776a3528f332486766c
    OleObjectBlob   =   "VBA_FORM.frx":0000
    StartUpPosition =   1  '所有者中心
 End
@@ -13,14 +17,18 @@ Attribute VB_GlobalNameSpace = False
 Attribute VB_Creatable = False
 Attribute VB_PredeclaredId = True
 Attribute VB_Exposed = False
+<<<<<<< HEAD
 Private Sub AutoRotate_Click()
   Tools.自动旋转角度
 End Sub
 
+=======
+>>>>>>> 556e97d494ce938408287776a3528f332486766c
 Private Sub btn_autoalign_bycolumn_Click()
   autogroup("group", 1).CreateSelection
 End Sub
 
+<<<<<<< HEAD
 Private Sub btn_corners_off_Click()
   Tools.corner_off
 End Sub
@@ -31,6 +39,9 @@ End Sub
 
 
 Private Sub CB_AQX_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal y As Single)
+=======
+Private Sub CB_AQX_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
+>>>>>>> 556e97d494ce938408287776a3528f332486766c
   If Button = 2 Then
     Tools.guideangle ActiveSelectionRange, 0#   ' 右键 0距离贴紧
   ElseIf Shift = fmCtrlMask Then
@@ -57,10 +68,13 @@ Private Sub CB_JHDX_Click()
   Tools.交换对象
 End Sub
 
+<<<<<<< HEAD
 Private Sub CB_make_sizes_Click()
   Tools.Make_Sizes
 End Sub
 
+=======
+>>>>>>> 556e97d494ce938408287776a3528f332486766c
 Private Sub CB_PLBZ_Click()
   Tools.批量标注
 End Sub
@@ -86,7 +100,11 @@ Private Sub CB_VBA_Click()
   MsgBox "你好 CorelVBA!"
 End Sub
 
+<<<<<<< HEAD
 Private Sub CB_VBA_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal y As Single)
+=======
+Private Sub CB_VBA_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
+>>>>>>> 556e97d494ce938408287776a3528f332486766c
   CB_VBA.BackColor = RGB(255, 0, 0)
 End Sub
 

代码练习/使用字典和排序计算行列.bas

@@ -0,0 +1,53 @@
+Private Type Coordinate
+    x As Double
+    y As Double
+End Type
+
+Sub 计算行列()   ' 字典使用计算行列
+
+  ActiveDocument.Unit = cdrMillimeter
+  Set xdict = CreateObject("Scripting.dictionary")
+  Set ydict = CreateObject("Scripting.dictionary")
+  Dim dot As Coordinate, Offset As Coordinate
+  Dim s As Shape, ssr As ShapeRange
+  Set ssr = ActiveSelectionRange
+  
+  ' 当前选择物件的范围边界
+  set_lx = ssr.LeftX: set_rx = ssr.RightX
+  set_by = ssr.BottomY: set_ty = ssr.TopY
+  ssr(1).GetSize Offset.x, Offset.y
+  ' 当前选择物件 ShapeRange 初步排序
+  ssr.Sort " @shape1.Top * 100 - @shape1.Left > @shape2.Top * 100 - @shape2.Left"
+  
+  For Each s In ssr
+    dot.x = s.CenterX: dot.y = s.CenterY
+    If xdict.Exists(Int(dot.x)) = False Then xdict.Add Int(dot.x), dot.x
+    If ydict.Exists(Int(dot.y)) = False Then ydict.Add Int(dot.y), dot.y
+  Next s
+  
+'  MsgBox "字典使用计算行列:" & xdict.Count & ydict.Count
+  Dim cnt As Long: cnt = 1
+  
+  ' 遍历字典，输出
+  Dim key As Variant
+  For Each key In xdict.keys
+      dot.x = xdict(key)
+      puts dot.x, set_by - Offset.y / 2, cnt
+      cnt = cnt + 1
+  Next key
+  
+  cnt = 1
+  For Each key In ydict.keys
+      dot.y = ydict(key)
+      puts set_lx - Offset.x / 2, dot.y, cnt
+      cnt = cnt + 1
+  Next key
+  
+End Sub
+
+Private Sub puts(x, y, n)
+  Dim st As String
+  st = str(n)
+  Set s = ActiveLayer.CreateArtisticText(0, 0, st)
+  s.CenterX = x: s.CenterY = y
+End Sub