forked from hongwenjun/corelvba
-
Notifications
You must be signed in to change notification settings - Fork 0
/
Copy pathAuto_ColorMark.bas
160 lines (140 loc) · 5.42 KB
/
Auto_ColorMark.bas
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
'// 请先选择要印刷的物件群组，本插件完成设置页面大小，自动中线色阶条对准线功能
Sub Auto_ColorMark()
On Error GoTo ErrorHandler
ActiveDocument.BeginCommandGroup: Application.Optimization = True
Dim doc As Document: Set doc = ActiveDocument: doc.Unit = cdrMillimeter
' 物件群组，设置页面大小
Call set_page_size
'// 获得页面中心点 x,y
px = ActiveDocument.ActivePage.CenterX
py = ActiveDocument.ActivePage.CenterY
'// 导入色阶条中线对准线标记文件 ColorMark.cdr 解散群组
doc.ActiveLayer.Import Path & "GMS\ColorMark.cdr"
ActiveDocument.ReferencePoint = cdrBottomMiddle
' ActiveDocument.Selection.SetPosition px, -100
ActiveDocument.Selection.Ungroup
Dim sh As Shape, shs As Shapes
Set shs = ActiveSelection.Shapes
'// 按 MarkName 名称查找放置中线对准线标记等
For Each sh In shs
ActiveDocument.ClearSelection
sh.CreateSelection
If "CenterLine" = sh.ObjectData("MarkName").Value Then
put_center_line sh
ElseIf "TargetLine" = sh.ObjectData("MarkName").Value Then
put_target_line sh
ElseIf "ColorStrip" = sh.ObjectData("MarkName").Value Then
put_ColorStrip sh ' 放置彩色色阶条
' sh.Delete ' 工厂定置不用色阶条
ElseIf "ColorMark" = sh.ObjectData("MarkName").Value Then
' CMYK四色标记放置咬口
If (px > py) Then
sh.SetPosition px + 25#, 0
Else
sh.Rotate 270#
ActiveDocument.ReferencePoint = cdrBottomLeft
sh.SetPosition 0, py - 48#
End If
Else
sh.Delete ' 没找到标记 ColorMark 删除
End If
Next sh
' 标准页面大小和添加页面框
put_page_size
put_page_line
'// 使用CQL 颜色标志查找，然后群组统一设置线宽和注册色
ActivePage.Shapes.FindShapes(Query:="@colors.find(RGB(26, 22, 35))").CreateSelection
ActiveSelection.Group
ActiveSelection.Outline.SetProperties 0.1, Color:=CreateRegistrationColor
'// 代码操作结束恢复窗口刷新
ActiveDocument.EndCommandGroup
Application.Optimization = False
ActiveWindow.Refresh: Application.Refresh
Exit Sub
ErrorHandler:
MsgBox "请先选择要印刷的物件群组，本插件完成设置页面大小，自动中线色阶条对准线功能!"
Application.Optimization = False
On Error Resume Next
End Sub
Private Sub set_page_size()
' 实践应用: 选择物件群组,页面设置物件大小,物件页面居中
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)
sh.AlignToPageCenter cdrAlignHCenter + cdrAlignVCenter
End Sub
Private Function set_line_color(line As Shape)
'// 设置线宽和注册色
line.Outline.SetProperties Color:=CreateRGBColor(26, 22, 35)
End Function
Private Function put_target_line(sh As Shape)
' 在页面四角放置套准标记线 Set sh = ActiveDocument.Selection
set_line_color sh
sh.AlignToPage cdrAlignLeft + cdrAlignTop
sh.Duplicate 0, 0
sh.Rotate 180
sh.AlignToPage cdrAlignRight + cdrAlignBottom
sh.Duplicate 0, 0
sh.Flip cdrFlipHorizontal ' 物件镜像
sh.AlignToPage cdrAlignLeft + cdrAlignBottom
sh.Duplicate 0, 0
sh.Rotate 180
sh.AlignToPage cdrAlignRight + cdrAlignTop
End Function
Private Function put_center_line(sh As Shape)
' 在页面四边放置中线 Set sh = ActiveDocument.Selection
set_line_color sh
sh.AlignToPage cdrAlignHCenter + cdrAlignTop
sh.Duplicate 0, 0
sh.Rotate 180
sh.AlignToPage cdrAlignHCenter + cdrAlignBottom
sh.Duplicate 0, 0
sh.Rotate 90
sh.AlignToPage cdrAlignVCenter + cdrAlignRight
sh.Duplicate 0, 0
sh.Rotate 180
sh.AlignToPage cdrAlignVCenter + cdrAlignLeft
End Function
Private Function put_ColorStrip(sh As Shape)
' 在页面四边放置中线 Set sh = ActiveDocument.Selection
sh.OrderToBack
If ActivePage.SizeWidth >= ActivePage.SizeHeight Then
sh.AlignToPage cdrAlignLeft + cdrAlignTop
sh.Duplicate 5, 0
sh.AlignToPage cdrAlignRight + cdrAlignTop
sh.Duplicate -25, 0
sh.Rotate 90
sh.AlignToPage cdrAlignLeft + cdrAlignBottom
sh.Duplicate 0, 5
sh.AlignToPage cdrAlignRight + cdrAlignBottom
sh.Move 0, 5
Else
sh.AlignToPage cdrAlignLeft + cdrAlignTop
sh.Duplicate 5, 0
sh.AlignToPage cdrAlignLeft + cdrAlignBottom
sh.Duplicate 5, 0
sh.Rotate 270
sh.AlignToPage cdrAlignRight + cdrAlignTop
sh.Duplicate 0, -5
sh.AlignToPage cdrAlignRight + cdrAlignBottom
sh.Move 0, 25
End If
End Function
Private Function put_page_line()
' 添加页面框线
Dim s1 As Shape
Set s1 = ActiveLayer.CreateRectangle2(0, 0, ActivePage.SizeWidth, ActivePage.SizeHeight)
s1.Fill.ApplyNoFill: s1.OrderToBack
s1.Outline.SetProperties 0.04, Color:=CreateCMYKColor(0, 100, 0, 0)
End Function
Private Function put_page_size()
' 添加文字 页面大小
Dim st As Shape
size = Trim(Str(Int(ActivePage.SizeWidth))) + "x" + Trim(Str(Int(ActivePage.SizeHeight))) + "mm"
Set st = ActiveLayer.CreateArtisticText(0, 0, size, , , "Arial", 8)
st.AlignToPage cdrAlignRight + cdrAlignTop
st.Move -3, -0.2
End Function