添加功能: Adobe_Illustrator复制粘贴互转 标记画框 一键智能拆字 拆分线段

UI/Toolbar.bas

@@ -8,11 +8,12 @@ Begin {C62A69F0-16DC-11CE-9E98-00AA00574A4F} Toolbar
    OleObjectBlob   =   "Toolbar.frx":0000
    StartUpPosition =   1  '所有者中心
 End
-Attribute VB_Name = "ToolBar"
+Attribute VB_Name = "Toolbar"
 Attribute VB_GlobalNameSpace = False
 Attribute VB_Creatable = False
 Attribute VB_PredeclaredId = True
 Attribute VB_Exposed = False
+
 #If VBA7 Then
     Private Declare PtrSafe Function DrawMenuBar Lib "user32" (ByVal Hwnd As Long) As Long
     Private Declare PtrSafe Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal Hwnd As Long, ByVal nIndex As Long) As Long
@@ -33,6 +34,7 @@ Private Const WS_CAPTION As Long = &HC00000
 Private Const WS_EX_DLGMODALFRAME = &H1&
 
 
+
 Private Sub UserForm_Initialize()
   Dim IStyle As Long
   Dim Hwnd As Long
@@ -58,9 +60,9 @@ End With
   OptKey = True
 
   ' 读取角线设置
-  Bleed.Text = API.GetSet("Bleed")
-  Line_len.Text = API.GetSet("Line_len")
-  Outline_Width.Text = API.GetSet("Outline_Width")
+  Bleed.text = API.GetSet("Bleed")
+  Line_len.text = API.GetSet("Line_len")
+  Outline_Width.text = GetSetting("262235.xyz", "Settings", "Outline_Width", "0.2")
 End Sub
 
 Private Sub UserForm_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal y As Single)
@@ -263,22 +265,85 @@ Private Sub OPEN_UI_BIG_Click()
 End Sub
 
 Private Sub Settings_Click()
-  If 0 < Val(Bleed.Text) * Val(Line_len.Text) < 100 Then
-   SaveSetting "262235.xyz", "Settings", "Bleed", Bleed.Text
-   SaveSetting "262235.xyz", "Settings", "Line_len", Line_len.Text
-   SaveSetting "262235.xyz", "Settings", "Outline_Width", Outline_Width.Text
+  If 0 < Val(Bleed.text) * Val(Line_len.text) < 100 Then
+   SaveSetting "262235.xyz", "Settings", "Bleed", Bleed.text
+   SaveSetting "262235.xyz", "Settings", "Line_len", Line_len.text
+   SaveSetting "262235.xyz", "Settings", "Outline_Width", Outline_Width.text
   End If
 
   Me.Height = 30
 End Sub
 
+
+'''/////////  图标鼠标左右点击功能调用   /////////'''
+
 Private Sub Tools_Icon_Click()
   ' 调用语句
   i = GMSManager.RunMacro("CorelDRAW_VBA", "学习CorelVBA.start")
   Me.Height = 30
 End Sub
 
-Private Sub Split_Segment_Click()
-  Tools.Split_Segment
+'''////  选择多物件，组合然后拆分线段，为角线爬虫准备  ////'''
+Private Sub Split_Segment_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal y As Single)
+  If Button = 2 Then
+    MsgBox "鼠标右键，功能待定"
+    Exit Sub
+  End If
+  
+  If Button Then
+      Tools.Split_Segment
+  Me.Height = 30
+  End If
+End Sub
+
+Private Sub Split_Segment_Copy_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal y As Single)
+  If Button = 2 Then
+    MsgBox "鼠标右键，功能待定"
+    Exit Sub
+  End If
+  
+  If Button Then
+      Tools.Split_Segment
   Me.Height = 30
+  End If
+End Sub
+
+'''////  CorelDRAW 与 Adobe_Illustrator 剪贴板转换差  ////'''
+Private Sub Adobe_Illustrator_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal y As Single)
+  Dim value As Integer
+  If Button = 2 Then
+    value = GMSManager.RunMacro("AIClipboard", "CopyPaste.PasteAIFormat")
+    Exit Sub
+  End If
+  
+  If Button Then
+    value = GMSManager.RunMacro("AIClipboard", "CopyPaste.CopyAIFormat")
+    MsgBox "CorelDRAW 与 Adobe_Illustrator 剪贴板转换" & vbNewLine & "鼠标左键复制，鼠标右键粘贴"
+  End If
+End Sub
+
+'''////  标记画框 支持容差  ////'''
+Private Sub Mark_CreateRectangle_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal y As Single)
+  If Button = 2 Then
+    Tools.Mark_CreateRectangle True
+  ElseIf Shift = fmCtrlMask Then
+    Tools.Mark_CreateRectangle False
+  Else
+    Tools.Create_Tolerance
+  End If
 End Sub
+
+''////  一键拆开多行组合的文字字符  ////'''
+Private Sub Batch_Combine_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal y As Single)
+  If Button = 2 Then
+    Tools.Batch_Combine
+    MsgBox "右键暂定功能: 智能群组后的拆开组合"
+    Exit Sub
+  End If
+  
+  If Button Then
+    Tools.Take_Apart_Character
+    Me.Height = 30
+  End If
+End Sub
+

donate.md

@@ -17,4 +17,13 @@
 始于初见
 杰开设计(半修道半缘君)
 鹏阳图文广告(靓仔)
+[%ĀĀÙ]客服中心
+溜溜
 ```
+
+### 会员群福利: 
+```
+1. 本工具免费开源，捐赠会员有得到最新内测版软件，和有限技术支持
+2. 有免费试用观看教学视频的福利 (私密，手工注册帐号)
+3. 等待补充添加福利
+```

module/API.bas

@@ -26,11 +26,23 @@ Public Function GetClipBoardString() As String
 End Function
 
 '// 文本字符复制到剪贴板
-Public Function WriteClipBoard(s As String)
+Public Function WriteClipBoard(ByVal s As String)
   On Error Resume Next
+
+' VBA_WIN10(vba7) 使用PutInClipboard乱码解决办法
+#If VBA7 Then
+  With CreateObject("Forms.TextBox.1")
+    .MultiLine = True
+    .text = s
+    .SelStart = 0
+    .SelLength = .TextLength
+    .Copy
+  End With
+#Else
   Dim MyData As New DataObject
   MyData.SetText s
   MyData.PutInClipboard
+#End If
 End Function
 
 
@@ -69,26 +81,26 @@ Private test_ArraySort()
 End Sub
 
 Function FindAllShapes() As ShapeRange
-    Dim s As Shape
-    Dim srPowerClipped As New ShapeRange
-    Dim sr As ShapeRange, srAll As New ShapeRange
-    
-    If ActiveSelection.Shapes.Count > 0 Then
-        Set sr = ActiveSelection.Shapes.FindShapes()
-    Else
-        Set sr = ActivePage.Shapes.FindShapes()
-    End If
-    
-    Do
-        For Each s In sr.Shapes.FindShapes(Query:="[email protected]")
-            srPowerClipped.AddRange s.PowerClip.Shapes.FindShapes()
-        Next s
-        srAll.AddRange sr
-        sr.RemoveAll
-        sr.AddRange srPowerClipped
-        srPowerClipped.RemoveAll
-    Loop Until sr.Count = 0
-    
-    Set FindAllShapes = srAll
+  Dim s As Shape
+  Dim srPowerClipped As New ShapeRange
+  Dim sr As ShapeRange, srAll As New ShapeRange
+  
+  If ActiveSelection.Shapes.Count > 0 Then
+    Set sr = ActiveSelection.Shapes.FindShapes()
+  Else
+    Set sr = ActivePage.Shapes.FindShapes()
+  End If
+  
+  Do
+    For Each s In sr.Shapes.FindShapes(Query:="[email protected]")
+        srPowerClipped.AddRange s.PowerClip.Shapes.FindShapes()
+    Next s
+    srAll.AddRange sr
+    sr.RemoveAll
+    sr.AddRange srPowerClipped
+    srPowerClipped.RemoveAll
+  Loop Until sr.Count = 0
+  
+  Set FindAllShapes = srAll
 End Function
 

module/CQL查找相同.bas

@@ -5,13 +5,15 @@ End Sub
 
 Public Function CQLline_CM100()
   On Error GoTo err
-  Dim cm(3) As Color, i As Long
+  Dim cm(5) As Color, i As Long
   Set cm(0) = CreateCMYKColor(100, 0, 0, 0)  '青
   Set cm(1) = CreateCMYKColor(0, 100, 0, 0)  '洋红
   Set cm(2) = CreateCMYKColor(100, 100, 0, 0) '洋红
+  Set cm(3) = CreateRGBColor(0, 255, 0) ' RGB 绿
+  Set cm(4) = CreateRGBColor(255, 0, 0) ' RGB 红
 
 ActiveDocument.ClearSelection
-For i = 0 To 2
+For i = 0 To 4
   cm(i).ConvertToRGB
   r = cm(i).RGBRed
   G = cm(i).RGBGreen

module/Tools.bas

@@ -151,8 +151,9 @@ Public Function 尺寸取整()
     s = s & size & vbNewLine
   Next sh
 
-  MsgBox "物件尺寸信息到剪贴板" & vbNewLine & s
+  MsgBox "物件尺寸信息到剪贴板" & vbNewLine & s & vbNewLine
   API.WriteClipBoard s
+
 End Function
 
 Public Function 居中页面()
@@ -249,7 +250,7 @@ ErrorHandler:
     On Error Resume Next
 End Function
 
-'' 选择多物件，组合然后拆分线段，为角线爬虫准备
+'''////  选择多物件，组合然后拆分线段，为角线爬虫准备  ////'''
 Public Function Split_Segment()
   On Error GoTo ErrorHandler
   ActiveDocument.BeginCommandGroup:  Application.Optimization = True
@@ -260,7 +261,7 @@ Public Function Split_Segment()
   Dim nr As NodeRange
   Dim nd As Node
   
-  Set s = ssr.Combine
+  Set s = ssr.UngroupAllEx.Combine
   Set nr = s.Curve.Nodes.All
   
   nr.BreakApart
@@ -277,3 +278,166 @@ ErrorHandler:
   Application.Optimization = False
   On Error Resume Next
 End Function
+
+
+'''////  标记画框 支持容差  ////'''
+Public Function Mark_CreateRectangle(expand As Boolean)
+  On Error GoTo ErrorHandler
+  ActiveDocument.BeginCommandGroup:  Application.Optimization = True
+  
+  ActiveDocument.Unit = cdrMillimeter
+  ActiveDocument.ReferencePoint = cdrBottomLeft
+  Dim ssr As ShapeRange
+  Set ssr = ActiveSelectionRange
+  Dim sh As Shape
+  Dim tr As Double
+  
+  tr = 0
+  If GlobalUserData.Exists("Tolerance", 1) Then
+    tr = Val(GlobalUserData("Tolerance", 1))
+  End If
+
+  For Each sh In ssr
+    If expand = False Then
+      mark_shape sh
+    Else
+      mark_shape_expand sh, tr
+    End If
+  Next sh
+  
+  ActiveDocument.EndCommandGroup
+  Application.Optimization = False
+  ActiveWindow.Refresh:    Application.Refresh
+Exit Function
+ErrorHandler:
+  Application.Optimization = False
+  On Error Resume Next
+End Function
+
+Private Function mark_shape_expand(sh As Shape, tr As Double)
+    Dim s As Shape
+    Dim x As Double, y As Double, w As Double, h As Double, r As Double
+    sh.GetBoundingBox x, y, w, h
+    x = x - tr: y = y - tr:   w = w + 2 * tr: h = h + 2 * tr
+    
+    r = Max(w, h) / Min(w, h) / 30 * Math.Sqr(w * h)
+    If w < h Then
+      Set s = ActiveLayer.CreateRectangle2(x - r, y, w + 2 * r, h)
+    Else
+      Set s = ActiveLayer.CreateRectangle2(x, y - r, w, h + 2 * r)
+    End If
+    s.Outline.SetProperties Color:=CreateRGBColor(0, 255, 0)
+End Function
+
+Public Function Create_Tolerance()
+  Dim text As String
+  If GlobalUserData.Exists("Tolerance", 1) Then
+    text = GlobalUserData("Tolerance", 1)
+  End If
+  text = InputBox("请输入容差值 0 --> 99", "容差值(mm)", text)
+  If text = "" Then Exit Function
+  GlobalUserData("Tolerance", 1) = text
+End Function
+
+Private Function mark_shape(sh As Shape)
+  Dim s As Shape
+  Dim x As Double, y As Double, w As Double, h As Double
+  sh.GetBoundingBox x, y, w, h
+  Set s = ActiveLayer.CreateRectangle2(x, y, w, h)
+  s.Outline.SetProperties Color:=CreateRGBColor(0, 255, 0)
+End Function
+
+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
+  End If
+    Min = a
+End Function
+
+
+'''////  批量组合合并  ////'''
+Public Function Batch_Combine()
+  On Error GoTo ErrorHandler
+  ActiveDocument.BeginCommandGroup:  Application.Optimization = True
+  
+  Dim ssr As ShapeRange
+  Set ssr = ActiveSelectionRange
+  Dim sh As Shape
+  For Each sh In ssr
+    sh.UngroupAllEx.Combine
+  Next sh
+  
+  ActiveDocument.EndCommandGroup
+  Application.Optimization = False
+  ActiveWindow.Refresh:    Application.Refresh
+  
+Exit Function
+ErrorHandler:
+  Application.Optimization = False
+  On Error Resume Next
+End Function
+
+'''////  一键拆开多行组合的文字字符  ////'''
+Public Function Take_Apart_Character()
+  On Error GoTo ErrorHandler
+  ActiveDocument.BeginCommandGroup:  Application.Optimization = True
+  ActiveDocument.Unit = cdrMillimeter
+  ActiveDocument.ReferencePoint = cdrBottomLeft
+  
+  Dim ssr As ShapeRange
+  Set ssr = ActiveSelectionRange
+  Dim s1 As Shape, sh As Shape, s As Shape
+  Dim tr As Double
+  
+  ' 记忆选择范围
+  Dim x As Double, y As Double, w As Double, h As Double
+  ssr.GetBoundingBox x, y, w, h
+' ActiveLayer.CreateRectangle2 x, y, w, h
+  
+  ' 解散群组，先组合，再散开
+  Set s = ssr.UngroupAllEx.Combine
+  Set ssr = s.BreakApartEx
+
+  ' 读取容差值
+  tr = 0
+  If GlobalUserData.Exists("Tolerance", 1) Then
+    tr = Val(GlobalUserData("Tolerance", 1))
+  End If
+
+  ' 标记画框，选择标记框
+  For Each sh In ssr
+    mark_shape_expand sh, tr
+  Next sh
+  
+  Set ssr = ActivePage.Shapes.FindShapes(Query:="@colors.find(RGB(0, 255, 0))")
+  ActiveDocument.ClearSelection
+  ssr.AddToSelection
+  
+  ' 调用 智能群组 后删除标记画框
+  智能群组和查找.智能群组
+  ssr.Delete
+  
+  ' 调用 批量组合合并
+  ActiveDocument.ReferencePoint = cdrBottomLeft
+  Set sh = ActivePage.SelectShapesFromRectangle(x - 1, y - 1, w + 2, h + 2, False)
+  sh.Shapes.All.AddToSelection
+
+  Batch_Combine
+
+  ActiveDocument.EndCommandGroup
+  Application.Optimization = False
+  ActiveWindow.Refresh:    Application.Refresh
+  
+Exit Function
+ErrorHandler:
+  Application.Optimization = False
+  On Error Resume Next
+End Function
+

module/convert.py

@@ -36,5 +36,5 @@ def ReadDirectoryFile(rootdir):
                            os.path.join(parent, filename))
 
 if __name__ == "__main__":
-    src_path = "R:/corelvba/module"
+    src_path = "R:/zip"
     ReadDirectoryFile(src_path)