1
1

Woodman.frm 21 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555
  1. VERSION 5.00
  2. Begin {C62A69F0-16DC-11CE-9E98-00AA00574A4F} Woodman
  3. Caption = "Batch Dimension Nodes"
  4. ClientHeight = 2220
  5. ClientLeft = 45
  6. ClientTop = 330
  7. ClientWidth = 3945
  8. OleObjectBlob = "Woodman.frx":0000
  9. StartUpPosition = 1 '所有者中心
  10. End
  11. Attribute VB_Name = "Woodman"
  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. #If VBA7 Then
  19. Private Declare PtrSafe Function DrawMenuBar Lib "user32" (ByVal hwnd As Long) As Long
  20. Private Declare PtrSafe Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
  21. Private Declare PtrSafe Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
  22. Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
  23. Private Declare PtrSafe Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
  24. #Else
  25. Private Declare Function DrawMenuBar Lib "user32" (ByVal hwnd As Long) As Long
  26. Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
  27. Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
  28. Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
  29. Private Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
  30. #End If
  31. Private Const GWL_STYLE As Long = (-16)
  32. Private Const GWL_EXSTYLE = (-20)
  33. Private Const WS_CAPTION As Long = &HC00000
  34. Private Const WS_EX_DLGMODALFRAME = &H1&
  35. '// Minimizes the window and retains dimensioning functionality '// 最小化窗口并保留标注尺寸功能
  36. Private Function MiniForm()
  37. Dim IStyle As Long
  38. Dim hwnd As Long
  39. hwnd = FindWindow("ThunderDFrame", Woodman.Caption)
  40. IStyle = GetWindowLong(hwnd, GWL_STYLE)
  41. IStyle = IStyle And Not WS_CAPTION
  42. SetWindowLong hwnd, GWL_STYLE, IStyle
  43. DrawMenuBar hwnd
  44. IStyle = GetWindowLong(hwnd, GWL_EXSTYLE) And Not WS_EX_DLGMODALFRAME
  45. SetWindowLong hwnd, GWL_EXSTYLE, IStyle
  46. Dim ctl As Variant '// CorelDRAW 2020 定义成 Variant 才不会错误
  47. For Each ctl In Woodman.Controls
  48. ctl.Visible = False
  49. ctl.Top = 2
  50. Next ctl
  51. With Me
  52. .StartUpPosition = 0
  53. .BackColor = &H80000012
  54. .Left = Val(GetSetting("LYVBA", "Settings", "Left", "400")) + 318
  55. .Top = Val(GetSetting("LYVBA", "Settings", "Top", "55")) - 2
  56. .Height = 28
  57. .width = 98
  58. .MarkLines_Makesize.Visible = True
  59. .btn_Makesizes.Visible = True
  60. .Manual_Makesize.Visible = True
  61. .chkOpposite.Visible = True
  62. .X_EXIT.Visible = True
  63. .MarkLines_Makesize.Left = 1
  64. .btn_Makesizes.Left = 26
  65. .Manual_Makesize.Left = 50
  66. .chkOpposite.Left = 75: .chkOpposite.Top = 14
  67. .X_EXIT.Left = 85: .X_EXIT.Top = 0
  68. End With
  69. End Function
  70. Private Sub btn_MiniForm_Click()
  71. MiniForm
  72. End Sub
  73. Private Sub UserForm_Initialize()
  74. LNG_CODE = Val(GetSetting("LYVBA", "Settings", "I18N_LNG", "1033"))
  75. Init_Translations Me, LNG_CODE
  76. Me.Caption = i18n("Batch Dimension Nodes", LNG_CODE)
  77. End Sub
  78. Private Sub btn_square_hi_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal Y As Single)
  79. API.BeginOpt
  80. Set os = ActiveSelectionRange
  81. Set ss = os.Shapes
  82. For Each s In ss
  83. s.SizeWidth = s.SizeHeight
  84. Next s
  85. API.EndOpt
  86. End Sub
  87. Private Sub btn_square_wi_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal Y As Single)
  88. API.BeginOpt
  89. Set os = ActiveSelectionRange
  90. Set ss = os.Shapes
  91. For Each s In ss
  92. s.SizeHeight = s.SizeWidth
  93. Next s
  94. API.EndOpt
  95. End Sub
  96. Private Sub btn_Makesizes_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal Y As Single)
  97. On Error GoTo ErrorHandler
  98. API.BeginOpt
  99. Dim os As ShapeRange
  100. Dim s As Shape
  101. Dim sr As ShapeRange
  102. Set doc = ActiveDocument
  103. Set sr = ActiveSelectionRange
  104. sr.RemoveAll
  105. If Shift = 4 Then
  106. Set os = ActiveSelectionRange
  107. For Each s In os.Shapes
  108. If s.Type = cdrLinearDimensionShape Then s.Delete
  109. Next s
  110. ElseIf Shift = 1 Then
  111. Set os = ActiveSelectionRange
  112. For Each s In os.Shapes
  113. If s.Type = cdrLinearDimensionShape Then sr.Add s
  114. Next s
  115. sr.CreateSelection
  116. ElseIf Shift = 2 Then
  117. Set os = ActiveSelectionRange
  118. For Each s In os.Shapes
  119. If s.Type = cdrLinearDimensionShape Then s.Delete
  120. Next s
  121. If os.Count > 0 Then
  122. os.Shapes.FindShapes(Query:="@name ='DMKLine'").CreateSelection
  123. ActiveSelectionRange.Delete
  124. End If
  125. Else
  126. make_sizes Shift
  127. End If
  128. ErrorHandler:
  129. API.EndOpt
  130. End Sub
  131. Private Sub btn_sizes_up_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal Y As Single)
  132. make_sizes_sep "up", Shift
  133. End Sub
  134. Private Sub btn_sizes_dn_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal Y As Single)
  135. make_sizes_sep "dn", Shift
  136. End Sub
  137. Private Sub btn_sizes_lf_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal Y As Single)
  138. make_sizes_sep "lf", Shift
  139. End Sub
  140. Private Sub btn_sizes_ri_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal Y As Single)
  141. make_sizes_sep "ri", Shift
  142. End Sub
  143. Private Sub btn_sizes_btw_up_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal Y As Single)
  144. make_sizes_sep "upb", Shift
  145. End Sub
  146. Private Sub btn_sizes_btw_dn_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal Y As Single)
  147. make_sizes_sep "dnb", Shift
  148. End Sub
  149. Private Sub btn_sizes_btw_lf_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal Y As Single)
  150. make_sizes_sep "lfb", Shift
  151. End Sub
  152. Private Sub btn_sizes_btw_ri_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal Y As Single)
  153. make_sizes_sep "rib", Shift
  154. End Sub
  155. Sub make_sizes_sep(dr, Optional shft = 0, Optional ByVal mirror As Boolean = False)
  156. On Error GoTo ErrorHandler
  157. API.BeginOpt "Make Size"
  158. Set doc = ActiveDocument
  159. Dim s As Shape, sh As Shape
  160. Dim pts As New SnapPoint, pte As New SnapPoint
  161. Dim os As ShapeRange
  162. Set os = ActiveSelectionRange
  163. Dim border As Variant
  164. Dim Line_len As Double
  165. If shft > 1 Then
  166. Line_len = API.Set_Space_Width '// 设置文字空间间隙
  167. Else
  168. Line_len = API.Set_Space_Width(True) '// 只读文字空间间隙
  169. End If
  170. border = Array(cdrBottomRight, cdrBottomLeft, os.TopY + Line_len, os.TopY + 2 * Line_len, _
  171. cdrBottomRight, cdrTopRight, os.LeftX - Line_len, os.LeftX - 2 * Line_len)
  172. If mirror = True Then border = Array(cdrTopRight, cdrTopLeft, os.BottomY - Line_len, os.BottomY - 2 * Line_len, _
  173. cdrBottomLeft, cdrTopLeft, os.RightX + Line_len, os.RightX + 2 * Line_len)
  174. #If VBA7 Then
  175. If dr = "upbx" Or dr = "upb" Or dr = "dnb" Or dr = "up" Or dr = "dn" Then os.Sort "@shape1.left < @shape2.left"
  176. If dr = "lfbx" Or dr = "lfb" Or dr = "rib" Or dr = "lf" Or dr = "ri" Then os.Sort "@shape1.top > @shape2.top"
  177. #Else
  178. If dr = "upbx" Or dr = "upb" Or dr = "dnb" Or dr = "up" Or dr = "dn" Then Set os = X4_Sort_ShapeRange(os, stlx)
  179. If dr = "lfbx" Or dr = "lfb" Or dr = "rib" Or dr = "lf" Or dr = "ri" Then Set os = X4_Sort_ShapeRange(os, stty).ReverseRange
  180. #End If
  181. If os.Count > 0 Then
  182. If os.Count > 1 And Len(dr) > 2 And os.Shapes.Count > 1 Then
  183. For i = 1 To os.Shapes.Count - 1
  184. Select Case dr
  185. Case "upbx"
  186. #If VBA7 Then
  187. Set pts = os.Shapes(i).SnapPoints.BBox(border(0))
  188. Set pte = os.Shapes(i + 1).SnapPoints.BBox(border(1))
  189. Set sh = ActiveLayer.CreateLinearDimension(cdrDimensionHorizontal, pts, pte, True, 0, border(2), cdrDimensionStyleEngineering)
  190. If shft > 0 And i = 1 Then
  191. Dimension_SetProperty sh, PresetProperty.value
  192. Set pts = os.FirstShape.SnapPoints.BBox(border(0))
  193. Set pte = os.LastShape.SnapPoints.BBox(border(1))
  194. Set sh = ActiveLayer.CreateLinearDimension(cdrDimensionHorizontal, pts, pte, True, 0, border(3), cdrDimensionStyleEngineering)
  195. End If
  196. Case "lfbx"
  197. Set pts = os.Shapes(i).SnapPoints.BBox(border(4))
  198. Set pte = os.Shapes(i + 1).SnapPoints.BBox(border(5))
  199. Set sh = ActiveLayer.CreateLinearDimension(cdrDimensionVertical, pts, pte, True, border(6), 0, cdrDimensionStyleEngineering)
  200. If shft > 0 And i = 1 Then
  201. Dimension_SetProperty sh, PresetProperty.value
  202. Set pts = os.FirstShape.SnapPoints.BBox(border(4))
  203. Set pte = os.LastShape.SnapPoints.BBox(border(5))
  204. Set sh = ActiveLayer.CreateLinearDimension(cdrDimensionVertical, pts, pte, True, border(7), 0, cdrDimensionStyleEngineering)
  205. End If
  206. #Else
  207. ' X4 There is a difference
  208. Set pts = CreateSnapPoint(os.Shapes(i).CenterX, os.Shapes(i).CenterY)
  209. Set pte = CreateSnapPoint(os.Shapes(i + 1).CenterX, os.Shapes(i + 1).CenterY)
  210. Set sh = ActiveLayer.CreateLinearDimension(cdrDimensionHorizontal, pts, pte, True, 0, border(2), Textsize:=18)
  211. Case "lfbx"
  212. Set pts = CreateSnapPoint(os.Shapes(i).CenterX, os.Shapes(i).CenterY)
  213. Set pte = CreateSnapPoint(os.Shapes(i + 1).CenterX, os.Shapes(i + 1).CenterY)
  214. Set sh = ActiveLayer.CreateLinearDimension(cdrDimensionVertical, pts, pte, True, border(6), 0, Textsize:=18)
  215. #End If
  216. Case "upb"
  217. Set pts = os.Shapes(i).SnapPoints.BBox(cdrTopRight)
  218. Set pte = os.Shapes(i + 1).SnapPoints.BBox(cdrTopLeft)
  219. Set sh = ActiveLayer.CreateLinearDimension(cdrDimensionHorizontal, pts, pte, True, os.LeftX + os.SizeWidth / 10, os.TopY + os.SizeHeight / 10, cdrDimensionStyleEngineering)
  220. Case "dnb"
  221. Set pts = os.Shapes(i).SnapPoints.BBox(cdrBottomRight)
  222. Set pte = os.Shapes(i + 1).SnapPoints.BBox(cdrBottomLeft)
  223. Set sh = ActiveLayer.CreateLinearDimension(cdrDimensionHorizontal, pts, pte, True, os.LeftX + os.SizeWidth / 10, os.BottomY - os.SizeHeight / 10, cdrDimensionStyleEngineering)
  224. Case "lfb"
  225. Set pts = os.Shapes(i).SnapPoints.BBox(cdrBottomLeft)
  226. Set pte = os.Shapes(i + 1).SnapPoints.BBox(cdrTopLeft)
  227. Set sh = ActiveLayer.CreateLinearDimension(cdrDimensionVertical, pts, pte, True, os.LeftX - os.SizeWidth / 10, os.BottomY + os.SizeHeight / 10, cdrDimensionStyleEngineering)
  228. Case "rib"
  229. Set pts = os.Shapes(i).SnapPoints.BBox(cdrBottomRight)
  230. Set pte = os.Shapes(i + 1).SnapPoints.BBox(cdrTopRight)
  231. Set sh = ActiveLayer.CreateLinearDimension(cdrDimensionVertical, pts, pte, True, os.RightX + os.SizeWidth / 10, os.BottomY + os.SizeHeight / 10, cdrDimensionStyleEngineering)
  232. End Select
  233. '// 尺寸标注设置属性
  234. Dimension_SetProperty sh, PresetProperty.value
  235. 'ActiveDocument.ClearSelection
  236. Next i
  237. Else
  238. If shft > 0 Then
  239. Select Case dr
  240. Case "up"
  241. Set pts = os.FirstShape.SnapPoints.BBox(cdrTopLeft)
  242. Set pte = os.LastShape.SnapPoints.BBox(cdrTopRight)
  243. Set sh = ActiveLayer.CreateLinearDimension(cdrDimensionHorizontal, pts, pte, True, os.LeftX + os.SizeWidth / 10, os.TopY + os.SizeHeight / 10, cdrDimensionStyleEngineering)
  244. Case "dn"
  245. Set pts = os.FirstShape.SnapPoints.BBox(cdrBottomLeft)
  246. Set pte = os.LastShape.SnapPoints.BBox(cdrBottomRight)
  247. Set sh = ActiveLayer.CreateLinearDimension(cdrDimensionHorizontal, pts, pte, True, os.LeftX + os.SizeWidth / 10, os.BottomY - os.SizeHeight / 10, cdrDimensionStyleEngineering)
  248. Case "lf"
  249. Set pts = os.FirstShape.SnapPoints.BBox(cdrTopLeft)
  250. Set pte = os.LastShape.SnapPoints.BBox(cdrBottomLeft)
  251. Set sh = ActiveLayer.CreateLinearDimension(cdrDimensionVertical, pts, pte, True, os.LeftX - os.SizeWidth / 10, os.BottomY + os.SizeHeight / 10, cdrDimensionStyleEngineering)
  252. Case "ri"
  253. Set pts = os.FirstShape.SnapPoints.BBox(cdrTopRight)
  254. Set pte = os.LastShape.SnapPoints.BBox(cdrBottomRight)
  255. Set sh = ActiveLayer.CreateLinearDimension(cdrDimensionVertical, pts, pte, True, os.RightX + os.SizeWidth / 10, os.BottomY + os.SizeHeight / 10, cdrDimensionStyleEngineering)
  256. End Select
  257. Dimension_SetProperty sh, PresetProperty.value
  258. Else
  259. For Each s In os.Shapes
  260. Select Case dr
  261. Case "up"
  262. Set pts = s.SnapPoints.BBox(cdrTopLeft)
  263. Set pte = s.SnapPoints.BBox(cdrTopRight)
  264. Set sh = ActiveLayer.CreateLinearDimension(cdrDimensionHorizontal, pts, pte, True, s.LeftX + s.SizeWidth / 10, s.TopY + s.SizeHeight / 10, cdrDimensionStyleEngineering)
  265. Case "dn"
  266. Set pts = s.SnapPoints.BBox(cdrBottomLeft)
  267. Set pte = s.SnapPoints.BBox(cdrBottomRight)
  268. Set sh = ActiveLayer.CreateLinearDimension(cdrDimensionHorizontal, pts, pte, True, s.LeftX + s.SizeWidth / 10, s.BottomY - s.SizeHeight / 10, cdrDimensionStyleEngineering)
  269. Case "lf"
  270. Set pts = s.SnapPoints.BBox(cdrTopLeft)
  271. Set pte = s.SnapPoints.BBox(cdrBottomLeft)
  272. Set sh = ActiveLayer.CreateLinearDimension(cdrDimensionVertical, pts, pte, True, s.LeftX - s.SizeWidth / 10, s.BottomY + s.SizeHeight / 10, cdrDimensionStyleEngineering)
  273. Case "ri"
  274. Set pts = s.SnapPoints.BBox(cdrTopRight)
  275. Set pte = s.SnapPoints.BBox(cdrBottomRight)
  276. Set sh = ActiveLayer.CreateLinearDimension(cdrDimensionVertical, pts, pte, True, s.RightX + s.SizeWidth / 10, s.BottomY + s.SizeHeight / 10, cdrDimensionStyleEngineering)
  277. End Select
  278. Dimension_SetProperty sh, PresetProperty.value
  279. Next s
  280. End If
  281. End If
  282. End If
  283. os.CreateSelection
  284. ErrorHandler:
  285. API.EndOpt
  286. End Sub
  287. Sub make_sizes(Optional shft = 0)
  288. ' On Error GoTo ErrorHandler
  289. ' API.BeginOpt
  290. Dim s As Shape
  291. Dim pts As SnapPoint, pte As SnapPoint
  292. Dim os As ShapeRange
  293. Set os = ActiveSelectionRange
  294. If os.Count > 0 Then
  295. For Each s In os.Shapes
  296. #If VBA7 Then
  297. Set pts = s.SnapPoints.BBox(cdrTopLeft)
  298. Set pte = s.SnapPoints.BBox(cdrTopRight)
  299. Set ptle = s.SnapPoints.BBox(cdrBottomLeft)
  300. If shft <> 6 Then Dimension_SetProperty ActiveLayer.CreateLinearDimension(cdrDimensionVertical, pts, ptle, True, _
  301. s.LeftX - s.SizeWidth / 10, s.BottomY + s.SizeHeight / 10, cdrDimensionStyleEngineering), PresetProperty.value
  302. If shft <> 3 Then Dimension_SetProperty ActiveLayer.CreateLinearDimension(cdrDimensionHorizontal, pts, pte, True, _
  303. s.LeftX + s.SizeWidth / 10, s.TopY + s.SizeHeight / 10, cdrDimensionStyleEngineering), PresetProperty.value
  304. #Else
  305. ' X4 There is a difference
  306. Set pts = s.SnapPoints(cdrTopLeft)
  307. Set pte = s.SnapPoints(cdrTopRight)
  308. Set ptle = s.SnapPoints(cdrBottomLeft)
  309. If shft <> 6 Then ActiveLayer.CreateLinearDimension cdrDimensionVertical, pts, ptle, True, _
  310. s.LeftX - s.SizeWidth / 10, s.BottomY + s.SizeHeight / 10, cdrDimensionStyleEngineering, Textsize:=18
  311. If shft <> 3 Then ActiveLayer.CreateLinearDimension cdrDimensionHorizontal, pts, pte, True, _
  312. s.LeftX + s.SizeWidth / 10, s.TopY + s.SizeHeight / 10, cdrDimensionStyleEngineering, Textsize:=18
  313. #End If
  314. Next s
  315. End If
  316. ErrorHandler:
  317. API.EndOpt
  318. End Sub
  319. '// 节点连接合并
  320. Private Sub btn_join_nodes_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal Y As Single)
  321. ActiveSelection.CustomCommand "ConvertTo", "JoinCurves"
  322. Application.Refresh
  323. End Sub
  324. '// 节点优化减少
  325. Private Sub btn_nodes_reduce_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal Y As Single)
  326. On Error GoTo ErrorHandler: API.BeginOpt
  327. Set doc = ActiveDocument
  328. Dim s As Shape
  329. ps = Array(1)
  330. doc.Unit = cdrTenthMicron
  331. Set os = ActivePage.Shapes
  332. If os.Count > 0 Then
  333. For Each s In os
  334. s.ConvertToCurves
  335. If Not s.DisplayCurve Is Nothing Then
  336. s.Curve.AutoReduceNodes 50
  337. End If
  338. Next s
  339. End If
  340. ErrorHandler:
  341. API.EndOpt
  342. End Sub
  343. '// 使用标记线批量建立尺寸标注: 左键上标注,右键右标注
  344. Private Sub MarkLines_Makesize_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal Y As Single)
  345. Dim sr As ShapeRange
  346. Set sr = ActiveSelectionRange
  347. '// 右键
  348. If Button = 2 Then
  349. If chkOpposite.value = True Then
  350. CutLines.Dimension_MarkLines cdrAlignTop, True
  351. make_sizes_sep "upbx", Shift, True
  352. Else
  353. CutLines.Dimension_MarkLines cdrAlignLeft, True
  354. make_sizes_sep "lfbx", Shift, True
  355. End If
  356. '// 左键
  357. ElseIf Button = 1 Then
  358. If chkOpposite.value = True Then
  359. CutLines.Dimension_MarkLines cdrAlignLeft, False
  360. make_sizes_sep "lfbx", Shift, False
  361. Else
  362. CutLines.Dimension_MarkLines cdrAlignTop, False
  363. make_sizes_sep "upbx", Shift, False
  364. End If
  365. End If
  366. sr.CreateSelection
  367. End Sub
  368. '// 使用手工选节点建立尺寸标注,使用Ctrl分离尺寸标注
  369. Private Sub Manual_Makesize_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal Y As Single)
  370. If Button = 2 Then
  371. '// 右键
  372. ElseIf Shift = fmCtrlMask Then
  373. Slanted_Makesize '// 手动标注倾斜尺寸
  374. Else
  375. Untie_MarkLines '// 解绑尺寸,分离尺寸
  376. End If
  377. End Sub
  378. '// 解绑尺寸,分离尺寸
  379. Private Function Untie_MarkLines()
  380. Dim os As ShapeRange, dss As New ShapeRange
  381. Set os = ActiveSelectionRange
  382. For Each s In os.Shapes
  383. If s.Type = cdrLinearDimensionShape Then
  384. dss.Add s
  385. End If
  386. Next s
  387. If dss.Count > 0 Then
  388. dss.BreakApartEx
  389. os.Shapes.FindShapes(Query:="@name ='DMKLine'").CreateSelection
  390. ActiveSelectionRange.Delete
  391. End If
  392. End Function
  393. '// 手动标注倾斜尺寸
  394. Private Function Slanted_Makesize()
  395. On Error GoTo ErrorHandler
  396. API.BeginOpt
  397. Dim nr As NodeRange, cnt As Integer
  398. Dim sr As ShapeRange, sh As Shape
  399. Dim x1 As Double, y1 As Double
  400. Dim x2 As Double, y2 As Double
  401. Set sr = ActiveSelectionRange
  402. Set nr = ActiveShape.Curve.Selection
  403. If chkOpposite.value = False Then
  404. Slanted_Sort_Make sr '// 排序标注倾斜尺寸
  405. Exit Function
  406. End If
  407. If nr.Count < 2 Then Exit Function
  408. cnt = nr.Count
  409. While cnt > 1
  410. x1 = nr(cnt).PositionX
  411. y1 = nr(cnt).PositionY
  412. x2 = nr(cnt - 1).PositionX
  413. y2 = nr(cnt - 1).PositionY
  414. Set pts = CreateSnapPoint(x1, y1)
  415. Set pte = CreateSnapPoint(x2, y2)
  416. Set sh = ActiveLayer.CreateLinearDimension(cdrDimensionSlanted, pts, pte, True, x1 - 20, y1 + 20, cdrDimensionStyleEngineering)
  417. Dimension_SetProperty sh, PresetProperty.value
  418. cnt = cnt - 1
  419. Wend
  420. ErrorHandler:
  421. API.EndOpt
  422. End Function
  423. '// 排序标注倾斜尺寸
  424. Private Function Slanted_Sort_Make(shs As ShapeRange)
  425. On Error GoTo ErrorHandler
  426. Dim sr As New ShapeRange
  427. Dim s As Shape, sh As Shape
  428. Dim nr As NodeRange
  429. For Each sh In shs
  430. Set nr = sh.Curve.Selection
  431. For Each n In nr
  432. Set s = ActiveLayer.CreateEllipse2(n.PositionX, n.PositionY, 0.5, 0.5)
  433. sr.Add s
  434. Next n
  435. Next sh
  436. CutLines.RemoveDuplicates sr '// 简单删除重复算法
  437. #If VBA7 Then
  438. sr.Sort "@shape1.left < @shape2.left"
  439. #Else
  440. Set sr = X4_Sort_ShapeRange(sr, stlx)
  441. #End If
  442. For i = 1 To sr.Count - 1
  443. x1 = sr(i + 1).CenterX
  444. y1 = sr(i + 1).CenterY
  445. x2 = sr(i).CenterX
  446. y2 = sr(i).CenterY
  447. Set pts = CreateSnapPoint(x1, y1)
  448. Set pte = CreateSnapPoint(x2, y2)
  449. #If VBA7 Then
  450. Set sh = ActiveLayer.CreateLinearDimension(cdrDimensionSlanted, pts, pte, True, x1 - 20, y1 + 20, cdrDimensionStyleEngineering)
  451. #Else
  452. ' X4 There is a difference
  453. Set sh = ActiveLayer.CreateLinearDimension(cdrDimensionSlanted, pts, pte, True, (x1 + x2) / 2, (y1 + y2) / 2, cdrDimensionStyleEngineering, Textsize:=18)
  454. #End If
  455. Dimension_SetProperty sh, PresetProperty.value
  456. Next i
  457. sr.Delete
  458. ErrorHandler:
  459. API.EndOpt
  460. End Function
  461. '// 尺寸标注设置属性
  462. Private Function Dimension_SetProperty(sh_dim As Shape, Optional ByVal Preset As Boolean = False)
  463. #If VBA7 Then
  464. If Preset And sh_dim.Type = cdrLinearDimensionShape Then
  465. With sh_dim.Style.GetProperty("dimension")
  466. .SetProperty "precision", 0 ' 小数位数
  467. .SetProperty "showUnits", 0 ' 是否显示单位 0/1
  468. .SetProperty "textPlacement", 0 ' 0、上方,1、下方,2、中间
  469. ' .SetProperty "dynamicText", 0 ' 是否可以编辑尺寸0/1
  470. ' .SetProperty "overhang", 500000 '
  471. End With
  472. End If
  473. #Else
  474. ' X4 There is a difference
  475. #End If
  476. End Function
  477. Private Sub X_EXIT_Click()
  478. Unload Me '// EXIT
  479. End Sub