贪心商人TSP升级

UI/Toolbar.bas

@@ -12,9 +12,8 @@ Attribute VB_GlobalNameSpace = False
 Attribute VB_Creatable = False
 Attribute VB_PredeclaredId = True
 Attribute VB_Exposed = False
-
-
 #If VBA7 Then
+    Private Declare PtrSafe Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
     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
     Private Declare PtrSafe Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
@@ -22,6 +21,7 @@ Attribute VB_Exposed = False
     Private Declare PtrSafe Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
     
 #Else
+    Private Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
     Private Declare Function DrawMenuBar Lib "user32" (ByVal hwnd As Long) As Long
     Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
     Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
@@ -36,6 +36,7 @@ Private Const WS_EX_DLGMODALFRAME = &H1&
 Public UIL_Key As Boolean
 Public pic1, pic2
 
+
 Private Sub Change_UI_Close_Voice_Click()
   Speak_Msg "修改UI图片更换界面  注册表关闭语音 详QQ群"
   MsgBox "请给我支持!" & vbNewLine & "您的支持，我才能有动力添加更多功能." & vbNewLine & "蘭雅CorelVBA中秋节版" & vbNewLine & "coreldrawvba插件交流群  8531411"
@@ -266,10 +267,43 @@ Private Sub 调用多页合并工具()
 End Sub
 
 
-Private Sub CDR_TO_TSP_Click()
-  TSP.CDR_TO_TSP
+Private Sub Cdr_Nodes_BT_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
+  If Button = 2 Then
+    TSP.Nodes_To_TSP
+  ElseIf Shift = fmCtrlMask Then
+    TSP.CDR_TO_TSP
+  Else
+    ' Ctrl + 鼠标  空
+  End If
+End Sub
+
+Private Sub Cdr_Nodes_BT_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
+  TSP_L1.ForeColor = RGB(0, 150, 255)
+End Sub
+
+Private Sub START_TSP_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
+  TSP_L2.ForeColor = RGB(0, 150, 255)
+End Sub
+
+Private Sub PATH_TO_TSP_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
+  TSP_L3.ForeColor = RGB(0, 150, 255)
+End Sub
+
+Private Sub TSP2DRAW_LINE_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
+  TSP_L4.ForeColor = RGB(0, 150, 255)
 End Sub
 
+Private Sub TSP2DRAW_LINE_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
+  If Button = 2 Then
+    TSP.TSP_TO_DRAW_LINE
+  ElseIf Shift = fmCtrlMask Then
+    TSP.TSP_TO_DRAW_LINES
+  Else
+    ' Ctrl + 鼠标  空
+  End If
+End Sub
+
+
 Private Sub START_TSP_Click()
   TSP.START_TSP
 End Sub
@@ -282,10 +316,6 @@ Private Sub QR2Vector_Click()
   Tools.QRCode_to_Vector
 End Sub
 
-Private Sub TSP_TO_DRAW_LINE_Click()
-  TSP.TSP_TO_DRAW_LINE
-End Sub
-
 
 Private Sub BITMAP_MAKE_DOTS_Click()
   Tools.Python_BITMAP
@@ -446,3 +476,17 @@ Private Sub UniteOne_BT_MouseDown(ByVal Button As Integer, ByVal Shift As Intege
     ' Ctrl + 鼠标  空
   End If
 End Sub
+
+'''////  Adobe AI EPS INDD PDF和CorelDRAW 缩略图工具  ////'''
+Private Sub AdobeThumbnail_Click()
+    Dim h As Long, r As Long
+    mypath = Path & "GMS\262235.xyz\"
+    App = mypath & "GuiAdobeThumbnail.exe"
+    
+    h = FindWindow(vbNullString, "CorelVBA 青年节 By 蘭雅sRGB")
+    i = ShellExecute(h, "", App, "", mypath, 1)
+End Sub
+
+Private Sub Quick_Color_Select_Click()
+  Tools.quickColorSelect
+End Sub

donate.md

@@ -26,7 +26,11 @@
 溜溜
 A
 顶天办公
+廣告标识
 大白
+√奋斗吧√
+哈哈
+深蓝*浅蓝
 ```
 
 ### 会员群福利: 

module/TSP.bas

@@ -22,26 +22,45 @@ Public Function CDR_TO_TSP()
 End Function
 
 
-Public Function PATH_TO_TSP()
+Public Function Nodes_To_TSP()
+  On Error GoTo ErrorHandler
+  ActiveDocument.BeginCommandGroup:  Application.Optimization = True
+  
   Set fs = CreateObject("Scripting.FileSystemObject")
   Set f = fs.CreateTextFile("C:\TSP\CDR_TO_TSP", True)
-  
   ActiveDocument.Unit = cdrMillimeter
-  Dim sh As Shape, shs As Shapes, cs As Shape
-  Dim X As Double, Y As Double
-  Set shs = ActiveSelection.Shapes
   
+  Dim ssr As ShapeRange
+  Set ssr = ActiveSelectionRange.Duplicate
+  Dim s As Shape
+  Dim nr As NodeRange
+  Dim nd As Node
+  
+  Dim X As String, Y As String
   Dim TSP As String
-  TSP = shs.Count & " " & 0 & vbNewLine
-  For Each sh In shs
-    X = sh.CenterX
-    Y = sh.CenterY
-    TSP = TSP & X & " " & Y & vbNewLine
-  Next sh
+  
+  Set s = ssr.UngroupAllEx.Combine
+  Set nr = s.Curve.Nodes.All
+  
+  TSP = nr.Count & " " & 0 & vbNewLine
+  For Each n In nr
+      X = Round(n.PositionX, 3) & " "
+      Y = Round(n.PositionY, 3) & vbNewLine
+      TSP = TSP & X & Y
+  Next n
   
   f.WriteLine TSP
   f.Close
-  MsgBox "选择曲线导出节点信息到数据文件!" & vbNewLine
+  s.Delete
+  MsgBox "选择物件导出节点信息到数据文件!" & vbNewLine
+  
+  ActiveDocument.EndCommandGroup
+  Application.Optimization = False
+  ActiveWindow.Refresh:    Application.Refresh
+Exit Function
+ErrorHandler:
+  Application.Optimization = False
+  On Error Resume Next
 End Function
 
 
@@ -50,6 +69,7 @@ Public Function START_TSP()
     Shell cmd_line
 End Function
 
+
 Public Function TSP_TO_DRAW_LINE()
   On Error GoTo ErrorHandler
   ActiveDocument.Unit = cdrMillimeter
@@ -94,48 +114,51 @@ ErrorHandler:
   On Error Resume Next
 End Function
 
-Public Function TSP_TO_DRAW_LINE_BAK()
+
+Private Function set_line_color(line As Shape)
+   '// 设置线条标记
+  line.Outline.SetProperties Color:=CreateRGBColor(26, 22, 35)
+End Function
+
+Public Function TSP_TO_DRAW_LINES()
   On Error GoTo ErrorHandler
+  ActiveDocument.BeginCommandGroup: Application.Optimization = True
   ActiveDocument.Unit = cdrMillimeter
   
+  Set fs = CreateObject("Scripting.FileSystemObject")
+  Set f = fs.OpenTextFile("C:\TSP\TSP2.txt", 1, False)
   Dim Str, arr, n
-  Str = API.GetClipBoardString
+  Dim line As Shape
+  Str = f.ReadAll()
+  
   Str = VBA.replace(Str, vbNewLine, " ")
   Do While InStr(Str, "  ")
-      Str = VBA.replace(Str, "  ", " ")
+    Str = VBA.replace(Str, "  ", " ")
   Loop
   
   arr = Split(Str)
-  total = Val(arr(0))
-  
-  ReDim ce(total) As CurveElement
-  Dim crv As Curve
-  
-  ce(0).ElementType = cdrElementStart
-  ce(0).PositionX = 0
-  ce(0).PositionY = 0
-  
-  Dim X As Double
-  Dim Y As Double
-  For n = 2 To UBound(arr) - 1 Step 2
+  For n = 2 To UBound(arr) - 1 Step 4
     X = Val(arr(n))
     Y = Val(arr(n + 1))
-  
-    ce(n / 2).ElementType = cdrElementLine
-    ce(n / 2).PositionX = X
-    ce(n / 2).PositionY = Y
-  
+    x1 = Val(arr(n + 2))
+    y1 = Val(arr(n + 3))
+
+    Set line = ActiveLayer.CreateLineSegment(X, Y, x1, y1)
+    set_line_color line
   Next
   
-  Set crv = CreateCurve(ActiveDocument)
-  crv.CreateSubPathFromArray ce
-  ActiveLayer.CreateCurve crv
+  ActivePage.Shapes.FindShapes(Query:="@colors.find(RGB(26, 22, 35))").CreateSelection
+  ActiveSelection.Group
+  ActiveSelection.Outline.SetProperties 0.2, Color:=CreateCMYKColor(0, 100, 100, 0)
   
+  ActiveDocument.EndCommandGroup: Application.Optimization = False
+  ActiveWindow.Refresh: Application.Refresh
+Exit Function
 ErrorHandler:
-  On Error Resume Next
+    Application.Optimization = False
+    On Error Resume Next
 End Function
 
-
 Public Function MAKE_TSP()
     cmd_line = "C:\TSP\TSP.exe"
     Shell cmd_line
@@ -143,7 +166,7 @@ End Function
 
 ' 位图制作小圆点
 Public Function BITMAP_MAKE_DOTS()
- ' On Error GoTo ErrorHandler
+  On Error GoTo ErrorHandler
   ActiveDocument.BeginCommandGroup: Application.Optimization = True
   ActiveDocument.Unit = cdrMillimeter
   Dim line, art, n, h, w
@@ -162,7 +185,7 @@ Public Function BITMAP_MAKE_DOTS()
   arr = Split(line)
   h = Val(arr(0)): w = Val(arr(1))
   
-  If h * w > 40000 Then
+  If h * w > 20000 Then
       MsgBox "位图转换后的小圆点数量比较多:" & vbNewLine & h & " x " & w & " = " & h * w
       flag = 1
   End If

module/Tools.bas

@@ -198,7 +198,7 @@ Public Function Python_BITMAP()
 End Function
 
 Public Function Python_Make_QRCode()
-    mypy = Path & "GMS\262235.xyz\Make_QRCode.py.py"
+    mypy = Path & "GMS\262235.xyz\Make_QRCode.py"
     cmd_line = "pythonw " & Chr(34) & mypy & Chr(34)
     Shell cmd_line
 End Function
@@ -643,3 +643,40 @@ Public Function Mark_Range_Box()
   Set s1 = ActiveLayer.CreateRectangle2(X, Y, w, h)
   s1.Outline.SetProperties Color:=CreateRGBColor(0, 255, 0) ' RGB 绿
 End Function
+
+
+'''//// 快速颜色选择 ////'''
+Sub quickColorSelect()
+    Dim X As Double, Y As Double
+    Dim s As Shape, s1 As Shape
+    Dim sr As ShapeRange, sr2 As ShapeRange
+    Dim Shift As Long, bClick As Boolean
+    Dim c As New Color, c2 As New Color
+
+    EventsEnabled = False
+    
+    Set sr = ActivePage.Shapes.FindShapes(Query:="@fill.type = 'uniform'")
+    ActiveDocument.ClearSelection
+    bClick = False
+    While Not bClick
+    On Error Resume Next
+        bClick = ActiveDocument.GetUserClick(X, Y, Shift, 10, False, cdrCursorPickNone)
+        If Not bClick Then
+            Set s = ActivePage.SelectShapesAtPoint(X, Y, False)
+            Set s = s.Shapes.Last
+            c2.CopyAssign s.Fill.UniformColor
+            Set sr2 = New ShapeRange
+            For Each s1 In sr.Shapes
+                c.CopyAssign s1.Fill.UniformColor
+                If c.IsSame(c2) Then
+                    sr2.Add s1
+                End If
+            Next s1
+            sr2.CreateSelection
+            ActiveWindow.Refresh
+        End If
+    Wend
+    
+    EventsEnabled = True
+End Sub
+