2023年9月更新功能: 添加批量旋转移动 镜像 自动间距 转平功能

API.bas

@@ -198,14 +198,14 @@ Public Function pFootInXY(P, a, b)
     If a(1) = b(1) Then
         pFootInXY = Array(P(0), a(1), 0#): Exit Function
     End If
-    Dim aa, bb, c, d, x, Y
+    Dim aa, bb, c, d, x, y
     aa = (a(1) - b(1)) / (a(0) - b(0))
     bb = a(1) - aa * a(0)
     c = -(a(0) - b(0)) / (a(1) - b(1))
     d = P(1) - c * P(0)
     x = (d - bb) / (aa - c)
-    Y = aa * x + bb
-    pFootInXY = Array(x, Y, 0#)
+    y = aa * x + bb
+    pFootInXY = Array(x, y, 0#)
 End Function
 
 

AverageDistance.bas

@@ -2,6 +2,7 @@ Attribute VB_Name = "AverageDistance"
 Public AutoDistribute_Key As Boolean
 Public first_StaticID As Long
 
+'// Ñ¡ÔñµÄÎï¼þƽ¾ù¾àÀë
 Public Function Average_Distance()
   On Error GoTo ErrorHandler
   API.BeginOpt

Box.bas

@@ -236,8 +236,8 @@ Public Function Simple_box_three(Optional ByVal l As Double, Optional ByVal w As
 End Function
 
 '// »­Ò»ÌõÏߣ¬ÉèÖÃÂÖÀªÉ« M100
-Private Function DrawLine(X1, Y1, X2, Y2) As Shape
-  Set DrawLine = ActiveLayer.CreateLineSegment(X1, Y1, X2, Y2)
+Private Function DrawLine(x1, y1, x2, y2) As Shape
+  Set DrawLine = ActiveLayer.CreateLineSegment(x1, y1, x2, y2)
   DrawLine.Outline.SetProperties Color:=CreateCMYKColor(0, 100, 0, 0)
 End Function
 

Form/lines.bas

@@ -0,0 +1,99 @@
+Attribute VB_Name = "lines"
+'// This is free and unencumbered software released into the public domain.
+'// For more information, please refer to  https://github.com/hongwenjun
+
+Sub start()
+  LinesForm.Show 0
+End Sub
+
+Public Function Nodes_DrawLines()
+  Dim sr As ShapeRange, sr_tmp As New ShapeRange, sr_lines As New ShapeRange
+  Dim s As Shape, sh As Shape
+  Dim nr As NodeRange
+  Set sr = ActiveSelectionRange
+  If sr.Count = 0 Then Exit Function
+  
+  For Each sh In sr
+    Set nr = sh.Curve.Selection
+    If nr.Count > 0 Then
+      For Each n In nr
+        Set s = ActiveLayer.CreateEllipse2(n.PositionX, n.PositionY, 0.5, 0.5)
+        sr_tmp.Add s
+      Next n
+    End If
+  Next sh
+  
+  '// 没有选择节点的情况，使用物件中心划线
+  If sr_tmp.Count < 2 And sr.Count > 1 Then
+    Set Line = DrawLine(sr(1), sr(2))
+    sr_lines.Add Line
+  End If
+
+#If VBA7 Then
+    sr_tmp.Sort "@shape1.left < @shape2.left"
+#Else
+    Set sr_tmp = X4_Sort_ShapeRange(sr_tmp, stlx)
+#End If
+
+  '// 使用 Count 遍历 shaperange 这种情况方便点
+  For i = 1 To sr_tmp.Count - 1
+    Set Line = DrawLine(sr_tmp(i), sr_tmp(i + 1))
+    sr_lines.Add Line
+  Next
+  
+  sr_tmp.Delete
+  sr_lines.CreateSelection
+End Function
+
+Public Function Draw_Multiple_Lines(hv As cdrAlignType)
+  Dim sr As ShapeRange, sr_lines As New ShapeRange
+  Set sr = ActiveSelectionRange
+  
+  If sr.Count < 2 Then Exit Function
+  
+#If VBA7 Then
+  If hv = cdrAlignVCenter Then
+    '// 从左到右排序
+    sr.Sort "@shape1.left < @shape2.left"
+  ElseIf hv = cdrAlignHCenter Then
+    '// 从上到下排序
+    sr.Sort "@shape1.top < @shape2.top"
+  End If
+#Else
+  '// X4_Sort_ShapeRange for CorelDRAW X4
+  If hv = cdrAlignVCenter Then
+    Set sr = X4_Sort_ShapeRange(sr, stlx)
+  ElseIf hv = cdrAlignHCenter Then
+    Set sr = X4_Sort_ShapeRange(sr, stty)
+  End If
+ 
+#End If
+
+  For i = 1 To sr.Count - 1 Step 2
+    Set Line = DrawLine(sr(i), sr(i + 1))
+    sr_lines.Add Line
+  Next
+ 
+  sr_lines.CreateSelection
+End Function
+
+Public Function FirtLineTool()
+  Dim sr As ShapeRange
+  Set sr = ActiveSelectionRange
+  If sr.Count > 1 Then
+    Set Line = DrawLine(sr(1), sr(2))
+  End If
+End Function
+
+Private Function DrawLine(ByVal s1 As Shape, ByVal s2 As Shape) As Shape
+'// 创建线段方法在图层上的指定位置创建由单个线段组成的曲线。
+ Set DrawLine = ActiveLayer.CreateLineSegment(s1.CenterX, s1.CenterY, s2.CenterX, s2.CenterY)
+
+End Function
+
+Private Sub Test()
+  ActiveDocument.Unit = cdrMillimeter
+  Set Rect = ActiveLayer.CreateRectangle(0, 0, 30, 30)
+  Set ell = ActiveLayer.CreateEllipse2(50, 50, 10, 10)
+  Set Line = DrawLine(Rect, ell)
+End Sub

LinesForm.frm

@@ -0,0 +1,192 @@
+VERSION 5.00
+Begin {C62A69F0-16DC-11CE-9E98-00AA00574A4F} LinesForm 
+   Caption         =   "LinesForm"
+   ClientHeight    =   2430
+   ClientLeft      =   45
+   ClientTop       =   390
+   ClientWidth     =   4680
+   OleObjectBlob   =   "LinesForm.frx":0000
+   StartUpPosition =   1  '所有者中心
+End
+Attribute VB_Name = "LinesForm"
+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
+
+'// 插件名称 VBA_UserForm
+Private Const TOOLNAME As String = "LYVBA"
+Private Const SECTION As String = "LinesForm"
+
+'// 用户窗口初始化
+Private Sub UserForm_Initialize()
+
+  With Me
+    .StartUpPosition = 0
+    .Left = Val(GetSetting(TOOLNAME, SECTION, "form_left", 900))
+    .Top = Val(GetSetting(TOOLNAME, SECTION, "form_top", 200))
+  End With
+
+End Sub
+
+
+'// 关闭窗口时保存窗口位置
+Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
+    saveFormPos True
+End Sub
+
+'// 保存窗口位置和加载窗口位置
+Sub saveFormPos(bDoSave As Boolean)
+  If bDoSave Then 'save position
+    SaveSetting TOOLNAME, SECTION, "form_left", Me.Left
+    SaveSetting TOOLNAME, SECTION, "form_top", Me.Top
+  End If
+End Sub
+
+Private Sub MyPen_Click()
+On Error GoTo ErrorHandler
+  API.BeginOpt
+  lines.Nodes_DrawLines
+ErrorHandler:
+  API.EndOpt
+End Sub
+
+
+'// 左键右键Ctrl三键控制
+Private Sub PenDrawLines_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal y As Single)
+On Error GoTo ErrorHandler
+  API.BeginOpt
+  If Button = 2 Then
+    lines.Draw_Multiple_Lines cdrAlignVCenter
+    
+  ElseIf Shift = fmCtrlMask Then
+    lines.Draw_Multiple_Lines cdrAlignHCenter
+  Else
+    lines.Draw_Multiple_Lines 0
+  End If
+ErrorHandler:
+  API.EndOpt
+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.Simple_Train_Arrangement 3#
+  ElseIf Shift = fmCtrlMask Then
+    Tools.Simple_Train_Arrangement 0#
+  Else
+    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.Simple_Ladder_Arrangement 3#
+  ElseIf Shift = fmCtrlMask Then
+    Tools.Simple_Ladder_Arrangement 0#
+  Else
+    Tools.Simple_Ladder_Arrangement Set_Space_Width
+  End If
+End Sub
+
+
+Private Sub MakeBox_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal y As Single)
+  On Error GoTo ErrorHandler
+  API.BeginOpt
+  
+  Dim size As Variant
+  size = input_box_lwh
+  l = size(0): w = size(1): h = size(2): b = size(3)
+  If b = 0 Then b = 15
+  
+  If Button = 2 Then
+    box.Simple_box_five l, w, h, b
+  ElseIf Shift = fmCtrlMask Then
+    box.Simple_box_four l, w, h, b
+  Else
+    box.Simple_box_three l, w, h, b
+  End If
+  
+ErrorHandler:
+  API.EndOpt
+End Sub
+
+Private Sub Cmd_3D_Click()
+  box.Simple_3Deffect
+End Sub
+
+
+'// 角度和旋转工具, 左键左转，右键右转
+Private Sub Rotate_Shapes_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal y As Single)
+  If Button = 2 Then   '// 右键的代码
+    Shapes_Rotate -90
+  ElseIf Shift = fmCtrlMask Then     '// 左键的代码
+    Shapes_Rotate 90
+  Else    '// CTRL的代码
+    Shapes_Rotate -45
+  End If
+End Sub
+
+'// 移动和再制，我们来制作三键控制，左键只移动，右键是反方向，按CTRL 是复制的
+Private Sub Move_Left_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal y As Single)
+  If Button = 2 Then   '// 右键的代码
+    move_shapes 100, 0
+  ElseIf Shift = fmCtrlMask Then     '// 左键的代码
+    move_shapes -100, 0
+  Else    '// CTRL的代码
+    Duplicate_shapes -100, 0
+  End If
+End Sub
+
+Private Sub Move_Up_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal y As Single)
+  If Button = 2 Then   '// 右键的代码
+    move_shapes 0, -100
+  ElseIf Shift = fmCtrlMask Then     '// 左键的代码
+    move_shapes 0, 100
+  Else    '// CTRL的代码
+    Duplicate_shapes 0, 100
+  End If
+End Sub
+
+'// 测量标尺和水平尺
+Private Sub Ruler_Measuring_BT_Click()
+  '// 角度转平
+  Angle_to_Horizon
+End Sub
+
+'// 选择的物件平均距离
+Private Sub Average_Distance_BT_Click()
+  Average_Distance
+End Sub
+
+Private Sub chkAutoDistribute_Click()
+  AutoDistribute_Key = chkAutoDistribute.Value
+End Sub
+
+'// 镜像工具
+Private Sub MirrorLine_Click()
+  Mirror_ByGuide
+End Sub
+
+'// 平行线工具 CTRL 键设置距离
+Private Sub ParallelLines_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal y As Single)
+  Dim sp As Double
+  text = GlobalUserData("SpaceWidth", 1)
+  sp = Val(text)
+  If Button = 2 Then   '// 右键的代码
+    Create_Parallel_Lines -sp
+  ElseIf Shift = fmCtrlMask Then     '// 左键的代码
+    Create_Parallel_Lines sp
+  Else    '// CTRL的代码
+    Create_Parallel_Lines Set_Space_Width
+  End If
+End Sub
+
+'// 标记镜像参考线
+Private Sub Set_Guide_Click()
+  Set_Guides_Name
+End Sub

MirrorParalleHorizon.bas

@@ -0,0 +1,142 @@
+Attribute VB_Name = "MirrorParalleHorizon"
+'// 两个端点的坐标,为(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
+  
+  '// 角度转平
+  Public Function Angle_to_Horizon()
+    On Error GoTo ErrorHandler
+    API.BeginOpt
+    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:
+    API.EndOpt
+  End Function
+
+'// 自动旋转角度
+Public Function Auto_Rotation_Angle()
+  On Error GoTo ErrorHandler
+  API.BeginOpt
+  
+'  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:
+  API.EndOpt
+End Function
+
+'// 交换对象
+Public Function Exchange_Object()
+  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
+
+'// 标记镜像参考线
+Public Function Set_Guides_Name()
+  On Error GoTo ErrorHandler
+  API.BeginOpt
+  Dim sr As ShapeRange, s As Shape
+  Set sr = ActiveSelectionRange
+  
+  For Each s In sr
+    s.name = "MirrorGuides"
+  Next s
+
+'// 感谢李总捐赠，定置透明度70%
+  With ActiveSelection.Transparency
+    .ApplyUniformTransparency 70
+ '   .AppliedTo = cdrApplyToFillAndOutline
+ '   .MergeMode = cdrMergeNormal
+  End With
+  
+ErrorHandler:
+  API.EndOpt
+End Function
+
+'// 参考线镜像
+Public Function Mirror_ByGuide()
+  On Error GoTo ErrorHandler
+  API.BeginOpt
+  Dim sr As ShapeRange, gds As ShapeRange
+  Set sr = ActiveSelectionRange
+  Set gds = sr.Shapes.FindShapes(Query:="@name ='MirrorGuides'")
+  
+  If gds.Count > 0 Then
+ '//   sr.RemoveRange gds
+    Set nr = gds(1).DisplayCurve.Nodes.All
+  Else
+    Set nr = sr.LastShape.DisplayCurve.Nodes.All
+ '//   sr.Remove sr.Count
+  End If
+  
+  If nr.Count >= 2 Then
+    byshape = False
+    x1 = nr.FirstNode.PositionX: y1 = nr.FirstNode.PositionY
+    x2 = nr.LastNode.PositionX: y2 = nr.LastNode.PositionY
+    a = lineangle(x1, y1, x2, y2)  '// 参考线和水平的夹角 a
+    
+    ang = 90 - a    '// 镜像的旋转角度
+   Set s = sr.Group
+      With s
+        Set s_copy = .Duplicate   '// 复制物件保留，然后按 x1,y1 点 旋转
+        
+        .RotationCenterX = x1
+        .RotationCenterY = y1
+        .Rotate ang
+        If Not byshape Then
+            lx = .LeftX
+            .Stretch -1#, 1#    '// 通过拉伸完成镜像
+            .LeftX = lx
+            .Move (x1 - .LeftX) * 2 - .SizeWidth, 0
+            .RotationCenterX = x1     '// 之前因为镜像，旋转中心点反了，重置回来
+            .RotationCenterY = y1
+            .Rotate -ang
+        End If
+        .RotationCenterX = .CenterX   '// 重置回旋转中心点为物件中心
+        .RotationCenterY = .CenterY
+        .Ungroup
+        s_copy.Ungroup
+      End With
+  End If
+
+ErrorHandler:
+  API.EndOpt
+End Function
+
+'// 物件建立平行线
+Public Function Create_Parallel_Lines(space As Double)
+  On Error GoTo ErrorHandler
+  API.BeginOpt
+  
+  Dim sr As ShapeRange
+  Set sr = ActiveSelectionRange
+  sr.CreateParallelCurves 1, space
+
+ErrorHandler:
+  API.EndOpt
+End Function

README.md

@@ -11,13 +11,28 @@
 - 4.选择多个物件，按从上到下按左对齐，鼠标左右键加Ctrl控制物件的间距
 - 5.兰雅VBA 线段简易包装盒插件，鼠标左右键加Ctrl，目前有三种样式(如图)
 - 6.选择盒子的顶正侧三面，点击生成简易的3D变形效果
+- 7.2023年9月更新功能: 添加批量旋转移动 镜像 自动间距 转平功能
 
 ### github开源网址: https://github.com/hongwenjun/vbabox
 ### 兰雅VBA 线段简易包装盒插件 [免费开源下载](https://lyvba.com/Lanya_LinesTool.zip)
 
-
+## 功能演示
+- 绘制易包装盒
 ![](https://github.com/hongwenjun/vbabox/blob/main/img/vbabox.webp)
 
+- 镜像功能
+![](https://github.com/hongwenjun/vbabox/blob/main/img/Mirror.gif)
+
+- 物件自动中心间距
+![](https://github.com/hongwenjun/vbabox/blob/main/img/Average.gif)
+
+- 物件转水平
+![](https://github.com/hongwenjun/vbabox/blob/main/img/Horizon.gif)
+
+- 平线线功能
+![](https://github.com/hongwenjun/vbabox/blob/main/img/Paralle.gif)
+
+--
 ## CorelDRAW VBA 插件 简易的长宽高盒子插件和源码和步骤原理
 
 https://www.bilibili.com/video/BV1MF411f7qu/