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 s.Delete Next s 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 Line_len = API.GetSet("Line_len") border = Array(cdrBottomRight, cdrBottomLeft, os.TopY + 10, os.TopY + 20 + Line_len, _ cdrBottomRight, cdrTopRight, os.LeftX - 10, os.LeftX - 20 - Line_len) If chkOpposite.value Then border = Array(cdrTopRight, cdrTopLeft, os.BottomY - 10, os.BottomY - 20 - Line_len, _ cdrBottomLeft, cdrTopLeft, os.RightX + 10, os.RightX + 20 + 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_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single) 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 End Sub Private Sub chkOpposite_Click() ' Debug.Print chkOpposite.value End Sub 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 ActiveDocument.Unit = cdrMillimeter Dim nr As NodeRange, cnt As Integer Dim x1 As Double, y1 As Double Dim x2 As Double, y2 As Double Set nr = ActiveShape.Curve.Selection 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 - 5, y1 + 5, cdrDimensionStyleEngineering cnt = cnt - 1 Wend ErrorHandler: End Function