VERSION 5.00 Begin {C62A69F0-16DC-11CE-9E98-00AA00574A4F} Toolbar Caption = "Toolbar" ClientHeight = 3960 ClientLeft = 45 ClientTop = 330 ClientWidth = 6750 OleObjectBlob = "Toolbar.frx":0000 End 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 Private Declare PtrSafe Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long Private Declare PtrSafe Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long #Else 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 Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long Private Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long #End If Private Const GWL_STYLE As Long = (-16) Private Const GWL_EXSTYLE = (-20) Private Const WS_CAPTION As Long = &HC00000 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" End Sub Private Sub UserForm_Initialize() Dim IStyle As Long Dim hwnd As Long hwnd = FindWindow("ThunderDFrame", Me.Caption) IStyle = GetWindowLong(hwnd, GWL_STYLE) IStyle = IStyle And Not WS_CAPTION SetWindowLong hwnd, GWL_STYLE, IStyle DrawMenuBar hwnd IStyle = GetWindowLong(hwnd, GWL_EXSTYLE) And Not WS_EX_DLGMODALFRAME SetWindowLong hwnd, GWL_EXSTYLE, IStyle With Me .StartUpPosition = 0 .Left = Val(GetSetting("262235.xyz", "Settings", "Left", "400")) ' 设置工具栏位置 .Top = Val(GetSetting("262235.xyz", "Settings", "Top", "55")) .Height = 30 .Width = 336 End With OutlineKey = True OptKey = True ' 读取角线设置 Bleed.text = API.GetSet("Bleed") Line_len.text = API.GetSet("Line_len") Outline_Width.text = GetSetting("262235.xyz", "Settings", "Outline_Width", "0.2") UIFile = Path & "GMS\262235.xyz\ToolBar.jpg" If API.ExistsFile_UseFso(UIFile) Then UI.Picture = LoadPicture(UIFile) '换UI图 Set pic1 = LoadPicture(UIFile) End If UIL = Path & "GMS\262235.xyz\ToolBar1.jpg" If API.ExistsFile_UseFso(UIL) Then Set pic2 = LoadPicture(UIL) UIL_Key = True End If End Sub Private Sub UI_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single) UI.Visible = False If Y > 1 And Y < 16 And UIL_Key Then UI.Picture = pic2 ElseIf Y > 16 And UIL_Key Then UI.Picture = pic1 End If UI.Visible = True ' Debug.Print X & " , " & Y End Sub Private Sub UserForm_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single) If Button Then mx = X my = Y End If With Me .Height = 30 End With End Sub Private Sub UserForm_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single) If Button Then Me.Left = Me.Left - mx + X Me.Top = Me.Top - my + Y End If End Sub Private Sub LOGO_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single) If Abs(X - 14) < 14 And Abs(Y - 14) < 14 And Button = 2 Then Me.Width = 336 OPEN_UI_BIG.Left = 322 UI.Visible = True LOGO.Visible = False X_EXIT.Visible = False TOP_ALIGN_BT.Visible = False LEFT_ALIGN_BT.Visible = False Exit Sub End If If Button Then mx = X my = Y End If End Sub Private Sub LOGO_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single) If Button Then Me.Left = Me.Left - mx + X Me.Top = Me.Top - my + Y End If End Sub Private Sub UI_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single) Dim c As New Color ' 定义图标坐标pos Dim pos_x As Variant Dim pos_y As Variant pos_y = Array(14) pos_x = Array(14, 41, 67, 94, 121, 148, 174, 201, 228, 254, 281, 308, 334, 361, 388, 415, 441, 468, 495) '// 鼠标右键 扩展键按钮优先 收缩工具栏 标记范围框 居中页面 尺寸取整数 单色黑中线标记 扩展工具栏 排列工具 扩展工具栏收缩 If Abs(X - pos_x(0)) < 14 And Abs(Y - pos_y(0)) < 14 And Button = 2 Then Me.Width = 30 UI.Visible = False LOGO.Visible = True X_EXIT.Visible = True Exit Sub ElseIf Abs(X - pos_x(1)) < 14 And Abs(Y - pos_y(0)) < 14 And Button = 2 Then Tools.居中页面 Exit Sub ElseIf Abs(X - pos_x(2)) < 14 And Abs(Y - pos_y(0)) < 14 And Button = 2 Then Tools.Mark_Range_Box Exit Sub ElseIf Abs(X - pos_x(3)) < 14 And Abs(Y - pos_y(0)) < 14 And Button = 2 Then Tools.尺寸取整 Exit Sub ElseIf Abs(X - pos_x(5)) < 14 And Abs(Y - pos_y(0)) < 14 And Button = 2 Then 自动中线色阶条.Auto_ColorMark_K Exit Sub '//分分合合把几个功能按键合并到一起,定义到右键上 ElseIf Abs(X - pos_x(4)) < 14 And Abs(Y - pos_y(0)) < 14 And Button = 2 Then Tools.分分合合 Exit Sub ElseIf Abs(X - pos_x(6)) < 14 And Abs(Y - pos_y(0)) < 14 And Button = 2 Then 智能群组和查找.智能群组 API.Create_Tolerance Exit Sub ElseIf Abs(X - pos_x(8)) < 14 And Abs(Y - pos_y(0)) < 14 And Button = 2 Then '// 右键扩展工具栏 Me.Height = 30 + 45 Exit Sub ElseIf Abs(X - pos_x(10)) < 14 And Abs(Y - pos_y(0)) < 14 And Button = 2 Then '// 右键排列工具 TOP_ALIGN_BT.Visible = True LEFT_ALIGN_BT.Visible = True Exit Sub ElseIf Abs(X - pos_x(11)) < 14 And Abs(Y - pos_y(0)) < 14 And Button = 2 Then '// 右键扩展工具栏收缩 Me.Height = 30 Exit Sub End If '// 鼠标左键 单击按钮功能 按工具栏上图标正常功能 If Abs(X - pos_x(0)) < 14 And Abs(Y - pos_y(0)) < 14 Then 裁切线.start ElseIf Abs(X - pos_x(1)) < 14 And Abs(Y - pos_y(0)) < 14 Then 剪贴板尺寸建立矩形.start ElseIf Abs(X - pos_x(2)) < 14 And Abs(Y - pos_y(0)) < 14 Then 裁切线.SelectLine_to_Cropline ElseIf Abs(X - pos_x(3)) < 14 And Abs(Y - pos_y(0)) < 14 Then 拼版裁切线.arrange ElseIf Abs(X - pos_x(4)) < 14 And Abs(Y - pos_y(0)) < 14 Then 拼版裁切线.Cut_lines ElseIf Abs(X - pos_x(5)) < 14 And Abs(Y - pos_y(0)) < 14 Then 自动中线色阶条.Auto_ColorMark ElseIf Abs(X - pos_x(6)) < 14 And Abs(Y - pos_y(0)) < 14 Then 智能群组和查找.智能群组 ElseIf Abs(X - pos_x(7)) < 14 And Abs(Y - pos_y(0)) < 14 Then CQL_FIND_UI.Show 0 ElseIf Abs(X - pos_x(8)) < 14 And Abs(Y - pos_y(0)) < 14 Then Replace_UI.Show 0 ElseIf Abs(X - pos_x(9)) < 14 And Abs(Y - pos_y(0)) < 14 Then Tools.TextShape_ConvertToCurves ElseIf Abs(X - pos_x(10)) < 14 And Abs(Y - pos_y(0)) < 14 Then '// 扩展工具栏 Me.Height = 30 + 45 Speak_Msg "左右键有不同功能" ElseIf Abs(X - pos_x(11)) < 14 And Abs(Y - pos_y(0)) < 14 Then '// 最小化 Me.Width = 30 Me.Height = 30 OPEN_UI_BIG.Left = 61 UI.Visible = False LOGO.Visible = True X_EXIT.Visible = True ' 保存工具条位置 Left 和 Top SaveSetting "262235.xyz", "Settings", "Left", Me.Left SaveSetting "262235.xyz", "Settings", "Top", Me.Top Speak_Msg "左键缩小 右键收缩" End If End Sub Private Sub X_EXIT_Click() Unload Me ' 关闭 End Sub Private Sub 调用多页合并工具() Dim value As Integer value = GMSManager.RunMacro("合并多页工具", "合并多页运行.run") End Sub Private Sub CDR_TO_TSP_Click() TSP.CDR_TO_TSP End Sub Private Sub START_TSP_Click() TSP.START_TSP End Sub Private Sub PATH_TO_TSP_Click() TSP.MAKE_TSP End Sub 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 TSP.BITMAP_MAKE_DOTS End Sub Private Sub CBPY01_Click() Tools.Python_Organize_Size Me.Height = 30 End Sub Private Sub CBPY02_Click() Tools.Python_Get_Barcode_Number Me.Height = 30 End Sub Private Sub CBPY03_Click() Tools.Python_Make_QRCode Tools.QRCode_replace End Sub Private Sub OPEN_UI_BIG_Click() Unload Me CorelVBA.Show 0 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 End If ' 保存工具条位置 Left 和 Top SaveSetting "262235.xyz", "Settings", "Left", Me.Left SaveSetting "262235.xyz", "Settings", "Top", Me.Top Me.Height = 30 End Sub '''///////// 图标鼠标左右点击功能调用 /////////''' Private Sub Tools_Icon_Click() ' 调用语句 i = GMSManager.RunMacro("CorelDRAW_VBA", "学习CorelVBA.start") End Sub '''//// 选择多物件,组合然后拆分线段,为角线爬虫准备 ////''' 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 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 End If Speak_Msg "拆分线段" 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 Create_Tolerance End If Speak_Msg "标记画框 右键支持容差" 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 ElseIf Shift = fmCtrlMask Then Tools.Take_Apart_Character Else Create_Tolerance End If Speak_Msg "智能拆字" End Sub '''//// 简单一刀切 ////''' Private Sub Single_Line_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single) If Button = 2 Then Tools.Single_Line_Vertical ElseIf Shift = fmCtrlMask Then Tools.Single_Line Else Tools.Single_Line_LastNode End If Speak_Msg "简单一刀切" End Sub '''//// 傻瓜火车排列 ////''' Private Sub TOP_ALIGN_BT_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single) If Button = 2 Then Tools.傻瓜火车排列 3# ElseIf Shift = fmCtrlMask Then Tools.傻瓜火车排列 0# Else Tools.傻瓜火车排列 Set_Space_Width End If End Sub '''//// 傻瓜阶梯排列 ////''' Private Sub LEFT_ALIGN_BT_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single) If Button = 2 Then Tools.傻瓜阶梯排列 3# ElseIf Shift = fmCtrlMask Then Tools.傻瓜阶梯排列 0# Else Tools.傻瓜阶梯排列 Set_Space_Width End If End Sub '''//// 多页合并一页工具 ////''' Private Sub UniteOne_BT_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single) If Button = 2 Then ' 右键 ElseIf Shift = fmCtrlMask Then UniteOne.Show 0 Speak_Msg "多页合并一页" Else ' Ctrl + 鼠标 空 End If End Sub