1
1

ZCOPY.frm 15 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308
  1. VERSION 5.00
  2. Begin {C62A69F0-16DC-11CE-9E98-00AA00574A4F} ZCOPY
  3. Caption = "UserForm1"
  4. ClientHeight = 3855
  5. ClientLeft = 45
  6. ClientTop = 330
  7. ClientWidth = 4860
  8. OleObjectBlob = "ZCOPY.frx":0000
  9. StartUpPosition = 1 'CenterOwner
  10. End
  11. Attribute VB_Name = "ZCOPY"
  12. Attribute VB_GlobalNameSpace = False
  13. Attribute VB_Creatable = False
  14. Attribute VB_PredeclaredId = True
  15. Attribute VB_Exposed = False
  16. Private Sub btn_square_hi_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal Y As Single)
  17. If get_events("btn_square_hi", Shift, Button) = "exit" Then Exit Sub
  18. Set os = ActiveSelectionRange
  19. Set ss = os.Shapes
  20. uc = 0
  21. For Each s In ss
  22. s.SizeWidth = s.SizeHeight
  23. uc = uc + 1
  24. Next s
  25. Application.Refresh
  26. If ch_main_switch Then ActiveWindow.Activate
  27. End Sub
  28. Private Sub btn_square_wi_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal Y As Single)
  29. If get_events("btn_square_wi", Shift, Button) = "exit" Then Exit Sub
  30. Set os = ActiveSelectionRange
  31. Set ss = os.Shapes
  32. uc = 0
  33. For Each s In ss
  34. s.SizeHeight = s.SizeWidth
  35. uc = uc + 1
  36. Next s
  37. Application.Refresh
  38. If ch_main_switch Then ActiveWindow.Activate
  39. End Sub
  40. Private Sub btn_makesizes_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal Y As Single)
  41. If get_events("btn_makesizes", Shift, Button) = "exit" Then Exit Sub
  42. Dim os As ShapeRange
  43. Dim s As Shape
  44. Dim sr As ShapeRange
  45. Set doc = ActiveDocument
  46. 'rasm.Dimension.TextShape.Text.Story.size = CLng(fnt)
  47. 'rasm.Style.GetProperty("dimension").SetProperty "precision", 0
  48. 'rasm.Style.GetProperty("dimension").SetProperty "units", 3
  49. doc.BeginCommandGroup "delete sizes"
  50. Set sr = ActiveSelectionRange
  51. sr.RemoveAll
  52. If Shift = 4 Then
  53. On Error Resume Next
  54. Set os = ActiveSelectionRange
  55. For Each s In os.Shapes
  56. If s.Type = cdrLinearDimensionShape Then s.Delete
  57. Next s
  58. On Error GoTo 0
  59. ElseIf Shift = 1 Then
  60. Set os = ActiveSelectionRange
  61. For Each s In os.Shapes
  62. If s.Type = cdrLinearDimensionShape Then sr.Add s
  63. Next s
  64. sr.CreateSelection
  65. On Error GoTo 0
  66. ElseIf Shift = 2 Then
  67. On Error Resume Next
  68. Set os = ActiveSelectionRange
  69. For Each s In os.Shapes
  70. If s.Type = cdrLinearDimensionShape Then s.Delete
  71. Next s
  72. On Error GoTo 0
  73. Else
  74. Make_Sizes Shift
  75. End If
  76. doc.EndCommandGroup
  77. Application.Refresh
  78. End Sub
  79. Private Sub btn_sizes_up_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal Y As Single)
  80. If get_events("btn_sizes_up", Shift, Button) = "exit" Then Exit Sub
  81. make_sizes_sep "up", Shift
  82. End Sub
  83. Private Sub btn_sizes_dn_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal Y As Single)
  84. If get_events("btn_sizes_dn", Shift, Button) = "exit" Then Exit Sub
  85. make_sizes_sep "dn", Shift
  86. End Sub
  87. Private Sub btn_sizes_lf_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal Y As Single)
  88. If get_events("btn_sizes_lf", Shift, Button) = "exit" Then Exit Sub
  89. make_sizes_sep "lf", Shift
  90. End Sub
  91. Private Sub btn_sizes_ri_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal Y As Single)
  92. If get_events("btn_sizes_ri", Shift, Button) = "exit" Then Exit Sub
  93. make_sizes_sep "ri", Shift
  94. End Sub
  95. Private Sub btn_sizes_btw_up_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal Y As Single)
  96. If get_events("btn_sizes_btw_up", Shift, Button) = "exit" Then Exit Sub
  97. make_sizes_sep "upb", Shift
  98. End Sub
  99. Private Sub btn_sizes_btw_dn_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal Y As Single)
  100. If get_events("btn_sizes_btw_dn", Shift, Button) = "exit" Then Exit Sub
  101. make_sizes_sep "dnb", Shift
  102. End Sub
  103. Private Sub btn_sizes_btw_lf_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal Y As Single)
  104. If get_events("btn_sizes_btw_lf", Shift, Button) = "exit" Then Exit Sub
  105. make_sizes_sep "lfb", Shift
  106. End Sub
  107. Private Sub btn_sizes_btw_ri_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal Y As Single)
  108. If get_events("btn_sizes_btw_ri", Shift, Button) = "exit" Then Exit Sub
  109. make_sizes_sep "rib", Shift
  110. End Sub
  111. Sub make_sizes_sep(dr, Optional shft = 0)
  112. Set doc = ActiveDocument
  113. Dim s As Shape
  114. Dim pts As New SnapPoint, pte As New SnapPoint
  115. Dim os As ShapeRange
  116. un = doc.Unit
  117. doc.Unit = cdrMillimeter
  118. doc.BeginCommandGroup "make sizes"
  119. Set os = ActiveSelectionRange
  120. If dr = "upb" Or dr = "dnb" Or dr = "up" Or dr = "dn" Then os.Sort "@shape1.left < @shape2.left"
  121. If dr = "lfb" Or dr = "rib" Or dr = "lf" Or dr = "ri" Then os.Sort "@shape1.top > @shape2.top"
  122. If os.Count > 0 Then
  123. If os.Count > 1 And Len(dr) > 2 Then
  124. For i = 1 To os.Shapes.Count - 1
  125. Select Case dr
  126. Case "upb":
  127. Set pts = os.Shapes(i).SnapPoints.BBox(cdrTopRight)
  128. Set pte = os.Shapes(i + 1).SnapPoints.BBox(cdrTopLeft)
  129. ActiveLayer.CreateLinearDimension cdrDimensionHorizontal, pts, pte, True, os.LeftX + os.SizeWidth / 10, os.TopY + os.SizeHeight / 10, cdrDimensionStyleEngineering
  130. Case "dnb":
  131. Set pts = os.Shapes(i).SnapPoints.BBox(cdrBottomRight)
  132. Set pte = os.Shapes(i + 1).SnapPoints.BBox(cdrBottomLeft)
  133. ActiveLayer.CreateLinearDimension cdrDimensionHorizontal, pts, pte, True, os.LeftX + os.SizeWidth / 10, os.BottomY - os.SizeHeight / 10, cdrDimensionStyleEngineering
  134. Case "lfb":
  135. Set pts = os.Shapes(i).SnapPoints.BBox(cdrBottomLeft)
  136. Set pte = os.Shapes(i + 1).SnapPoints.BBox(cdrTopLeft)
  137. ActiveLayer.CreateLinearDimension cdrDimensionVertical, pts, pte, True, os.LeftX - os.SizeWidth / 10, os.BottomY + os.SizeHeight / 10, cdrDimensionStyleEngineering
  138. Case "rib":
  139. Set pts = os.Shapes(i).SnapPoints.BBox(cdrBottomRight)
  140. Set pte = os.Shapes(i + 1).SnapPoints.BBox(cdrTopRight)
  141. ActiveLayer.CreateLinearDimension cdrDimensionVertical, pts, pte, True, os.RightX + os.SizeWidth / 10, os.BottomY + os.SizeHeight / 10, cdrDimensionStyleEngineering
  142. End Select
  143. 'ActiveDocument.ClearSelection
  144. Next i
  145. Else
  146. If shft > 0 Then
  147. Select Case dr
  148. Case "up":
  149. Set pts = os.FirstShape.SnapPoints.BBox(cdrTopLeft)
  150. Set pte = os.LastShape.SnapPoints.BBox(cdrTopRight)
  151. ActiveLayer.CreateLinearDimension cdrDimensionHorizontal, pts, pte, True, os.LeftX + os.SizeWidth / 10, os.TopY + os.SizeHeight / 10, cdrDimensionStyleEngineering
  152. Case "dn":
  153. Set pts = os.FirstShape.SnapPoints.BBox(cdrBottomLeft)
  154. Set pte = os.LastShape.SnapPoints.BBox(cdrBottomRight)
  155. ActiveLayer.CreateLinearDimension cdrDimensionHorizontal, pts, pte, True, os.LeftX + os.SizeWidth / 10, os.BottomY - os.SizeHeight / 10, cdrDimensionStyleEngineering
  156. Case "lf":
  157. Set pts = os.FirstShape.SnapPoints.BBox(cdrTopLeft)
  158. Set pte = os.LastShape.SnapPoints.BBox(cdrBottomLeft)
  159. ActiveLayer.CreateLinearDimension cdrDimensionVertical, pts, pte, True, os.LeftX - os.SizeWidth / 10, os.BottomY + os.SizeHeight / 10, cdrDimensionStyleEngineering
  160. Case "ri":
  161. Set pts = os.FirstShape.SnapPoints.BBox(cdrTopRight)
  162. Set pte = os.LastShape.SnapPoints.BBox(cdrBottomRight)
  163. ActiveLayer.CreateLinearDimension cdrDimensionVertical, pts, pte, True, os.RightX + os.SizeWidth / 10, os.BottomY + os.SizeHeight / 10, cdrDimensionStyleEngineering
  164. End Select
  165. Else
  166. For Each s In os.Shapes
  167. Select Case dr
  168. Case "up":
  169. Set pts = s.SnapPoints.BBox(cdrTopLeft)
  170. Set pte = s.SnapPoints.BBox(cdrTopRight)
  171. ActiveLayer.CreateLinearDimension cdrDimensionHorizontal, pts, pte, True, s.LeftX + s.SizeWidth / 10, s.TopY + s.SizeHeight / 10, cdrDimensionStyleEngineering
  172. Case "dn":
  173. Set pts = s.SnapPoints.BBox(cdrBottomLeft)
  174. Set pte = s.SnapPoints.BBox(cdrBottomRight)
  175. ActiveLayer.CreateLinearDimension cdrDimensionHorizontal, pts, pte, True, s.LeftX + s.SizeWidth / 10, s.BottomY - s.SizeHeight / 10, cdrDimensionStyleEngineering
  176. Case "lf":
  177. Set pts = s.SnapPoints.BBox(cdrTopLeft)
  178. Set pte = s.SnapPoints.BBox(cdrBottomLeft)
  179. ActiveLayer.CreateLinearDimension cdrDimensionVertical, pts, pte, True, s.LeftX - s.SizeWidth / 10, s.BottomY + s.SizeHeight / 10, cdrDimensionStyleEngineering
  180. Case "ri":
  181. Set pts = s.SnapPoints.BBox(cdrTopRight)
  182. Set pte = s.SnapPoints.BBox(cdrBottomRight)
  183. ActiveLayer.CreateLinearDimension cdrDimensionVertical, pts, pte, True, s.RightX + s.SizeWidth / 10, s.BottomY + s.SizeHeight / 10, cdrDimensionStyleEngineering
  184. End Select
  185. Next s
  186. End If
  187. End If
  188. End If
  189. os.CreateSelection
  190. doc.EndCommandGroup
  191. doc.Unit = un
  192. End Sub
  193. Sub Make_Sizes(Optional shft = 0)
  194. Set doc = ActiveDocument
  195. Dim s As Shape
  196. Dim pts As SnapPoint, pte As SnapPoint
  197. Dim os As ShapeRange
  198. un = doc.Unit
  199. doc.Unit = cdrMillimeter
  200. doc.BeginCommandGroup "make sizes"
  201. Set os = ActiveSelectionRange
  202. If os.Count > 0 Then
  203. For Each s In os.Shapes
  204. Set pts = s.SnapPoints.BBox(cdrTopLeft)
  205. Set pte = s.SnapPoints.BBox(cdrTopRight)
  206. Set ptle = s.SnapPoints.BBox(cdrBottomLeft)
  207. If shft <> 6 Then ActiveLayer.CreateLinearDimension cdrDimensionVertical, pts, ptle, True, s.LeftX - s.SizeWidth / 10, s.BottomY + s.SizeHeight / 10, cdrDimensionStyleEngineering
  208. If shft <> 3 Then ActiveLayer.CreateLinearDimension cdrDimensionHorizontal, pts, pte, True, s.LeftX + s.SizeWidth / 10, s.TopY + s.SizeHeight / 10, cdrDimensionStyleEngineering
  209. Next s
  210. End If
  211. doc.EndCommandGroup
  212. doc.Unit = un
  213. End Sub
  214. Public Function make_selection(Optional mode = "fcolor", Optional sel = True, Optional OSS As ShapeRange = Nothing, Optional colr = Nothing) As ShapeRange
  215. Dim s As Shape, lst As Shape
  216. Dim sr As ShapeRange
  217. 'Dim os As ShapeRange
  218. Set doc = ActiveDocument
  219. doc.Unit = cdrTenthMicron
  220. If OSS Is Nothing Then
  221. If toolspanel.num_list.Value Or mode = "locked" Then
  222. Set os = ActivePage
  223. Else
  224. Set os = ActiveSelectionRange
  225. End If
  226. Else
  227. Set os = OSS
  228. End If
  229. Set sr = ActiveSelectionRange
  230. sr.RemoveAll
  231. If sel Then ActiveDocument.ClearSelection
  232. Set lst = os.Shapes.First
  233. For Each s In os.Shapes
  234. Select Case mode
  235. Case "ocolor": If s.Outline.Type <> cdrNoOutline And s.Shapes.Count = 0 And s.Outline.Color.HexValue = colr.HexValue Then sr.Add s
  236. Case "fcolor": If s.Fill.Type <> cdrNoFill And s.Shapes.Count = 0 And s.Fill.UniformColor.HexValue = colr.HexValue Then sr.Add s
  237. Case "nofil": If s.Fill.Type = cdrNoFill And s.Shapes.Count = 0 Then sr.Add s
  238. Case "fil": If s.Fill.Type <> cdrNoFill And s.Shapes.Count = 0 Then sr.Add s
  239. Case "abr": If s.Outline.Type <> cdrNoOutline And s.Shapes.Count = 0 Then sr.Add s
  240. Case "noabr": If s.Outline.Type = cdrNoOutline And s.Shapes.Count = 0 Then sr.Add s
  241. Case "open": If Not s.DisplayCurve Is Nothing Then If Not s.DisplayCurve.Closed Then sr.Add s
  242. Case "closed": If Not s.DisplayCurve Is Nothing Then If s.DisplayCurve.Closed Then sr.Add s
  243. Case "single": If s.Shapes.Count = 0 Then sr.Add s
  244. Case "dashed": If s.Outline.Style.DashCount > 0 Then sr.Add s
  245. Case "groups": If s.Shapes.Count > 0 And s.Effect Is Nothing Then sr.Add s
  246. Case "text": If s.Shapes.Count = 0 And s.Type = cdrTextShape Then sr.Add s
  247. Case "notext": If s.Shapes.Count = 0 And s.Type <> cdrTextShape Then sr.Add s
  248. Case "images": If s.Type = cdrBitmapShape Then sr.Add s
  249. Case "locked": If s.Locked Then sr.Add s
  250. Case "effects": If s.Effects.Count > 0 Or Not s.Effect Is Nothing Then sr.Add s
  251. Case "noeffects": If s.Effects.Count = 0 And s.Effect Is Nothing Then sr.Add s
  252. Case "bigger":
  253. arelst = lst.SizeHeight * lst.SizeWidth
  254. ares = s.SizeHeight * s.SizeWidth
  255. If ares >= arelst Then
  256. are = one_shape_area(lst)
  257. If one_shape_area(s) >= are Then sr.Add s
  258. End If
  259. Case "smaller":
  260. arelst = lst.SizeHeight * lst.SizeWidth
  261. ares = s.SizeHeight * s.SizeWidth
  262. If ares <= arelst Then
  263. are = one_shape_area(lst)
  264. If one_shape_area(s) <= are Then sr.Add s
  265. End If
  266. Case "last":
  267. If lst.Fill.Type = cdrNoFill Then
  268. 's.CreateSelection
  269. If s.Outline.Type <> cdrNoOutline Then If s.Outline.Color.HexValue = lst.Outline.Color.HexValue Then sr.Add s
  270. Else
  271. If s.Fill.UniformColor.HexValue = lst.Fill.UniformColor.HexValue Then sr.Add s
  272. End If
  273. End Select
  274. Next s
  275. If sr.Shapes.Count > 0 And sel Then sr.CreateSelection
  276. Set make_selection = sr
  277. Application.Refresh
  278. ActiveWindow.Activate
  279. End Function
  280. Public Function get_events(btn As String, Optional shft = 0, Optional click = 1)
  281. out = "ok"
  282. get_events = out
  283. End Function