Enhance the function of magic modification

UI/frmArrange.bas → UI/ArrangeForm.bas

@@ -1,21 +1,22 @@
 VERSION 5.00
-Begin {C62A69F0-16DC-11CE-9E98-00AA00574A4F} joyar01 
+Begin {C62A69F0-16DC-11CE-9E98-00AA00574A4F} ArrangeForm 
    Caption         =   "蘭雅sRGB 手动拼版 │ 嘉盟赞助"
    ClientHeight    =   2475
    ClientLeft      =   45
    ClientTop       =   330
    ClientWidth     =   4650
-   OleObjectBlob   =   "joyar01.frx":0000
+   OleObjectBlob   =   "ArrangeForm.frx":0000
    ShowModal       =   0   'False
    StartUpPosition =   2  '屏幕中心
    WhatsThisButton =   -1  'True
    WhatsThisHelp   =   -1  'True
 End
-Attribute VB_Name = "joyar01"
+Attribute VB_Name = "ArrangeForm"
 Attribute VB_GlobalNameSpace = False
 Attribute VB_Creatable = False
 Attribute VB_PredeclaredId = True
 Attribute VB_Exposed = False
+
 Private Sub CommandButton1_Click()
   On Error GoTo ErrorHandler
   ActiveDocument.Unit = cdrMillimeter
@@ -60,18 +61,18 @@ End Sub
 Private Function arrange_Clone(matrix As Variant, s As ShapeRange)
   ls = matrix(0): hs = matrix(1)
   lj = matrix(2): hj = matrix(3)
-  x = s.SizeWidth: y = s.SizeHeight
+  x = s.SizeWidth: Y = s.SizeHeight
   Set s1 = s.Clone
   '// StepAndRepeat 方法在范围内创建多个形状副本
   Set dup1 = s1.StepAndRepeat(ls - 1, x + lj, 0#)
-  Set dup2 = ActiveDocument.CreateShapeRangeFromArray(dup1, s1).StepAndRepeat(hs - 1, 0#, -(y + hj))
+  Set dup2 = ActiveDocument.CreateShapeRangeFromArray(dup1, s1).StepAndRepeat(hs - 1, 0#, -(Y + hj))
   s1.Delete
 End Function
 
 Private Function arrange_Clone_one(matrix As Variant, s As ShapeRange)
   ls = matrix(0): hs = matrix(1)
   lj = matrix(2): hj = matrix(3)
-  x = s.SizeWidth: y = s.SizeHeight
+  x = s.SizeWidth: Y = s.SizeHeight
   Set s1 = s.Clone
   '// StepAndRepeat 方法在范围内创建多个形状副本
   If ls > 1 Then
@@ -80,7 +81,7 @@ Private Function arrange_Clone_one(matrix As Variant, s As ShapeRange)
     Set dup1 = s1
   End If
   If hs > 1 Then
-    Set dup2 = ActiveDocument.CreateShapeRangeFromArray(dup1, s1).StepAndRepeat(hs - 1, 0#, -(y + hj))
+    Set dup2 = ActiveDocument.CreateShapeRangeFromArray(dup1, s1).StepAndRepeat(hs - 1, 0#, -(Y + hj))
   End If
   s1.Delete
 End Function

UI/Woodman.bas

@@ -1,18 +1,20 @@
 VERSION 5.00
 Begin {C62A69F0-16DC-11CE-9E98-00AA00574A4F} Woodman 
-   Caption         =   "Woodman标注尺寸节点"
-   ClientHeight    =   1935
+   Caption         =   "批量标注尺寸节点"
+   ClientHeight    =   1980
    ClientLeft      =   45
    ClientTop       =   330
-   ClientWidth     =   3765
+   ClientWidth     =   3960
    OleObjectBlob   =   "Woodman.frx":0000
    StartUpPosition =   1  '所有者中心
 End
-Attribute VB_Name = "woodman"
+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
@@ -117,36 +119,67 @@ Sub make_sizes_sep(dr, Optional shft = 0)
     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 = "upb" Or dr = "dnb" Or dr = "up" Or dr = "dn" Then os.Sort "@shape1.left < @shape2.left"
-    If dr = "lfb" Or dr = "rib" Or dr = "lf" Or dr = "ri" Then os.Sort "@shape1.top > @shape2.top"
+    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
+            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)
+                            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)
+                            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)
+                            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)
+                            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
+            Next i
         Else
             If shft > 0 Then
                 Select Case dr
@@ -323,3 +356,71 @@ ErrorHandler:
 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
+

module/CutLines.bas

@@ -52,12 +52,12 @@ End Function
 
 
 Sub test_MarkLines()
- ' Dimension_MarkLines cdrAlignLeft
-  Dimension_MarkLines cdrAlignTop
+  Dimension_MarkLines cdrAlignLeft, True
+'  Dimension_MarkLines cdrAlignTop, True
 End Sub
 
 '// 标注尺寸标记线
-Public Function Dimension_MarkLines(Optional ByVal mark As cdrAlignType = cdrAlignTop)
+Public Function Dimension_MarkLines(Optional ByVal mark As cdrAlignType = cdrAlignTop, Optional ByVal mirror As Boolean = False)
   If 0 = ActiveSelectionRange.Count Then Exit Function
   API.BeginOpt
   Bleed = API.GetSet("Bleed")
@@ -92,6 +92,8 @@ Public Function Dimension_MarkLines(Optional ByVal mark As cdrAlignType = cdrAli
   '// 物件范围边界
   px = OrigSelection.LeftX
   py = OrigSelection.TopY
+  mpx = OrigSelection.RightX
+  mpy = OrigSelection.BottomY
   
   '// 页面边缘对齐
   For Each s In sr
@@ -107,9 +109,17 @@ Public Function Dimension_MarkLines(Optional ByVal mark As cdrAlignType = cdrAli
   
   '// 设置线宽和颜色，再选择
    sr.SetOutlineProperties Outline_Width
-   sr.SetOutlineProperties Color:=CreateRGBColor(0, 255, 0)
+   sr.SetOutlineProperties Color:=CreateCMYKColor(80, 40, 0, 20)
    sr.AddToSelection
    
+   If mirror Then
+    If mark = cdrAlignTop Then
+      sr.BottomY = mpy - Line_len - Bleed
+    Else
+      sr.RightX = mpx + Line_len + Bleed
+    End If
+   End If
+   
   API.EndOpt
 End Function
 
@@ -128,6 +138,7 @@ Private Function RemoveDuplicates(sr As ShapeRange)
     If cnt > 1 Then
       If Check_duplicate(sr(cnt - 1), sr(cnt)) Then rms.Add sr(cnt)
     End If
+    s.Name = "DMKLine"
     cnt = cnt + 1
   Next s