CorelDRAW VBA 简单代码实现绘制盒子

landboy

前两天在本论坛看到网友，问怎么绘制如下图简单的封套盒子。
所以有了思路，就动手写了代码




代码中的公式，不用初中知识应该就可以理解的。
就是计算几个矩形多大，绘制4条线，把线移动到正确的位置

1. Public Function Simple_box_one()
   
2.   ActiveDocument.Unit = CDRMillimeter
   
3.   l = 100: w = 50: h = 70: b = 15
   
4.   boxL = 2 * l + 2 * w + b
   
5.   boxH = h
   
6.   l1x = w
   
7.   l2x = w + l
   
8.   l3x = 2 * w + l
   
9.   l4x = 2 * (w + l)
   
10.   
    
11.   Set Rect = ActiveLayer.CreateRectangle(0, 0, boxL, boxH)
    
12.   Set sl1 = DrawLine(l1x, 0, l1x, h)
    
13.   Set sl2 = DrawLine(l2x, 0, l2x, h)
    
14.   Set sl3 = DrawLine(l3x, 0, l3x, h)
    
15.   Set sl4 = DrawLine(l4x, 0, l4x, h)
    
16. End Function

复制代码

1. Public Function Simple_box_two()
   
2.   ActiveDocument.Unit = cdrMillimeter
   
3.   l = 100: w = 50: h = 70: b = 15
   
4.   boxL = 2 * l + 2 * w + b: boxH = h
   
5.   l1x = w: l2x = w + l: l3x = 2 * w + l: l4x = 2 * (w + l)
   
6.   
   
7.   Set mAInRect = ActiveLayer.CreateRectangle(0, 0, boxL, boxH)
   
8.   
   
9.   Set topRect = ActiveLayer.CreateRectangle(0, 0, l, w)
   
10.   topRect.Move l1x, h
    
11.   Set bottomRect = ActiveLayer.CreateRectangle(0, 0, l, w)
    
12.   bottomRect.Move l3x, -w
    
13.   
    
14.   Set sl1 = DrawLine(l1x, 0, l1x, h)
    
15.   Set sl2 = DrawLine(l2x, 0, l2x, h)
    
16.   Set sl3 = DrawLine(l3x, 0, l3x, h)
    
17.   Set sl4 = DrawLine(l4x, 0, l4x, h)
    
18. End Function

复制代码

绘制线条的代码写成函数调用，可以设置颜色或者粗细

1. '// 画一条线，设置轮廓色 M100
   
2. Private Function DrawLine(X1, Y1, X2, Y2) As Shape
   
3.   Set DrawLine = ActiveLayer.CreateLineSegment(X1, Y1, X2, Y2)
   
4.   DrawLine.Outline.SetProperties Color:=CreateCMYKColor(0, 100, 0, 0)
   
5. End Function

复制代码

landboy

圆角插口和翅膀的代码


建立圆角矩形函数 CreateRectangle(0, 0, l, b, 50, 50) ，第5-6参数，指定上2圆角的系数

翅膀是个自定义多节点曲线，先用矩形函数，绘制一个临时物件s 确定范围大小

然后定义 DrawWing(s As Shape) 函数来手工绘制，如图

sp.AppendLineSegment 4, y - 2.5  '// 绘制直线
sp.AppendCurveSegment2 6.5, y, 4.1, y - 1.25, 5.1, y  '// 绘制曲线







下面是绘制整个盒子完整的代码

1. Public Function Simple_box_three()
   
2.   ActiveDocument.Unit = cdrMillimeter
   
3.   Dim sr As New ShapeRange, wing As New ShapeRange
   
4.   Dim sh As Shape
   
5.   l = 100: w = 50: h = 70: b = 15
   
6.   boxL = 2 * l + 2 * w + b: boxH = h
   
7.   l1x = w: l2x = w + l: l3x = 2 * w + l: l4x = 2 * (w + l)
   
8.   
   
9.   '// 绘制主体上下盖矩形
   
10.   Set mainRect = ActiveLayer.CreateRectangle(0, 0, boxL, boxH)
    
11.   Set topRect = ActiveLayer.CreateRectangle(0, 0, l, w)
    
12.   topRect.Move l1x, h
    
13.   Set bottomRect = ActiveLayer.CreateRectangle(0, 0, l, w)
    
14.   bottomRect.Move l3x, -w
    
15.   
    
16.   '// 绘制Box 圆角矩形插口
    
17.   Set top_RoundRect = ActiveLayer.CreateRectangle(0, 0, l, b, 50, 50)
    
18.   top_RoundRect.Move l1x, h + w
    
19.   Set bottom_RoundRect = ActiveLayer.CreateRectangle(0, 0, l, b, 0, 0, 50, 50)
    
20.   bottom_RoundRect.Move l3x, -w - b
    
21.    
    
22.   '// 绘制box 四个翅膀
    
23.   Set sh = DrawWing(ActiveLayer.CreateRectangle(0, 0, w, (w + b) / 2 - 2))
    
24.   wing.Add sh.Duplicate(0, h)
    
25.   wing.Add sh.Duplicate(l2x, h)
    
26.   wing.Add sh.Duplicate(0, -sh.SizeHeight)
    
27.   wing.Add sh.Duplicate(l2x, -sh.SizeHeight)
    
28.   wing(2).Flip cdrFlipHorizontal
    
29.   wing(3).Flip cdrFlipVertical
    
30.   wing(4).Rotate 180
    
31. 
    
32.   '// 添加到物件组，设置轮廓色 C100
    
33.   sr.Add mainRect: sr.Add topRect: sr.Add bottomRect
    
34.   sr.Add top_RoundRect: sr.Add bottom_RoundRect
    
35.   sr.AddRange wing: sh.Delete
    
36.   sr.SetOutlineProperties Color:=CreateCMYKColor(100, 0, 0, 0)
    
37.   
    
38.   '// 绘制尺寸刀痕线
    
39.   Set sl1 = DrawLine(l1x, 0, l1x, h)
    
40.   Set sl2 = DrawLine(l2x, 0, l2x, h)
    
41.   Set sl3 = DrawLine(l3x, 0, l3x, h)
    
42.   Set sl4 = DrawLine(l4x, 0, l4x, h)
    
43.   
    
44.   '// 盒子box 群组
    
45.   sr.Add sl1: sr.Add sl2: sr.Add sl3: sr.Add sl4
    
46.   sr.CreateSelection: sr.Group
    
47.   
    
48. End Function
    
49. 
    
50. '// 画一条线，设置轮廓色 M100
    
51. Private Function DrawLine(X1, Y1, X2, Y2) As Shape
    
52.   Set DrawLine = ActiveLayer.CreateLineSegment(X1, Y1, X2, Y2)
    
53.   DrawLine.Outline.SetProperties Color:=CreateCMYKColor(0, 100, 0, 0)
    
54. End Function
    
55. 
    
56. 
    
57. Private Function DrawWing(s As Shape) As Shape
    
58.     Dim sp As SubPath, crv As Curve
    
59.     Dim x As Double, y As Double
    
60.     x = s.SizeWidth: y = s.SizeHeight
    
61.     s.Delete
    
62.    
    
63.     '// 绘制 Box 翅膀 Wing
    
64.     Set crv = Application.CreateCurve(ActiveDocument)
    
65.     Set sp = crv.CreateSubPath(0, 0)
    
66.     sp.AppendLineSegment 0, 4
    
67.     sp.AppendLineSegment 2, 6
    
68.     sp.AppendLineSegment 4, y - 2.5
    
69.     sp.AppendCurveSegment2 6.5, y, 4.1, y - 1.25, 5.1, y
    
70.     sp.AppendLineSegment x - 2, y
    
71.     sp.AppendLineSegment x - 2, 3
    
72.     sp.AppendLineSegment x, 0
    
73.    
    
74.     sp.Closed = True
    
75.     Set DrawWing = ActiveLayer.CreateCurve(crv)
    
76. End Function

复制代码

最后在窗口空间中添加一个图片当按钮

1. Private Sub MakeBox_Click()
   
2.   box.Simple_box_three
   
3. End Sub
   

复制代码

stehong

学习是好的 应用就没必要了 因为优秀的很多
有空是不是可以研究下这种

jiangyu

stehong 发表于 2023-8-6 11:54
学习是好的 应用就没必要了 因为优秀的很多
有空是不是可以研究下这种

这种应该去找做刀模的人做吧，这边大多是做平面设计的，应该不会有人知道做刀模的施工参数。只是照猫画虎的，画出来该加的地方没加，该减的地方没减，那不是无用功了。

landboy

stehong 发表于 2023-8-6 11:54
学习是好的 应用就没必要了 因为优秀的很多
有空是不是可以研究下这种

所以， 你可以参考 这个，
制作你想要的盒子插件

                               
登录/注册后可看大图

stehong

jiangyu 发表于 2023-8-6 18:52
这种应该去找做刀模的人做吧，这边大多是做平面设计的，应该不会有人知道做刀模的施工参数。只是照猫画虎 ...

一般都是比画个尺寸样式出来再交给做刀模的做