1
1

CQL_FIND_UI.frm 8.7 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274
  1. VERSION 5.00
  2. Begin {C62A69F0-16DC-11CE-9E98-00AA00574A4F} CQL_FIND_UI
  3. ClientHeight = 7830
  4. ClientLeft = 45
  5. ClientTop = 330
  6. ClientWidth = 11610
  7. OleObjectBlob = "CQL_FIND_UI.frx":0000
  8. StartUpPosition = 1 'CenterOwner
  9. End
  10. Attribute VB_Name = "CQL_FIND_UI"
  11. Attribute VB_GlobalNameSpace = False
  12. Attribute VB_Creatable = False
  13. Attribute VB_PredeclaredId = True
  14. Attribute VB_Exposed = False
  15. '// This is free and unencumbered software released into the public domain.
  16. '// For more information, please refer to https://github.com/hongwenjun
  17. #If VBA7 Then
  18. Private Declare PtrSafe Function DrawMenuBar Lib "user32" (ByVal hwnd As Long) As Long
  19. Private Declare PtrSafe Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
  20. Private Declare PtrSafe Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
  21. Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
  22. Private Declare PtrSafe Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
  23. #Else
  24. Private Declare Function DrawMenuBar Lib "user32" (ByVal hwnd As Long) As Long
  25. Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
  26. Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
  27. Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
  28. Private Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
  29. #End If
  30. Private Const GWL_STYLE As Long = (-16)
  31. Private Const GWL_EXSTYLE = (-20)
  32. Private Const WS_CAPTION As Long = &HC00000
  33. Private Const WS_EX_DLGMODALFRAME = &H1&
  34. Private Sub UserForm_Initialize()
  35. Dim IStyle As Long
  36. Dim hwnd As Long
  37. hwnd = FindWindow("ThunderDFrame", Me.Caption)
  38. IStyle = GetWindowLong(hwnd, GWL_STYLE)
  39. IStyle = IStyle And Not WS_CAPTION
  40. SetWindowLong hwnd, GWL_STYLE, IStyle
  41. DrawMenuBar hwnd
  42. IStyle = GetWindowLong(hwnd, GWL_EXSTYLE) And Not WS_EX_DLGMODALFRAME
  43. SetWindowLong hwnd, GWL_EXSTYLE, IStyle
  44. With Me
  45. ' .StartUpPosition = 0
  46. ' .Left = 500
  47. ' .Top = 200
  48. .width = 378
  49. .Height = 228
  50. End With
  51. LNG_CODE = API.GetLngCode
  52. Init_Translations Me, LNG_CODE
  53. If LNG_CODE = 1033 Then
  54. txtInfo.text = "Usage: A->Left B->Right C->Ctrl"
  55. Else
  56. txtInfo.text = "使用: A->左键 B->右键 C->Ctrl键"
  57. End If
  58. End Sub
  59. Private Sub LOGO_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
  60. If Button Then
  61. mx = X
  62. my = Y
  63. End If
  64. End Sub
  65. Private Sub LOGO_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
  66. If Button Then
  67. '// Debug.Print X, Y
  68. Me.Left = Me.Left - mx + X
  69. Me.Top = Me.Top - my + Y
  70. End If
  71. End Sub
  72. Private Sub Image1_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
  73. Dim pos_x As Variant
  74. Dim pos_y As Variant
  75. pos_x = Array(307, 27)
  76. pos_y = Array(64, 126, 188, 200)
  77. If Abs(X - pos_x(0)) < 30 And Abs(Y - pos_y(0)) < 30 Then
  78. Call CQLSameUniformColor
  79. ElseIf Abs(X - pos_x(0)) < 30 And Abs(Y - pos_y(1)) < 30 Then
  80. Call CQLSameOutlineColor
  81. ElseIf Abs(X - pos_x(0)) < 30 And Abs(Y - pos_y(2)) < 30 Then
  82. Call CQLSameSize
  83. ElseIf Abs(X - pos_x(1)) < 30 And Abs(Y - pos_y(3)) < 30 Then
  84. '// WebHelp "https://262235.xyz/index.php/tag/vba/"
  85. End If
  86. '// 预置颜色轮廓选择 和 '// 彩蛋功能
  87. If Abs(X - 178) < 30 And Abs(Y - 118) < 30 = True Then
  88. Image1.Visible = False
  89. Close_Icon.Visible = False
  90. X_EXIT.Visible = True
  91. With CQL_FIND_UI
  92. .StartUpPosition = 0
  93. .Left = Val(GetSetting("LYVBA", "Settings", "Left", "400")) + 318
  94. .Top = Val(GetSetting("LYVBA", "Settings", "Top", "55")) - 2
  95. .Height = 30
  96. .width = .width - 20
  97. End With
  98. If OptBt.value Then
  99. frmSelectSame.Show 0
  100. Else
  101. CQLFindSame.CQLline_CM100
  102. End If
  103. Exit Sub
  104. End If
  105. CQL_FIND_UI.Hide
  106. End Sub
  107. Private Sub MADD_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
  108. If Button = 2 Then
  109. Store_Instruction 2, "add"
  110. ElseIf Shift = fmCtrlMask Then
  111. Store_Instruction 1, "add"
  112. Else
  113. Store_Instruction 3, "add"
  114. End If
  115. txtInfo.text = StoreCount
  116. End Sub
  117. Private Sub MSUB_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
  118. If Button = 2 Then
  119. Store_Instruction 2, "sub"
  120. ElseIf Shift = fmCtrlMask Then
  121. Store_Instruction 1, "sub"
  122. Else
  123. Store_Instruction 3, "sub"
  124. End If
  125. txtInfo.text = StoreCount
  126. End Sub
  127. Private Sub MRLW_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
  128. If Button = 2 Then
  129. Store_Instruction 2, "lw"
  130. ElseIf Shift = fmCtrlMask Then
  131. Store_Instruction 1, "lw"
  132. Else
  133. Store_Instruction 3, "lw"
  134. End If
  135. txtInfo.text = StoreCount
  136. End Sub
  137. Private Sub MZERO_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
  138. If Button = 2 Then
  139. Store_Instruction 2, "zero"
  140. ElseIf Shift = fmCtrlMask Then
  141. Store_Instruction 1, "zero"
  142. Else
  143. Store_Instruction 3, "zero"
  144. End If
  145. txtInfo.text = StoreCount
  146. End Sub
  147. Private Sub CQLSameSize()
  148. ActiveDocument.Unit = cdrMillimeter
  149. Dim s As Shape
  150. Set s = ActiveShape
  151. If s Is Nothing Then Exit Sub
  152. If OptBt.value = True Then
  153. ActiveDocument.ClearSelection
  154. OptBt.value = 0
  155. CQL_FIND_UI.Hide
  156. Dim x1 As Double, y1 As Double, x2 As Double, y2 As Double
  157. Dim Shift As Long
  158. Dim box As Boolean
  159. box = ActiveDocument.GetUserArea(x1, y1, x2, y2, Shift, 10, False, cdrCursorWeldSingle)
  160. If Not b Then
  161. ' MsgBox "选区范围: " & x1 & y1 & x2 & y2
  162. Set sh = ActivePage.SelectShapesFromRectangle(x1, y1, x2, y2, False)
  163. sh.Shapes.FindShapes(Query:="@width = {" & s.SizeWidth & " mm} and @height ={" & s.SizeHeight & "mm}").CreateSelection
  164. End If
  165. Else
  166. ActivePage.Shapes.FindShapes(Query:="@width = {" & s.SizeWidth & " mm} and @height ={" & s.SizeHeight & "mm}").CreateSelection
  167. End If
  168. End Sub
  169. Private Sub CQLSameOutlineColor()
  170. On Error GoTo err
  171. Dim colr As New Color, s As Shape
  172. Set s = ActiveShape
  173. If s Is Nothing Then Exit Sub
  174. colr.CopyAssign s.Outline.Color
  175. colr.ConvertToRGB
  176. ' 查找对象
  177. r = colr.RGBRed
  178. G = colr.RGBGreen
  179. b = colr.RGBBlue
  180. If OptBt.value = True Then
  181. ActiveDocument.ClearSelection
  182. OptBt.value = 0
  183. CQL_FIND_UI.Hide
  184. Dim x1 As Double, y1 As Double, x2 As Double, y2 As Double
  185. Dim Shift As Long
  186. Dim box As Boolean
  187. box = ActiveDocument.GetUserArea(x1, y1, x2, y2, Shift, 10, False, cdrCursorWeldSingle)
  188. If Not b Then
  189. ' MsgBox "选区范围: " & x1 & y1 & x2 & y2
  190. Set sh = ActivePage.SelectShapesFromRectangle(x1, y1, x2, y2, False)
  191. sh.Shapes.FindShapes(Query:="@Outline.Color.rgb[.r='" & r & "' And .g='" & G & "' And .b='" & b & "']").CreateSelection
  192. End If
  193. Else
  194. ActivePage.Shapes.FindShapes(Query:="@Outline.Color.rgb[.r='" & r & "' And .g='" & G & "' And .b='" & b & "']").CreateSelection
  195. End If
  196. Exit Sub
  197. err:
  198. MsgBox "对象轮廓为空。"
  199. End Sub
  200. Private Sub CQLSameUniformColor()
  201. On Error GoTo err
  202. Dim colr As New Color, s As Shape
  203. Set s = ActiveShape
  204. If s Is Nothing Then Exit Sub
  205. If s.Fill.Type = cdrFountainFill Then MsgBox "不支持渐变色。": Exit Sub
  206. colr.CopyAssign s.Fill.UniformColor
  207. colr.ConvertToRGB
  208. ' 查找对象
  209. r = colr.RGBRed
  210. G = colr.RGBGreen
  211. b = colr.RGBBlue
  212. If OptBt.value = True Then
  213. ActiveDocument.ClearSelection
  214. OptBt.value = 0
  215. CQL_FIND_UI.Hide
  216. Dim x1 As Double, y1 As Double, x2 As Double, y2 As Double
  217. Dim Shift As Long
  218. Dim box As Boolean
  219. box = ActiveDocument.GetUserArea(x1, y1, x2, y2, Shift, 10, False, cdrCursorWeldSingle)
  220. If Not b Then
  221. '// MsgBox "选区范围: " & x1 & y1 & x2 & y2
  222. Set sh = ActivePage.SelectShapesFromRectangle(x1, y1, x2, y2, False)
  223. sh.Shapes.FindShapes(Query:="@fill.color.rgb[.r='" & r & "' And .g='" & G & "' And .b='" & b & "']").CreateSelection
  224. End If
  225. Else
  226. ActivePage.Shapes.FindShapes(Query:="@fill.color.rgb[.r='" & r & "' And .g='" & G & "' And .b='" & b & "']").CreateSelection
  227. End If
  228. Exit Sub
  229. err:
  230. MsgBox "对象填充为空。"
  231. End Sub
  232. Private Sub X_EXIT_Click()
  233. Unload Me '// 关闭
  234. End Sub
  235. Private Sub Close_Icon_Click()
  236. Unload Me '// 关闭
  237. End Sub