1
1

VBA_UI.bas 4.3 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131
  1. #If VBA7 Then
  2. 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
  3. Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
  4. #Else
  5. 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
  6. Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
  7. #End If
  8. Option Explicit
  9. Private Sub CommandButton1_Click()
  10. TextBox1.Value = "设置出血和裁切线功能目前有个想法。谁有兴趣制作漂亮的图标请联系我."
  11. MsgBox "请每天点击右边Logo,点击博客广告一次!" & vbNewLine & "您的支持,我才能有动力添加更多功能."
  12. End Sub
  13. Private Sub UI_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
  14. ' 定义图标坐标pos
  15. Dim pos_x As Variant
  16. Dim pos_Y As Variant
  17. pos_x = Array(32, 110, 186, 265, 345)
  18. pos_Y = Array(50, 135, 215)
  19. ' MsgBox "图标坐标: " & X & " , " & Y
  20. If Abs(X - pos_x(0)) < 30 And Abs(Y - pos_Y(0)) < 30 Then
  21. 物件角线
  22. ElseIf Abs(X - pos_x(1)) < 30 And Abs(Y - pos_Y(0)) < 30 Then
  23. 绘制矩形
  24. ElseIf Abs(X - pos_x(2)) < 30 And Abs(Y - pos_Y(0)) < 30 Then
  25. 角线爬虫
  26. ElseIf Abs(X - pos_x(3)) < 30 And Abs(Y - pos_Y(0)) < 30 Then
  27. 矩形拼版
  28. ElseIf Abs(X - pos_x(4)) < 30 And Abs(Y - pos_Y(0)) < 30 Then
  29. 拼版角线
  30. End If
  31. If Abs(X - pos_x(0)) < 30 And Abs(Y - pos_Y(1)) < 30 Then
  32. 居中页面
  33. ElseIf Abs(X - pos_x(1)) < 30 And Abs(Y - pos_Y(1)) < 30 Then
  34. 拼版标记
  35. ElseIf Abs(X - pos_x(2)) < 30 And Abs(Y - pos_Y(1)) < 30 Then
  36. 智能群组
  37. ElseIf Abs(X - pos_x(3)) < 30 And Abs(Y - pos_Y(1)) < 30 Then
  38. CQL选择
  39. ElseIf Abs(X - pos_x(4)) < 30 And Abs(Y - pos_Y(1)) < 30 Then
  40. 批量替换
  41. End If
  42. If Abs(X - pos_x(0)) < 30 And Abs(Y - pos_Y(2)) < 30 Then
  43. 尺寸取整
  44. ElseIf Abs(X - pos_x(1)) < 30 And Abs(Y - pos_Y(2)) < 30 Then
  45. Dim r As Long
  46. ElseIf Abs(X - pos_x(2)) < 30 And Abs(Y - pos_Y(2)) < 30 Then
  47. WebHelp
  48. ElseIf Abs(X - pos_x(3)) < 30 And Abs(Y - pos_Y(2)) < 30 Then
  49. WebHelp
  50. ElseIf Abs(X - pos_x(4)) < 30 And Abs(Y - pos_Y(2)) < 30 Then
  51. WebHelp
  52. End If
  53. End Sub
  54. Function WebHelp()
  55. Dim h As Long, r As Long
  56. h = FindWindow(vbNullString, "262235.xyz 老人关怀版 By 蘭雅sRGB 2022")
  57. r = ShellExecute(h, "", "https://262235.xyz", "", "", 1)
  58. End Function
  59. Private Sub 绘制矩形()
  60. 剪贴板尺寸建立矩形.start
  61. End Sub
  62. Private Sub 角线爬虫()
  63. 裁切线.SelectLine_to_Cropline
  64. End Sub
  65. Private Sub 矩形拼版()
  66. 拼版裁切线.arrange
  67. End Sub
  68. Private Sub 批量替换()
  69. 智能群组和查找.剪贴板物件替换
  70. End Sub
  71. Private Sub 拼版标记()
  72. 自动中线色阶条.Auto_ColorMark
  73. End Sub
  74. Private Sub 拼版角线()
  75. 拼版裁切线.Cut_lines
  76. End Sub
  77. Private Sub 物件角线()
  78. 裁切线.start
  79. End Sub
  80. Private Sub 智能群组()
  81. 智能群组和查找.智能群组
  82. End Sub
  83. Private Sub CQL选择()
  84. CQL查找相同.属性选择
  85. End Sub
  86. Private Sub 居中页面()
  87. ' 实践应用: 选择物件群组,页面设置物件大小,物件页面居中
  88. ActiveDocument.Unit = cdrMillimeter
  89. Dim OrigSelection As ShapeRange, sh As Shape
  90. Set OrigSelection = ActiveSelectionRange
  91. Set sh = OrigSelection.Group
  92. ' MsgBox "选择物件尺寸: " & sh.SizeWidth & "x" & sh.SizeHeight
  93. ActivePage.SetSize Int(sh.SizeWidth + 0.9), Int(sh.SizeHeight + 0.9)
  94. sh.AlignToPageCenter cdrAlignHCenter + cdrAlignVCenter
  95. End Sub
  96. Private Sub 尺寸取整()
  97. ActiveDocument.Unit = cdrMillimeter
  98. Dim sh As Shape, shs As Shapes
  99. Set shs = ActiveSelection.Shapes
  100. Dim s As String, size As String
  101. For Each sh In shs
  102. size = Int(sh.SizeWidth + 0.5) & "x" & Int(sh.SizeHeight + 0.5) & "mm"
  103. sh.SetSize Int(sh.SizeWidth + 0.5), Int(sh.SizeHeight + 0.5)
  104. s = s & size & vbNewLine
  105. Next sh
  106. MsgBox "物件尺寸信息到剪贴板" & vbNewLine & s
  107. API.WriteClipBoard s
  108. End Sub