零基础学习VBA 2022.12.9 源码更新

README.md

@@ -2,3 +2,18 @@
 
 ## 零基础学习VBA 首次上传代码演示
 ![](001.gif)
+
+
+## 零基础学习VBA 2022.12.9 源码更新
+![](https://raw.githubusercontent.com/hongwenjun/img/master/VBA/002.gif)
+
+
+
+### [捐赠 蘭雅CorelVBA工具 开源软件](https://github.com/hongwenjun/corelvba/blob/main/donate.md)
+# [CorelDRAW VBA](https://262235.xyz/index.php/tag/vba/)
+![](https://262235.xyz/usr/uploads/2022/03/525753621.webp)
+
+## 蘭雅CorelVBA 中秋版0909 免费下载
+### https://262235.xyz/262235_GMS_0909.7z
+
+## 蘭雅CorelVBA工具中秋预览版 [安装视频点击](https://262235.xyz/CorelVBA/install.mp4)

Tools.bas

@@ -1,35 +1,35 @@
 Attribute VB_Name = "Tools"
-Public Sub 填入居中文字(str)
+Public Sub 填入居中文字(Str)
   Dim s As Shape
   Set s = ActiveSelection
-  X = s.CenterX
+  x = s.CenterX
   Y = s.CenterY
   
-  Set s = ActiveLayer.CreateArtisticText(0, 0, str)
-  s.CenterX = X
+  Set s = ActiveLayer.CreateArtisticText(0, 0, Str)
+  s.CenterX = x
   s.CenterY = Y
 End Sub
 
 Public Sub 尺寸标注()
   ActiveDocument.Unit = cdrMillimeter
   Set s = ActiveSelection
-  X = s.CenterX: Y = s.TopY
+  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
+  s.CenterX = x: s.BottomY = Y + 5
 End Sub
 
-Public Sub 批量居中文字(str)
+Public Sub 批量居中文字(Str)
   Dim s As Shape, sr As ShapeRange
   Set sr = ActiveSelectionRange
   
   For Each s In sr.Shapes
-    X = s.CenterX: Y = s.CenterY
+    x = s.CenterX: Y = s.CenterY
     
-    Set s = ActiveLayer.CreateArtisticText(0, 0, str)
-    s.CenterX = X: s.CenterY = Y
+    Set s = ActiveLayer.CreateArtisticText(0, 0, Str)
+    s.CenterX = x: s.CenterY = Y
   Next
 End Sub
 
@@ -38,12 +38,12 @@ Public Sub
   Set sr = ActiveSelectionRange
   
   For Each s In sr.Shapes
-    X = s.CenterX: Y = s.TopY
+    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
+    s.CenterX = x: s.BottomY = Y + 5
   Next
 End Sub
 
@@ -78,3 +78,163 @@ Public Sub
     sr.Rotate -a
   End If
 End Sub
+
+
+' 实践应用: 选择物件群组,页面设置物件大小,物件页面居中
+Public Function 群组居中页面()
+  ActiveDocument.Unit = cdrMillimeter
+  Dim OrigSelection As ShapeRange, sh As Shape
+  Set OrigSelection = ActiveSelectionRange
+  Set sh = OrigSelection.Group
+  
+  ' MsgBox "选择物件尺寸: " & sh.SizeWidth & "x" & sh.SizeHeight
+  ActivePage.SetSize Int(sh.SizeWidth + 0.9), Int(sh.SizeHeight + 0.9)
+  
+#If VBA7 Then
+  ActiveDocument.ClearSelection
+  sh.AddToSelection
+  ActiveSelection.AlignAndDistribute 3, 3, 2, 0, False, 2
+#Else
+  sh.AlignToPageCenter cdrAlignHCenter + cdrAlignVCenter
+#End If
+
+End Function
+
+
+Public Function 批量多页居中()
+  If 0 = ActiveSelectionRange.Count Then Exit Function
+  On Error GoTo ErrorHandler
+  ActiveDocument.BeginCommandGroup:  Application.Optimization = True
+
+  ActiveDocument.Unit = cdrMillimeter
+  Set sr = ActiveSelectionRange
+  total = sr.Count
+
+  '// 建立多页面
+  Set doc = ActiveDocument
+  doc.AddPages (total - 1)
+
+  Dim sh As Shape
+  
+  '// 遍历批量物件，放置物件到页面
+  For i = 1 To sr.Count
+    doc.Pages(i).Activate
+    Set sh = sr.Shapes(i)
+    ActivePage.SetSize Int(sh.SizeWidth + 0.9), Int(sh.SizeHeight + 0.9)
+ 
+   '// 物件居中页面
+#If VBA7 Then
+  ActiveDocument.ClearSelection
+  sh.AddToSelection
+  ActiveSelection.AlignAndDistribute 3, 3, 2, 0, False, 2
+#Else
+  sh.AlignToPageCenter cdrAlignHCenter + cdrAlignVCenter
+#End If
+
+  Next i
+
+  ActiveDocument.EndCommandGroup: Application.Optimization = False
+  ActiveWindow.Refresh:   Application.Refresh
+Exit Function
+
+ErrorHandler:
+  Application.Optimization = False
+  MsgBox "请先选择一些物件"
+  On Error Resume Next
+End Function
+
+
+'// 安全线: 点击一次建立辅助线，再调用清除参考线
+Public Function guideangle(actnumber As ShapeRange, cardblood As Integer)
+  Dim sr As ShapeRange
+  Set sr = ActiveDocument.MasterPage.GuidesLayer.FindShapes(Type:=cdrGuidelineShape)
+  If sr.Count <> 0 Then
+    sr.Delete
+    Exit Function
+  End If
+  
+  If 0 = ActiveSelectionRange.Count Then Exit Function
+  ActiveDocument.Unit = cdrMillimeter
+
+  With actnumber
+    Set s1 = ActiveDocument.MasterPage.GuidesLayer.CreateGuideAngle(0, .TopY - cardblood, 0#)
+    Set s1 = ActiveDocument.MasterPage.GuidesLayer.CreateGuideAngle(0, .BottomY + cardblood, 0#)
+    Set s1 = ActiveDocument.MasterPage.GuidesLayer.CreateGuideAngle(.LeftX + cardblood, 0, 90#)
+    Set s1 = ActiveDocument.MasterPage.GuidesLayer.CreateGuideAngle(.RightX - cardblood, 0, 90#)
+  End With
+  
+End Function
+
+
+
+Public Function 按面积排列(space_width As Double)
+  If 0 = ActiveSelectionRange.Count Then Exit Function
+  ActiveDocument.Unit = cdrMillimeter
+  ActiveDocument.ReferencePoint = cdrCenter
+  
+  Set ssr = ActiveSelectionRange
+  cnt = 1
+
+#If VBA7 Then
+  ssr.Sort "@shape1.width * @shape1.height < @shape2.width * @shape2.height"
+#Else
+' X4 不支持 ShapeRange.sort
+#End If
+
+  Dim Str As String, size As String
+  For Each sh In ssr
+    size = Int(sh.SizeWidth + 0.5) & "x" & Int(sh.SizeHeight + 0.5) & "mm"
+    sh.SetSize Int(sh.SizeWidth + 0.5), Int(sh.SizeHeight + 0.5)
+    Str = Str & size & vbNewLine
+  Next sh
+
+  ActiveDocument.ReferencePoint = cdrTopLeft
+  For Each s In ssr
+    If cnt > 1 Then s.SetPosition ssr(cnt - 1).LeftX, ssr(cnt - 1).BottomY - space_width
+    cnt = cnt + 1
+  Next s
+
+'  写文件，可以EXCEL里统计
+'  Set fs = CreateObject("Scripting.FileSystemObject")
+'  Set f = fs.CreateTextFile("D:\size.txt", True)
+'  f.WriteLine str: f.Close
+
+  Str = 分类汇总(Str)
+  Debug.Print Str
+
+  Dim s1 As Shape
+  Set s1 = ActiveLayer.CreateParagraphText(0, 0, 100, 150, Str, Font:="华文中宋")
+End Function
+ 
+'// 实现Excel里分类汇总功能
+Private Function 分类汇总(Str As String) As String
+  Dim a, b, d, arr
+  Str = VBA.Replace(Str, vbNewLine, " ")
+  Do While InStr(Str, "  ")
+      Str = VBA.Replace(Str, "  ", " ")
+  Loop
+  arr = Split(Str)
+
+  Set d = CreateObject("Scripting.dictionary")
+
+  For i = 0 To UBound(arr) - 1
+    If d.Exists(arr(i)) = True Then
+      d.Item(arr(i)) = d.Item(arr(i)) + 1
+    Else
+       d.Add arr(i), 1
+    End If
+  Next
+
+  Str = "   规   格" & vbTab & vbTab & vbTab & "数量" & vbNewLine
+
+  a = d.keys: b = d.items
+  For i = 0 To d.Count - 1
+    ' Debug.Print a(i), b(i)
+    Str = Str & a(i) & vbTab & vbTab & b(i) & "条" & vbNewLine
+  Next
+
+  分类汇总 = Str & "合计总量:" & vbTab & vbTab & vbTab & UBound(arr) & "条" & vbNewLine
+End Function
+
+
+

VBA_FORM.frm

@@ -1,7 +1,7 @@
 VERSION 5.00
 Begin {C62A69F0-16DC-11CE-9E98-00AA00574A4F} VBA_FORM 
    Caption         =   "Hello_VBA"
-   ClientHeight    =   3165
+   ClientHeight    =   4830
    ClientLeft      =   45
    ClientTop       =   390
    ClientWidth     =   4710
@@ -13,6 +13,16 @@ Attribute VB_GlobalNameSpace = False
 Attribute VB_Creatable = False
 Attribute VB_PredeclaredId = True
 Attribute VB_Exposed = False
+Private Sub CB_AQX_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal Y As Single)
+  If Button = 2 Then
+    Tools.guideangle ActiveSelectionRange, 0#   ' 右键 0距离贴紧
+  ElseIf Shift = fmCtrlMask Then
+    Tools.guideangle ActiveSelectionRange, 4    ' 左键安全范围 4mm
+  Else
+    Tools.guideangle ActiveSelectionRange, -10     ' Ctrl + 鼠标左键
+  End If
+End Sub
+
 Private Sub CB_BZCC_Click()
   Tools.尺寸标注
 End Sub
@@ -29,18 +39,34 @@ Private Sub CB_PLBZ_Click()
   Tools.批量标注
 End Sub
 
+Private Sub CB_PLDYJZ_Click()
+  Tools.批量多页居中
+End Sub
+
 Private Sub CB_PLWZ_Click()
   Tools.批量居中文字 "CorelVBA批量文字"
 End Sub
 
+Private Sub CB_QZJZ_Click()
+  Tools.群组居中页面
+End Sub
+
+Private Sub CB_SIZESORT_Click()
+  Tools.按面积排列 50
+End Sub
+
 Private Sub CB_VBA_Click()
   MsgBox "你好 CorelVBA!"
 End Sub
 
-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)
   CB_VBA.BackColor = RGB(255, 0, 0)
 End Sub
 
+Private Sub CommandButton1_Click()
+
+End Sub
+
 Private Sub ZNQZ_Click()
   Tools.智能群组
 End Sub