1
1

Tools.bas 33 KB

1234567891011121314151617181920212223242526272829303132333435363738394041424344454647484950515253545556575859606162636465666768697071727374757677787980818283848586878889909192939495969798991001011021031041051061071081091101111121131141151161171181191201211221231241251261271281291301311321331341351361371381391401411421431441451461471481491501511521531541551561571581591601611621631641651661671681691701711721731741751761771781791801811821831841851861871881891901911921931941951961971981992002012022032042052062072082092102112122132142152162172182192202212222232242252262272282292302312322332342352362372382392402412422432442452462472482492502512522532542552562572582592602612622632642652662672682692702712722732742752762772782792802812822832842852862872882892902912922932942952962972982993003013023033043053063073083093103113123133143153163173183193203213223233243253263273283293303313323333343353363373383393403413423433443453463473483493503513523533543553563573583593603613623633643653663673683693703713723733743753763773783793803813823833843853863873883893903913923933943953963973983994004014024034044054064074084094104114124134144154164174184194204214224234244254264274284294304314324334344354364374384394404414424434444454464474484494504514524534544554564574584594604614624634644654664674684694704714724734744754764774784794804814824834844854864874884894904914924934944954964974984995005015025035045055065075085095105115125135145155165175185195205215225235245255265275285295305315325335345355365375385395405415425435445455465475485495505515525535545555565575585595605615625635645655665675685695705715725735745755765775785795805815825835845855865875885895905915925935945955965975985996006016026036046056066076086096106116126136146156166176186196206216226236246256266276286296306316326336346356366376386396406416426436446456466476486496506516526536546556566576586596606616626636646656666676686696706716726736746756766776786796806816826836846856866876886896906916926936946956966976986997007017027037047057067077087097107117127137147157167177187197207217227237247257267277287297307317327337347357367377387397407417427437447457467477487497507517527537547557567577587597607617627637647657667677687697707717727737747757767777787797807817827837847857867877887897907917927937947957967977987998008018028038048058068078088098108118128138148158168178188198208218228238248258268278288298308318328338348358368378388398408418428438448458468478488498508518528538548558568578588598608618628638648658668678688698708718728738748758768778788798808818828838848858868878888898908918928938948958968978988999009019029039049059069079089099109119129139149159169179189199209219229239249259269279289299309319329339349359369379389399409419429439449459469479489499509519529539549559569579589599609619629639649659669679689699709719729739749759769779789799809819829839849859869879889899909919929939949959969979989991000100110021003100410051006100710081009101010111012101310141015101610171018101910201021102210231024102510261027102810291030103110321033103410351036103710381039104010411042104310441045104610471048104910501051105210531054105510561057105810591060106110621063106410651066106710681069107010711072107310741075107610771078107910801081108210831084108510861087108810891090109110921093109410951096109710981099110011011102110311041105110611071108110911101111111211131114111511161117111811191120112111221123112411251126112711281129113011311132113311341135113611371138113911401141114211431144114511461147114811491150115111521153115411551156115711581159116011611162116311641165116611671168116911701171117211731174117511761177117811791180118111821183118411851186
  1. Attribute VB_Name = "Tools"
  2. '// This is free and unencumbered software released into the public domain.
  3. '// For more information, please refer to https://github.com/hongwenjun
  4. '// 简易火车排列
  5. Public Function Simple_Train_Arrangement(Space_Width As Double)
  6. API.BeginOpt
  7. Dim ssr As ShapeRange, s As Shape
  8. Dim cnt As Integer
  9. Set ssr = ActiveSelectionRange
  10. cnt = 1
  11. #If VBA7 Then
  12. ' ssr.sort " @shape1.top>@shape2.top"
  13. ssr.Sort " @shape1.left<@shape2.left"
  14. #Else
  15. ' X4 不支持 ShapeRange.sort 使用 lyvba32.dll 算法库排序 2023.07.08
  16. Set ssr = X4_Sort_ShapeRange(ssr, stlx)
  17. #End If
  18. ActiveDocument.ReferencePoint = cdrTopLeft
  19. For Each s In ssr
  20. '// 底对齐 If cnt > 1 Then s.SetPosition ssr(cnt - 1).RightX, ssr(cnt - 1).BottomY
  21. '// 改成顶对齐 2022-08-10
  22. ActiveDocument.ReferencePoint = cdrTopLeft + cdrBottomTop
  23. If cnt > 1 Then s.SetPosition ssr(cnt - 1).RightX + Space_Width, ssr(cnt - 1).TopY
  24. cnt = cnt + 1
  25. Next s
  26. API.EndOpt
  27. End Function
  28. '// 简易阶梯排列
  29. Public Function Simple_Ladder_Arrangement(Space_Width As Double)
  30. API.BeginOpt
  31. Dim ssr As ShapeRange, s As Shape
  32. Dim cnt As Integer
  33. Set ssr = ActiveSelectionRange
  34. cnt = 1
  35. #If VBA7 Then
  36. ssr.Sort " @shape1.top>@shape2.top"
  37. #Else
  38. ' X4 不支持 ShapeRange.sort 使用 lyvba32.dll 算法库排序 2023.07.08
  39. Set ssr = X4_Sort_ShapeRange(ssr, stty).ReverseRange
  40. #End If
  41. ActiveDocument.ReferencePoint = cdrTopLeft
  42. For Each s In ssr
  43. If cnt > 1 Then s.SetPosition ssr(cnt - 1).LeftX, ssr(cnt - 1).BottomY - Space_Width
  44. cnt = cnt + 1
  45. Next s
  46. API.EndOpt
  47. End Function
  48. '// 文本转曲线 默认使用简单转曲,参数 all=1 ,支持框选和图框剪裁内的文本
  49. Public Function TextShape_ConvertToCurves(Optional all = 0)
  50. API.BeginOpt
  51. On Error GoTo ErrorHandler
  52. Dim s As Shape, cnt As Long
  53. If all = 1 Then
  54. For Each s In API.FindAllShapes.Shapes.FindShapes(, cdrTextShape)
  55. s.ConvertToCurves
  56. cnt = cnt + 1
  57. Next s
  58. Else
  59. For Each s In ActivePage.FindShapes(, cdrTextShape)
  60. s.ConvertToCurves
  61. cnt = cnt + 1
  62. Next s
  63. End If
  64. ErrorHandler:
  65. API.EndOpt
  66. End Function
  67. '// 复制物件
  68. Public Function copy_shape()
  69. Dim OrigSelection As ShapeRange
  70. Set OrigSelection = ActiveSelectionRange
  71. OrigSelection.Copy
  72. End Function
  73. '// 旋转物件角度
  74. Public Function Rotate_Shapes(n As Double)
  75. API.BeginOpt
  76. Dim sh As Shape, shs As Shapes
  77. Set shs = ActiveSelection.Shapes
  78. Dim s As String, size As String
  79. For Each sh In shs
  80. sh.Rotate n
  81. Next sh
  82. API.EndOpt
  83. End Function
  84. '// 得到物件尺寸
  85. Public Function get_shape_size(ByRef sx As Double, ByRef sy As Double)
  86. ActiveDocument.Unit = cdrMillimeter
  87. Dim sh As ShapeRange
  88. Set sh = ActiveSelectionRange
  89. sx = sh.SizeWidth
  90. sy = sh.SizeHeight
  91. sx = Int(sx * 100 + 0.5) / 100
  92. sy = Int(sy * 100 + 0.5) / 100
  93. End Function
  94. '// 批量设置物件尺寸
  95. Public Function Set_Shapes_size(ByRef sx As Double, ByRef sy As Double)
  96. API.BeginOpt
  97. ActiveDocument.ReferencePoint = cdrCenter
  98. Dim sh As Shape, shs As Shapes
  99. Set shs = ActiveSelection.Shapes
  100. Dim s As String, size As String
  101. For Each sh In shs
  102. sh.SizeWidth = sx
  103. sh.SizeHeight = sy
  104. Next sh
  105. API.EndOpt
  106. End Function
  107. '// 批量设置物件尺寸整数
  108. Public Function Size_to_Integer()
  109. If 0 = ActiveSelectionRange.Count Then Exit Function
  110. API.BeginOpt
  111. '// 修改变形尺寸基准
  112. ActiveDocument.ReferencePoint = cdrCenter
  113. Dim sh As Shape, shs As Shapes
  114. Set shs = ActiveSelection.Shapes
  115. Dim s As String, size As String
  116. For Each sh In shs
  117. size = Int(sh.SizeWidth + 0.5) & "x" & Int(sh.SizeHeight + 0.5) & "mm"
  118. sh.SetSize Int(sh.SizeWidth + 0.5), Int(sh.SizeHeight + 0.5)
  119. s = s & size & vbNewLine
  120. Next sh
  121. API.WriteClipBoard s
  122. API.EndOpt
  123. MsgBox "Object Size Information To Clipboard:" & vbNewLine & s & vbNewLine
  124. End Function
  125. '// 设置物件页面居中
  126. Public Function Align_Page_Center()
  127. If 0 = ActiveSelectionRange.Count Then Exit Function
  128. '// 实践应用: 选择物件群组,页面设置物件大小,物件页面居中
  129. API.BeginOpt
  130. Dim OrigSelection As ShapeRange, sh As Shape
  131. Set OrigSelection = ActiveSelectionRange
  132. Set sh = OrigSelection.Group
  133. ActivePage.SetSize Int(sh.SizeWidth + 0.9), Int(sh.SizeHeight + 0.9)
  134. #If VBA7 Then
  135. ActiveDocument.ClearSelection
  136. sh.AddToSelection
  137. ActiveSelection.AlignAndDistribute 3, 3, 2, 0, False, 2
  138. #Else
  139. sh.AlignToPageCenter cdrAlignHCenter + cdrAlignVCenter
  140. #End If
  141. API.EndOpt
  142. End Function
  143. '''/// 使用Python脚本 整理尺寸 提取条码数字 建立二维码 位图转文本 ///'''
  144. Public Function Python_Organize_Size()
  145. On Error GoTo ErrorHandler
  146. mypy = path & "GMS\LYVBA\Organize_Size.py"
  147. cmd_line = "pythonw " & Chr(34) & mypy & Chr(34)
  148. Shell cmd_line
  149. ErrorHandler:
  150. End Function
  151. Public Function Python_Get_Barcode_Number()
  152. On Error GoTo ErrorHandler
  153. mypy = path & "GMS\LYVBA\Get_Barcode_Number.py"
  154. cmd_line = "pythonw " & Chr(34) & mypy & Chr(34)
  155. Shell cmd_line
  156. ErrorHandler:
  157. End Function
  158. Public Function Python_BITMAP()
  159. On Error GoTo ErrorHandler
  160. mypy = path & "GMS\LYVBA\BITMAP.py"
  161. cmd_line = "pythonw " & Chr(34) & mypy & Chr(34)
  162. Shell cmd_line
  163. ErrorHandler:
  164. End Function
  165. Public Function Python_BITMAP2()
  166. On Error GoTo ErrorHandler
  167. Bitmap = "C:\TSP\BITMAP.exe"
  168. Shell Bitmap
  169. ErrorHandler:
  170. End Function
  171. Public Function Python_Make_QRCode()
  172. On Error GoTo ErrorHandler
  173. mypy = path & "GMS\LYVBA\Make_QRCode.py"
  174. cmd_line = "pythonw " & Chr(34) & mypy & Chr(34)
  175. Shell cmd_line
  176. ErrorHandler:
  177. End Function
  178. '// QRCode二维码制作
  179. Public Function QRCode_replace()
  180. On Error GoTo ErrorHandler
  181. API.BeginOpt
  182. Dim image_path As String
  183. image_path = API.GetClipBoardString
  184. ActiveDocument.ReferencePoint = cdrCenter
  185. Dim sh As Shape, shs As Shapes, cs As Shape
  186. Dim X As Double, Y As Double
  187. Set shs = ActiveSelection.Shapes
  188. cnt = 0
  189. For Each sh In shs
  190. If cnt = 0 Then
  191. ActiveDocument.ClearSelection
  192. ActiveLayer.Import image_path
  193. Set sc = ActiveSelection
  194. cnt = 1
  195. Else
  196. sc.Duplicate 0, 0
  197. End If
  198. sh.GetPosition X, Y
  199. sc.SetPosition X, Y
  200. sh.GetSize X, Y
  201. sc.SetSize X, Y
  202. sh.Delete
  203. Next sh
  204. ErrorHandler:
  205. API.EndOpt
  206. End Function
  207. '// QRCode二维码转矢量图
  208. Public Function QRCode_to_Vector()
  209. On Error GoTo ErrorHandler
  210. Set sr = ActiveSelectionRange
  211. With sr(1).Bitmap.Trace(cdrTraceHighQualityImage)
  212. .TraceType = cdrTraceHighQualityImage
  213. .Smoothing = 50 '数值小则平滑,数值大则细节多
  214. .RemoveBackground = False
  215. .DeleteOriginalObject = True
  216. .Finish
  217. End With
  218. Exit Function
  219. ErrorHandler:
  220. On Error Resume Next
  221. End Function
  222. '''//// 选择多物件,组合然后拆分线段,为角线爬虫准备 ////'''
  223. Public Function Split_Segment()
  224. On Error GoTo ErrorHandler
  225. API.BeginOpt
  226. Dim ssr As ShapeRange, s As Shape
  227. Dim nr As NodeRange, nd As Node
  228. Set ssr = ActiveSelectionRange
  229. Set s = ssr.UngroupAllEx.Combine
  230. Set nr = s.Curve.Nodes.all
  231. nr.BreakApart
  232. s.BreakApartEx
  233. ' For Each nd In nr
  234. ' nd.BreakApart
  235. ' Next nd
  236. ErrorHandler:
  237. API.EndOpt
  238. End Function
  239. '''//// 标记画框 支持容差 ////'''
  240. Public Function Mark_CreateRectangle(expand As Boolean)
  241. On Error GoTo ErrorHandler
  242. API.BeginOpt
  243. ActiveDocument.ReferencePoint = cdrBottomLeft
  244. Dim ssr As ShapeRange
  245. Dim sh As Shape, tr As Double
  246. Set ssr = ActiveSelectionRange
  247. tr = 0
  248. If GlobalUserData.Exists("Tolerance", 1) Then
  249. tr = Val(GlobalUserData("Tolerance", 1))
  250. End If
  251. For Each sh In ssr
  252. If expand = False Then
  253. mark_shape sh
  254. Else
  255. mark_shape_expand sh, tr
  256. End If
  257. Next sh
  258. ErrorHandler:
  259. API.EndOpt
  260. End Function
  261. Private Function mark_shape_expand(sh As Shape, tr As Double)
  262. Dim s As Shape
  263. Dim X As Double, Y As Double, w As Double, h As Double, r As Double
  264. sh.GetBoundingBox X, Y, w, h
  265. X = X - tr: Y = Y - tr: w = w + 2 * tr: h = h + 2 * tr
  266. r = Max(w, h) / Min(w, h) / 30 * Math.Sqr(w * h)
  267. If w < h Then
  268. Set s = ActiveLayer.CreateRectangle2(X - r, Y, w + 2 * r, h)
  269. Else
  270. Set s = ActiveLayer.CreateRectangle2(X, Y - r, w, h + 2 * r)
  271. End If
  272. s.Outline.SetProperties Color:=CreateRGBColor(0, 255, 0)
  273. End Function
  274. Private Function mark_shape(sh As Shape)
  275. Dim s As Shape
  276. Dim X As Double, Y As Double, w As Double, h As Double
  277. sh.GetBoundingBox X, Y, w, h, True
  278. Set s = ActiveLayer.CreateRectangle2(X, Y, w, h)
  279. s.Outline.SetProperties Color:=CreateRGBColor(0, 255, 0)
  280. End Function
  281. Private Function Max(ByVal a, ByVal b)
  282. If a < b Then
  283. a = b
  284. End If
  285. Max = a
  286. End Function
  287. Private Function Min(ByVal a, ByVal b)
  288. If a > b Then
  289. a = b
  290. End If
  291. Min = a
  292. End Function
  293. '''//// 批量组合合并 ////'''
  294. Public Function Batch_Combine()
  295. On Error GoTo ErrorHandler
  296. API.BeginOpt
  297. Dim ssr As ShapeRange, sh As Shape
  298. Set ssr = ActiveSelectionRange
  299. For Each sh In ssr
  300. sh.UngroupAllEx.Combine
  301. Next sh
  302. ErrorHandler:
  303. API.EndOpt
  304. End Function
  305. '''//// 一键拆开多行组合的文字字符 ////''' ''' 本功能由群友半缘君赞助发行 '''
  306. Public Function Take_Apart_Character()
  307. On Error GoTo ErrorHandler
  308. API.BeginOpt
  309. ActiveDocument.ReferencePoint = cdrBottomLeft
  310. Dim ssr As ShapeRange
  311. Dim s1 As Shape, sh As Shape, s As Shape
  312. Dim tr As Double
  313. Set ssr = ActiveSelectionRange
  314. '// 记忆选择范围
  315. Dim X As Double, Y As Double, w As Double, h As Double
  316. ssr.GetBoundingBox X, Y, w, h
  317. Set s1 = ActiveLayer.CreateRectangle2(X, Y, w, h)
  318. '// 解散群组,先组合,再散开
  319. Set s = ssr.UngroupAllEx.Combine
  320. Set ssr = s.BreakApartEx
  321. '// 读取容差值
  322. tr = 0
  323. If GlobalUserData.Exists("Tolerance", 1) Then
  324. tr = Val(GlobalUserData("Tolerance", 1))
  325. End If
  326. '// 标记画框,选择标记框
  327. For Each sh In ssr
  328. mark_shape_expand sh, tr
  329. Next sh
  330. Set ssr = ActivePage.Shapes.FindShapes(Query:="@colors.find(RGB(0, 255, 0))")
  331. ActiveDocument.ClearSelection
  332. ssr.AddToSelection
  333. '// 调用 智能群组 后删除标记画框
  334. SmartGroup.Smart_Group
  335. ActiveDocument.BeginCommandGroup: Application.Optimization = True
  336. ssr.Delete
  337. Set sh = ActivePage.SelectShapesFromRectangle(s1.LeftX, s1.TopY, s1.RightX, s1.BottomY, False)
  338. ' sh.Shapes.All.Group
  339. s1.Delete
  340. '// 通过s1矩形范围选择群组后合并组合
  341. For Each s In sh.Shapes
  342. s.UngroupAllEx.Combine
  343. Next s
  344. ErrorHandler:
  345. API.EndOpt
  346. End Function
  347. '''//// 简单一刀切 识别群组 ////''' ''' 本功能由群友宏瑞广告赞助发行 '''
  348. Public Function Single_Line()
  349. If 0 = ActiveSelectionRange.Count Then Exit Function
  350. On Error GoTo ErrorHandler
  351. API.BeginOpt
  352. Dim cm(2) As Color
  353. Set cm(0) = CreateRGBColor(0, 255, 0) ' RGB 绿
  354. Set cm(1) = CreateRGBColor(255, 0, 0) ' RGB 红
  355. Dim ssr As ShapeRange
  356. Dim SrNew As New ShapeRange
  357. Dim s As Shape, s1 As Shape, line As Shape, line2 As Shape
  358. Dim cnt As Integer
  359. cnt = 1
  360. If 1 = ActiveSelectionRange.Count Then
  361. Set ssr = ActiveSelectionRange(1).UngroupAllEx
  362. Else
  363. Set ssr = ActiveSelectionRange
  364. End If
  365. '// 记忆选择范围
  366. Dim X As Double, Y As Double, w As Double, h As Double
  367. ssr.GetBoundingBox X, Y, w, h
  368. Set s1 = ActiveLayer.CreateRectangle2(X, Y, w, h)
  369. s1.Outline.SetProperties Color:=cm(0)
  370. SrNew.Add s1
  371. #If VBA7 Then
  372. ' ssr.sort " @shape1.top>@shape2.top"
  373. ssr.Sort " @shape1.left<@shape2.left"
  374. #Else
  375. ' X4 不支持 ShapeRange.sort
  376. #End If
  377. '// 相交 Set line2 = line.Intersect(s, True, True)
  378. '// 判断相交 line.Curve.IntersectsWith(s.Curve)
  379. For Each s In ssr
  380. If cnt > 1 Then
  381. s.ConvertToCurves
  382. Set line = ActiveLayer.CreateLineSegment(s.LeftX, s.TopY, s.LeftX, s.TopY - s.SizeHeight)
  383. line.Outline.SetProperties Color:=cm(1)
  384. SrNew.Add line
  385. End If
  386. cnt = cnt + 1
  387. Next s
  388. SrNew.Group
  389. ErrorHandler:
  390. API.EndOpt
  391. End Function
  392. Public Function Single_Line_Vertical()
  393. If 0 = ActiveSelectionRange.Count Then Exit Function
  394. On Error GoTo ErrorHandler
  395. API.BeginOpt
  396. Dim cm(2) As Color
  397. Set cm(0) = CreateRGBColor(0, 255, 0) ' RGB 绿
  398. Set cm(1) = CreateRGBColor(255, 0, 0) ' RGB 红
  399. Dim ssr As ShapeRange
  400. Dim SrNew As New ShapeRange
  401. Dim s As Shape, s1 As Shape, line As Shape, line2 As Shape
  402. Dim cnt As Integer
  403. cnt = 1
  404. If 1 = ActiveSelectionRange.Count Then
  405. Set ssr = ActiveSelectionRange(1).UngroupAllEx
  406. Else
  407. Set ssr = ActiveSelectionRange
  408. End If
  409. '// 记忆选择范围
  410. Dim X As Double, Y As Double, w As Double, h As Double
  411. ssr.GetBoundingBox X, Y, w, h
  412. Set s1 = ActiveLayer.CreateRectangle2(X, Y, w, h)
  413. s1.Outline.SetProperties Color:=cm(0)
  414. SrNew.Add s1
  415. #If VBA7 Then
  416. ssr.Sort " @shape1.top>@shape2.top"
  417. #Else
  418. ' X4 不支持 ShapeRange.sort
  419. #End If
  420. For Each s In ssr
  421. If cnt > 1 Then
  422. s.ConvertToCurves
  423. Set line = ActiveLayer.CreateLineSegment(s.LeftX, s.TopY, s.RightX, s.TopY)
  424. line.Outline.SetProperties Color:=cm(1)
  425. SrNew.Add line
  426. End If
  427. cnt = cnt + 1
  428. Next s
  429. SrNew.Group
  430. ErrorHandler:
  431. API.EndOpt
  432. End Function
  433. Public Function Single_Line_LastNode()
  434. If 0 = ActiveSelectionRange.Count Then Exit Function
  435. On Error GoTo ErrorHandler
  436. API.BeginOpt
  437. Dim cm(2) As Color
  438. Set cm(0) = CreateRGBColor(0, 255, 0) ' RGB 绿
  439. Set cm(1) = CreateRGBColor(255, 0, 0) ' RGB 红
  440. Dim ssr As ShapeRange
  441. Dim SrNew As New ShapeRange
  442. Dim s As Shape, s1 As Shape, line As Shape, line2 As Shape
  443. Dim cnt As Integer
  444. cnt = 1
  445. If 1 = ActiveSelectionRange.Count Then
  446. Set ssr = ActiveSelectionRange(1).UngroupAllEx
  447. Else
  448. Set ssr = ActiveSelectionRange
  449. End If
  450. ' 记忆选择范围
  451. Dim X As Double, Y As Double, w As Double, h As Double
  452. ssr.GetBoundingBox X, Y, w, h
  453. Set s1 = ActiveLayer.CreateRectangle2(X, Y, w, h)
  454. s1.Outline.SetProperties Color:=cm(0)
  455. SrNew.Add s1
  456. #If VBA7 Then
  457. ssr.Sort " @shape1.left<@shape2.left"
  458. #Else
  459. ' X4 不支持 ShapeRange.sort
  460. #End If
  461. Dim nr As NodeRange
  462. For Each s In ssr
  463. If cnt > 1 Then
  464. Set nr = s.DisplayCurve.Nodes.all
  465. Set line = ActiveLayer.CreateLineSegment(nr.FirstNode.PositionX, nr.FirstNode.PositionY, nr.LastNode.PositionX, nr.LastNode.PositionY)
  466. line.Outline.SetProperties Color:=cm(1)
  467. SrNew.Add line
  468. End If
  469. cnt = cnt + 1
  470. Next s
  471. SrNew.Group
  472. ErrorHandler:
  473. API.EndOpt
  474. End Function
  475. '''//// 选择范围画框 ////'''
  476. Public Function Mark_Range_Box()
  477. If 0 = ActiveSelectionRange.Count Then Exit Function
  478. ActiveDocument.Unit = cdrMillimeter
  479. Dim s1 As Shape, ssr As ShapeRange
  480. Set ssr = ActiveSelectionRange
  481. Dim X As Double, Y As Double, w As Double, h As Double
  482. ssr.GetBoundingBox X, Y, w, h
  483. Set s1 = ActiveLayer.CreateRectangle2(X, Y, w, h)
  484. s1.Outline.SetProperties Color:=CreateRGBColor(0, 255, 0) '// RGB 绿
  485. End Function
  486. '''//// 快速颜色选择 ////'''
  487. Function quickColorSelect()
  488. Dim X As Double, Y As Double
  489. Dim s As Shape, s1 As Shape
  490. Dim sr As ShapeRange, sr2 As ShapeRange
  491. Dim Shift As Long, bClick As Boolean
  492. Dim c As New Color, c2 As New Color
  493. EventsEnabled = False
  494. Set sr = ActivePage.Shapes.FindShapes(Query:="@fill.type = 'uniform'")
  495. ActiveDocument.ClearSelection
  496. bClick = False
  497. While Not bClick
  498. On Error Resume Next
  499. bClick = ActiveDocument.GetUserClick(X, Y, Shift, 10, False, cdrCursorPickNone)
  500. If Not bClick Then
  501. Set s = ActivePage.SelectShapesAtPoint(X, Y, False)
  502. Set s = s.Shapes.Last
  503. c2.CopyAssign s.Fill.UniformColor
  504. Set sr2 = New ShapeRange
  505. For Each s1 In sr.Shapes
  506. c.CopyAssign s1.Fill.UniformColor
  507. If c.IsSame(c2) Then
  508. sr2.Add s1
  509. End If
  510. Next s1
  511. sr2.CreateSelection
  512. ActiveWindow.Refresh
  513. End If
  514. Wend
  515. EventsEnabled = True
  516. End Function
  517. '''//// 切割图形-垂直分割-水平分割 ////'''
  518. Function divideVertically()
  519. If 0 = ActiveSelectionRange.Count Then Exit Function
  520. On Error GoTo ErrorHandler
  521. ActiveDocument.BeginCommandGroup: Application.Optimization = True
  522. cutInHalf 1
  523. ActiveDocument.EndCommandGroup
  524. Application.Optimization = False
  525. ActiveWindow.Refresh: Application.Refresh
  526. Exit Function
  527. ErrorHandler:
  528. Application.Optimization = False
  529. On Error Resume Next
  530. End Function
  531. Function divideHorizontally()
  532. If 0 = ActiveSelectionRange.Count Then Exit Function
  533. On Error GoTo ErrorHandler
  534. ActiveDocument.BeginCommandGroup: Application.Optimization = True
  535. cutInHalf 2
  536. ActiveDocument.EndCommandGroup
  537. Application.Optimization = False
  538. ActiveWindow.Refresh: Application.Refresh
  539. Exit Function
  540. ErrorHandler:
  541. Application.Optimization = False
  542. On Error Resume Next
  543. End Function
  544. Private Function cutInHalf(Optional method As Integer)
  545. Dim s As Shape, rect As Shape, rect2 As Shape
  546. Dim trimmed1 As Shape, trimmed2 As Shape
  547. Dim X As Double, Y As Double, w As Double, h As Double
  548. Dim vBool As Boolean
  549. Dim leeway As Double
  550. Dim sr As ShapeRange, sr2 As New ShapeRange
  551. vBool = True
  552. If method = 2 Then
  553. vBool = False
  554. End If
  555. leeway = 0.1
  556. Set sr = ActiveSelectionRange
  557. ActiveDocument.BeginCommandGroup "Cut in half"
  558. For Each s In sr
  559. s.GetBoundingBox X, Y, w, h
  560. If (vBool) Then
  561. 'vertical slice
  562. Set rect = ActiveLayer.CreateRectangle2(X - leeway, Y - leeway, (w / 2) + leeway, h + (leeway * 2))
  563. Set rect2 = ActiveLayer.CreateRectangle2(X + (w / 2), Y - leeway, (w / 2) + leeway, h + (leeway * 2))
  564. Else
  565. Set rect = ActiveLayer.CreateRectangle2(X - leeway, Y - leeway, w + (leeway * 2), (h / 2) + leeway)
  566. Set rect2 = ActiveLayer.CreateRectangle2(X - leeway, Y + (h / 2), w + (leeway * 2), (h / 2) + leeway)
  567. End If
  568. Set trimmed1 = rect.Intersect(s, True, True)
  569. rect.Delete
  570. Set trimmed2 = rect2.Intersect(s, True, True)
  571. s.Delete
  572. rect2.Delete
  573. sr2.Add trimmed1
  574. sr2.Add trimmed2
  575. Next s
  576. ActiveDocument.EndCommandGroup
  577. sr2.CreateSelection
  578. End Function
  579. '// 批量多页居中-遍历批量物件,放置物件到页面
  580. Public Function Batch_Align_Page_Center()
  581. If 0 = ActiveSelectionRange.Count Then Exit Function
  582. On Error GoTo ErrorHandler
  583. API.BeginOpt
  584. Dim sr As ShapeRange
  585. Set sr = ActiveSelectionRange
  586. total = sr.Count
  587. '// 建立多页面
  588. Set doc = ActiveDocument
  589. doc.AddPages (total - 1)
  590. Set sr = sorted(sr, topWt_left)
  591. Dim sh As Shape
  592. '// 遍历批量物件,放置物件到页面 InsertPagesEx ActivePage
  593. For i = 1 To sr.Count
  594. doc.Pages(i).Activate
  595. Set sh = sr.Shapes(i)
  596. ActivePage.SetSize Int(sh.SizeWidth + 0.9), Int(sh.SizeHeight + 0.9)
  597. '// 物件居中页面
  598. #If VBA7 Then
  599. ActiveDocument.ClearSelection
  600. sh.AddToSelection
  601. sh.MoveToLayer ActivePage.ActiveLayer
  602. ActiveSelection.AlignAndDistribute 3, 3, 2, 0, False, 2
  603. #Else
  604. sh.MoveToLayer doc.Pages(i).ActiveLayer
  605. sh.AlignToPageCenter cdrAlignHCenter + cdrAlignVCenter
  606. #End If
  607. Next i
  608. ErrorHandler:
  609. API.EndOpt
  610. End Function
  611. '// 安全线: 点击一次建立辅助线,再调用清除参考线
  612. Public Function guideangle(actnumber As ShapeRange, cardblood As Integer)
  613. Dim sr As ShapeRange
  614. Set sr = ActiveDocument.MasterPage.GuidesLayer.FindShapes(Type:=cdrGuidelineShape)
  615. If sr.Count <> 0 Then
  616. sr.Delete
  617. Exit Function
  618. End If
  619. If 0 = ActiveSelectionRange.Count Then Exit Function
  620. ActiveDocument.Unit = cdrMillimeter
  621. With actnumber
  622. Set s1 = ActiveDocument.MasterPage.GuidesLayer.CreateGuideAngle(0, .TopY - cardblood, 0#)
  623. Set s1 = ActiveDocument.MasterPage.GuidesLayer.CreateGuideAngle(0, .BottomY + cardblood, 0#)
  624. Set s1 = ActiveDocument.MasterPage.GuidesLayer.CreateGuideAngle(.LeftX + cardblood, 0, 90#)
  625. Set s1 = ActiveDocument.MasterPage.GuidesLayer.CreateGuideAngle(.RightX - cardblood, 0, 90#)
  626. End With
  627. End Function
  628. '// 标注尺寸 批量简单标注数字
  629. Public Function Simple_Label_Numbers()
  630. API.BeginOpt
  631. Set sr = ActiveSelectionRange
  632. For Each s In sr.Shapes
  633. X = s.CenterX: Y = s.TopY
  634. sw = s.SizeWidth: sh = s.SizeHeight
  635. text = Int(sw + 0.5) & "x" & Int(sh + 0.5) & "mm"
  636. Set s = ActiveLayer.CreateArtisticText(0, 0, text)
  637. s.CenterX = X: s.BottomY = Y + 5
  638. Next
  639. API.EndOpt
  640. End Function
  641. '// 修复圆角缺角到直角
  642. Public Function corner_off()
  643. API.BeginOpt
  644. Dim os As ShapeRange
  645. Dim s As Shape, fir As Shape, ci As Shape
  646. Dim nd As Node, nds As Node, nde As Node
  647. Set os = ActiveSelectionRange
  648. On Error GoTo errn
  649. selec = False
  650. If os.Shapes.Count = 1 Then
  651. Set s = os.FirstShape
  652. If Not s.Curve Is Nothing Then
  653. For Each nd In s.Curve.Nodes
  654. If nd.Selected Then
  655. selec = True
  656. Exit For
  657. End If
  658. Next nd
  659. End If
  660. End If
  661. If os.Shapes.Count > 1 Or Not selec Then
  662. os.ConvertToCurves
  663. For Each s In os.Shapes
  664. Set nds = Nothing
  665. Set nde = Nothing
  666. For k = 1 To 3
  667. For i = 1 To s.Curve.Nodes.Count
  668. If i <= s.Curve.Nodes.Count Then
  669. Set nd = s.Curve.Nodes(i)
  670. If Not nd.NextSegment Is Nothing And Not nd.PrevSegment Is Nothing Then
  671. 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
  672. corner_off_make s, nd.Previous, nd.Next
  673. ElseIf Not nd.Next.NextSegment Is Nothing Then
  674. If (nd.PrevSegment.Type = cdrLineSegment Or Abs(Abs(nd.PrevSegment.StartingControlPointAngle - nd.PrevSegment.EndingControlPointAngle) - 180) < 1) _
  675. And (nd.Next.NextSegment.Type = cdrLineSegment Or Abs(Abs(nd.Next.NextSegment.StartingControlPointAngle - nd.Next.NextSegment.EndingControlPointAngle) - 180) < 1) _
  676. And nd.NextSegment.Type = cdrCurveSegment Then
  677. corner_off_make s, nd, nd.Next
  678. End If
  679. End If
  680. End If
  681. End If
  682. Next i
  683. Next k
  684. Next s
  685. ElseIf os.Shapes.Count = 1 And selec Then
  686. Set nds = Nothing
  687. Set nde = Nothing
  688. For Each nd In s.Curve.Nodes
  689. If Not nd.Selected And Not nd.Next.Selected Then Exit For
  690. Next nd
  691. If Not nd Is s.Curve.Nodes.Last Then
  692. For i = 1 To s.Curve.Nodes.Count
  693. Set nd = nd.Next
  694. If Not nde Is Nothing And Not nds Is Nothing And Not nd.Selected Then Exit For
  695. If Not nds Is Nothing And nd.Selected Then Set nde = nd
  696. If nde Is Nothing And nds Is Nothing And nd.Selected Then Set nds = nd
  697. Next i
  698. If Not nds Is Nothing And Not nde Is Nothing Then
  699. 'ActiveLayer.CreateEllipse2 nds.PositionX, nds.PositionY, nde.PrevSegment.Length / 4
  700. 'ActiveLayer.CreateEllipse2 nde.PositionX, nde.PositionY, nde.PrevSegment.Length / 4
  701. corner_off_make s, nds, nde
  702. End If
  703. End If
  704. End If
  705. errn:
  706. API.EndOpt
  707. End Function
  708. Private Function corner_off_make(s As Shape, nds As Node, nde As Node)
  709. Dim l1 As Shape, l2 As Shape
  710. Dim os As ShapeRange
  711. Dim ss As Shape
  712. Set l1 = ActiveLayer.CreateLineSegment(nds.PositionX, nds.PositionY, nds.PositionX + s.SizeWidth * 3, nds.PositionY)
  713. l1.RotationCenterX = nds.PositionX
  714. l1.RotationAngle = nds.PrevSegment.EndingControlPointAngle + 180
  715. Set l2 = ActiveLayer.CreateLineSegment(nde.PositionX, nde.PositionY, nde.PositionX + s.SizeWidth * 3, nde.PositionY)
  716. l2.RotationCenterX = nde.PositionX
  717. l2.RotationAngle = nde.NextSegment.StartingControlPointAngle + 180
  718. Set lcross = l2.Curve.Segments.First.GetIntersections(l1.Curve.Segments.First)
  719. If lcross.Count > 0 Then
  720. cx = lcross(1).PositionX
  721. cy = lcross(1).PositionY
  722. sx = nds.PositionX
  723. sy = nds.PositionY
  724. ex = nde.PositionX
  725. ey = nde.PositionY
  726. l1.Curve.Nodes.Last.PositionX = cx
  727. l1.Curve.Nodes.Last.PositionY = cy
  728. l2.Curve.Nodes.Last.PositionX = cx
  729. l2.Curve.Nodes.Last.PositionY = cy
  730. s.Curve.Nodes.Range(Array(nds.AbsoluteIndex, nde.AbsoluteIndex)).BreakApart
  731. Set os = s.BreakApartEx
  732. oscnt = os.Shapes.Count
  733. For Each ss In os.Shapes
  734. If ss.Curve.Nodes.First.PositionX = ex And ss.Curve.Nodes.First.PositionY = ey Then Set s2 = ss
  735. If ss.Curve.Nodes.Last.PositionX = sx And ss.Curve.Nodes.Last.PositionY = sy Then Set s1 = ss
  736. If ss.Curve.Nodes.First.PositionX = sx And ss.Curve.Nodes.First.PositionY = sy Then ss.Delete
  737. Next ss
  738. If s1.Curve.Segments.Last.Type = cdrLineSegment Or Abs(Abs(s1.Curve.Segments.Last.StartingControlPointAngle - s1.Curve.Segments.Last.EndingControlPointAngle) - 180) < 1 Then
  739. s1.Curve.Nodes.Last.PositionX = lcross(1).PositionX
  740. s1.Curve.Nodes.Last.PositionY = lcross(1).PositionY
  741. l1.Delete
  742. Else
  743. Set s1 = l1.Weld(s1)
  744. End If
  745. If oscnt = 2 Then Set s2 = s1
  746. If s2.Curve.Segments.First.Type = cdrLineSegment Or Abs(Abs(s2.Curve.Segments.First.StartingControlPointAngle - s2.Curve.Segments.First.EndingControlPointAngle) - 180) < 1 Then
  747. s2.Curve.Nodes.First.PositionX = lcross(1).PositionX
  748. s2.Curve.Nodes.First.PositionY = lcross(1).PositionY
  749. l2.Delete
  750. Else
  751. Set s2 = l2.Weld(s2)
  752. End If
  753. If oscnt > 2 Then Set s2 = s1.Weld(s2)
  754. s2.CustomCommand "ConvertTo", "JoinCurves", 0.1
  755. Set s = s2
  756. Else
  757. l1.Delete
  758. l2.Delete
  759. End If
  760. End Function
  761. Public Function autogroup(Optional Group As String = "group", Optional shft = 0, Optional sss As Shapes = Nothing, Optional undogroup = True) As ShapeRange
  762. Dim sr As ShapeRange, sr_all As ShapeRange, os As ShapeRange
  763. Dim sp As SubPaths
  764. Dim arr()
  765. Dim s As Shape
  766. If sss Is Nothing Then Set os = ActiveSelectionRange Else Set os = sss.all
  767. On Error GoTo errn
  768. ActiveDocument.BeginCommandGroup: Application.Optimization = True
  769. If ActiveSelection.Shapes.Count > 0 Then
  770. gcnt = os.Shapes.Count
  771. ReDim arr(1 To gcnt, 1 To gcnt)
  772. Set sr_all = ActiveSelectionRange
  773. sr_all.RemoveAll
  774. ReDim arr(1 To gcnt, 1 To gcnt)
  775. ActiveDocument.Unit = cdrTenthMicron
  776. sgap = 10
  777. If shft = 2 Or shft = 3 Or shft = 6 Or shft = 7 Then
  778. os.RemoveAll
  779. For Each s In ActiveSelectionRange.Shapes
  780. os.Add ActivePage.SelectShapesFromRectangle(s.LeftX - sgap, s.BottomY - sgap, s.RightX + sgap, s.TopY + sgap, True)
  781. Next s
  782. End If
  783. For i = 1 To os.Shapes.Count
  784. Set s1 = os.Shapes(i)
  785. arr(i, i) = i
  786. For j = 1 To os.Shapes.Count
  787. Set s2 = os.Shapes(j)
  788. 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
  789. If shft = 1 Or shft = 3 Or shft = 5 Or shft = 7 Then
  790. Set isec = s1.Intersect(s2)
  791. If Not isec Is Nothing Then
  792. arr(i, j) = j
  793. isec.CreateSelection
  794. isec.Delete
  795. End If
  796. Else
  797. arr(i, j) = j
  798. End If
  799. End If
  800. Next j
  801. Next i
  802. For i = 1 To gcnt
  803. arr = collect_arr(arr, i, i)
  804. Next i
  805. Set sr = ActiveSelectionRange
  806. For i = 1 To gcnt
  807. sr.RemoveAll
  808. inar = 0
  809. For j = 1 To gcnt
  810. If arr(i, j) > 0 Then
  811. sr.Add os.Shapes(j)
  812. inar = inar + 1
  813. End If
  814. Next j
  815. If inar > 1 Then
  816. If Group = "group" Then
  817. If shft < 4 Then sr_all.Add sr.Group
  818. End If
  819. Else
  820. If sr.Shapes.Count > 0 Then sr_all.AddRange sr
  821. End If
  822. Next i
  823. Set autogroup = sr_all
  824. End If
  825. ActiveDocument.EndCommandGroup
  826. Application.Optimization = False
  827. ActiveWindow.Refresh: Application.Refresh
  828. Exit Function
  829. errn:
  830. Application.Optimization = False
  831. End Function
  832. Public Function collect_arr(arr, ci, ki)
  833. lim = UBound(arr)
  834. For k = 1 To lim
  835. If arr(ki, k) > 0 Then
  836. arr(ci, k) = k
  837. If ki <> ci Then arr(ki, k) = Empty
  838. If ci <> k And ki <> k Then arr = collect_arr(arr, ci, k)
  839. End If
  840. Next k
  841. 'If ki <> ci Then arr(ki, ki) = Empty
  842. collect_arr = arr
  843. End Function
  844. '// 两个端点的坐标,为(x1,y1)和(x2,y2) 那么其角度a的tan值: tana=(y2-y1)/(x2-x1)
  845. '// 所以计算arctan(y2-y1)/(x2-x1), 得到其角度值a
  846. '// VB中用atn(), 返回值是弧度,需要 乘以 PI /180
  847. Private Function lineangle(x1, y1, x2, y2) As Double
  848. pi = 4 * VBA.Atn(1) '// 计算圆周率
  849. If x2 = x1 Then
  850. lineangle = 90: Exit Function
  851. End If
  852. lineangle = VBA.Atn((y2 - y1) / (x2 - x1)) / pi * 180
  853. End Function
  854. '// 角度转平
  855. Public Function Angle_to_Horizon()
  856. On Error GoTo ErrorHandler
  857. API.BeginOpt
  858. Set sr = ActiveSelectionRange
  859. Set nr = sr.LastShape.DisplayCurve.Nodes.all
  860. If nr.Count = 2 Then
  861. x1 = nr.FirstNode.PositionX: y1 = nr.FirstNode.PositionY
  862. x2 = nr.LastNode.PositionX: y2 = nr.LastNode.PositionY
  863. a = lineangle(x1, y1, x2, y2): sr.Rotate -a
  864. sr.LastShape.Delete '// 删除参考线
  865. End If
  866. ErrorHandler:
  867. API.EndOpt
  868. End Function
  869. '// 自动旋转角度
  870. Public Function Auto_Rotation_Angle()
  871. On Error GoTo ErrorHandler
  872. API.BeginOpt
  873. ' ActiveDocument.ReferencePoint = cdrCenter
  874. Set sr = ActiveSelectionRange
  875. Set nr = sr.LastShape.DisplayCurve.Nodes.all
  876. If nr.Count = 2 Then
  877. x1 = nr.FirstNode.PositionX: y1 = nr.FirstNode.PositionY
  878. x2 = nr.LastNode.PositionX: y2 = nr.LastNode.PositionY
  879. a = lineangle(x1, y1, x2, y2): sr.Rotate 90 + a
  880. sr.LastShape.Delete '// 删除参考线
  881. End If
  882. ErrorHandler:
  883. API.EndOpt
  884. End Function
  885. '// 交换对象
  886. Public Function Exchange_Object()
  887. Set sr = ActiveSelectionRange
  888. If sr.Count = 2 Then
  889. X = sr.LastShape.CenterX: Y = sr.LastShape.CenterY
  890. sr.LastShape.CenterX = sr.FirstShape.CenterX: sr.LastShape.CenterY = sr.FirstShape.CenterY
  891. sr.FirstShape.CenterX = X: sr.FirstShape.CenterY = Y
  892. End If
  893. End Function
  894. '// 参考线镜像
  895. Public Function Mirror_ByGuide()
  896. On Error GoTo ErrorHandler
  897. API.BeginOpt
  898. Set sr = ActiveSelectionRange
  899. Set nr = sr.LastShape.DisplayCurve.Nodes.all
  900. If nr.Count >= 2 Then
  901. byshape = False
  902. x1 = nr.FirstNode.PositionX: y1 = nr.FirstNode.PositionY
  903. x2 = nr.LastNode.PositionX: y2 = nr.LastNode.PositionY
  904. a = lineangle(x1, y1, x2, y2) '// 参考线和水平的夹角 a
  905. sr.remove sr.Count
  906. ang = 90 - a '// 镜像的旋转角度
  907. For Each s In sr
  908. With s
  909. .Duplicate '// 复制物件保留,然后按 x1,y1 点 旋转
  910. .RotationCenterX = x1
  911. .RotationCenterY = y1
  912. .Rotate ang
  913. If Not byshape Then
  914. lx = .LeftX
  915. .Stretch -1#, 1# '// 通过拉伸完成镜像
  916. .LeftX = lx
  917. .Move (x1 - .LeftX) * 2 - .SizeWidth, 0
  918. .RotationCenterX = x1 '// 之前因为镜像,旋转中心点反了,重置回来
  919. .RotationCenterY = y1
  920. .Rotate -ang
  921. End If
  922. .RotationCenterX = .CenterX '// 重置回旋转中心点为物件中心
  923. .RotationCenterY = .CenterY
  924. End With
  925. Next s
  926. End If
  927. ErrorHandler:
  928. API.EndOpt
  929. End Function
  930. '// 按面积排列计数
  931. Public Function Count_byArea(Space_Width As Double)
  932. If 0 = ActiveSelectionRange.Count Then Exit Function
  933. API.BeginOpt
  934. ActiveDocument.ReferencePoint = cdrCenter
  935. Set ssr = ActiveSelectionRange
  936. cnt = 1
  937. #If VBA7 Then
  938. ssr.Sort "@shape1.width * @shape1.height < @shape2.width * @shape2.height"
  939. #Else
  940. ' X4 不支持 ShapeRange.sort
  941. #End If
  942. Dim str As String, size As String
  943. For Each sh In ssr
  944. size = Int(sh.SizeWidth + 0.5) & "x" & Int(sh.SizeHeight + 0.5) & "mm"
  945. sh.SetSize Int(sh.SizeWidth + 0.5), Int(sh.SizeHeight + 0.5)
  946. str = str & size & vbNewLine
  947. Next sh
  948. ActiveDocument.ReferencePoint = cdrTopLeft
  949. For Each s In ssr
  950. If cnt > 1 Then s.SetPosition ssr(cnt - 1).LeftX, ssr(cnt - 1).BottomY - Space_Width
  951. cnt = cnt + 1
  952. Next s
  953. ' 写文件,可以EXCEL里统计
  954. ' Set fs = CreateObject("Scripting.FileSystemObject")
  955. ' Set f = fs.CreateTextFile("D:\size.txt", True)
  956. ' f.WriteLine str: f.Close
  957. str = Subtotals(str)
  958. Debug.Print str
  959. Dim s1 As Shape
  960. ' Set s1 = ActiveLayer.CreateParagraphText(0, 0, 100, 150, Str, Font:="华文中宋")
  961. X = ssr.FirstShape.LeftX - 100
  962. Y = ssr.FirstShape.TopY
  963. Set s1 = ActiveLayer.CreateParagraphText(X, Y, X + 90, Y - 150, str, Font:="华文中宋")
  964. API.EndOpt
  965. End Function
  966. '// 实现Excel里分类汇总功能
  967. Private Function Subtotals(str As String) As String
  968. Dim a, b, d, arr
  969. str = VBA.Replace(str, vbNewLine, " ")
  970. Do While InStr(str, " ")
  971. str = VBA.Replace(str, " ", " ")
  972. Loop
  973. arr = Split(str)
  974. Set d = CreateObject("Scripting.dictionary")
  975. For i = 0 To UBound(arr) - 1
  976. If d.Exists(arr(i)) = True Then
  977. d.Item(arr(i)) = d.Item(arr(i)) + 1
  978. Else
  979. d.Add arr(i), 1
  980. End If
  981. Next
  982. str = " 规 格" & vbTab & vbTab & vbTab & "数量" & vbNewLine
  983. a = d.keys: b = d.items
  984. For i = 0 To d.Count - 1
  985. ' Debug.Print a(i), b(i)
  986. str = str & a(i) & vbTab & vbTab & b(i) & "条" & vbNewLine
  987. Next
  988. Subtotals = str & "合计总量:" & vbTab & vbTab & vbTab & UBound(arr) & "条" & vbNewLine
  989. End Function