|
|
@@ -172,7 +172,7 @@ Public Function 居中页面()
|
|
|
ActiveDocument.Unit = cdrMillimeter
|
|
|
Dim OrigSelection As ShapeRange, sh As Shape
|
|
|
Set OrigSelection = ActiveSelectionRange
|
|
|
- Set sh = OrigSelection.Group
|
|
|
+ Set sh = OrigSelection.group
|
|
|
ActivePage.SetSize Int(sh.SizeWidth + 0.9), Int(sh.SizeHeight + 0.9)
|
|
|
|
|
|
#If VBA7 Then
|
|
|
@@ -360,16 +360,16 @@ Private Function mark_shape(sh As Shape)
|
|
|
s.Outline.SetProperties Color:=CreateRGBColor(0, 255, 0)
|
|
|
End Function
|
|
|
|
|
|
-Private Function Max(ByVal a, ByVal B)
|
|
|
- If a < B Then
|
|
|
- a = B
|
|
|
+Private Function Max(ByVal a, ByVal b)
|
|
|
+ If a < b Then
|
|
|
+ a = b
|
|
|
End If
|
|
|
Max = a
|
|
|
End Function
|
|
|
|
|
|
-Private Function Min(ByVal a, ByVal B)
|
|
|
- If a > B Then
|
|
|
- a = B
|
|
|
+Private Function Min(ByVal a, ByVal b)
|
|
|
+ If a > b Then
|
|
|
+ a = b
|
|
|
End If
|
|
|
Min = a
|
|
|
End Function
|
|
|
@@ -511,7 +511,7 @@ Public Function Single_Line()
|
|
|
cnt = cnt + 1
|
|
|
Next s
|
|
|
|
|
|
- SrNew.Group
|
|
|
+ SrNew.group
|
|
|
|
|
|
ActiveDocument.EndCommandGroup
|
|
|
Application.Optimization = False
|
|
|
@@ -570,7 +570,7 @@ Public Function Single_Line_Vertical()
|
|
|
cnt = cnt + 1
|
|
|
Next s
|
|
|
|
|
|
- SrNew.Group
|
|
|
+ SrNew.group
|
|
|
|
|
|
ActiveDocument.EndCommandGroup
|
|
|
Application.Optimization = False
|
|
|
@@ -630,7 +630,7 @@ Public Function Single_Line_LastNode()
|
|
|
cnt = cnt + 1
|
|
|
Next s
|
|
|
|
|
|
- SrNew.Group
|
|
|
+ SrNew.group
|
|
|
|
|
|
ActiveDocument.EndCommandGroup
|
|
|
Application.Optimization = False
|
|
|
@@ -795,9 +795,9 @@ Public Function 批量多页居中()
|
|
|
Dim sh As Shape
|
|
|
|
|
|
'// 遍历批量物件，放置物件到页面
|
|
|
- For I = 1 To sr.Count
|
|
|
- doc.Pages(I).Activate
|
|
|
- Set sh = sr.Shapes(I)
|
|
|
+ For i = 1 To sr.Count
|
|
|
+ doc.Pages(i).Activate
|
|
|
+ Set sh = sr.Shapes(i)
|
|
|
ActivePage.SetSize Int(sh.SizeWidth + 0.9), Int(sh.SizeHeight + 0.9)
|
|
|
|
|
|
'// 物件居中页面
|
|
|
@@ -809,7 +809,7 @@ Public Function 批量多页居中()
|
|
|
sh.AlignToPageCenter cdrAlignHCenter + cdrAlignVCenter
|
|
|
#End If
|
|
|
|
|
|
- Next I
|
|
|
+ Next i
|
|
|
|
|
|
ActiveDocument.EndCommandGroup: Application.Optimization = False
|
|
|
ActiveWindow.Refresh: Application.Refresh
|
|
|
@@ -857,3 +857,408 @@ Public Function Simple_Label_Numbers()
|
|
|
s.CenterX = X: s.BottomY = Y + 5
|
|
|
Next
|
|
|
End Function
|
|
|
+
|
|
|
+'// 修复圆角缺角到直角
|
|
|
+Public Sub corner_off()
|
|
|
+ Dim os As ShapeRange
|
|
|
+ Dim s As Shape, fir As Shape, ci As Shape
|
|
|
+ Dim nd As Node, nds As Node, nde As Node
|
|
|
+
|
|
|
+ Set os = ActiveSelectionRange
|
|
|
+ ud = ActiveDocument.Unit
|
|
|
+ ActiveDocument.Unit = cdrMillimeter
|
|
|
+On Error GoTo errn
|
|
|
+ ActiveDocument.BeginCommandGroup "corners off"
|
|
|
+ Application.Optimization = True
|
|
|
+ selec = False
|
|
|
+ If os.Shapes.Count = 1 Then
|
|
|
+ Set s = os.FirstShape
|
|
|
+ If Not s.Curve Is Nothing Then
|
|
|
+ For Each nd In s.Curve.Nodes
|
|
|
+ If nd.Selected Then
|
|
|
+ selec = True
|
|
|
+ Exit For
|
|
|
+ End If
|
|
|
+ Next nd
|
|
|
+ End If
|
|
|
+ End If
|
|
|
+
|
|
|
+ If os.Shapes.Count > 1 Or Not selec Then
|
|
|
+ os.ConvertToCurves
|
|
|
+ For Each s In os.Shapes
|
|
|
+ Set nds = Nothing
|
|
|
+ Set nde = Nothing
|
|
|
+ For k = 1 To 3
|
|
|
+ For i = 1 To s.Curve.Nodes.Count
|
|
|
+ If i <= s.Curve.Nodes.Count Then
|
|
|
+ Set nd = s.Curve.Nodes(i)
|
|
|
+ If Not nd.NextSegment Is Nothing And Not nd.PrevSegment Is Nothing Then
|
|
|
+ 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
|
|
|
+ corner_off_make s, nd.Previous, nd.Next
|
|
|
+ ElseIf Not nd.Next.NextSegment Is Nothing Then
|
|
|
+ If (nd.PrevSegment.Type = cdrLineSegment Or Abs(Abs(nd.PrevSegment.StartingControlPointAngle - nd.PrevSegment.EndingControlPointAngle) - 180) < 1) _
|
|
|
+ And (nd.Next.NextSegment.Type = cdrLineSegment Or Abs(Abs(nd.Next.NextSegment.StartingControlPointAngle - nd.Next.NextSegment.EndingControlPointAngle) - 180) < 1) _
|
|
|
+ And nd.NextSegment.Type = cdrCurveSegment Then
|
|
|
+ corner_off_make s, nd, nd.Next
|
|
|
+ End If
|
|
|
+ End If
|
|
|
+ End If
|
|
|
+ End If
|
|
|
+ Next i
|
|
|
+ Next k
|
|
|
+
|
|
|
+
|
|
|
+ Next s
|
|
|
+ ElseIf os.Shapes.Count = 1 And selec Then
|
|
|
+ Set nds = Nothing
|
|
|
+ Set nde = Nothing
|
|
|
+ For Each nd In s.Curve.Nodes
|
|
|
+ If Not nd.Selected And Not nd.Next.Selected Then Exit For
|
|
|
+ Next nd
|
|
|
+ If Not nd Is s.Curve.Nodes.Last Then
|
|
|
+ For i = 1 To s.Curve.Nodes.Count
|
|
|
+ Set nd = nd.Next
|
|
|
+ If Not nde Is Nothing And Not nds Is Nothing And Not nd.Selected Then Exit For
|
|
|
+ If Not nds Is Nothing And nd.Selected Then Set nde = nd
|
|
|
+ If nde Is Nothing And nds Is Nothing And nd.Selected Then Set nds = nd
|
|
|
+ Next i
|
|
|
+
|
|
|
+ If Not nds Is Nothing And Not nde Is Nothing Then
|
|
|
+ 'ActiveLayer.CreateEllipse2 nds.PositionX, nds.PositionY, nde.PrevSegment.Length / 4
|
|
|
+ 'ActiveLayer.CreateEllipse2 nde.PositionX, nde.PositionY, nde.PrevSegment.Length / 4
|
|
|
+ corner_off_make s, nds, nde
|
|
|
+ End If
|
|
|
+ End If
|
|
|
+ End If
|
|
|
+errn:
|
|
|
+ Application.Optimization = False
|
|
|
+ ActiveDocument.EndCommandGroup
|
|
|
+ Application.Refresh
|
|
|
+ ActiveDocument.Unit = ud
|
|
|
+End Sub
|
|
|
+
|
|
|
+Private Sub corner_off_make(s As Shape, nds As Node, nde As Node)
|
|
|
+ Dim l1 As Shape, l2 As Shape
|
|
|
+ Dim os As ShapeRange
|
|
|
+ Dim ss As Shape
|
|
|
+ ud = ActiveDocument.Unit
|
|
|
+ ActiveDocument.Unit = cdrMillimeter
|
|
|
+
|
|
|
+ Set l1 = ActiveLayer.CreateLineSegment(nds.PositionX, nds.PositionY, nds.PositionX + s.SizeWidth * 3, nds.PositionY)
|
|
|
+ l1.RotationCenterX = nds.PositionX
|
|
|
+ l1.RotationAngle = nds.PrevSegment.EndingControlPointAngle + 180
|
|
|
+
|
|
|
+ Set l2 = ActiveLayer.CreateLineSegment(nde.PositionX, nde.PositionY, nde.PositionX + s.SizeWidth * 3, nde.PositionY)
|
|
|
+ l2.RotationCenterX = nde.PositionX
|
|
|
+ l2.RotationAngle = nde.NextSegment.StartingControlPointAngle + 180
|
|
|
+
|
|
|
+ Set lcross = l2.Curve.Segments.First.GetIntersections(l1.Curve.Segments.First)
|
|
|
+ If lcross.Count > 0 Then
|
|
|
+ cx = lcross(1).PositionX
|
|
|
+ cy = lcross(1).PositionY
|
|
|
+ sx = nds.PositionX
|
|
|
+ sy = nds.PositionY
|
|
|
+ ex = nde.PositionX
|
|
|
+ ey = nde.PositionY
|
|
|
+
|
|
|
+ l1.Curve.Nodes.Last.PositionX = cx
|
|
|
+ l1.Curve.Nodes.Last.PositionY = cy
|
|
|
+ l2.Curve.Nodes.Last.PositionX = cx
|
|
|
+ l2.Curve.Nodes.Last.PositionY = cy
|
|
|
+
|
|
|
+ s.Curve.Nodes.Range(Array(nds.AbsoluteIndex, nde.AbsoluteIndex)).BreakApart
|
|
|
+ Set os = s.BreakApartEx
|
|
|
+ oscnt = os.Shapes.Count
|
|
|
+ For Each ss In os.Shapes
|
|
|
+ If ss.Curve.Nodes.First.PositionX = ex And ss.Curve.Nodes.First.PositionY = ey Then Set s2 = ss
|
|
|
+ If ss.Curve.Nodes.Last.PositionX = sx And ss.Curve.Nodes.Last.PositionY = sy Then Set s1 = ss
|
|
|
+ If ss.Curve.Nodes.First.PositionX = sx And ss.Curve.Nodes.First.PositionY = sy Then ss.Delete
|
|
|
+ Next ss
|
|
|
+
|
|
|
+ If s1.Curve.Segments.Last.Type = cdrLineSegment Or Abs(Abs(s1.Curve.Segments.Last.StartingControlPointAngle - s1.Curve.Segments.Last.EndingControlPointAngle) - 180) < 1 Then
|
|
|
+ s1.Curve.Nodes.Last.PositionX = lcross(1).PositionX
|
|
|
+ s1.Curve.Nodes.Last.PositionY = lcross(1).PositionY
|
|
|
+ l1.Delete
|
|
|
+ Else
|
|
|
+ Set s1 = l1.Weld(s1)
|
|
|
+ End If
|
|
|
+ If oscnt = 2 Then Set s2 = s1
|
|
|
+ If s2.Curve.Segments.First.Type = cdrLineSegment Or Abs(Abs(s2.Curve.Segments.First.StartingControlPointAngle - s2.Curve.Segments.First.EndingControlPointAngle) - 180) < 1 Then
|
|
|
+ s2.Curve.Nodes.First.PositionX = lcross(1).PositionX
|
|
|
+ s2.Curve.Nodes.First.PositionY = lcross(1).PositionY
|
|
|
+ l2.Delete
|
|
|
+ Else
|
|
|
+ Set s2 = l2.Weld(s2)
|
|
|
+ End If
|
|
|
+ If oscnt > 2 Then Set s2 = s1.Weld(s2)
|
|
|
+ s2.CustomCommand "ConvertTo", "JoinCurves", 0.1
|
|
|
+ Set s = s2
|
|
|
+ Else
|
|
|
+ l1.Delete
|
|
|
+ l2.Delete
|
|
|
+ End If
|
|
|
+ ActiveDocument.Unit = ud
|
|
|
+End Sub
|
|
|
+
|
|
|
+Public Function autogroup(Optional group As String = "group", Optional shft = 0, Optional sss As Shapes = Nothing, Optional undogroup = True) As ShapeRange
|
|
|
+ Dim sr As ShapeRange, sr_all As ShapeRange, os As ShapeRange
|
|
|
+ Dim sp As SubPaths
|
|
|
+ Dim arr()
|
|
|
+ Dim s As Shape
|
|
|
+ If sss Is Nothing Then Set os = ActiveSelectionRange Else Set os = sss.All
|
|
|
+ On Error GoTo errn
|
|
|
+ ActiveDocument.BeginCommandGroup: Application.Optimization = True
|
|
|
+
|
|
|
+ If ActiveSelection.Shapes.Count > 0 Then
|
|
|
+ gcnt = os.Shapes.Count
|
|
|
+ ReDim arr(1 To gcnt, 1 To gcnt)
|
|
|
+ Set sr_all = ActiveSelectionRange
|
|
|
+ sr_all.RemoveAll
|
|
|
+ ReDim arr(1 To gcnt, 1 To gcnt)
|
|
|
+ ActiveDocument.Unit = cdrTenthMicron
|
|
|
+ sgap = 10
|
|
|
+ If shft = 2 Or shft = 3 Or shft = 6 Or shft = 7 Then
|
|
|
+ os.RemoveAll
|
|
|
+ For Each s In ActiveSelectionRange.Shapes
|
|
|
+ os.Add ActivePage.SelectShapesFromRectangle(s.LeftX - sgap, s.BottomY - sgap, s.RightX + sgap, s.TopY + sgap, True)
|
|
|
+ Next s
|
|
|
+ End If
|
|
|
+
|
|
|
+ For i = 1 To os.Shapes.Count
|
|
|
+ Set s1 = os.Shapes(i)
|
|
|
+ arr(i, i) = i
|
|
|
+ For j = 1 To os.Shapes.Count
|
|
|
+ Set s2 = os.Shapes(j)
|
|
|
+ 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
|
|
|
+ If shft = 1 Or shft = 3 Or shft = 5 Or shft = 7 Then
|
|
|
+ Set isec = s1.Intersect(s2)
|
|
|
+ If Not isec Is Nothing Then
|
|
|
+ arr(i, j) = j
|
|
|
+ isec.CreateSelection
|
|
|
+ isec.Delete
|
|
|
+ End If
|
|
|
+ Else
|
|
|
+ arr(i, j) = j
|
|
|
+ End If
|
|
|
+ End If
|
|
|
+ Next j
|
|
|
+ Next i
|
|
|
+
|
|
|
+ For i = 1 To gcnt
|
|
|
+ arr = collect_arr(arr, i, i)
|
|
|
+ Next i
|
|
|
+
|
|
|
+ Set sr = ActiveSelectionRange
|
|
|
+
|
|
|
+ For i = 1 To gcnt
|
|
|
+ sr.RemoveAll
|
|
|
+ inar = 0
|
|
|
+ For j = 1 To gcnt
|
|
|
+ If arr(i, j) > 0 Then
|
|
|
+ sr.Add os.Shapes(j)
|
|
|
+ inar = inar + 1
|
|
|
+ End If
|
|
|
+ Next j
|
|
|
+ If inar > 1 Then
|
|
|
+ If group = "group" Then
|
|
|
+ If shft < 4 Then sr_all.Add sr.group
|
|
|
+ End If
|
|
|
+ Else
|
|
|
+ If sr.Shapes.Count > 0 Then sr_all.AddRange sr
|
|
|
+ End If
|
|
|
+ Next i
|
|
|
+ Set autogroup = sr_all
|
|
|
+ End If
|
|
|
+
|
|
|
+ ActiveDocument.EndCommandGroup
|
|
|
+ Application.Optimization = False
|
|
|
+ ActiveWindow.Refresh: Application.Refresh
|
|
|
+ Exit Function
|
|
|
+errn:
|
|
|
+ Application.Optimization = False
|
|
|
+End Function
|
|
|
+
|
|
|
+Public Function collect_arr(arr, ci, ki)
|
|
|
+ lim = UBound(arr)
|
|
|
+ For k = 1 To lim
|
|
|
+ If arr(ki, k) > 0 Then
|
|
|
+ arr(ci, k) = k
|
|
|
+ If ki <> ci Then arr(ki, k) = Empty
|
|
|
+ If ci <> k And ki <> k Then arr = collect_arr(arr, ci, k)
|
|
|
+ End If
|
|
|
+ Next k
|
|
|
+ 'If ki <> ci Then arr(ki, ki) = Empty
|
|
|
+ collect_arr = arr
|
|
|
+End Function
|
|
|
+
|
|
|
+' 两个端点的坐标,为(x1,y1)和(x2,y2) 那么其角度a的tan值: tana=(y2-y1)/(x2-x1)
|
|
|
+' 所以计算arctan(y2-y1)/(x2-x1), 得到其角度值a
|
|
|
+' VB中用atn(), 返回值是弧度，需要 乘以 PI /180
|
|
|
+Private Function lineangle(x1, y1, x2, y2) As Double
|
|
|
+ pi = 4 * VBA.Atn(1) ' 计算圆周率
|
|
|
+ If x2 = x1 Then
|
|
|
+ lineangle = 90: Exit Function
|
|
|
+ End If
|
|
|
+ lineangle = VBA.Atn((y2 - y1) / (x2 - x1)) / pi * 180
|
|
|
+End Function
|
|
|
+
|
|
|
+Public Function 角度转平()
|
|
|
+ On Error GoTo ErrorHandler
|
|
|
+' ActiveDocument.ReferencePoint = cdrCenter
|
|
|
+ Set sr = ActiveSelectionRange
|
|
|
+ Set nr = sr.LastShape.DisplayCurve.Nodes.All
|
|
|
+
|
|
|
+ If nr.Count = 2 Then
|
|
|
+ x1 = nr.FirstNode.PositionX: y1 = nr.FirstNode.PositionY
|
|
|
+ x2 = nr.LastNode.PositionX: y2 = nr.LastNode.PositionY
|
|
|
+ a = lineangle(x1, y1, x2, y2): sr.Rotate -a
|
|
|
+ ' sr.LastShape.Delete '// 删除参考线
|
|
|
+ End If
|
|
|
+ErrorHandler:
|
|
|
+End Function
|
|
|
+
|
|
|
+Public Function 自动旋转角度()
|
|
|
+ On Error GoTo ErrorHandler
|
|
|
+' ActiveDocument.ReferencePoint = cdrCenter
|
|
|
+ Set sr = ActiveSelectionRange
|
|
|
+ Set nr = sr.LastShape.DisplayCurve.Nodes.All
|
|
|
+
|
|
|
+ If nr.Count = 2 Then
|
|
|
+ x1 = nr.FirstNode.PositionX: y1 = nr.FirstNode.PositionY
|
|
|
+ x2 = nr.LastNode.PositionX: y2 = nr.LastNode.PositionY
|
|
|
+ a = lineangle(x1, y1, x2, y2): sr.Rotate 90 + a
|
|
|
+ sr.LastShape.Delete '// 删除参考线
|
|
|
+ End If
|
|
|
+ErrorHandler:
|
|
|
+End Function
|
|
|
+
|
|
|
+
|
|
|
+Public Function 交换对象()
|
|
|
+ Set sr = ActiveSelectionRange
|
|
|
+ If sr.Count = 2 Then
|
|
|
+ X = sr.LastShape.CenterX: Y = sr.LastShape.CenterY
|
|
|
+ sr.LastShape.CenterX = sr.FirstShape.CenterX: sr.LastShape.CenterY = sr.FirstShape.CenterY
|
|
|
+ sr.FirstShape.CenterX = X: sr.FirstShape.CenterY = Y
|
|
|
+ End If
|
|
|
+End Function
|
|
|
+
|
|
|
+Public Function 参考线镜像()
|
|
|
+ On Error GoTo ErrorHandler
|
|
|
+ Set sr = ActiveSelectionRange
|
|
|
+ Set nr = sr.LastShape.DisplayCurve.Nodes.All
|
|
|
+
|
|
|
+ If nr.Count = 2 Then
|
|
|
+ ActiveDocument.BeginCommandGroup "Mirror": Application.Optimization = True
|
|
|
+ byshape = False
|
|
|
+ x1 = nr.FirstNode.PositionX: y1 = nr.FirstNode.PositionY
|
|
|
+ x2 = nr.LastNode.PositionX: y2 = nr.LastNode.PositionY
|
|
|
+ a = lineangle(x1, y1, x2, y2) '// 参考线和水平的夹角 a
|
|
|
+ sr.Remove sr.Count
|
|
|
+
|
|
|
+ ang = 90 - a ' 镜像的旋转角度
|
|
|
+ For Each s In sr
|
|
|
+ With s
|
|
|
+ .Duplicate ' // 复制物件保留，然后按 x1,y1 点 旋转
|
|
|
+ .RotationCenterX = x1
|
|
|
+ .RotationCenterY = y1
|
|
|
+ .Rotate ang
|
|
|
+ If Not byshape Then
|
|
|
+ lx = .LeftX
|
|
|
+ .Stretch -1#, 1# ' // 通过拉伸完成镜像
|
|
|
+ .LeftX = lx
|
|
|
+ .Move (x1 - .LeftX) * 2 - .SizeWidth, 0
|
|
|
+ .RotationCenterX = x1 '// 之前因为镜像，旋转中心点反了，重置回来
|
|
|
+ .RotationCenterY = y1
|
|
|
+ .Rotate -ang
|
|
|
+ End If
|
|
|
+ .RotationCenterX = .CenterX '// 重置回旋转中心点为物件中心
|
|
|
+ .RotationCenterY = .CenterY
|
|
|
+ End With
|
|
|
+ Next s
|
|
|
+ ActiveDocument.EndCommandGroup
|
|
|
+ End If
|
|
|
+
|
|
|
+ ActiveDocument.EndCommandGroup
|
|
|
+ Application.Optimization = False
|
|
|
+ ActiveWindow.Refresh: Application.Refresh
|
|
|
+ErrorHandler:
|
|
|
+ Application.Optimization = False
|
|
|
+End Function
|
|
|
+
|
|
|
+
|
|
|
+Public Function 按面积排列(space_width As Double)
|
|
|
+ If 0 = ActiveSelectionRange.Count Then Exit Function
|
|
|
+ ActiveDocument.BeginCommandGroup: Application.Optimization = True
|
|
|
+ ActiveDocument.Unit = cdrMillimeter
|
|
|
+ ActiveDocument.ReferencePoint = cdrCenter
|
|
|
+
|
|
|
+ Set ssr = ActiveSelectionRange
|
|
|
+ cnt = 1
|
|
|
+
|
|
|
+#If VBA7 Then
|
|
|
+ ssr.Sort "@shape1.width * @shape1.height < @shape2.width * @shape2.height"
|
|
|
+#Else
|
|
|
+' X4 不支持 ShapeRange.sort
|
|
|
+#End If
|
|
|
+
|
|
|
+ Dim Str As String, size As String
|
|
|
+ For Each sh In ssr
|
|
|
+ size = Int(sh.SizeWidth + 0.5) & "x" & Int(sh.SizeHeight + 0.5) & "mm"
|
|
|
+ sh.SetSize Int(sh.SizeWidth + 0.5), Int(sh.SizeHeight + 0.5)
|
|
|
+ Str = Str & size & vbNewLine
|
|
|
+ Next sh
|
|
|
+
|
|
|
+ ActiveDocument.ReferencePoint = cdrTopLeft
|
|
|
+ For Each s In ssr
|
|
|
+ If cnt > 1 Then s.SetPosition ssr(cnt - 1).LeftX, ssr(cnt - 1).BottomY - space_width
|
|
|
+ cnt = cnt + 1
|
|
|
+ Next s
|
|
|
+
|
|
|
+' 写文件，可以EXCEL里统计
|
|
|
+' Set fs = CreateObject("Scripting.FileSystemObject")
|
|
|
+' Set f = fs.CreateTextFile("D:\size.txt", True)
|
|
|
+' f.WriteLine str: f.Close
|
|
|
+
|
|
|
+ Str = 分类汇总(Str)
|
|
|
+ Debug.Print Str
|
|
|
+
|
|
|
+ Dim s1 As Shape
|
|
|
+' Set s1 = ActiveLayer.CreateParagraphText(0, 0, 100, 150, Str, Font:="华文中宋")
|
|
|
+ X = ssr.FirstShape.LeftX - 100
|
|
|
+ Y = ssr.FirstShape.TopY
|
|
|
+ Set s1 = ActiveLayer.CreateParagraphText(X, Y, X + 90, Y - 150, Str, Font:="华文中宋")
|
|
|
+
|
|
|
+ ActiveDocument.EndCommandGroup
|
|
|
+ Application.Optimization = False
|
|
|
+ ActiveWindow.Refresh: Application.Refresh
|
|
|
+End Function
|
|
|
+
|
|
|
+'// 实现Excel里分类汇总功能
|
|
|
+Private Function 分类汇总(Str As String) As String
|
|
|
+ Dim a, b, d, arr
|
|
|
+ Str = VBA.Replace(Str, vbNewLine, " ")
|
|
|
+ Do While InStr(Str, " ")
|
|
|
+ Str = VBA.Replace(Str, " ", " ")
|
|
|
+ Loop
|
|
|
+ arr = Split(Str)
|
|
|
+
|
|
|
+ Set d = CreateObject("Scripting.dictionary")
|
|
|
+
|
|
|
+ For i = 0 To UBound(arr) - 1
|
|
|
+ If d.Exists(arr(i)) = True Then
|
|
|
+ d.Item(arr(i)) = d.Item(arr(i)) + 1
|
|
|
+ Else
|
|
|
+ d.Add arr(i), 1
|
|
|
+ End If
|
|
|
+ Next
|
|
|
+
|
|
|
+ Str = " 规 格" & vbTab & vbTab & vbTab & "数量" & vbNewLine
|
|
|
+
|
|
|
+ a = d.keys: b = d.items
|
|
|
+ For i = 0 To d.Count - 1
|
|
|
+ ' Debug.Print a(i), b(i)
|
|
|
+ Str = Str & a(i) & vbTab & vbTab & b(i) & "条" & vbNewLine
|
|
|
+ Next
|
|
|
+
|
|
|
+ 分类汇总 = Str & "合计总量:" & vbTab & vbTab & vbTab & UBound(arr) & "条" & vbNewLine
|
|
|
+End Function
|
