1
1

frmSelectSame.frm 31 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708
  1. VERSION 5.00
  2. Begin {C62A69F0-16DC-11CE-9E98-00AA00574A4F} frmSelectSame
  3. Caption = "相似选择-魔改版 蘭雅"
  4. ClientHeight = 5775
  5. ClientLeft = 495
  6. ClientTop = 5895
  7. ClientWidth = 2625
  8. OleObjectBlob = "frmSelectSame.frx":0000
  9. ShowModal = 0 'False
  10. End
  11. Attribute VB_Name = "frmSelectSame"
  12. Attribute VB_GlobalNameSpace = False
  13. Attribute VB_Creatable = False
  14. Attribute VB_PredeclaredId = True
  15. Attribute VB_Exposed = False
  16. Option Explicit
  17. '需要显式声明所有变量。 这可以防止无意中使用缓慢的“Variant”类型变量,这些变量在特定类型未知时使用。
  18. 'Requires explicit declaration of all variables. This protects against inadvertent use of the slow 'Variant' type variables which are used when the specific type is unknown.
  19. Public ssreg As ShapeRange
  20. Private Const TOOLNAME As String = "VBA_SelectSame"
  21. Private Const SECTION As String = "Options"
  22. Private Sub btnSelect_Click()
  23. If 0 = ActiveSelectionRange.Count Then Exit Sub
  24. On Error GoTo ErrorHandler
  25. Dim fLeft As Double, fTop As Double
  26. fLeft = frmSelectSame.Left
  27. fTop = frmSelectSame.Top
  28. SaveSetting "SelectSame", "Preferences", "form_left", fLeft
  29. SaveSetting "SelectSame", "Preferences", "form_top", fTop
  30. '// 区域范围选择,需要关闭刷新优化
  31. If OptBt.Value = False Then
  32. API.BeginOpt
  33. Else
  34. add_ssreg
  35. End If
  36. If (chkFill = False And chkOutline = False And chkOutlineColor = False And _
  37. chkOutlineLength = False And chkSize = False And chkWHratio = False And _
  38. chkType = False And chkNodes = False And chkSegments = False And _
  39. chkPaths = False And chkFontName = False And chkFontSize = False And chkShapeName = False) Then
  40. MsgBox "请至少选择一个选项", vbCritical, "Select Same"
  41. GoTo ErrorHandler
  42. End If
  43. '// "ME"是一个VBA保留字,返回对当前代码所在窗体(或类模块)的引用。 chk... 函数返回同名复选按钮的当前值。
  44. '// "ME" is a VBA reserved word, returning a reference to the form (or class module) in which the current code is located.
  45. '// The chk... functions return the current Value of the check buttons of the same name.
  46. With Me
  47. .SelectAllSimilar .chkFill, .chkOutline, .chkOutlineColor, .chkOutlineLength, _
  48. .chkSize, .chkWHratio, .chkType, .chkNodes, .chkSegments, .chkPaths, _
  49. .OptDoc, .Optpage, .Optlayer, .chkInGroups, .chkColorMark, .chkIndiv, _
  50. .chkFontName, .chkFontSize, .chkShapeName
  51. End With
  52. API.EndOpt
  53. Exit Sub
  54. ErrorHandler:
  55. Application.Optimization = False
  56. End Sub
  57. Sub SelectAllSimilar(Optional CheckFill As Boolean = True, _
  58. Optional CheckOutline As Boolean = True, _
  59. Optional CheckOutlineColor As Boolean = True, _
  60. Optional CheckOutlineLength As Boolean = True, _
  61. Optional CheckSize As Boolean = False, _
  62. Optional CheckWHratio As Boolean = False, _
  63. Optional CheckType As Boolean = True, _
  64. Optional CountNodes As Boolean = False, _
  65. Optional CountSegments As Boolean = False, _
  66. Optional CountPaths As Boolean = False, _
  67. Optional WithinDoc As Boolean = False, _
  68. Optional WithinPage As Boolean = True, _
  69. Optional WithinLayer As Boolean = False, _
  70. Optional WithinGroups As Boolean = True, _
  71. Optional CheckColorMark As Boolean = False, _
  72. Optional CheckIndiv As Boolean = True, _
  73. Optional CheckFontName As Boolean = False, _
  74. Optional CheckFontSize As Boolean = False, _
  75. Optional CheckShapeName As Boolean = False)
  76. 'Object variables. Reference to:
  77. Dim shpsSelected As Shapes 'selected shapes,
  78. Dim shpsToTest As Shapes 'full set of shapes to be tested, ' 待测形状全部集合
  79. Dim pagesr As ShapeRange 'pages shapes collection,
  80. Dim docsr As New ShapeRange
  81. Dim shpModel As Shape 'a pre-selected shape,
  82. Dim shpToMatch As Shape 'a shape to be matched,
  83. 'Dim oScript As Object 'CorelScript object,
  84. Dim clnModelShapes As Collection 'our list of pre-selected shapes, '定义源对象集合
  85. Dim clnSubShapes As Collection 'our list of shapes inside a group. '定义群组内的目标对象
  86. Dim P As Page, p1 As Page '文档中查找使用
  87. Dim shr As ShapeRange, sr As New ShapeRange
  88. Dim i As Integer ' '文档中循环查找计数使用
  89. Dim fsn As Shape '// 扩展功能: 字体字号标记名检测源对象
  90. On Error GoTo NothingSelected 'Get a reference to any
  91. Set shr = ActiveSelectionRange
  92. Set shpsSelected = ActiveDocument.Selection.Shapes
  93. ' On Error GoTo 0 'pre-selected shapes. 将文档中当前选中的范围作为源对象
  94. If shpsSelected.Count > 0 Then 'Gather the pre-selected shapes
  95. Set clnModelShapes = New Collection 'into a new collection for
  96. For Each shpModel In shpsSelected 'simple processing. 建立源对象集合
  97. clnModelShapes.Add shpModel
  98. Next
  99. '// 魔改分支 字体-字号-标记名
  100. If CheckFontName Or CheckFontSize Or CheckShapeName Then
  101. Set fsn = shr(1)
  102. End If
  103. '===================================
  104. ' TurnOptimizations cdrOptimizationOn
  105. '===================================
  106. If WithinPage Then
  107. If OptBt.Value = True Then
  108. Set shpsToTest = ssreg.Shapes
  109. OptBt.Value = 0
  110. API.BeginOpt
  111. Else
  112. Set shpsToTest = ActivePage.Shapes
  113. End If
  114. 'Ensure that "Edit across layers"
  115. 'is ON. Otherwise, selecting
  116. ' Set oScript = CorelScript 'across layers, followed by
  117. ' oScript.SetMultiLayer True 'grouping, can flatten all
  118. ' Set oScript = Nothing 'layers into one. 选中表示将对当前页面的所有对象与源对象进行匹配,否则只匹配当前图层的对象
  119. 'Replace the above with this line, CoreScript is not longer support X7+
  120. ActiveDocument.EditAcrossLayers = True
  121. End If
  122. If WithinLayer Then
  123. Set shpsToTest = ActivePage.ActiveLayer.Shapes
  124. End If
  125. If WithinDoc Then '在当前文档查找,将当前页面相应的对象加入到待比较范围
  126. For i = 1 To ActiveDocument.Pages.Count
  127. ActiveDocument.Pages(i).Activate
  128. Set p1 = ActiveDocument.Pages(i)
  129. Set pagesr = ActivePage.SelectShapesFromRectangle(0, p1.CenterY * 2, p1.CenterX * 2, 0, False).Shapes.All
  130. Debug.Print p1.CenterY * 2 & p1.CenterX * 2
  131. docsr.AddRange pagesr '各页面依次查找,相应的对象加入到待比较范围
  132. Next i
  133. Set shpsToTest = docsr.Shapes
  134. ' MsgBox "共有待比较对象 " & shpsToTest.Count & " 个"
  135. Label13.Caption = "共有待比较对象 " & shpsToTest.Count & " 个"
  136. 'p1.Activate
  137. End If
  138. If WithinGroups Then 'Check through flattened list.
  139. Set clnSubShapes = FlatShapeList(shpsToTest)
  140. '=======
  141. For Each shpToMatch In clnSubShapes
  142. If Not shpToMatch.Selected Then 'If the shape is not yet selected,
  143. '==================== 'check the models for a match.
  144. For Each shpModel In clnModelShapes
  145. If ShapesMatch(shpToMatch, shpModel, CheckFill, _
  146. CheckOutline, CheckOutlineColor, CheckOutlineLength, CheckSize, CheckWHratio, _
  147. CheckType, CountNodes, CountSegments, CountPaths, CheckIndiv) Then
  148. 'shpToMatch.AddToSelection
  149. sr.Add shpToMatch
  150. Exit For 'If a match has now been found,
  151. End If 'we can skip any remaining models.
  152. Next
  153. '=====================
  154. End If
  155. Next
  156. '=======
  157. Else 'Check through top-level list.
  158. For Each shpToMatch In shpsToTest
  159. If Not shpToMatch.Selected Then 'If the shape is not yet selected,
  160. 'check the models for a match.
  161. For Each shpModel In clnModelShapes
  162. If ShapesMatch(shpToMatch, shpModel, CheckFill, _
  163. CheckOutline, CheckOutlineColor, CheckOutlineLength, CheckSize, CheckWHratio, _
  164. CheckType, CountNodes, CountSegments, CountPaths, CheckIndiv) Then
  165. 'shpToMatch.AddToSelection
  166. sr.Add shpToMatch
  167. Exit For 'If a match has now been found,
  168. End If 'we can skip any remaining models.
  169. Next
  170. End If
  171. Next
  172. End If
  173. '===================================
  174. ' TurnOptimizations cdrOptimizationOff
  175. 'CorelScript.RedrawScreen
  176. '===================================
  177. 'sr.Add ActiveDocument.Selection
  178. If CheckColorMark And sr.Count > 0 Then sr.SetOutlineProperties , , CreateCMYKColor(0, 100, 0, 0) '轮廓线上色
  179. sr.AddRange shr
  180. '// 魔改分支 字体-字号-标记名
  181. If CheckFontName Or CheckFontSize Or CheckShapeName Then
  182. If CheckFontName Then ShapesMatch_Font_Name fsn, sr, "FontName"
  183. If CheckFontSize Then ShapesMatch_Font_Name fsn, sr, "FontSize"
  184. If CheckShapeName Then ShapesMatch_Font_Name fsn, sr, "ShapeName"
  185. End If
  186. sr.CreateSelection
  187. '// 显示找到对象
  188. Label13.Caption = "共找到 " & sr.Count & " 个对象"
  189. End If
  190. Set clnModelShapes = Nothing 'Release the memory allocated
  191. Set shpsToTest = Nothing
  192. Exit Sub
  193. NothingSelected:
  194. End Sub
  195. '// 添加区域选择分支
  196. Private Function add_ssreg()
  197. Dim ssr As ShapeRange, shr As ShapeRange
  198. Dim x1 As Double, y1 As Double, x2 As Double, y2 As Double
  199. Dim Shift As Long
  200. Dim b As Boolean
  201. Set shr = ActiveSelectionRange
  202. b = ActiveDocument.GetUserArea(x1, y1, x2, y2, Shift, 10, False, cdrCursorWeldSingle)
  203. If Not b Then
  204. Set ssreg = ActivePage.SelectShapesFromRectangle(x1, y1, x2, y2, True).Shapes.All
  205. End If
  206. ActiveDocument.ClearSelection
  207. shr.CreateSelection
  208. End Function
  209. '// 魔改分支 字体-字号-标记名 检查匹配
  210. Private Function ShapesMatch_Font_Name(ByVal fsn As Shape, sr As ShapeRange, Check_Case As String)
  211. Dim xz As String, sh_name As String, strFontName As String
  212. Dim FontSize As Double
  213. Dim srText As ShapeRange
  214. Set srText = sr.Shapes.FindShapes(Type:=cdrTextShape)
  215. Select Case Check_Case
  216. Case "FontName"
  217. If fsn.Type = cdrTextShape Then
  218. strFontName = fsn.text.Story.Font
  219. Set sr = srText.Shapes.FindShapes(Query:="@type ='text:artistic' or @type ='text:paragraph' and @com.text.story.font = '" & strFontName & "'")
  220. End If
  221. Case "FontSize"
  222. If fsn.Type = cdrTextShape Then
  223. FontSize = fsn.text.Story.size
  224. Set sr = srText.Shapes.FindShapes(Query:="@type ='text:artistic' or @type ='text:paragraph' and (@com.text.story.size - " & FontSize & ").abs() < 0.1 ")
  225. End If
  226. Case "ShapeName"
  227. sh_name = fsn.name
  228. Set sr = sr.Shapes.FindShapes(Query:="@name ='" & sh_name & "'")
  229. End Select
  230. End Function
  231. Private Function ShapesMatch(shpShape As Shape, shpModel As Shape, _
  232. Optional CheckFill As Boolean = True, _
  233. Optional CheckOutline As Boolean = True, _
  234. Optional CheckOutlineColor As Boolean = True, _
  235. Optional CheckOutlineLength As Boolean = True, _
  236. Optional CheckSize As Boolean = False, _
  237. Optional CheckWHratio As Boolean = False, _
  238. Optional CheckType As Boolean = True, _
  239. Optional CountNodes As Boolean = False, _
  240. Optional CountSegments As Boolean = False, _
  241. Optional CountPaths As Boolean = False, _
  242. Optional CheckIndiv As Boolean = False) As Boolean
  243. 'Sizes "match" if they differ by less than one per cent
  244. Dim ToleranceSize As Double '面积大小允许波动
  245. ToleranceSize = Me.TextBox1 / 100 '面积大小允许波动,以百分比为单位
  246. Dim ToleranceLength As Double '线长允许波动
  247. ToleranceLength = Me.TextBox2 / 100 '长度允许波动,以百分比为单位
  248. Dim ToleranceNodesCount As Long '节点数量允许波动,以 点 单位
  249. ToleranceNodesCount = Me.TextBox3 '节点数量允许波动,以 点 单位
  250. Dim ToleranceSubPathsCount As Long '子路径 子线段 允许波动,以 条 为单位
  251. ToleranceSubPathsCount = Me.TextBox4 '子路径 子线段 允许波动,以 条 为单位
  252. Dim ToleranceWHratio As Double '长宽比 允许波动,以 百分比 为单位
  253. ToleranceWHratio = Me.TextBox5 '长宽比 允许波动,以 百分比 为单位
  254. Dim ToleranceSegmentsCount As Long '线段数 允许波动,以 个 为单位
  255. ToleranceSegmentsCount = Me.TextBox6 '线段数 允许波动,以 个 为单位
  256. 'Object Variables. 'Reference to:
  257. Dim clrModel As Color 'color features of model shape,
  258. Dim clrShape As Color 'color features of shape to be tested
  259. Dim fillModel As Fill 'fill style of model shape,
  260. Dim outlnModel As Outline 'outline style of model shape,
  261. Dim crvModel As Curve 'Bezier curve of model shape,
  262. Dim crvShape As Curve 'Bezier curve of shape to be tested,
  263. Dim fntModel As StructFontProperties 'font properties of model text shape,
  264. Dim trgModel As text 'general text properties of model shape.
  265. Dim spath As SubPath, opath As SubPath
  266. Dim j As Integer
  267. 'Simple Variables. Storage of:
  268. Dim dblWidth As Double 'width of a shape,
  269. Dim dblHeight As Double 'height of a shape,
  270. Dim lngShapeType As cdrShapeType 'code for type of shape to be tested,
  271. Dim lngModelType As cdrShapeType 'code for the type of a model shape,
  272. Dim lngType As Long 'code for the type of a fill, color,
  273. 'or outline.
  274. 'Does the SHAPE match the MODEL ?
  275. 'Exit immediately on any mismatch.
  276. With shpShape
  277. lngShapeType = .Type 'Same basic TYPE of shape ?
  278. lngModelType = shpModel.Type
  279. If CheckType Then If lngShapeType <> lngModelType Then GoTo NoMatch
  280. 'A GROUP ? delegate to GroupsMatch()
  281. ' If lngShapeType = cdrGroupShape Then
  282. ' ShapesMatch = GroupsMatch(shpShape, shpModel, CheckSize, _
  283. ' CountNodes, CountPaths)
  284. ' Exit Function
  285. ' End If
  286. 'Does SIZE count ? Is so, are the
  287. If CheckSize Then 'size differences significant ?
  288. dblWidth = shpModel.SizeWidth
  289. If Abs(.SizeWidth - dblWidth) > (dblWidth * _
  290. ToleranceSize) Then GoTo NoMatch
  291. dblHeight = shpModel.SizeHeight
  292. If Abs(.SizeHeight - dblHeight) > (dblHeight * _
  293. ToleranceSize) Then GoTo NoMatch
  294. End If
  295. If CheckWHratio Then 'size width and height ratio differences significant ?
  296. dblWidth = shpModel.SizeWidth
  297. dblHeight = shpModel.SizeHeight
  298. If Abs(.SizeHeight / .SizeWidth - dblHeight / dblWidth) > (dblHeight / dblWidth * ToleranceWHratio) Then GoTo NoMatch
  299. End If
  300. If CountNodes Or CountPaths Or CheckOutlineLength Or CountSegments Then
  301. 'Only Curves can match ...
  302. If lngShapeType <> cdrCurveShape Then GoTo NoMatch
  303. Set crvShape = .Curve
  304. Set crvModel = shpModel.Curve
  305. 'If CheckIndiv Then '逐条子路径比较
  306. 'If Abs(crvShape.SubPaths.Count - crvModel.SubPaths.Count) <> 0 Then GoTo NoMatch
  307. 'For j = 1 To crvShape.SubPaths.Count
  308. 'If Abs(crvShape.SubPath(j).Nodes.Count - crvModel.SubPath(j).Nodes.Count) > ToleranceNodesCount Then GoTo NoMatch
  309. 'Next j
  310. If CountPaths Then 'Do the PATH counts match ?
  311. If VersionMajor > 12 Then 'GDG ##########################################
  312. If Abs(crvShape.SubPaths.Count - crvModel.SubPaths.Count) > ToleranceSubPathsCount Then GoTo NoMatch
  313. 'MsgBox "subpaths1: " & crvShape.SubPaths.Count & "subpaths2: " & crvModel.SubPaths.Count
  314. Else
  315. If Abs(crvShape.SubPathCount - crvModel.SubPathCount) > ToleranceSubPathsCount Then GoTo NoMatch
  316. End If 'GDG #############################################################
  317. End If
  318. If CountNodes Then 'Do the NODE counts match ?
  319. If VersionMajor > 12 Then 'GDG ##########################################
  320. If Abs(crvShape.Nodes.Count - crvModel.Nodes.Count) > ToleranceNodesCount Then GoTo NoMatch
  321. Else
  322. If Abs(crvShape.NodeCount - crvModel.NodeCount) > ToleranceNodesCount Then GoTo NoMatch
  323. End If 'GDG #############################################################
  324. End If
  325. If CountSegments Then 'Do the Segments counts match ?
  326. If VersionMajor > 12 Then 'GDG ##########################################
  327. If Abs(crvShape.Segments.Count - crvModel.Segments.Count) > ToleranceSegmentsCount Then GoTo NoMatch
  328. Else
  329. If Abs(crvShape.SegmentCount - crvModel.SegmentCount) > ToleranceSegmentsCount Then GoTo NoMatch
  330. End If 'GDG #############################################################
  331. End If
  332. If CheckOutlineLength Then 'Do the curve length match ?
  333. If VersionMajor > 12 Then 'GDG ##########################################
  334. If Abs(crvShape.Length - crvModel.Length) > crvModel.Length * ToleranceLength Then GoTo NoMatch
  335. 'MsgBox "subpaths1: " & crvShape.SubPaths.Count & "subpaths2: " & crvModel.SubPaths.Count
  336. Else
  337. If Abs(crvShape.Length - crvModel.Length) > crvModel.Length * ToleranceLength Then GoTo NoMatch
  338. End If 'GDG #############################################################
  339. End If
  340. End If
  341. If CheckFill Then
  342. Set fillModel = shpModel.Fill
  343. With .Fill 'Is the FILL type the same ?
  344. lngType = .Type
  345. If lngType <> shpModel.Fill.Type Then GoTo NoMatch
  346. If lngType = cdrUniformFill Then
  347. 'Does the uniform fill match ?
  348. If VersionMajor > 12 Then 'GDG ##########################################
  349. 'GDG ##########################################
  350. Dim col1 As New Color
  351. col1.CopyAssign .UniformColor
  352. Dim col2 As New Color
  353. col2.CopyAssign shpModel.Fill.UniformColor
  354. 'GDG ##########################################
  355. If col1.IsSame(col2) = False Then GoTo NoMatch
  356. Else
  357. Set clrModel = fillModel.UniformColor
  358. lngType = .UniformColor.Type
  359. If lngType <> clrModel.Type Then GoTo NoMatch
  360. If .UniformColor.name(True) <> clrModel.name(True) Then GoTo NoMatch
  361. End If 'GDG #############################################################
  362. End If
  363. End With
  364. End If
  365. If CheckOutline Then '(Groups have no outline)
  366. If lngShapeType <> cdrGroupShape Then
  367. Set outlnModel = shpModel.Outline
  368. If Not outlnModel Is Nothing Then
  369. With .Outline
  370. lngType = .Type
  371. If lngType <> outlnModel.Type Then GoTo NoMatch
  372. If lngType > 0 Then 'Does the shape have an OUTLINE ?
  373. 'Same LINE WIDTH ?
  374. If .Width <> outlnModel.Width Then GoTo NoMatch
  375. 'Matching LINE COLOR ?
  376. ' Set clrShape = .Color
  377. ' lngType = clrShape.Type
  378. ' Set clrModel = outlnModel.Color
  379. ' If lngType <> clrModel.Type Then GoTo NoMatch
  380. ' If clrShape.Name(True) <> clrModel.Name(True) Then GoTo NoMatch
  381. End If
  382. End With
  383. End If
  384. End If
  385. End If
  386. If CheckOutlineColor Then '(Groups have no outline)
  387. If lngShapeType <> cdrGroupShape Then
  388. Set outlnModel = shpModel.Outline
  389. If Not outlnModel Is Nothing Then
  390. With .Outline
  391. lngType = .Type
  392. If lngType <> outlnModel.Type Then GoTo NoMatch
  393. If lngType > 0 Then 'Does the shape have an OUTLINE ?
  394. 'Matching LINE COLOR ?
  395. If VersionMajor > 12 Then 'GDG ##########################################
  396. 'GDG ##########################################
  397. Dim col3 As New Color
  398. col3.CopyAssign .Color
  399. Dim col4 As New Color
  400. col4.CopyAssign shpModel.Outline.Color
  401. 'GDG ##########################################
  402. If col3.IsSame(col4) = False Then GoTo NoMatch
  403. Else
  404. Set clrShape = .Color
  405. lngType = clrShape.Type
  406. Set clrModel = outlnModel.Color
  407. If lngType <> clrModel.Type Then GoTo NoMatch
  408. If clrShape.name(True) <> clrModel.name(True) _
  409. Then GoTo NoMatch
  410. End If
  411. End If
  412. End With
  413. End If
  414. End If
  415. End If
  416. End With
  417. ShapesMatch = True
  418. Exit Function
  419. NoMatch:
  420. ShapesMatch = False
  421. NoMatchExit:
  422. ShapesMatch = False
  423. Exit Function
  424. End Function
  425. Private Function GroupsMatch(Group As Shape, GroupModel As Shape, _
  426. Optional CheckFill As Boolean = True, _
  427. Optional CheckOutline As Boolean = True, _
  428. Optional CheckOutlineColor As Boolean = True, _
  429. Optional CheckOutlineLength As Boolean = True, _
  430. Optional CheckSize As Boolean = False, _
  431. Optional CheckType As Boolean = True, _
  432. Optional CountNodes As Boolean = False, _
  433. Optional CountPaths As Boolean = False) As Boolean
  434. 'Object Variables. Reference to:
  435. Dim shpsModels As Shapes 'shapes in the pre-selected group,
  436. Dim shpsInGroup As Shapes 'shapes in the group to be tested,
  437. Dim shpModel As Shape 'a shape in the pre-selected group,
  438. Dim shpInGroup As Shape 'a shape in the group to be tested.
  439. 'Simple Variables Storage of:
  440. Dim lngInGroup As Long 'number of shapes in a group,
  441. Dim i As Long 'a numeric index to a
  442. 'particular sub-group.
  443. 'On Error GoTo NoMatch 'Shape & model must be groups.
  444. Set shpsModels = GroupModel.Shapes
  445. Set shpsInGroup = Group.Shapes
  446. 'On Error GoTo 0
  447. 'Same number of shapes
  448. lngInGroup = shpsModels.Count 'in each group ?
  449. If shpsInGroup.Count <> lngInGroup Then GoTo NoMatch
  450. For i = 1 To lngInGroup 'Try to Match all sub-shapes,
  451. Set shpInGroup = shpsInGroup(i) 'and GroupsMatch all sub-groups.
  452. Set shpModel = shpsModels(i)
  453. If shpModel.Type <> cdrGroupShape Then
  454. If Not ShapesMatch(shpInGroup, shpModel, _
  455. CheckSize, CountNodes) Then GoTo NoMatch
  456. Else
  457. If Not GroupsMatch(shpInGroup, shpModel, _
  458. CheckSize, CountNodes) Then GoTo NoMatch
  459. End If
  460. Next i
  461. GroupsMatch = True
  462. Exit Function
  463. NoMatch:
  464. GroupsMatch = False
  465. End Function
  466. Private Function FlatShapeList(TopLevelShapes As Shapes) As Collection
  467. 'Object Variables. Reference to:
  468. Dim shpTopLevel As Shape 'a top-level shape,
  469. Dim shpInGroup As Shape 'a shape inside a group,
  470. Dim clnAllShapes As Collection 'our list of all members and
  471. 'descendants of TopLevelShapes.
  472. If TopLevelShapes.Count Then
  473. Set clnAllShapes = New Collection
  474. For Each shpTopLevel In TopLevelShapes
  475. 'Add shape to list, keyed under
  476. 'a string version of its unique ID
  477. clnAllShapes.Add shpTopLevel
  478. 'If the shape is a group, then
  479. 'also gather all its descendants
  480. 'and add them to the list.
  481. If shpTopLevel.Type = cdrGroupShape Then
  482. For Each shpInGroup In ShapesInGroup(shpTopLevel)
  483. clnAllShapes.Add shpInGroup
  484. Next
  485. End If
  486. Next
  487. Set FlatShapeList = clnAllShapes 'Return the assembled collection.
  488. Else
  489. Set FlatShapeList = Nothing
  490. End If
  491. End Function
  492. Private Function ShapesInGroup(GroupShape As Shape) As Collection
  493. 'Object Variables. Reference to:
  494. Dim shpsInGroup As Shapes 'the set of shapes inside a group,
  495. Dim shpInGroup As Shape 'a particular shape in a group,
  496. Dim shpNested As Shape 'a shape inside a sub-group,
  497. Dim clnShapeList As Collection 'our list of all nested shapes.
  498. If GroupShape.Type = cdrGroupShape Then
  499. Set shpsInGroup = GroupShape.Shapes 'Get a reference to the
  500. 'shapes in this group.
  501. Set clnShapeList = New Collection
  502. For Each shpInGroup In shpsInGroup
  503. clnShapeList.Add shpInGroup 'Add all shapes in the group to
  504. 'our main collection.
  505. If shpInGroup.Type = cdrGroupShape Then
  506. 'Recurse to get nested shapes.
  507. For Each shpNested In ShapesInGroup(shpInGroup)
  508. clnShapeList.Add shpNested
  509. Next
  510. End If
  511. Next
  512. Set ShapesInGroup = clnShapeList 'Return the assembled collection.
  513. Else
  514. Set ShapesInGroup = Nothing 'Release the memory if the
  515. End If 'collection is not needed
  516. End Function
  517. Private Sub UserForm_Activate()
  518. Const YES As String = "True"
  519. Const NO As String = "False"
  520. OptDoc = GetSetting(TOOLNAME, SECTION, "InDoc", NO)
  521. Optlayer = GetSetting(TOOLNAME, SECTION, "InLayer", NO)
  522. Optpage = GetSetting(TOOLNAME, SECTION, "InPage", YES)
  523. chkColorMark = GetSetting(TOOLNAME, SECTION, "ColorMark", YES)
  524. chkFill = GetSetting(TOOLNAME, SECTION, "Fill", YES)
  525. chkInGroups = GetSetting(TOOLNAME, SECTION, "InGroups", YES)
  526. chkNodes = GetSetting(TOOLNAME, SECTION, "Nodes", NO)
  527. chkSegments = GetSetting(TOOLNAME, SECTION, "Segments", NO)
  528. chkOutline = GetSetting(TOOLNAME, SECTION, "Outline", YES)
  529. chkOutlineColor = GetSetting(TOOLNAME, SECTION, "OutlineColor", NO)
  530. chkOutlineLength = GetSetting(TOOLNAME, SECTION, "OutlineLength", YES)
  531. chkPaths = GetSetting(TOOLNAME, SECTION, "Paths", NO)
  532. chkSize = GetSetting(TOOLNAME, SECTION, "Size", NO)
  533. chkWHratio = GetSetting(TOOLNAME, SECTION, "WHratio", NO)
  534. chkType = GetSetting(TOOLNAME, SECTION, "Type", YES)
  535. chkIndiv = GetSetting(TOOLNAME, SECTION, "Indiv", NO)
  536. chkColorMark = GetSetting(TOOLNAME, SECTION, "ColorMark", NO)
  537. saveFormPos False
  538. End Sub
  539. Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
  540. saveFormPos True
  541. End Sub
  542. Sub saveFormPos(bDoSave As Boolean)
  543. Dim dL, dT
  544. If bDoSave Then 'save position
  545. SaveSetting TOOLNAME, SECTION, "form_left", Me.Left
  546. SaveSetting TOOLNAME, SECTION, "form_top", Me.Top
  547. Else 'place instead.
  548. dL = GetSetting(TOOLNAME, SECTION, "form_left", 900)
  549. dT = GetSetting(TOOLNAME, SECTION, "form_top", 200)
  550. Me.Left = dL: Me.Top = dT
  551. End If
  552. End Sub
  553. Private Sub OptDoc_Click()
  554. SaveSetting TOOLNAME, SECTION, "InDoc", CStr(OptDoc)
  555. End Sub
  556. Private Sub Optlayer_Click()
  557. SaveSetting TOOLNAME, SECTION, "InLayer", CStr(Optlayer)
  558. End Sub
  559. Private Sub Optpage_Click()
  560. SaveSetting TOOLNAME, SECTION, "InPage", CStr(Optpage)
  561. End Sub
  562. Private Sub chkColorMark_Click()
  563. SaveSetting TOOLNAME, SECTION, "ColorMark", CStr(chkColorMark)
  564. End Sub
  565. Private Sub chkIndiv_Click()
  566. SaveSetting TOOLNAME, SECTION, "Indiv", CStr(chkIndiv)
  567. End Sub
  568. Private Sub chkFill_Click()
  569. SaveSetting TOOLNAME, SECTION, "Fill", CStr(chkFill)
  570. End Sub
  571. Private Sub chkInGroups_Click()
  572. SaveSetting TOOLNAME, SECTION, "InGroups", CStr(chkInGroups)
  573. End Sub
  574. Private Sub chkNodes_Click()
  575. SaveSetting TOOLNAME, SECTION, "Nodes", CStr(chkNodes)
  576. End Sub
  577. Private Sub chkSegments_Click()
  578. SaveSetting TOOLNAME, SECTION, "Segments", CStr(chkSegments)
  579. End Sub
  580. Private Sub chkOutline_Click()
  581. SaveSetting TOOLNAME, SECTION, "Outline", CStr(chkOutline)
  582. End Sub
  583. Private Sub chkOutlineColor_Click()
  584. SaveSetting TOOLNAME, SECTION, "OutlineColor", CStr(chkOutlineColor)
  585. End Sub
  586. Private Sub chkPaths_Click()
  587. SaveSetting TOOLNAME, SECTION, "Paths", CStr(chkPaths)
  588. End Sub
  589. Private Sub chkSize_Click()
  590. SaveSetting TOOLNAME, SECTION, "Size", CStr(chkSize)
  591. End Sub
  592. Private Sub chkWHratio_Click()
  593. SaveSetting TOOLNAME, SECTION, "WHratio", CStr(chkWHratio)
  594. End Sub
  595. Private Sub chkType_Click()
  596. SaveSetting TOOLNAME, SECTION, "Type", CStr(chkType)
  597. End Sub
  598. Private Sub chkOutLineLength_Click()
  599. SaveSetting TOOLNAME, SECTION, "OutlineLength", CStr(chkOutlineLength)
  600. End Sub