VERSION 5.00 Begin {C62A69F0-16DC-11CE-9E98-00AA00574A4F} Woodman Caption = "批量标注尺寸节点" ClientHeight = 1980 ClientLeft = 45 ClientTop = 330 ClientWidth = 3960 OleObjectBlob = "Woodman.frx":0000 StartUpPosition = 1 '所有者中心 End Attribute VB_Name = "Woodman" Attribute VB_GlobalNameSpace = False Attribute VB_Creatable = False Attribute VB_PredeclaredId = True Attribute VB_Exposed = False Private Sub btn_square_hi_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single) ActiveDocument.BeginCommandGroup: Application.Optimization = True Set os = ActiveSelectionRange Set ss = os.Shapes uc = 0 For Each s In ss s.SizeWidth = s.SizeHeight uc = uc + 1 Next s Application.Optimization = False ActiveWindow.Refresh: Application.Refresh End Sub Private Sub btn_square_wi_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single) ActiveDocument.BeginCommandGroup: Application.Optimization = True Set os = ActiveSelectionRange Set ss = os.Shapes uc = 0 For Each s In ss s.SizeHeight = s.SizeWidth uc = uc + 1 Next s Application.Optimization = False ActiveWindow.Refresh: Application.Refresh End Sub Private Sub btn_makesizes_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single) Dim os As ShapeRange Dim s As Shape Dim sr As ShapeRange Set doc = ActiveDocument 'rasm.Dimension.TextShape.Text.Story.size = CLng(fnt) 'rasm.Style.GetProperty("dimension").SetProperty "precision", 0 'rasm.Style.GetProperty("dimension").SetProperty "units", 3 doc.BeginCommandGroup "delete sizes" Set sr = ActiveSelectionRange sr.RemoveAll If Shift = 4 Then On Error Resume Next Set os = ActiveSelectionRange For Each s In os.Shapes If s.Type = cdrLinearDimensionShape Then s.Delete Next s On Error GoTo 0 ElseIf Shift = 1 Then Set os = ActiveSelectionRange For Each s In os.Shapes If s.Type = cdrLinearDimensionShape Then sr.Add s Next s sr.CreateSelection On Error GoTo 0 ElseIf Shift = 2 Then On Error Resume Next Set os = ActiveSelectionRange For Each s In os.Shapes If s.Type = cdrLinearDimensionShape Then sr.Add s Next s If sr.Count > 0 Then os.Shapes.FindShapes(Query:="@name ='DMKLine'").CreateSelection ActiveSelectionRange.Delete End If On Error GoTo 0 Else make_sizes Shift End If doc.EndCommandGroup Application.Refresh End Sub Private Sub btn_sizes_up_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single) make_sizes_sep "up", Shift End Sub Private Sub btn_sizes_dn_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single) make_sizes_sep "dn", Shift End Sub Private Sub btn_sizes_lf_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single) make_sizes_sep "lf", Shift End Sub Private Sub btn_sizes_ri_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single) make_sizes_sep "ri", Shift End Sub Private Sub btn_sizes_btw_up_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single) make_sizes_sep "upb", Shift End Sub Private Sub btn_sizes_btw_dn_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single) make_sizes_sep "dnb", Shift End Sub Private Sub btn_sizes_btw_lf_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single) make_sizes_sep "lfb", Shift End Sub Private Sub btn_sizes_btw_ri_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single) make_sizes_sep "rib", Shift End Sub Sub make_sizes_sep(dr, Optional shft = 0) Set doc = ActiveDocument Dim s As Shape Dim pts As New SnapPoint, pte As New SnapPoint Dim os As ShapeRange un = doc.Unit doc.Unit = cdrMillimeter doc.BeginCommandGroup "make sizes" Set os = ActiveSelectionRange Dim border As Variant Dim Line_len As Double If shft > 1 Then Line_len = API.Set_Space_Width '// 设置文字空间间隙 Else Line_len = API.Set_Space_Width(True) '// 只读文字空间间隙 End If border = Array(cdrBottomRight, cdrBottomLeft, os.TopY + Line_len, os.TopY + 2 * Line_len, _ cdrBottomRight, cdrTopRight, os.LeftX - Line_len, os.LeftX - 2 * Line_len) If chkOpposite.value Then border = Array(cdrTopRight, cdrTopLeft, os.BottomY - Line_len, os.BottomY - 2 * Line_len, _ cdrBottomLeft, cdrTopLeft, os.RightX + Line_len, os.RightX + 2 * Line_len) If dr = "upbx" Or dr = "upb" Or dr = "dnb" Or dr = "up" Or dr = "dn" Then os.Sort "@shape1.left < @shape2.left" If dr = "lfbx" Or dr = "lfb" Or dr = "rib" Or dr = "lf" Or dr = "ri" Then os.Sort "@shape1.top > @shape2.top" If os.Count > 0 Then If os.Count > 1 And Len(dr) > 2 Then For i = 1 To os.Shapes.Count - 1 Select Case dr Case "upbx": Set pts = os.Shapes(i).SnapPoints.BBox(border(0)) Set pte = os.Shapes(i + 1).SnapPoints.BBox(border(1)) ActiveLayer.CreateLinearDimension cdrDimensionHorizontal, pts, pte, True, 0, border(2), cdrDimensionStyleEngineering If shft > 0 And i = 1 Then Set pts = os.FirstShape.SnapPoints.BBox(border(0)) Set pte = os.LastShape.SnapPoints.BBox(border(1)) ActiveLayer.CreateLinearDimension cdrDimensionHorizontal, pts, pte, True, 0, border(3), cdrDimensionStyleEngineering End If Case "lfbx": Set pts = os.Shapes(i).SnapPoints.BBox(border(4)) Set pte = os.Shapes(i + 1).SnapPoints.BBox(border(5)) ActiveLayer.CreateLinearDimension cdrDimensionVertical, pts, pte, True, border(6), 0, cdrDimensionStyleEngineering If shft > 0 And i = 1 Then Set pts = os.FirstShape.SnapPoints.BBox(border(4)) Set pte = os.LastShape.SnapPoints.BBox(border(5)) ActiveLayer.CreateLinearDimension cdrDimensionVertical, pts, pte, True, border(7), 0, cdrDimensionStyleEngineering End If Case "upb": Set pts = os.Shapes(i).SnapPoints.BBox(cdrTopRight) Set pte = os.Shapes(i + 1).SnapPoints.BBox(cdrTopLeft) ActiveLayer.CreateLinearDimension cdrDimensionHorizontal, pts, pte, True, os.LeftX + os.SizeWidth / 10, os.TopY + os.SizeHeight / 10, cdrDimensionStyleEngineering Case "dnb": Set pts = os.Shapes(i).SnapPoints.BBox(cdrBottomRight) Set pte = os.Shapes(i + 1).SnapPoints.BBox(cdrBottomLeft) ActiveLayer.CreateLinearDimension cdrDimensionHorizontal, pts, pte, True, os.LeftX + os.SizeWidth / 10, os.BottomY - os.SizeHeight / 10, cdrDimensionStyleEngineering Case "lfb": Set pts = os.Shapes(i).SnapPoints.BBox(cdrBottomLeft) Set pte = os.Shapes(i + 1).SnapPoints.BBox(cdrTopLeft) ActiveLayer.CreateLinearDimension cdrDimensionVertical, pts, pte, True, os.LeftX - os.SizeWidth / 10, os.BottomY + os.SizeHeight / 10, cdrDimensionStyleEngineering Case "rib": Set pts = os.Shapes(i).SnapPoints.BBox(cdrBottomRight) Set pte = os.Shapes(i + 1).SnapPoints.BBox(cdrTopRight) ActiveLayer.CreateLinearDimension cdrDimensionVertical, pts, pte, True, os.RightX + os.SizeWidth / 10, os.BottomY + os.SizeHeight / 10, cdrDimensionStyleEngineering End Select 'ActiveDocument.ClearSelection Next i Else If shft > 0 Then Select Case dr Case "up": Set pts = os.FirstShape.SnapPoints.BBox(cdrTopLeft) Set pte = os.LastShape.SnapPoints.BBox(cdrTopRight) ActiveLayer.CreateLinearDimension cdrDimensionHorizontal, pts, pte, True, os.LeftX + os.SizeWidth / 10, os.TopY + os.SizeHeight / 10, cdrDimensionStyleEngineering Case "dn": Set pts = os.FirstShape.SnapPoints.BBox(cdrBottomLeft) Set pte = os.LastShape.SnapPoints.BBox(cdrBottomRight) ActiveLayer.CreateLinearDimension cdrDimensionHorizontal, pts, pte, True, os.LeftX + os.SizeWidth / 10, os.BottomY - os.SizeHeight / 10, cdrDimensionStyleEngineering Case "lf": Set pts = os.FirstShape.SnapPoints.BBox(cdrTopLeft) Set pte = os.LastShape.SnapPoints.BBox(cdrBottomLeft) ActiveLayer.CreateLinearDimension cdrDimensionVertical, pts, pte, True, os.LeftX - os.SizeWidth / 10, os.BottomY + os.SizeHeight / 10, cdrDimensionStyleEngineering Case "ri": Set pts = os.FirstShape.SnapPoints.BBox(cdrTopRight) Set pte = os.LastShape.SnapPoints.BBox(cdrBottomRight) ActiveLayer.CreateLinearDimension cdrDimensionVertical, pts, pte, True, os.RightX + os.SizeWidth / 10, os.BottomY + os.SizeHeight / 10, cdrDimensionStyleEngineering End Select Else For Each s In os.Shapes Select Case dr Case "up": Set pts = s.SnapPoints.BBox(cdrTopLeft) Set pte = s.SnapPoints.BBox(cdrTopRight) ActiveLayer.CreateLinearDimension cdrDimensionHorizontal, pts, pte, True, s.LeftX + s.SizeWidth / 10, s.TopY + s.SizeHeight / 10, cdrDimensionStyleEngineering Case "dn": Set pts = s.SnapPoints.BBox(cdrBottomLeft) Set pte = s.SnapPoints.BBox(cdrBottomRight) ActiveLayer.CreateLinearDimension cdrDimensionHorizontal, pts, pte, True, s.LeftX + s.SizeWidth / 10, s.BottomY - s.SizeHeight / 10, cdrDimensionStyleEngineering Case "lf": Set pts = s.SnapPoints.BBox(cdrTopLeft) Set pte = s.SnapPoints.BBox(cdrBottomLeft) ActiveLayer.CreateLinearDimension cdrDimensionVertical, pts, pte, True, s.LeftX - s.SizeWidth / 10, s.BottomY + s.SizeHeight / 10, cdrDimensionStyleEngineering Case "ri": Set pts = s.SnapPoints.BBox(cdrTopRight) Set pte = s.SnapPoints.BBox(cdrBottomRight) ActiveLayer.CreateLinearDimension cdrDimensionVertical, pts, pte, True, s.RightX + s.SizeWidth / 10, s.BottomY + s.SizeHeight / 10, cdrDimensionStyleEngineering End Select Next s End If End If End If os.CreateSelection doc.EndCommandGroup doc.Unit = un End Sub Sub make_sizes(Optional shft = 0) Set doc = ActiveDocument Dim s As Shape Dim pts As SnapPoint, pte As SnapPoint Dim os As ShapeRange un = doc.Unit doc.Unit = cdrMillimeter doc.BeginCommandGroup "make sizes" Set os = ActiveSelectionRange If os.Count > 0 Then For Each s In os.Shapes Set pts = s.SnapPoints.BBox(cdrTopLeft) Set pte = s.SnapPoints.BBox(cdrTopRight) Set ptle = s.SnapPoints.BBox(cdrBottomLeft) If shft <> 6 Then ActiveLayer.CreateLinearDimension cdrDimensionVertical, pts, ptle, True, s.LeftX - s.SizeWidth / 10, s.BottomY + s.SizeHeight / 10, cdrDimensionStyleEngineering If shft <> 3 Then ActiveLayer.CreateLinearDimension cdrDimensionHorizontal, pts, pte, True, s.LeftX + s.SizeWidth / 10, s.TopY + s.SizeHeight / 10, cdrDimensionStyleEngineering Next s End If doc.EndCommandGroup doc.Unit = un End Sub Public Function make_selection(Optional mode = "fcolor", Optional sel = True, Optional OSS As ShapeRange = Nothing, Optional colr = Nothing) As ShapeRange Dim s As Shape, lst As Shape Dim sr As ShapeRange 'Dim os As ShapeRange Set doc = ActiveDocument doc.Unit = cdrTenthMicron If OSS Is Nothing Then If toolspanel.num_list.value Or mode = "locked" Then Set os = ActivePage Else Set os = ActiveSelectionRange End If Else Set os = OSS End If Set sr = ActiveSelectionRange sr.RemoveAll If sel Then ActiveDocument.ClearSelection Set lst = os.Shapes.First For Each s In os.Shapes Select Case mode Case "ocolor": If s.Outline.Type <> cdrNoOutline And s.Shapes.Count = 0 And s.Outline.Color.HexValue = colr.HexValue Then sr.Add s Case "fcolor": If s.Fill.Type <> cdrNoFill And s.Shapes.Count = 0 And s.Fill.UniformColor.HexValue = colr.HexValue Then sr.Add s Case "nofil": If s.Fill.Type = cdrNoFill And s.Shapes.Count = 0 Then sr.Add s Case "fil": If s.Fill.Type <> cdrNoFill And s.Shapes.Count = 0 Then sr.Add s Case "abr": If s.Outline.Type <> cdrNoOutline And s.Shapes.Count = 0 Then sr.Add s Case "noabr": If s.Outline.Type = cdrNoOutline And s.Shapes.Count = 0 Then sr.Add s Case "open": If Not s.DisplayCurve Is Nothing Then If Not s.DisplayCurve.Closed Then sr.Add s Case "closed": If Not s.DisplayCurve Is Nothing Then If s.DisplayCurve.Closed Then sr.Add s Case "single": If s.Shapes.Count = 0 Then sr.Add s Case "dashed": If s.Outline.Style.DashCount > 0 Then sr.Add s Case "groups": If s.Shapes.Count > 0 And s.Effect Is Nothing Then sr.Add s Case "text": If s.Shapes.Count = 0 And s.Type = cdrTextShape Then sr.Add s Case "notext": If s.Shapes.Count = 0 And s.Type <> cdrTextShape Then sr.Add s Case "images": If s.Type = cdrBitmapShape Then sr.Add s Case "locked": If s.Locked Then sr.Add s Case "effects": If s.Effects.Count > 0 Or Not s.Effect Is Nothing Then sr.Add s Case "noeffects": If s.Effects.Count = 0 And s.Effect Is Nothing Then sr.Add s Case "bigger": arelst = lst.SizeHeight * lst.SizeWidth ares = s.SizeHeight * s.SizeWidth If ares >= arelst Then are = one_shape_area(lst) If one_shape_area(s) >= are Then sr.Add s End If Case "smaller": arelst = lst.SizeHeight * lst.SizeWidth ares = s.SizeHeight * s.SizeWidth If ares <= arelst Then are = one_shape_area(lst) If one_shape_area(s) <= are Then sr.Add s End If Case "last": If lst.Fill.Type = cdrNoFill Then 's.CreateSelection If s.Outline.Type <> cdrNoOutline Then If s.Outline.Color.HexValue = lst.Outline.Color.HexValue Then sr.Add s Else If s.Fill.UniformColor.HexValue = lst.Fill.UniformColor.HexValue Then sr.Add s End If End Select Next s If sr.Shapes.Count > 0 And sel Then sr.CreateSelection Set make_selection = sr Application.Refresh ActiveWindow.Activate End Function Public Function get_events(btn As String, Optional shft = 0, Optional click = 1) out = "ok" get_events = out End Function Private Sub btn_join_nodes_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single) ActiveSelection.CustomCommand "ConvertTo", "JoinCurves" Application.Refresh End Sub Private Sub btn_nodes_reduce_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single) On Error GoTo ErrorHandler Set doc = ActiveDocument Dim s As Shape ps = Array(1) doc.Unit = cdrTenthMicron Set os = ActivePage.Shapes If os.Count > 0 Then doc.BeginCommandGroup "reduce nodes" For Each s In os s.ConvertToCurves If Not s.DisplayCurve Is Nothing Then s.Curve.AutoReduceNodes 50 End If Next s doc.EndCommandGroup End If Application.Refresh ErrorHandler: MsgBox "s.Curve.AutoReduceNodes 只有高版本才支持本API" End Sub '// 使用标记线批量建立尺寸标注 Private Sub MarkLines_Makesize_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single) Dim sr As ShapeRange Set sr = ActiveSelectionRange If Button = 2 Then CutLines.Dimension_MarkLines cdrAlignLeft, chkOpposite.value make_sizes_sep "lfbx", Shift Else CutLines.Dimension_MarkLines cdrAlignTop, chkOpposite.value Label_Makesizes.Caption = "试试右键" make_sizes_sep "upbx", Shift End If sr.CreateSelection End Sub Private Sub chkOpposite_Click() ' Debug.Print chkOpposite.value End Sub '// 使用手工选节点建立尺寸标注，使用Ctrl分离尺寸标注 Private Sub Manual_Makesize_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single) If Button = 2 Then '// 右键 ElseIf Shift = fmCtrlMask Then Slanted_Makesize '// 手动标注倾斜尺寸 Else Untie_MarkLines '// 解绑尺寸，分离尺寸 End If End Sub '// 解绑尺寸，分离尺寸 Private Function Untie_MarkLines() Dim os As ShapeRange, dss As New ShapeRange Set os = ActiveSelectionRange For Each s In os.Shapes If s.Type = cdrLinearDimensionShape Then dss.Add s End If Next s If dss.Count > 0 Then dss.BreakApartEx os.Shapes.FindShapes(Query:="@name ='DMKLine'").CreateSelection ActiveSelectionRange.Delete End If End Function '// 手动标注倾斜尺寸 Private Function Slanted_Makesize() On Error GoTo ErrorHandler API.BeginOpt Dim nr As NodeRange, cnt As Integer Dim sr As ShapeRange Dim x1 As Double, y1 As Double Dim x2 As Double, y2 As Double Set sr = ActiveSelectionRange Set nr = ActiveShape.Curve.Selection If chkOpposite.value = False Then Slanted_Sort_Make sr '// 排序标注倾斜尺寸 Exit Function End If If nr.Count < 2 Then Exit Function cnt = nr.Count While cnt > 1 x1 = nr(cnt).PositionX y1 = nr(cnt).PositionY x2 = nr(cnt - 1).PositionX y2 = nr(cnt - 1).PositionY Set pts = CreateSnapPoint(x1, y1) Set pte = CreateSnapPoint(x2, y2) ActiveLayer.CreateLinearDimension cdrDimensionSlanted, pts, pte, True, x1 - 20, y1 + 20, cdrDimensionStyleEngineering cnt = cnt - 1 Wend ErrorHandler: API.EndOpt End Function '// 排序标注倾斜尺寸 Private Function Slanted_Sort_Make(shs As ShapeRange) Dim sr As New ShapeRange, sr_copy As New ShapeRange Dim s As Shape, sh As Shape Dim nr As NodeRange For Each sh In shs Set nr = sh.Curve.Selection For Each n In nr Set s = ActiveLayer.CreateEllipse2(n.PositionX, n.PositionY, 0.5, 0.5) sr.Add s Next n Next sh CutLines.RemoveDuplicates sr '// 简单删除重复算法 sr.Sort "@shape1.left < @shape2.left" sr.CreateSelection Set sr_copy = ActiveSelectionRange ' Debug.Print sr_copy.Count For i = 1 To sr_copy.Count - 1 x1 = sr_copy(i + 1).CenterX y1 = sr_copy(i + 1).CenterY x2 = sr_copy(i).CenterX y2 = sr_copy(i).CenterY Set pts = CreateSnapPoint(x1, y1) Set pte = CreateSnapPoint(x2, y2) ActiveLayer.CreateLinearDimension cdrDimensionSlanted, pts, pte, True, x1 - 20, y1 + 20, cdrDimensionStyleEngineering Next i sr_copy.Delete API.EndOpt End Function