1
1

MakeSizePlus.frm 26 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732
  1. VERSION 5.00
  2. Begin {C62A69F0-16DC-11CE-9E98-00AA00574A4F} MakeSizePlus
  3. Caption = "Batch Dimensions Plus"
  4. ClientHeight = 3690
  5. ClientLeft = 45
  6. ClientTop = 330
  7. ClientWidth = 5115
  8. OleObjectBlob = "MakeSizePlus.frx":0000
  9. StartUpPosition = 1 'CenterOwner
  10. End
  11. Attribute VB_Name = "MakeSizePlus"
  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. '// 插件名称 VBA_UserForm
  36. Private Const TOOLNAME As String = "LYVBA"
  37. Private Const SECTION As String = "MakeSizePlus"
  38. Private sreg As New ShapeRange
  39. Private Sub UserForm_Initialize()
  40. With Me
  41. .StartUpPosition = 0
  42. .Left = Val(GetSetting(TOOLNAME, SECTION, "form_left", 900))
  43. .Top = Val(GetSetting(TOOLNAME, SECTION, "form_top", 200))
  44. .width = Val(GetSetting(TOOLNAME, SECTION, "form_width", 200))
  45. .Height = Val(GetSetting(TOOLNAME, SECTION, "form_Height", 105))
  46. End With
  47. LNG_CODE = API.GetLngCode
  48. Init_Translations Me, LNG_CODE
  49. Me.Caption = i18n("Batch Dimensions Plus", LNG_CODE)
  50. ' 读取线设置
  51. Bleed.text = API.GetSet("Bleed")
  52. Line_len.text = API.GetSet("Line_len")
  53. Outline_Width.text = GetSetting("LYVBA", "Settings", "Outline_Width", "0.2")
  54. End Sub
  55. '// 关闭窗口时保存窗口位置
  56. Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
  57. saveFormPos True
  58. End Sub
  59. '// 保存窗口位置和加载窗口位置
  60. Sub saveFormPos(bDoSave As Boolean)
  61. If bDoSave Then 'save position
  62. SaveSetting TOOLNAME, SECTION, "form_left", Me.Left
  63. SaveSetting TOOLNAME, SECTION, "form_top", Me.Top
  64. SaveSetting TOOLNAME, SECTION, "form_width", Me.width
  65. SaveSetting TOOLNAME, SECTION, "form_Height", Me.Height
  66. End If
  67. End Sub
  68. Private Sub btn_ExpandForm_Click()
  69. With Me
  70. If .width = 200 Then
  71. .width = 260: .Height = 132
  72. ElseIf .Height = 132 Then
  73. .Height = 206
  74. Else
  75. .width = 200: .Height = 105
  76. End If
  77. End With
  78. End Sub
  79. '// Minimizes the window and retains dimensioning functionality '// 最小化窗口并保留标注尺寸功能
  80. Private Function MiniForm()
  81. Dim IStyle As Long
  82. Dim hwnd As Long
  83. hwnd = FindWindow("ThunderDFrame", MakeSizePlus.Caption)
  84. IStyle = GetWindowLong(hwnd, GWL_STYLE)
  85. IStyle = IStyle And Not WS_CAPTION
  86. SetWindowLong hwnd, GWL_STYLE, IStyle
  87. DrawMenuBar hwnd
  88. IStyle = GetWindowLong(hwnd, GWL_EXSTYLE) And Not WS_EX_DLGMODALFRAME
  89. SetWindowLong hwnd, GWL_EXSTYLE, IStyle
  90. Dim ctl As Variant '// CorelDRAW 2020 定义成 Variant 才不会错误
  91. For Each ctl In MakeSizePlus.Controls
  92. ctl.Visible = False
  93. ctl.Top = 2
  94. Next ctl
  95. With Me
  96. .StartUpPosition = 0
  97. .BackColor = &H80000012
  98. .Left = Val(GetSetting("LYVBA", "Settings", "Left", "400")) + 318
  99. .Top = Val(GetSetting("LYVBA", "Settings", "Top", "55")) - 2
  100. .Height = 28
  101. .width = 98
  102. .MarkLines_Makesize.Visible = True
  103. .btn_Makesizes.Visible = True
  104. .Manual_Makesize.Visible = True
  105. .chkOpposite.Visible = True
  106. .X_EXIT.Visible = True
  107. .MarkLines_Makesize.Left = 1
  108. .btn_Makesizes.Left = 26
  109. .Manual_Makesize.Left = 50
  110. .chkOpposite.Left = 75: .chkOpposite.Top = 14
  111. .X_EXIT.Left = 85: .X_EXIT.Top = 0
  112. End With
  113. End Function
  114. Private Sub btn_MiniForm_Click()
  115. MiniForm
  116. End Sub
  117. Private Sub Settings_Click()
  118. If 0 < Val(Bleed.text) * Val(Line_len.text) < 100 Then
  119. SaveSetting "LYVBA", "Settings", "Bleed", Bleed.text
  120. SaveSetting "LYVBA", "Settings", "Line_len", Line_len.text
  121. SaveSetting "LYVBA", "Settings", "Outline_Width", Outline_Width.text
  122. Call API.Set_Space_Width '// 设置空间间隙
  123. End If
  124. End Sub
  125. Private Sub btn_Makesizes_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
  126. On Error GoTo ErrorHandler
  127. API.BeginOpt
  128. Dim os As ShapeRange
  129. Dim s As Shape
  130. Dim sr As ShapeRange
  131. Set doc = ActiveDocument
  132. Set sr = ActiveSelectionRange
  133. sr.RemoveAll
  134. If Shift = 4 Then
  135. Set os = ActiveSelectionRange
  136. For Each s In os.Shapes
  137. If s.Type = cdrTextShape Then sr.Add s
  138. Next s
  139. sr.CreateSelection
  140. ElseIf Shift = 1 Then
  141. Set os = ActiveSelectionRange
  142. For Each s In os.Shapes
  143. If s.Type = cdrLinearDimensionShape Then sr.Add s
  144. Next s
  145. sr.CreateSelection
  146. ElseIf Shift = 2 Then
  147. Set os = ActiveSelectionRange
  148. For Each s In os.Shapes
  149. If s.Type = cdrLinearDimensionShape Then sr.Add s
  150. Next s
  151. sr.Delete
  152. If os.Count > 0 Then
  153. os.Shapes.FindShapes(Query:="@name ='DMKLine'").CreateSelection
  154. ActiveSelectionRange.Delete
  155. End If
  156. Else
  157. make_sizes Shift
  158. End If
  159. ErrorHandler:
  160. API.EndOpt
  161. End Sub
  162. Sub make_sizes_sep(dr, Optional shft = 0, Optional ByVal mirror As Boolean = False)
  163. On Error GoTo ErrorHandler
  164. API.BeginOpt "Make Size"
  165. Set doc = ActiveDocument
  166. Dim s As Shape, sh As Shape
  167. Dim pts As New SnapPoint, pte As New SnapPoint
  168. Dim os As ShapeRange
  169. Set os = ActiveSelectionRange
  170. Dim border As Variant
  171. Dim Line_len As Double
  172. Line_len = API.Set_Space_Width(True) '// 读取间隔
  173. border = Array(cdrBottomRight, cdrBottomLeft, os.TopY + Line_len, os.TopY + 2 * Line_len, _
  174. cdrBottomRight, cdrTopRight, os.LeftX - Line_len, os.LeftX - 2 * Line_len)
  175. If mirror = True Then border = Array(cdrTopRight, cdrTopLeft, os.BottomY - Line_len, os.BottomY - 2 * Line_len, _
  176. cdrBottomLeft, cdrTopLeft, os.RightX + Line_len, os.RightX + 2 * Line_len)
  177. If dr = "upbx" Or dr = "upb" Or dr = "dnb" Or dr = "up" Or dr = "dn" Then Set os = X4_Sort_ShapeRange(os, stlx)
  178. If dr = "lfbx" Or dr = "lfb" Or dr = "rib" Or dr = "lf" Or dr = "ri" Then Set os = X4_Sort_ShapeRange(os, stty).ReverseRange
  179. If os.Count > 0 Then
  180. If os.Count > 1 And Len(dr) > 2 And os.Shapes.Count > 1 Then
  181. For i = 1 To os.Shapes.Count - 1
  182. Select Case dr
  183. Case "upbx"
  184. #If VBA7 Then
  185. Set pts = os.Shapes(i).SnapPoints.BBox(border(0))
  186. Set pte = os.Shapes(i + 1).SnapPoints.BBox(border(1))
  187. Set sh = ActiveLayer.CreateLinearDimension(cdrDimensionHorizontal, pts, pte, True, 0, border(2), cdrDimensionStyleEngineering)
  188. If shft > 0 And i = 1 Then
  189. Dimension_SetProperty sh, PresetProperty.value
  190. Set pts = os.FirstShape.SnapPoints.BBox(border(0))
  191. Set pte = os.LastShape.SnapPoints.BBox(border(1))
  192. Set sh = ActiveLayer.CreateLinearDimension(cdrDimensionHorizontal, pts, pte, True, 0, border(3), cdrDimensionStyleEngineering)
  193. End If
  194. Case "lfbx"
  195. Set pts = os.Shapes(i).SnapPoints.BBox(border(4))
  196. Set pte = os.Shapes(i + 1).SnapPoints.BBox(border(5))
  197. Set sh = ActiveLayer.CreateLinearDimension(cdrDimensionVertical, pts, pte, True, border(6), 0, cdrDimensionStyleEngineering)
  198. If shft > 0 And i = 1 Then
  199. Dimension_SetProperty sh, PresetProperty.value
  200. Set pts = os.FirstShape.SnapPoints.BBox(border(4))
  201. Set pte = os.LastShape.SnapPoints.BBox(border(5))
  202. Set sh = ActiveLayer.CreateLinearDimension(cdrDimensionVertical, pts, pte, True, border(7), 0, cdrDimensionStyleEngineering)
  203. End If
  204. #Else
  205. ' X4 There is a difference
  206. Set pts = CreateSnapPoint(os.Shapes(i).CenterX, os.Shapes(i).CenterY)
  207. Set pte = CreateSnapPoint(os.Shapes(i + 1).CenterX, os.Shapes(i + 1).CenterY)
  208. Set sh = ActiveLayer.CreateLinearDimension(cdrDimensionHorizontal, pts, pte, True, 0, border(2), Textsize:=18)
  209. Case "lfbx"
  210. Set pts = CreateSnapPoint(os.Shapes(i).CenterX, os.Shapes(i).CenterY)
  211. Set pte = CreateSnapPoint(os.Shapes(i + 1).CenterX, os.Shapes(i + 1).CenterY)
  212. Set sh = ActiveLayer.CreateLinearDimension(cdrDimensionVertical, pts, pte, True, border(6), 0, Textsize:=18)
  213. #End If
  214. Case "upb"
  215. Set pts = os.Shapes(i).SnapPoints.BBox(cdrTopRight)
  216. Set pte = os.Shapes(i + 1).SnapPoints.BBox(cdrTopLeft)
  217. Set sh = ActiveLayer.CreateLinearDimension(cdrDimensionHorizontal, pts, pte, True, os.LeftX + os.SizeWidth / 10, os.TopY + os.SizeHeight / 10, cdrDimensionStyleEngineering)
  218. Case "dnb"
  219. Set pts = os.Shapes(i).SnapPoints.BBox(cdrBottomRight)
  220. Set pte = os.Shapes(i + 1).SnapPoints.BBox(cdrBottomLeft)
  221. Set sh = ActiveLayer.CreateLinearDimension(cdrDimensionHorizontal, pts, pte, True, os.LeftX + os.SizeWidth / 10, os.BottomY - os.SizeHeight / 10, cdrDimensionStyleEngineering)
  222. Case "lfb"
  223. Set pts = os.Shapes(i).SnapPoints.BBox(cdrBottomLeft)
  224. Set pte = os.Shapes(i + 1).SnapPoints.BBox(cdrTopLeft)
  225. Set sh = ActiveLayer.CreateLinearDimension(cdrDimensionVertical, pts, pte, True, os.LeftX - os.SizeWidth / 10, os.BottomY + os.SizeHeight / 10, cdrDimensionStyleEngineering)
  226. Case "rib"
  227. Set pts = os.Shapes(i).SnapPoints.BBox(cdrBottomRight)
  228. Set pte = os.Shapes(i + 1).SnapPoints.BBox(cdrTopRight)
  229. Set sh = ActiveLayer.CreateLinearDimension(cdrDimensionVertical, pts, pte, True, os.RightX + os.SizeWidth / 10, os.BottomY + os.SizeHeight / 10, cdrDimensionStyleEngineering)
  230. End Select
  231. '// 尺寸标注设置属性
  232. Dimension_SetProperty sh, PresetProperty.value
  233. 'ActiveDocument.ClearSelection
  234. Next i
  235. Else
  236. If shft > 0 Then
  237. Select Case dr
  238. Case "up"
  239. Set pts = os.FirstShape.SnapPoints.BBox(cdrTopLeft)
  240. Set pte = os.LastShape.SnapPoints.BBox(cdrTopRight)
  241. Set sh = ActiveLayer.CreateLinearDimension(cdrDimensionHorizontal, pts, pte, True, os.LeftX + os.SizeWidth / 10, os.TopY + os.SizeHeight / 10, cdrDimensionStyleEngineering)
  242. Case "dn"
  243. Set pts = os.FirstShape.SnapPoints.BBox(cdrBottomLeft)
  244. Set pte = os.LastShape.SnapPoints.BBox(cdrBottomRight)
  245. Set sh = ActiveLayer.CreateLinearDimension(cdrDimensionHorizontal, pts, pte, True, os.LeftX + os.SizeWidth / 10, os.BottomY - os.SizeHeight / 10, cdrDimensionStyleEngineering)
  246. Case "lf"
  247. Set pts = os.FirstShape.SnapPoints.BBox(cdrTopLeft)
  248. Set pte = os.LastShape.SnapPoints.BBox(cdrBottomLeft)
  249. Set sh = ActiveLayer.CreateLinearDimension(cdrDimensionVertical, pts, pte, True, os.LeftX - os.SizeWidth / 10, os.BottomY + os.SizeHeight / 10, cdrDimensionStyleEngineering)
  250. Case "ri"
  251. Set pts = os.FirstShape.SnapPoints.BBox(cdrTopRight)
  252. Set pte = os.LastShape.SnapPoints.BBox(cdrBottomRight)
  253. Set sh = ActiveLayer.CreateLinearDimension(cdrDimensionVertical, pts, pte, True, os.RightX + os.SizeWidth / 10, os.BottomY + os.SizeHeight / 10, cdrDimensionStyleEngineering)
  254. End Select
  255. Dimension_SetProperty sh, PresetProperty.value
  256. Else
  257. For Each s In os.Shapes
  258. Select Case dr
  259. Case "up"
  260. Set pts = s.SnapPoints.BBox(cdrTopLeft)
  261. Set pte = s.SnapPoints.BBox(cdrTopRight)
  262. Set sh = ActiveLayer.CreateLinearDimension(cdrDimensionHorizontal, pts, pte, True, s.LeftX + s.SizeWidth / 10, s.TopY + s.SizeHeight / 10, cdrDimensionStyleEngineering)
  263. Case "dn"
  264. Set pts = s.SnapPoints.BBox(cdrBottomLeft)
  265. Set pte = s.SnapPoints.BBox(cdrBottomRight)
  266. Set sh = ActiveLayer.CreateLinearDimension(cdrDimensionHorizontal, pts, pte, True, s.LeftX + s.SizeWidth / 10, s.BottomY - s.SizeHeight / 10, cdrDimensionStyleEngineering)
  267. Case "lf"
  268. Set pts = s.SnapPoints.BBox(cdrTopLeft)
  269. Set pte = s.SnapPoints.BBox(cdrBottomLeft)
  270. Set sh = ActiveLayer.CreateLinearDimension(cdrDimensionVertical, pts, pte, True, s.LeftX - s.SizeWidth / 10, s.BottomY + s.SizeHeight / 10, cdrDimensionStyleEngineering)
  271. Case "ri"
  272. Set pts = s.SnapPoints.BBox(cdrTopRight)
  273. Set pte = s.SnapPoints.BBox(cdrBottomRight)
  274. Set sh = ActiveLayer.CreateLinearDimension(cdrDimensionVertical, pts, pte, True, s.RightX + s.SizeWidth / 10, s.BottomY + s.SizeHeight / 10, cdrDimensionStyleEngineering)
  275. End Select
  276. Dimension_SetProperty sh, PresetProperty.value
  277. Next s
  278. End If
  279. End If
  280. End If
  281. os.CreateSelection
  282. ErrorHandler:
  283. API.EndOpt
  284. End Sub
  285. Sub make_sizes(Optional shft = 0)
  286. On Error GoTo ErrorHandler
  287. API.BeginOpt
  288. Dim s As Shape
  289. Dim pts As SnapPoint, pte As SnapPoint
  290. Dim os As ShapeRange
  291. Set os = ActiveSelectionRange
  292. If os.Count > 0 Then
  293. For Each s In os.Shapes
  294. #If VBA7 Then
  295. Set pts = s.SnapPoints.BBox(cdrTopLeft)
  296. Set pte = s.SnapPoints.BBox(cdrTopRight)
  297. Set ptle = s.SnapPoints.BBox(cdrBottomLeft)
  298. If shft <> 6 Then Dimension_SetProperty ActiveLayer.CreateLinearDimension(cdrDimensionVertical, pts, ptle, True, _
  299. s.LeftX - s.SizeWidth / 10, s.BottomY + s.SizeHeight / 10, cdrDimensionStyleEngineering), PresetProperty.value
  300. If shft <> 3 Then Dimension_SetProperty ActiveLayer.CreateLinearDimension(cdrDimensionHorizontal, pts, pte, True, _
  301. s.LeftX + s.SizeWidth / 10, s.TopY + s.SizeHeight / 10, cdrDimensionStyleEngineering), PresetProperty.value
  302. #Else
  303. ' X4 There is a difference
  304. Set pts = s.SnapPoints(cdrTopLeft)
  305. Set pte = s.SnapPoints(cdrTopRight)
  306. Set ptle = s.SnapPoints(cdrBottomLeft)
  307. If shft <> 6 Then ActiveLayer.CreateLinearDimension cdrDimensionVertical, pts, ptle, True, _
  308. s.LeftX - s.SizeWidth / 10, s.BottomY + s.SizeHeight / 10, cdrDimensionStyleEngineering, Textsize:=18
  309. If shft <> 3 Then ActiveLayer.CreateLinearDimension cdrDimensionHorizontal, pts, pte, True, _
  310. s.LeftX + s.SizeWidth / 10, s.TopY + s.SizeHeight / 10, cdrDimensionStyleEngineering, Textsize:=18
  311. #End If
  312. Next s
  313. End If
  314. ErrorHandler:
  315. API.EndOpt
  316. End Sub
  317. '// 使用标记线批量建立尺寸标注: 左键上标注,右键右标注
  318. Private Sub MarkLines_Makesize_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
  319. Dim sr As ShapeRange
  320. Set sr = ActiveSelectionRange
  321. '// 右键
  322. If Button = 2 Then
  323. If chkOpposite.value = True Then
  324. CutLines.Dimension_MarkLines cdrAlignTop, True
  325. make_sizes_sep "upbx", Shift, True
  326. Else
  327. CutLines.Dimension_MarkLines cdrAlignLeft, True
  328. make_sizes_sep "lfbx", Shift, True
  329. End If
  330. '// 左键
  331. ElseIf Button = 1 Then
  332. If chkOpposite.value = True Then
  333. CutLines.Dimension_MarkLines cdrAlignLeft, False
  334. make_sizes_sep "lfbx", Shift, False
  335. Else
  336. CutLines.Dimension_MarkLines cdrAlignTop, False
  337. make_sizes_sep "upbx", Shift, False
  338. End If
  339. End If
  340. sr.CreateSelection
  341. End Sub
  342. '// 使用手工选节点建立尺寸标注,使用Ctrl分离尺寸标注
  343. Private Sub Manual_Makesize_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
  344. If Button = 2 Then
  345. '// 右键
  346. ElseIf Shift = fmCtrlMask Then
  347. Slanted_Makesize '// 手动标注倾斜尺寸
  348. Else
  349. ModulePlus.Untie_MarkLines '// 解绑尺寸,分离尺寸
  350. End If
  351. End Sub
  352. '// 手动标注倾斜尺寸
  353. Private Function Slanted_Makesize()
  354. On Error GoTo ErrorHandler
  355. API.BeginOpt
  356. Dim nr As NodeRange, cnt As Integer
  357. Dim sr As ShapeRange, sh As Shape
  358. Dim x1 As Double, y1 As Double
  359. Dim x2 As Double, y2 As Double
  360. Set sr = ActiveSelectionRange
  361. Set nr = ActiveShape.Curve.Selection
  362. If chkOpposite.value = False Then
  363. Slanted_Sort_Make sr '// 排序标注倾斜尺寸
  364. Exit Function
  365. End If
  366. If nr.Count < 2 Then Exit Function
  367. cnt = nr.Count
  368. While cnt > 1
  369. x1 = nr(cnt).PositionX
  370. y1 = nr(cnt).PositionY
  371. x2 = nr(cnt - 1).PositionX
  372. y2 = nr(cnt - 1).PositionY
  373. Set pts = CreateSnapPoint(x1, y1)
  374. Set pte = CreateSnapPoint(x2, y2)
  375. Set sh = ActiveLayer.CreateLinearDimension(cdrDimensionSlanted, pts, pte, True, x1 - 20, y1 + 20, cdrDimensionStyleEngineering)
  376. Dimension_SetProperty sh, PresetProperty.value
  377. cnt = cnt - 1
  378. Wend
  379. ErrorHandler:
  380. API.EndOpt
  381. End Function
  382. '// 排序标注倾斜尺寸
  383. Private Function Slanted_Sort_Make(shs As ShapeRange)
  384. On Error GoTo ErrorHandler
  385. Dim sr As New ShapeRange
  386. Dim s As Shape, sh As Shape
  387. Dim nr As NodeRange
  388. For Each sh In shs
  389. Set nr = sh.Curve.Selection
  390. For Each n In nr
  391. Set s = ActiveLayer.CreateEllipse2(n.PositionX, n.PositionY, 0.5, 0.5)
  392. sr.Add s
  393. Next n
  394. Next sh
  395. CutLines.RemoveDuplicates sr '// 简单删除重复算法
  396. Set sr = X4_Sort_ShapeRange(sr, stlx)
  397. For i = 1 To sr.Count - 1
  398. x1 = sr(i + 1).CenterX
  399. y1 = sr(i + 1).CenterY
  400. x2 = sr(i).CenterX
  401. y2 = sr(i).CenterY
  402. Set pts = CreateSnapPoint(x1, y1)
  403. Set pte = CreateSnapPoint(x2, y2)
  404. #If VBA7 Then
  405. Set sh = ActiveLayer.CreateLinearDimension(cdrDimensionSlanted, pts, pte, True, x1 - 20, y1 + 20, cdrDimensionStyleEngineering)
  406. #Else
  407. ' X4 There is a difference
  408. Set sh = ActiveLayer.CreateLinearDimension(cdrDimensionSlanted, pts, pte, True, (x1 + x2) / 2, (y1 + y2) / 2, cdrDimensionStyleEngineering, Textsize:=18)
  409. #End If
  410. Dimension_SetProperty sh, PresetProperty.value
  411. Next i
  412. sr.Delete
  413. ErrorHandler:
  414. API.EndOpt
  415. End Function
  416. '// 尺寸标注设置属性
  417. Private Function Dimension_SetProperty(sh_dim As Shape, Optional ByVal Preset As Boolean = False)
  418. #If VBA7 Then
  419. If Preset And sh_dim.Type = cdrLinearDimensionShape Then
  420. With sh_dim.Style.GetProperty("dimension")
  421. .SetProperty "precision", 0 ' 小数位数
  422. .SetProperty "showUnits", 0 ' 是否显示单位 0/1
  423. .SetProperty "textPlacement", 0 ' 0、上方,1、下方,2、中间
  424. ' .SetProperty "dynamicText", 0 ' 是否可以编辑尺寸0/1
  425. ' .SetProperty "overhang", 500000 '
  426. End With
  427. End If
  428. sh_dim.Outline.width = API.GetSet("Outline_Width")
  429. #Else
  430. ' X4 There is a difference
  431. #End If
  432. End Function
  433. '// 尺寸标注左边
  434. Private Sub Makesize_Left_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
  435. If Button = 2 Then
  436. CutLines.Dimension_MarkLines cdrAlignLeft, False
  437. make_sizes_sep "lfbx", Button, False
  438. ElseIf Shift = fmCtrlMask Then
  439. CutLines.Dimension_MarkLines cdrAlignLeft, False
  440. make_sizes_sep "lfbx", Shift, False
  441. Else
  442. '// Ctrl Key
  443. make_sizes_sep "lfb"
  444. End If
  445. End Sub
  446. '// 尺寸标注右边
  447. Private Sub Makesize_Right_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
  448. If Button = 2 Then
  449. CutLines.Dimension_MarkLines cdrAlignLeft, True
  450. make_sizes_sep "lfbx", Button, True
  451. ElseIf Shift = fmCtrlMask Then
  452. CutLines.Dimension_MarkLines cdrAlignLeft, True
  453. make_sizes_sep "lfbx", Shift, True
  454. Else
  455. '// Ctrl Key
  456. make_sizes_sep "rib"
  457. End If
  458. End Sub
  459. '// 尺寸标注向上
  460. Private Sub Makesize_Up_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
  461. If Button = 2 Then
  462. CutLines.Dimension_MarkLines cdrAlignTop, False
  463. make_sizes_sep "upbx", Button, False
  464. ElseIf Shift = fmCtrlMask Then
  465. CutLines.Dimension_MarkLines cdrAlignTop, False
  466. make_sizes_sep "upbx", Shift, False
  467. Else
  468. '// Ctrl Key
  469. make_sizes_sep "upb"
  470. End If
  471. End Sub
  472. '// 尺寸标注向下
  473. Private Sub Makesize_Down_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
  474. If Button = 2 Then
  475. CutLines.Dimension_MarkLines cdrAlignTop, True
  476. make_sizes_sep "upbx", Button, True
  477. ElseIf Shift = fmCtrlMask Then
  478. CutLines.Dimension_MarkLines cdrAlignTop, True
  479. make_sizes_sep "upbx", Shift, True
  480. Else
  481. '// Ctrl Key
  482. make_sizes_sep "dnb"
  483. End If
  484. End Sub
  485. Private Sub MakeRuler_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
  486. On Error GoTo ErrorHandler
  487. API.BeginOpt
  488. Set sreg = Nothing
  489. If Button = 2 And Shift = 0 Then '// 鼠标右键 标注右边
  490. Ruler_Align cdrAlignRight
  491. ElseIf Button = 2 And Shift = 2 Then '// Ctrl+鼠标右键 标注左边
  492. Ruler_Align cdrAlignLeft
  493. ElseIf Shift = 0 Then '// 鼠标左键,标注在上边
  494. Ruler_Align cdrAlignTop
  495. ElseIf Shift = 2 Then '// Ctrl+鼠标左键,标注下边
  496. Ruler_Align cdrAlignBottom
  497. End If
  498. sreg.CreateSelection
  499. ErrorHandler:
  500. API.EndOpt
  501. End Sub
  502. Private Sub MakeRuler_Align_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
  503. On Error GoTo ErrorHandler
  504. API.BeginOpt
  505. Set sreg = Nothing
  506. Dim ra As cdrAlignType
  507. ra = cdrAlignTop
  508. ' 定义方向上下左右
  509. Dim pos_x As Variant, pos_y As Variant
  510. pos_x = Array(27, 27, 12, 44)
  511. pos_y = Array(12, 44, 27, 27)
  512. If Abs(X - pos_x(0)) < 14 And Abs(Y - pos_y(0)) < 14 Then
  513. ra = cdrAlignTop
  514. ElseIf Abs(X - pos_x(1)) < 14 And Abs(Y - pos_y(1)) < 14 Then
  515. ra = cdrAlignBottom
  516. ElseIf Abs(X - pos_x(2)) < 14 And Abs(Y - pos_y(2)) < 14 Then
  517. ra = cdrAlignLeft
  518. ElseIf Abs(X - pos_x(3)) < 14 And Abs(Y - pos_y(3)) < 14 Then
  519. ra = cdrAlignRight
  520. End If
  521. Ruler_Align ra
  522. sreg.CreateSelection
  523. ErrorHandler:
  524. API.EndOpt
  525. End Sub
  526. Private Function Ruler_Align(ra As cdrAlignType)
  527. If ra = cdrAlignRight Then '// 标注右边
  528. CutLines.Dimension_MarkLines cdrAlignLeft, True
  529. Add_Ruler_Text_Y True
  530. ElseIf ra = cdrAlignLeft Then '// 标注左边
  531. CutLines.Dimension_MarkLines cdrAlignLeft, False
  532. Add_Ruler_Text_Y True
  533. ElseIf ra = cdrAlignTop Then '// 标注上边
  534. CutLines.Dimension_MarkLines cdrAlignTop, False
  535. Add_Ruler_Text True
  536. ElseIf ra = cdrAlignBottom Then '// 标注下边
  537. CutLines.Dimension_MarkLines cdrAlignTop, True
  538. Add_Ruler_Text True
  539. End If
  540. End Function
  541. '// 标尺线转换成距离数字
  542. Private Function Add_Ruler_Text(rm_lines As Boolean)
  543. On Error GoTo ErrorHandler
  544. API.BeginOpt
  545. Dim s As Shape, t As Shape, sr As ShapeRange
  546. Dim text As String
  547. Set sr = ActiveSelectionRange
  548. Set sr = X4_Sort_ShapeRange(sr, stlx)
  549. For Each s In sr
  550. X = s.CenterX: Y = s.CenterY
  551. text = str(Int(X - sr.FirstShape.CenterX + 0.5))
  552. Set t = ActiveLayer.CreateArtisticText(X, Y, text)
  553. t.CenterX = X: t.CenterY = Y
  554. sreg.Add t
  555. Next
  556. If rm_lines Then sr.Delete
  557. ErrorHandler:
  558. API.EndOpt
  559. End Function
  560. '// 标尺线转换成距离数字
  561. Private Function Add_Ruler_Text_Y(rm_lines As Boolean)
  562. On Error GoTo ErrorHandler
  563. API.BeginOpt
  564. Dim s As Shape, t As Shape, sr As ShapeRange
  565. Dim text As String
  566. Set sr = ActiveSelectionRange
  567. Set sr = X4_Sort_ShapeRange(sr, stty)
  568. For Each s In sr
  569. X = s.CenterX: Y = s.CenterY
  570. text = str(Int(Y - sr.FirstShape.CenterY + 0.5))
  571. Set t = ActiveLayer.CreateArtisticText(X, Y, text)
  572. t.Rotate 90
  573. t.CenterX = X: t.CenterY = Y
  574. sreg.Add t
  575. Next
  576. If rm_lines Then sr.Delete
  577. ErrorHandler:
  578. API.EndOpt
  579. End Function
  580. Private Sub X_EXIT_Click()
  581. Me.width = 200: Me.Height = 105
  582. Unload Me '// EXIT
  583. End Sub
  584. Private Sub I18N_LNG_Click()
  585. LNG_CODE = API.GetLngCode
  586. If LNG_CODE = 1033 Then
  587. LNG_CODE = 2052
  588. Else
  589. LNG_CODE = 1033
  590. End If
  591. SaveSetting "LYVBA", "Settings", "I18N_LNG", LNG_CODE
  592. LNG_CODE = API.GetLngCode
  593. MsgBox i18n("Chinese And English Language Switching Is Completed, Please Restart The Plug-In.", LNG_CODE), vbOKOnly, i18n("Lanya Corelvba Plug-In", LNG_CODE)
  594. End Sub
  595. Private Sub Bt_SplitSegment_Click()
  596. ModulePlus.SplitSegment
  597. End Sub
  598. Private Sub btn_square_hi_Click()
  599. ModulePlus.square_hw "Height"
  600. End Sub
  601. Private Sub btn_square_wi_Click()
  602. ModulePlus.square_hw "Width"
  603. End Sub
  604. '// 节点连接合并
  605. Private Sub btn_join_nodes_Click()
  606. ActiveSelection.CustomCommand "ConvertTo", "JoinCurves"
  607. Application.Refresh
  608. End Sub
  609. '// 节点优化减少
  610. Private Sub btn_nodes_reduce_Click()
  611. ModulePlus.Nodes_Reduce
  612. End Sub
  613. '// 选择标注线 选择文字 删除或者解绑标准线
  614. Private Sub SelectText_Click()
  615. ModulePlus.Dimension_Select_or_Delete 4
  616. End Sub
  617. Private Sub SelectLine_Click()
  618. ModulePlus.Dimension_Select_or_Delete 1
  619. End Sub
  620. Private Sub Delete_Dimension_Click()
  621. ModulePlus.Dimension_Select_or_Delete 2
  622. End Sub
  623. Private Sub bt_Untie_MarkLines_Click()
  624. ModulePlus.Untie_MarkLines
  625. End Sub