Tools.bas 25 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771772773774775776777778779780781782783784785786787788789790791792793794795796797798799800801802803804805806807808809810811812813814815816817818819820821822823824825826827828829
  1. Attribute VB_Name = "Tools"
  2. #If VBA7 Then
  3. Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As LongPtr)
  4. #Else
  5. Private Declare Sub Sleep Lib "kernel32" (ByValdwMilliseconds As Long)
  6. #End If
  7. Public Function wait()
  8. Sleep 3000
  9. End Function
  10. Public Sub 填入居中文字(str)
  11. Dim s As Shape
  12. Dim x As Double, Y As Double, Shift As Long
  13. Dim b As Boolean
  14. b = ActiveDocument.GetUserClick(x, Y, Shift, 10, False, cdrCursorIntersectSingle)
  15. str = VBA.Replace(str, vbNewLine, Chr(10))
  16. str = VBA.Replace(str, Chr(10), vbNewLine)
  17. Set s = ActiveLayer.CreateArtisticText(0, 0, str)
  18. s.CenterX = x
  19. s.CenterY = Y
  20. End Sub
  21. Public Sub 尺寸标注()
  22. ActiveDocument.Unit = cdrMillimeter
  23. Set s = ActiveSelection
  24. x = s.CenterX: Y = s.TopY
  25. sw = s.SizeWidth: sh = s.SizeHeight
  26. text = Int(sw) & "x" & Int(sh) & "mm"
  27. Set s = ActiveLayer.CreateArtisticText(0, 0, text)
  28. s.CenterX = x: s.BottomY = Y + 5
  29. End Sub
  30. Public Sub 批量居中文字(str)
  31. Dim s As Shape, sr As ShapeRange
  32. Set sr = ActiveSelectionRange
  33. For Each s In sr.Shapes
  34. x = s.CenterX: Y = s.CenterY
  35. Set s = ActiveLayer.CreateArtisticText(0, 0, str)
  36. s.CenterX = x: s.CenterY = Y
  37. Next
  38. End Sub
  39. Public Sub 批量标注()
  40. ActiveDocument.Unit = cdrMillimeter
  41. Set sr = ActiveSelectionRange
  42. For Each s In sr.Shapes
  43. x = s.CenterX: Y = s.TopY
  44. sw = s.SizeWidth: sh = s.SizeHeight
  45. text = Int(sw + 0.5) & "x" & Int(sh + 0.5) & "mm"
  46. Set s = ActiveLayer.CreateArtisticText(0, 0, text)
  47. s.CenterX = x: s.BottomY = Y + 5
  48. Next
  49. End Sub
  50. Public Sub 智能群组()
  51. Set s1 = ActiveSelectionRange.CustomCommand("Boundary", "CreateBoundary")
  52. Set brk1 = s1.BreakApartEx
  53. For Each s In brk1
  54. Set sh = ActivePage.SelectShapesFromRectangle(s.LeftX, s.TopY, s.RightX, s.BottomY, True)
  55. sh.Shapes.All.Group
  56. s.Delete
  57. Next
  58. End Sub
  59. ' 实践应用: 选择物件群组,页面设置物件大小,物件页面居中
  60. Public Function 群组居中页面()
  61. ActiveDocument.Unit = cdrMillimeter
  62. Dim OrigSelection As ShapeRange, sh As Shape
  63. Set OrigSelection = ActiveSelectionRange
  64. Set sh = OrigSelection.Group
  65. ' MsgBox "选择物件尺寸: " & sh.SizeWidth & "x" & sh.SizeHeight
  66. ActivePage.SetSize Int(sh.SizeWidth + 0.9), Int(sh.SizeHeight + 0.9)
  67. #If VBA7 Then
  68. ActiveDocument.ClearSelection
  69. sh.AddToSelection
  70. ActiveSelection.AlignAndDistribute 3, 3, 2, 0, False, 2
  71. #Else
  72. sh.AlignToPageCenter cdrAlignHCenter + cdrAlignVCenter
  73. #End If
  74. End Function
  75. Public Function 批量多页居中()
  76. If 0 = ActiveSelectionRange.Count Then Exit Function
  77. On Error GoTo ErrorHandler
  78. ActiveDocument.BeginCommandGroup: Application.Optimization = True
  79. ActiveDocument.Unit = cdrMillimeter
  80. Set sr = ActiveSelectionRange
  81. total = sr.Count
  82. '// 建立多页面
  83. Set doc = ActiveDocument
  84. doc.AddPages (total - 1)
  85. Dim sh As Shape
  86. '// 遍历批量物件,放置物件到页面
  87. For i = 1 To sr.Count
  88. doc.Pages(i).Activate
  89. Set sh = sr.Shapes(i)
  90. ActivePage.SetSize Int(sh.SizeWidth + 0.9), Int(sh.SizeHeight + 0.9)
  91. '// 物件居中页面
  92. #If VBA7 Then
  93. ActiveDocument.ClearSelection
  94. sh.AddToSelection
  95. ActiveSelection.AlignAndDistribute 3, 3, 2, 0, False, 2
  96. #Else
  97. sh.AlignToPageCenter cdrAlignHCenter + cdrAlignVCenter
  98. #End If
  99. Next i
  100. ActiveDocument.EndCommandGroup: Application.Optimization = False
  101. ActiveWindow.Refresh: Application.Refresh
  102. Exit Function
  103. ErrorHandler:
  104. Application.Optimization = False
  105. MsgBox "请先选择一些物件"
  106. On Error Resume Next
  107. End Function
  108. '// 安全线: 点击一次建立辅助线,再调用清除参考线
  109. Public Function guideangle(actnumber As ShapeRange, cardblood As Integer)
  110. Dim sr As ShapeRange
  111. Set sr = ActiveDocument.MasterPage.GuidesLayer.FindShapes(Type:=cdrGuidelineShape)
  112. If sr.Count <> 0 Then
  113. sr.Delete
  114. Exit Function
  115. End If
  116. If 0 = ActiveSelectionRange.Count Then Exit Function
  117. ActiveDocument.Unit = cdrMillimeter
  118. With actnumber
  119. Set s1 = ActiveDocument.MasterPage.GuidesLayer.CreateGuideAngle(0, .TopY - cardblood, 0#)
  120. Set s1 = ActiveDocument.MasterPage.GuidesLayer.CreateGuideAngle(0, .BottomY + cardblood, 0#)
  121. Set s1 = ActiveDocument.MasterPage.GuidesLayer.CreateGuideAngle(.LeftX + cardblood, 0, 90#)
  122. Set s1 = ActiveDocument.MasterPage.GuidesLayer.CreateGuideAngle(.RightX - cardblood, 0, 90#)
  123. End With
  124. End Function
  125. Public Function splash_cnt()
  126. splash.Show 0
  127. splash.text1 = splash.text1 & ">"
  128. Sleep 100
  129. End Function
  130. Public Function vba_cnt()
  131. ' VBA_FORM.text1 = VBA_FORM.text1 & ">"
  132. Sleep 100
  133. End Function
  134. Public Function 按面积排列(space_width As Double)
  135. If 0 = ActiveSelectionRange.Count Then Exit Function
  136. ActiveDocument.Unit = cdrMillimeter
  137. ActiveDocument.ReferencePoint = cdrCenter
  138. Set ssr = ActiveSelectionRange
  139. cnt = 1
  140. #If VBA7 Then
  141. ssr.Sort "@shape1.width * @shape1.height < @shape2.width * @shape2.height"
  142. #Else
  143. ' X4 不支持 ShapeRange.sort
  144. #End If
  145. Dim str As String, size As String
  146. For Each sh In ssr
  147. size = Int(sh.SizeWidth + 0.5) & "x" & Int(sh.SizeHeight + 0.5) & "mm"
  148. sh.SetSize Int(sh.SizeWidth + 0.5), Int(sh.SizeHeight + 0.5)
  149. str = str & size & vbNewLine
  150. Next sh
  151. ActiveDocument.ReferencePoint = cdrTopLeft
  152. For Each s In ssr
  153. If cnt > 1 Then s.SetPosition ssr(cnt - 1).LeftX, ssr(cnt - 1).BottomY - space_width
  154. cnt = cnt + 1
  155. vba_cnt
  156. Next s
  157. ' 写文件,可以EXCEL里统计
  158. ' Set fs = CreateObject("Scripting.FileSystemObject")
  159. ' Set f = fs.CreateTextFile("D:\size.txt", True)
  160. ' f.WriteLine str: f.Close
  161. str = 分类汇总(str)
  162. Debug.Print str
  163. Dim s1 As Shape
  164. ' Set s1 = ActiveLayer.CreateParagraphText(0, 0, 100, 150, Str, Font:="华文中宋")
  165. x = ssr.FirstShape.LeftX - 100
  166. Y = ssr.FirstShape.TopY
  167. Set s1 = ActiveLayer.CreateParagraphText(x, Y, x + 90, Y - 150, str, Font:="华文中宋")
  168. End Function
  169. '// 实现Excel里分类汇总功能
  170. Private Function 分类汇总(str As String) As String
  171. Dim a, b, d, arr
  172. str = VBA.Replace(str, vbNewLine, " ")
  173. Do While InStr(str, " ")
  174. str = VBA.Replace(str, " ", " ")
  175. Loop
  176. arr = Split(str)
  177. Set d = CreateObject("Scripting.dictionary")
  178. For i = 0 To UBound(arr) - 1
  179. If d.Exists(arr(i)) = True Then
  180. d.Item(arr(i)) = d.Item(arr(i)) + 1
  181. Else
  182. d.Add arr(i), 1
  183. End If
  184. Next
  185. str = " 规 格" & vbTab & vbTab & vbTab & "数量" & vbNewLine
  186. a = d.keys: b = d.items
  187. For i = 0 To d.Count - 1
  188. ' Debug.Print a(i), b(i)
  189. str = str & a(i) & vbTab & vbTab & b(i) & "条" & vbNewLine
  190. Next
  191. 分类汇总 = str & "合计总量:" & vbTab & vbTab & vbTab & UBound(arr) & "条" & vbNewLine
  192. End Function
  193. ' 两个端点的坐标,为(x1,y1)和(x2,y2) 那么其角度a的tan值: tana=(y2-y1)/(x2-x1)
  194. ' 所以计算arctan(y2-y1)/(x2-x1), 得到其角度值a
  195. ' VB中用atn(), 返回值是弧度,需要 乘以 PI /180
  196. Private Function lineangle(x1, y1, x2, y2) As Double
  197. pi = 4 * VBA.Atn(1) ' 计算圆周率
  198. If x2 = x1 Then
  199. lineangle = 90: Exit Function
  200. End If
  201. lineangle = VBA.Atn((y2 - y1) / (x2 - x1)) / pi * 180
  202. End Function
  203. Public Function 角度转平()
  204. On Error GoTo ErrorHandler
  205. ' ActiveDocument.ReferencePoint = cdrCenter
  206. Set sr = ActiveSelectionRange
  207. Set nr = sr.LastShape.DisplayCurve.Nodes.All
  208. If nr.Count = 2 Then
  209. x1 = nr.FirstNode.PositionX: y1 = nr.FirstNode.PositionY
  210. x2 = nr.LastNode.PositionX: y2 = nr.LastNode.PositionY
  211. a = lineangle(x1, y1, x2, y2): sr.Rotate -a
  212. ' sr.LastShape.Delete '// 删除参考线
  213. End If
  214. ErrorHandler:
  215. End Function
  216. Public Function 自动旋转角度()
  217. On Error GoTo ErrorHandler
  218. ' ActiveDocument.ReferencePoint = cdrCenter
  219. Set sr = ActiveSelectionRange
  220. Set nr = sr.LastShape.DisplayCurve.Nodes.All
  221. If nr.Count = 2 Then
  222. x1 = nr.FirstNode.PositionX: y1 = nr.FirstNode.PositionY
  223. x2 = nr.LastNode.PositionX: y2 = nr.LastNode.PositionY
  224. a = lineangle(x1, y1, x2, y2): sr.Rotate 90 + a
  225. sr.LastShape.Delete '// 删除参考线
  226. End If
  227. ErrorHandler:
  228. End Function
  229. Public Function 交换对象()
  230. Set sr = ActiveSelectionRange
  231. If sr.Count = 2 Then
  232. x = sr.LastShape.CenterX: Y = sr.LastShape.CenterY
  233. sr.LastShape.CenterX = sr.FirstShape.CenterX: sr.LastShape.CenterY = sr.FirstShape.CenterY
  234. sr.FirstShape.CenterX = x: sr.FirstShape.CenterY = Y
  235. End If
  236. End Function
  237. Public Function 参考线镜像()
  238. On Error GoTo ErrorHandler
  239. Set sr = ActiveSelectionRange
  240. Set nr = sr.LastShape.DisplayCurve.Nodes.All
  241. If nr.Count = 2 Then
  242. ActiveDocument.BeginCommandGroup "Mirror"
  243. byshape = False
  244. x1 = nr.FirstNode.PositionX: y1 = nr.FirstNode.PositionY
  245. x2 = nr.LastNode.PositionX: y2 = nr.LastNode.PositionY
  246. a = lineangle(x1, y1, x2, y2) '// 参考线和水平的夹角 a
  247. sr.Remove sr.Count
  248. ang = 90 - a ' 镜像的旋转角度
  249. For Each s In sr
  250. With s
  251. .Duplicate ' // 复制物件保留,然后按 x1,y1 点 旋转
  252. .RotationCenterX = x1
  253. .RotationCenterY = y1
  254. .Rotate ang
  255. If Not byshape Then
  256. lx = .LeftX
  257. .Stretch -1#, 1# ' // 通过拉伸完成镜像
  258. .LeftX = lx
  259. .Move (x1 - .LeftX) * 2 - .SizeWidth, 0
  260. .RotationCenterX = x1 '// 之前因为镜像,旋转中心点反了,重置回来
  261. .RotationCenterY = y1
  262. .Rotate -ang
  263. End If
  264. .RotationCenterX = .CenterX '// 重置回旋转中心点为物件中心
  265. .RotationCenterY = .CenterY
  266. End With
  267. Next s
  268. ActiveDocument.EndCommandGroup
  269. End If
  270. ErrorHandler:
  271. End Function
  272. Public Function autogroup(Optional Group As String = "group", Optional shft = 0, Optional sss As Shapes = Nothing, Optional undogroup = True) As ShapeRange
  273. Dim sr As ShapeRange, sr_all As ShapeRange, os As ShapeRange
  274. Dim sp As SubPaths
  275. Dim arr()
  276. Dim s As Shape
  277. If sss Is Nothing Then Set os = ActiveSelectionRange Else Set os = sss.All
  278. On Error GoTo errn
  279. ActiveDocument.BeginCommandGroup: Application.Optimization = True
  280. If ActiveSelection.Shapes.Count > 0 Then
  281. gcnt = os.Shapes.Count
  282. ReDim arr(1 To gcnt, 1 To gcnt)
  283. Set sr_all = ActiveSelectionRange
  284. sr_all.RemoveAll
  285. ReDim arr(1 To gcnt, 1 To gcnt)
  286. ActiveDocument.Unit = cdrTenthMicron
  287. sgap = 10
  288. If shft = 2 Or shft = 3 Or shft = 6 Or shft = 7 Then
  289. os.RemoveAll
  290. For Each s In ActiveSelectionRange.Shapes
  291. os.Add ActivePage.SelectShapesFromRectangle(s.LeftX - sgap, s.BottomY - sgap, s.RightX + sgap, s.TopY + sgap, True)
  292. Next s
  293. End If
  294. For i = 1 To os.Shapes.Count
  295. Set s1 = os.Shapes(i)
  296. arr(i, i) = i
  297. For j = 1 To os.Shapes.Count
  298. Set s2 = os.Shapes(j)
  299. If s2.LeftX < s1.RightX + sgap And s2.RightX > s1.LeftX - sgap And s2.BottomY < s1.TopY + sgap And s2.TopY > s1.BottomY - sgap Then
  300. If shft = 1 Or shft = 3 Or shft = 5 Or shft = 7 Then
  301. Set isec = s1.Intersect(s2)
  302. If Not isec Is Nothing Then
  303. arr(i, j) = j
  304. isec.CreateSelection
  305. isec.Delete
  306. End If
  307. Else
  308. arr(i, j) = j
  309. End If
  310. End If
  311. Next j
  312. Next i
  313. For i = 1 To gcnt
  314. arr = collect_arr(arr, i, i)
  315. Next i
  316. Set sr = ActiveSelectionRange
  317. For i = 1 To gcnt
  318. sr.RemoveAll
  319. inar = 0
  320. For j = 1 To gcnt
  321. If arr(i, j) > 0 Then
  322. sr.Add os.Shapes(j)
  323. inar = inar + 1
  324. End If
  325. Next j
  326. If inar > 1 Then
  327. If Group = "group" Then
  328. If shft < 4 Then sr_all.Add sr.Group
  329. End If
  330. Else
  331. If sr.Shapes.Count > 0 Then sr_all.AddRange sr
  332. End If
  333. Next i
  334. Set autogroup = sr_all
  335. End If
  336. ActiveDocument.EndCommandGroup
  337. Application.Optimization = False
  338. ActiveWindow.Refresh: Application.Refresh
  339. Exit Function
  340. errn:
  341. Application.Optimization = False
  342. End Function
  343. Public Function collect_arr(arr, ci, ki)
  344. lim = UBound(arr)
  345. For k = 1 To lim
  346. If arr(ki, k) > 0 Then
  347. arr(ci, k) = k
  348. If ki <> ci Then arr(ki, k) = Empty
  349. If ci <> k And ki <> k Then arr = collect_arr(arr, ci, k)
  350. End If
  351. Next k
  352. 'If ki <> ci Then arr(ki, ki) = Empty
  353. collect_arr = arr
  354. End Function
  355. Sub Make_Sizes()
  356. ActiveDocument.Unit = cdrMillimeter
  357. Set os = ActiveSelectionRange
  358. If os.Count > 0 Then
  359. For Each s In os.Shapes
  360. Set pts = os.FirstShape.SnapPoints.BBox(cdrTopLeft)
  361. Set pte = os.LastShape.SnapPoints.BBox(cdrTopRight)
  362. ActiveLayer.CreateLinearDimension cdrDimensionHorizontal, pts, pte, True, os.LeftX + os.SizeWidth / 10, os.TopY + os.SizeHeight / 10, cdrDimensionStyleEngineering
  363. Set pte = os.LastShape.SnapPoints.BBox(cdrBottomLeft)
  364. ActiveLayer.CreateLinearDimension cdrDimensionVertical, pts, pte, True, os.LeftX - os.SizeWidth / 10, os.BottomY + os.SizeHeight / 10, cdrDimensionStyleEngineering
  365. Next s
  366. End If
  367. End Sub
  368. '''//// 选择多物件,组合然后拆分线段,为角线爬虫准备 ////'''
  369. Public Function Split_Segment()
  370. On Error GoTo ErrorHandler
  371. ActiveDocument.BeginCommandGroup: Application.Optimization = True
  372. Dim ssr As ShapeRange
  373. Set ssr = ActiveSelectionRange
  374. Dim s As Shape
  375. Dim nr As NodeRange
  376. Dim nd As Node
  377. Set s = ssr.UngroupAllEx.Combine
  378. Set nr = s.Curve.Nodes.All
  379. nr.BreakApart
  380. s.BreakApartEx
  381. ' For Each nd In nr
  382. ' nd.BreakApart
  383. ' Next nd
  384. ActiveDocument.EndCommandGroup
  385. Application.Optimization = False
  386. ActiveWindow.Refresh: Application.Refresh
  387. Exit Function
  388. ErrorHandler:
  389. Application.Optimization = False
  390. On Error Resume Next
  391. End Function
  392. '// 修复圆角缺角到直角
  393. Public Sub corner_off()
  394. Dim os As ShapeRange
  395. Dim s As Shape, fir As Shape, ci As Shape
  396. Dim nd As Node, nds As Node, nde As Node
  397. Set os = ActiveSelectionRange
  398. ud = ActiveDocument.Unit
  399. ActiveDocument.Unit = cdrMillimeter
  400. On Error GoTo errn
  401. ActiveDocument.BeginCommandGroup "corners off"
  402. 'Application.Optimization = True
  403. selec = False
  404. If os.Shapes.Count = 1 Then
  405. Set s = os.FirstShape
  406. If Not s.Curve Is Nothing Then
  407. For Each nd In s.Curve.Nodes
  408. If nd.Selected Then
  409. selec = True
  410. Exit For
  411. End If
  412. Next nd
  413. End If
  414. End If
  415. If os.Shapes.Count > 1 Or Not selec Then
  416. os.ConvertToCurves
  417. For Each s In os.Shapes
  418. Set nds = Nothing
  419. Set nde = Nothing
  420. For k = 1 To 3
  421. For i = 1 To s.Curve.Nodes.Count
  422. If i <= s.Curve.Nodes.Count Then
  423. Set nd = s.Curve.Nodes(i)
  424. If Not nd.NextSegment Is Nothing And Not nd.PrevSegment Is Nothing Then
  425. If Abs(nd.PrevSegment.Length - nd.NextSegment.Length) < (nd.PrevSegment.Length + nd.NextSegment.Length) / 30 And nd.PrevSegment.Type = cdrCurveSegment And nd.NextSegment.Type = cdrCurveSegment Then
  426. corner_off_make s, nd.Previous, nd.Next
  427. ElseIf Not nd.Next.NextSegment Is Nothing Then
  428. If (nd.PrevSegment.Type = cdrLineSegment Or Abs(Abs(nd.PrevSegment.StartingControlPointAngle - nd.PrevSegment.EndingControlPointAngle) - 180) < 1) _
  429. And (nd.Next.NextSegment.Type = cdrLineSegment Or Abs(Abs(nd.Next.NextSegment.StartingControlPointAngle - nd.Next.NextSegment.EndingControlPointAngle) - 180) < 1) _
  430. And nd.NextSegment.Type = cdrCurveSegment Then
  431. corner_off_make s, nd, nd.Next
  432. End If
  433. End If
  434. End If
  435. End If
  436. Next i
  437. Next k
  438. Next s
  439. ElseIf os.Shapes.Count = 1 And selec Then
  440. Set nds = Nothing
  441. Set nde = Nothing
  442. For Each nd In s.Curve.Nodes
  443. If Not nd.Selected And Not nd.Next.Selected Then Exit For
  444. Next nd
  445. If Not nd Is s.Curve.Nodes.Last Then
  446. For i = 1 To s.Curve.Nodes.Count
  447. Set nd = nd.Next
  448. If Not nde Is Nothing And Not nds Is Nothing And Not nd.Selected Then Exit For
  449. If Not nds Is Nothing And nd.Selected Then Set nde = nd
  450. If nde Is Nothing And nds Is Nothing And nd.Selected Then Set nds = nd
  451. Next i
  452. If Not nds Is Nothing And Not nde Is Nothing Then
  453. 'ActiveLayer.CreateEllipse2 nds.PositionX, nds.PositionY, nde.PrevSegment.Length / 4
  454. 'ActiveLayer.CreateEllipse2 nde.PositionX, nde.PositionY, nde.PrevSegment.Length / 4
  455. corner_off_make s, nds, nde
  456. End If
  457. End If
  458. End If
  459. errn:
  460. Application.Optimization = False
  461. ActiveDocument.EndCommandGroup
  462. Application.Refresh
  463. ActiveDocument.Unit = ud
  464. End Sub
  465. Private Sub corner_off_make(s As Shape, nds As Node, nde As Node)
  466. Dim l1 As Shape, l2 As Shape
  467. Dim os As ShapeRange
  468. Dim ss As Shape
  469. ud = ActiveDocument.Unit
  470. ActiveDocument.Unit = cdrMillimeter
  471. Set l1 = ActiveLayer.CreateLineSegment(nds.PositionX, nds.PositionY, nds.PositionX + s.SizeWidth * 3, nds.PositionY)
  472. l1.RotationCenterX = nds.PositionX
  473. l1.RotationAngle = nds.PrevSegment.EndingControlPointAngle + 180
  474. Set l2 = ActiveLayer.CreateLineSegment(nde.PositionX, nde.PositionY, nde.PositionX + s.SizeWidth * 3, nde.PositionY)
  475. l2.RotationCenterX = nde.PositionX
  476. l2.RotationAngle = nde.NextSegment.StartingControlPointAngle + 180
  477. Set lcross = l2.Curve.Segments.First.GetIntersections(l1.Curve.Segments.First)
  478. If lcross.Count > 0 Then
  479. cx = lcross(1).PositionX
  480. cy = lcross(1).PositionY
  481. sx = nds.PositionX
  482. sy = nds.PositionY
  483. ex = nde.PositionX
  484. ey = nde.PositionY
  485. l1.Curve.Nodes.Last.PositionX = cx
  486. l1.Curve.Nodes.Last.PositionY = cy
  487. l2.Curve.Nodes.Last.PositionX = cx
  488. l2.Curve.Nodes.Last.PositionY = cy
  489. s.Curve.Nodes.Range(Array(nds.AbsoluteIndex, nde.AbsoluteIndex)).BreakApart
  490. Set os = s.BreakApartEx
  491. oscnt = os.Shapes.Count
  492. For Each ss In os.Shapes
  493. If ss.Curve.Nodes.First.PositionX = ex And ss.Curve.Nodes.First.PositionY = ey Then Set s2 = ss
  494. If ss.Curve.Nodes.Last.PositionX = sx And ss.Curve.Nodes.Last.PositionY = sy Then Set s1 = ss
  495. If ss.Curve.Nodes.First.PositionX = sx And ss.Curve.Nodes.First.PositionY = sy Then ss.Delete
  496. Next ss
  497. If s1.Curve.Segments.Last.Type = cdrLineSegment Or Abs(Abs(s1.Curve.Segments.Last.StartingControlPointAngle - s1.Curve.Segments.Last.EndingControlPointAngle) - 180) < 1 Then
  498. s1.Curve.Nodes.Last.PositionX = lcross(1).PositionX
  499. s1.Curve.Nodes.Last.PositionY = lcross(1).PositionY
  500. l1.Delete
  501. Else
  502. Set s1 = l1.Weld(s1)
  503. End If
  504. If oscnt = 2 Then Set s2 = s1
  505. If s2.Curve.Segments.First.Type = cdrLineSegment Or Abs(Abs(s2.Curve.Segments.First.StartingControlPointAngle - s2.Curve.Segments.First.EndingControlPointAngle) - 180) < 1 Then
  506. s2.Curve.Nodes.First.PositionX = lcross(1).PositionX
  507. s2.Curve.Nodes.First.PositionY = lcross(1).PositionY
  508. l2.Delete
  509. Else
  510. Set s2 = l2.Weld(s2)
  511. End If
  512. If oscnt > 2 Then Set s2 = s1.Weld(s2)
  513. s2.CustomCommand "ConvertTo", "JoinCurves", 0.1
  514. Set s = s2
  515. Else
  516. l1.Delete
  517. l2.Delete
  518. End If
  519. ActiveDocument.Unit = ud
  520. End Sub
  521. Sub ExportNodePositions()
  522. Dim s As Shape, n As Node
  523. Dim srActiveLayer As ShapeRange
  524. Dim x As Double, Y As Double
  525. Dim strNodePositions As String
  526. ActiveDocument.Unit = cdrMillimeter
  527. 'Get all the curve shapes on the Active Layer
  528. '获取Active Layer上的所有曲线形状
  529. Set srActiveLayer = ActiveLayer.Shapes.FindShapes(Query:="@type='curve'")
  530. 'This is another way you can get only the curve shapes
  531. '这是另一种你只能得到曲线形状的方法
  532. 'Set srActiveLayer = ActiveLayer.Shapes.FindShapes.FindAnyOfType(cdrCurveShape)
  533. 'Loop through each curve
  534. '遍历每条曲线
  535. For Each s In srActiveLayer.Shapes
  536. 'Loop though each node in the curve and get the position
  537. '遍历曲线中的每个节点并获取位置
  538. For Each n In s.Curve.Nodes
  539. n.GetPosition x, Y
  540. strNodePositions = strNodePositions & "x: " & x & " y: " & Y & vbCrLf
  541. Next n
  542. Next s
  543. 'Save the node positions to a file
  544. '将节点位置保存到文件
  545. Open "C:\Temp\NodePositions.txt" For Output As #1
  546. Print #1, strNodePositions
  547. Close #1
  548. End Sub
  549. Sub 服务器T()
  550. Dim mark As Shape
  551. Dim sr As ShapeRange
  552. Set sr = ActiveSelectionRange
  553. If (Shift And 1) <> 0 Then ActivePage.Shapes.FindShapes(Query:="@type ='rectangle'or @type ='curve'or @type ='Ellipse'or @type ='Polygon'").CreateSelection
  554. sr.Shapes.FindShapes(Query:="@type ='rectangle'or @type ='curve'or @type ='Ellipse'or @type ='Polygon'").ConvertToCurves
  555. If sr.Count = 0 Then Exit Sub
  556. ' CorelDRAW设置原点标记导出DXF使用
  557. ' 更新原点标记,现在能设置任意坐标点
  558. Dim MarkPos_Array() As Double
  559. MarkPos_Array = Get_MarkPosition
  560. AtOrigin MarkPos_Array(0), MarkPos_Array(1)
  561. sr.Add ActiveDocument.ActiveShape
  562. Set mark = ActiveDocument.ActiveShape
  563. ActiveDocument.ClearSelection
  564. sr.CreateSelection
  565. ' Set mark = ActiveDocument.ActiveShape
  566. ' If FileExists("d:\mytempdxf.dxf") Then
  567. ' DeleteFile "d:\mytempdxf.dxf"
  568. ' End If
  569. SaveDXF "d:\mytempdxf.dxf"
  570. ' Do While FileExists("d:\mytempdxf.dxf") = False
  571. ' DoEvents
  572. ' Delay 1
  573. ' Loop
  574. Shell Application.GMSManager.GMSPath & "tuznr.exe d:/mytempdxf.dxf", 1
  575. mark.Delete
  576. End Sub
  577. Sub SaveDXF(FileName As String)
  578. Dim expopt As StructExportOptions
  579. Set expopt = CreateStructExportOptions
  580. expopt.UseColorProfile = False
  581. Dim expflt As ExportFilter
  582. Set expflt = ActiveDocument.ExportEx(FileName, cdrDXF, cdrSelection, expopt)
  583. With expflt
  584. .BitmapType = 0 ' FilterDXFLib.dxfBitmapJPEG
  585. .TextAsCurves = True
  586. .Version = 3 ' FilterDXFLib.dxfVersion13
  587. .Units = 3 ' FilterDXFLib.dxfMillimeters
  588. .FillUnmapped = True
  589. .Finish
  590. End With
  591. End Sub
  592. ' 更新原点标记函数,现在能设置任意坐标点
  593. Sub AtOrigin(Optional px As Double = 0#, Optional py As Double = 0#)
  594. Dim doc As Document: Set doc = ActiveDocument
  595. doc.Unit = cdrMillimeter
  596. '// 导入原点标记标记文件 OriginMark.cdr 解散群组
  597. doc.ActiveLayer.Import path & "GMS\OriginMark.cdr"
  598. doc.ReferencePoint = cdrCenter
  599. doc.Selection.Ungroup
  600. Dim sh As Shape, shs As Shapes
  601. Set shs = ActiveSelection.Shapes
  602. '// 按 MarkName 名称查找 标记物件
  603. For Each sh In shs
  604. If "AtOrigin" = sh.ObjectData("MarkName").Value Then
  605. sh.SetPosition px, py
  606. Else
  607. sh.Delete ' 不需要的标记删除
  608. End If
  609. Next sh
  610. End Sub
  611. ' 使用 GlobalUserData 对象保存 Mark标记坐标文本,调用函数能设置文本
  612. Public Function Mark_SetPosition() As String
  613. Dim text As String
  614. If GlobalUserData.Exists("MarkPosition", 1) Then
  615. text = GlobalUserData("MarkPosition", 1)
  616. End If
  617. text = InputBox("请输入Mark标记坐标(x,y),空格或逗号间隔", "设置Mark标记坐标(x,y),单位(mm)", text)
  618. If text = "" Then Exit Function
  619. GlobalUserData("MarkPosition", 1) = text
  620. Mark_SetPosition = text
  621. End Function
  622. ' 调用设置Mark标记坐标功能,返回 数组(x,y)
  623. Public Function Get_MarkPosition() As Double()
  624. Dim MarkPos_Array(0 To 1) As Double
  625. Dim str, arr
  626. str = Mark_SetPosition
  627. ' 替换 逗号 为空格
  628. str = VBA.Replace(str, ",", " ")
  629. Do While InStr(str, " ") '多个空格换成一个空格
  630. str = VBA.Replace(str, " ", " ")
  631. Loop
  632. arr = Split(str)
  633. MarkPos_Array(0) = Val(arr(0))
  634. MarkPos_Array(1) = Val(arr(1))
  635. Debug.Print MarkPos_Array(0), MarkPos_Array(1) ' 视图->立即窗口,调试显示
  636. Get_MarkPosition = MarkPos_Array
  637. End Function
  638. Public Function SetNames()
  639. Dim ssr As ShapeRange
  640. Set ssr = ActiveSelectionRange
  641. #If VBA7 Then
  642. ssr.Sort " @shape1.left<@shape2.left"
  643. #Else
  644. ' X4 不支持 ShapeRange.sort
  645. #End If
  646. Dim text As String
  647. Dim lines() As String
  648. ' 提取文本信息,切割文本
  649. If ssr(1).Type = cdrTextShape Then
  650. If ssr(1).text.Type = cdrArtistic Then
  651. text = ssr(1).text.Story.text
  652. lines = Split(text, vbCr)
  653. ssr.Remove 1
  654. #If VBA7 Then
  655. ssr.Sort " @shape1.top>@shape2.top"
  656. #Else
  657. ' X4 不支持 ShapeRange.sort
  658. #End If
  659. End If
  660. Else
  661. MsgBox "请把多行文本放最左边"
  662. Exit Function
  663. End If
  664. ' Debug.Print ssr.Count, UBound(lines), LBound(lines)
  665. ' 给物件设置名称,用处:批量导出可以有一个名称
  666. i = 0
  667. If ssr.Count <= UBound(lines) + 1 Then
  668. For Each s In ssr
  669. s.name = lines(i)
  670. i = i + 1
  671. Next s
  672. End If
  673. If ssr.Count <> UBound(lines) + 1 Then MsgBox "文本行:" & (UBound(lines) + 1) & vbNewLine & "右边物件:" & ssr.Count
  674. End Function
  675. Sub Nodes_TO_TSP()
  676. Set fs = CreateObject("Scripting.FileSystemObject")
  677. Set f = fs.CreateTextFile("C:\TSP\CDR_TO_TSP", True)
  678. ActiveDocument.Unit = cdrMillimeter
  679. Dim s As Shape, ssr As ShapeRange
  680. Set ssr = ActiveSelectionRange
  681. Dim TSP As String
  682. TSP = (ssr.Count * 4) & " " & 0 & vbNewLine
  683. For Each s In ssr
  684. lx = s.LeftX: rx = s.RightX
  685. By = s.BottomY: ty = s.TopY
  686. TSP = TSP & lx & " " & By & vbNewLine
  687. TSP = TSP & lx & " " & ty & vbNewLine
  688. TSP = TSP & rx & " " & By & vbNewLine
  689. TSP = TSP & rx & " " & ty & vbNewLine
  690. Next s
  691. f.WriteLine TSP
  692. f.Close
  693. End Sub