添加矩形盒子和下插样式

Box.bas

@@ -1,9 +1,175 @@
 Attribute VB_Name = "box"
-Public Function Simple_box_three()
+Public Function Simple_box_five(Optional ByVal l As Double, Optional ByVal w As Double, Optional ByVal h As Double, Optional ByVal b As Double = 15)
+  Dim sr As New ShapeRange, wing As New ShapeRange, BottomWing As ShapeRange
+  Dim sh As Shape
+  l1x = w: l2x = w + l: l3x = 2 * w + l: l4x = 2 * (w + l)
+  
+  '// 绘制主体上下盖矩形
+  Set mainRect_aw = ActiveLayer.CreateRectangle(0, 0, w, h)
+  Set mainRect_al = ActiveLayer.CreateRectangle(0, 0, l, h)
+  mainRect_al.Move l1x, 0
+  Set mainRect_bw = ActiveLayer.CreateRectangle(0, 0, w, h)
+  mainRect_bw.Move l2x, 0
+  Set mainRect_bl = ActiveLayer.CreateRectangle(0, 0, l, h)
+  mainRect_bl.Move l3x, 0
+
+  Set topRect = ActiveLayer.CreateRectangle(0, 0, l, w)
+  topRect.Move l1x, h
+
+  '// 绘制Box 圆角矩形插口
+  Set top_RoundRect = ActiveLayer.CreateRectangle(0, 0, l, b, 75, 75)
+  top_RoundRect.Move l1x, h + w
+  Set Bond = DrawBond(b, h, l4x, 0)
+    
+  '// 绘制box 2个翅膀
+  Set sh = DrawWing(w, (w + b) / 2 - 2)
+  wing.Add sh.Duplicate(0, h)
+  wing.Add sh.Duplicate(l2x, h)
+  wing(2).Flip cdrFlipHorizontal
+
+  '// 绘制 Box 底下翅膀 BottomWing
+  Set BottomWing = DrawBottomWing(l, w, b)
+
+  '// 添加到物件组，设置轮廓色 C100
+  sr.Add mainRect_aw: sr.Add mainRect_al: sr.Add mainRect_bw: sr.Add mainRect_bl
+  sr.Add topRect: sr.Add Bond: sr.Add top_RoundRect
+  sr.AddRange BottomWing
+  sr.AddRange wing: sh.Delete
+  sr.SetOutlineProperties Color:=CreateCMYKColor(100, 0, 0, 0)
+  
+  sr.CreateSelection: sr.Group
+  
+End Function
+
+
+Private Function DrawBottomWing(ByVal l As Double, ByVal w As Double, ByVal b As Double) As ShapeRange
+  Dim sr As New ShapeRange, s As Shape
+  Dim sp As SubPath, crv(3) As Curve
+  
+  '// 绘制 Box 底下翅膀 BottomWing
+  Set crv(1) = Application.CreateCurve(ActiveDocument)
+  Set sp = crv(1).CreateSubPath(0, 0)
+  sp.AppendLineSegment w / 2, w * 0.275
+  sp.AppendLineSegment w / 2, w / 2 - 5
+  sp.AppendCurveSegment2 w / 2 + 5, w / 2, w / 2, w / 2 - 2.5, w / 2 + 2.5, w / 2
+  sp.AppendLineSegment w, w / 2
+  sp.AppendLineSegment w, 0
+  sp.Closed = True
+  sr.Add ActiveLayer.CreateCurve(crv(1))
+  
+  Set crv(2) = Application.CreateCurve(ActiveDocument)
+  Set sp = crv(2).CreateSubPath(0, 0)
+  sp.AppendLineSegment w / 2, w * 0.275
+  sp.AppendLineSegment w / 2 + b - 5, w * 0.275
+  sp.AppendCurveSegment2 w / 2 + b, w * 0.275 + 5, w / 2 + b - 2.5, w * 0.275, w / 2 + b, w * 0.275 + 2.5
+  sp.AppendLineSegment w / 2 + b, l - w * 0.275 - 5
+  sp.AppendCurveSegment2 w / 2 + b - 5, l - w * 0.275, w / 2 + b, l - w * 0.275 - 2.5, w / 2 + b - 2.5, l - w * 0.275
+  
+  sp.AppendLineSegment w / 2, l - w * 0.275
+  sp.AppendLineSegment 0, l
+  sp.Closed = True
+  sr.Add ActiveLayer.CreateCurve(crv(2))
+  
+  Set crv(3) = Application.CreateCurve(ActiveDocument)
+  Set sp = crv(3).CreateSubPath(0, 0)
+  sp.AppendLineSegment 0, l
+  sp.AppendLineSegment w / 2 + b, l
+  sp.AppendLineSegment w / 2 + b, l - w * 0.275 + 5
+  sp.AppendCurveSegment2 w / 2 + b - 5, l - w * 0.275, w / 2 + b, l - w * 0.275 + 2.5, w / 2 + b - 2.5, l - w * 0.275
+  sp.AppendLineSegment w / 2, l - w * 0.275
+  sp.AppendLineSegment w / 2, w * 0.275
+  sp.AppendLineSegment w / 2 + b - 5, w * 0.275
+  sp.AppendCurveSegment2 w / 2 + b, w * 0.275 - 5, w / 2 + b - 2.5, w * 0.275, w / 2 + b, w * 0.275 - 2.5
+  sp.AppendLineSegment w / 2 + b, 0
+  sp.Closed = True
+  sr.Add ActiveLayer.CreateCurve(crv(3))
+  
+  '// 移动到适合的地方
+  sr(1).Move 0, -w / 2: sr(1).Rotate 180
+  Set s = sr(1).Duplicate(0, 0): sr.Add s
+  s.Flip cdrFlipHorizontal: s.Move w + l, 0
+  
+  sr(2).Rotate -90: sr(3).Rotate -90
+  sr(2).LeftX = 2 * w + l: sr(3).LeftX = w
+  sr(2).TopY = 0: sr(3).TopY = 0
+  Set DrawBottomWing = sr
+End Function
+
+
+Public Function Simple_box_four(Optional ByVal l As Double, Optional ByVal w As Double, Optional ByVal h As Double, Optional ByVal b As Double = 15)
+  Dim sr As New ShapeRange, wing As New ShapeRange
+  Dim sh As Shape
+  l1x = w: l2x = w + l: l3x = 2 * w + l: l4x = 2 * (w + l)
+  
+  
+  '// 绘制主体上下盖矩形
+  Set mainRect_aw = ActiveLayer.CreateRectangle(0, 0, w, h)
+  Set mainRect_al = ActiveLayer.CreateRectangle(0, 0, l, h)
+  mainRect_al.Move l1x, 0
+  Set mainRect_bw = ActiveLayer.CreateRectangle(0, 0, w, h)
+  mainRect_bw.Move l2x, 0
+  Set mainRect_bl = ActiveLayer.CreateRectangle(0, 0, l, h)
+  mainRect_bl.Move l3x, 0
+
+  Set topRect = ActiveLayer.CreateRectangle(0, 0, l, w)
+  topRect.Move l1x, h
+  Set bottomRect = ActiveLayer.CreateRectangle(0, 0, l, w)
+  bottomRect.Move l3x, -w
+  
+  '// 绘制Box 圆角矩形插口
+  Set top_RoundRect = ActiveLayer.CreateRectangle(0, 0, l, b, 50, 50)
+  top_RoundRect.Move l1x, h + w
+  Set bottom_RoundRect = ActiveLayer.CreateRectangle(0, 0, l, b, 0, 0, 50, 50)
+  bottom_RoundRect.Move l3x, -w - b
+  Set Bond = DrawBond(b, h, l4x, 0)
+    
+  '// 绘制box 四个翅膀
+  Set sh = DrawWing(w, (w + b) / 2 - 2)
+  wing.Add sh.Duplicate(0, h)
+  wing.Add sh.Duplicate(l2x, h)
+  wing.Add sh.Duplicate(0, -sh.SizeHeight)
+  wing.Add sh.Duplicate(l2x, -sh.SizeHeight)
+  wing(2).Flip cdrFlipHorizontal
+  wing(3).Rotate 180
+  wing(4).Flip cdrFlipVertical
+
+  '// 添加到物件组，设置轮廓色 C100
+  sr.Add mainRect_aw: sr.Add mainRect_al: sr.Add mainRect_bw: sr.Add mainRect_bl
+  sr.Add topRect: sr.Add bottomRect: sr.Add Bond
+  sr.Add top_RoundRect: sr.Add bottom_RoundRect
+  sr.AddRange wing: sh.Delete
+  sr.SetOutlineProperties Color:=CreateCMYKColor(100, 0, 0, 0)
+  
+  sr.CreateSelection: sr.Group
+  
+End Function
+
+Public Function input_box_lwh() As Variant
+  Dim str, arr, n
+  str = InputBox("请输入长x宽x高，使用空格 * x 间隔", "盒子长宽高", "100 x 100 x 100 mm") & " "
+  str = Newline_to_Space(str)
+
+  ' 替换 mm x * 换行 TAB 为空格
+  str = VBA.Replace(str, "mm", " ")
+  str = VBA.Replace(str, "x", " ")
+  str = VBA.Replace(str, "X", " ")
+  str = VBA.Replace(str, "*", " ")
+
+  '// 换行转空格 多个空格换成一个空格
+  str = API.Newline_to_Space(str)
+
+  arr = Split(str)
+  arr(0) = Val(arr(0))
+  arr(1) = Val(arr(1))
+  arr(2) = Val(arr(2))
+  arr(3) = Val(arr(3))
+  input_box_lwh = arr
+End Function
+
+Public Function Simple_box_three(Optional ByVal l As Double, Optional ByVal w As Double, Optional ByVal h As Double, Optional ByVal b As Double = 15)
   ActiveDocument.Unit = cdrMillimeter
   Dim sr As New ShapeRange, wing As New ShapeRange
   Dim sh As Shape
-  l = 100: w = 50: h = 70: b = 15
   boxL = 2 * l + 2 * w + b: boxH = h
   l1x = w: l2x = w + l: l3x = 2 * w + l: l4x = 2 * (w + l)
   
@@ -21,14 +187,14 @@ Public Function Simple_box_three()
   bottom_RoundRect.Move l3x, -w - b
     
   '// 绘制box 四个翅膀
-  Set sh = DrawWing(ActiveLayer.CreateRectangle(0, 0, w, (w + b) / 2 - 2))
+  Set sh = DrawWing(w, (w + b) / 2 - 2)
   wing.Add sh.Duplicate(0, h)
   wing.Add sh.Duplicate(l2x, h)
   wing.Add sh.Duplicate(0, -sh.SizeHeight)
   wing.Add sh.Duplicate(l2x, -sh.SizeHeight)
   wing(2).Flip cdrFlipHorizontal
-  wing(3).Flip cdrFlipVertical
-  wing(4).Rotate 180
+  wing(3).Rotate 180
+  wing(4).Flip cdrFlipVertical
 
   '// 添加到物件组，设置轮廓色 C100
   sr.Add mainRect: sr.Add topRect: sr.Add bottomRect
@@ -55,20 +221,19 @@ Private Function DrawLine(X1, Y1, X2, Y2) As Shape
 End Function
 
 
-Private Function DrawWing(s As Shape) As Shape
+Private Function DrawWing(ByVal w As Double, ByVal h As Double) As Shape
     Dim sp As SubPath, crv As Curve
-    Dim x As Double, y As Double
-    x = s.SizeWidth: y = s.SizeHeight
-    s.Delete
+    Dim x As Double, Y As Double
+    x = w: Y = h
     
     '// 绘制 Box 翅膀 Wing
     Set crv = Application.CreateCurve(ActiveDocument)
     Set sp = crv.CreateSubPath(0, 0)
     sp.AppendLineSegment 0, 4
     sp.AppendLineSegment 2, 6
-    sp.AppendLineSegment 4, y - 2.5
-    sp.AppendCurveSegment2 6.5, y, 4.1, y - 1.25, 5.1, y
-    sp.AppendLineSegment x - 2, y
+    sp.AppendLineSegment 6, Y - 2.5
+    sp.AppendCurveSegment2 8.5, Y, 6.2, Y - 1.25, 7, Y
+    sp.AppendLineSegment x - 2, Y
     sp.AppendLineSegment x - 2, 3
     sp.AppendLineSegment x, 0
     
@@ -76,6 +241,24 @@ Private Function DrawWing(s As Shape) As Shape
     Set DrawWing = ActiveLayer.CreateCurve(crv)
 End Function
 
+Private Function DrawBond(ByVal w As Double, ByVal h As Double, ByVal move_x As Double, ByVal move_y As Double) As Shape
+    Dim sp As SubPath, crv As Curve
+    Dim x As Double, Y As Double
+    x = w: Y = h
+    
+    '// 绘制 Box 粘合边 Bond
+    Set crv = Application.CreateCurve(ActiveDocument)
+    Set sp = crv.CreateSubPath(0, 0)
+    sp.AppendLineSegment 0, Y
+    sp.AppendLineSegment x, Y - 5
+    sp.AppendLineSegment x, 5
+
+    sp.Closed = True
+    Set DrawBond = ActiveLayer.CreateCurve(crv)
+    DrawBond.Move move_x, move_y
+End Function
+
+
 Public Function Simple_box_one()
   ActiveDocument.Unit = cdrMillimeter
   l = 100: w = 50: h = 70: b = 15

Form/LinesForm.frm

@@ -19,7 +19,7 @@ End Sub
 
 
 '// ×ó¼üÓÒ¼üCtrlÈý¼ü¿ØÖÆ
-Private Sub PenDrawLines_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal y As Single)
+Private Sub PenDrawLines_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal Y As Single)
   If Button = 2 Then
     lines.Draw_Multiple_Lines cdrAlignVCenter
     
@@ -31,9 +31,8 @@ Private Sub PenDrawLines_MouseDown(ByVal Button As Integer, ByVal Shift As Integ
 End Sub
 
 
-
 '''////  ɵ¹Ï»ð³µÅÅÁÐ  ////'''
-Private Sub TOP_ALIGN_BT_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal y As Single)
+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
@@ -44,7 +43,7 @@ Private Sub TOP_ALIGN_BT_MouseDown(ByVal Button As Integer, ByVal Shift As Integ
 End Sub
 
 '''////  ɵ¹Ï½×ÌÝÅÅÁÐ  ////'''
-Private Sub LEFT_ALIGN_BT_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal y As Single)
+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
@@ -55,8 +54,27 @@ Private Sub LEFT_ALIGN_BT_MouseDown(ByVal Button As Integer, ByVal Shift As Inte
 End Sub
 
 
-Private Sub MakeBox_Click()
-  box.Simple_box_three
+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()