frmSelectSame.frm 32 KB

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