corelvba/UI/CQL_FIND_UI.frm

VERSION 5.00
Begin {C62A69F0-16DC-11CE-9E98-00AA00574A4F} CQL_FIND_UI 
   ClientHeight    =   7830
   ClientLeft      =   45
   ClientTop       =   330
   ClientWidth     =   11610
   OleObjectBlob   =   "CQL_FIND_UI.frx":0000
   StartUpPosition =   1  'CenterOwner
End
Attribute VB_Name = "CQL_FIND_UI"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False

'// This is free and unencumbered software released into the public domain.
'// For more information, please refer to  https://github.com/hongwenjun

#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&


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 = 500
  '  .Top = 200
    .width = 378
    .Height = 228
  End With
  
  txtInfo.text = "Usage: A->Left B->Right C->Ctrl"
End Sub

Private Sub LOGO_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
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
'//  Debug.Print X, Y
    Me.Left = Me.Left - mx + X
    Me.Top = Me.Top - my + Y
  End If
End Sub

Private Sub Image1_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
  Dim pos_x As Variant
  Dim pos_y As Variant
  pos_x = Array(307, 27)
  pos_y = Array(64, 126, 188, 200)

  If Abs(X - pos_x(0)) < 30 And Abs(Y - pos_y(0)) < 30 Then
    Call CQLSameUniformColor
  ElseIf Abs(X - pos_x(0)) < 30 And Abs(Y - pos_y(1)) < 30 Then
    Call CQLSameOutlineColor
  ElseIf Abs(X - pos_x(0)) < 30 And Abs(Y - pos_y(2)) < 30 Then
    Call CQLSameSize
  ElseIf Abs(X - pos_x(1)) < 30 And Abs(Y - pos_y(3)) < 30 Then
'//   WebHelp "https://262235.xyz/index.php/tag/vba/"
  End If
  
    '// 预置颜色轮廓选择    和 '// 彩蛋功能
  If Abs(X - 178) < 30 And Abs(Y - 118) < 30 = True Then
    Image1.Visible = False
    Close_Icon.Visible = False
    X_EXIT.Visible = True
    
    With CQL_FIND_UI
      .StartUpPosition = 0
      .Left = Val(GetSetting("LYVBA", "Settings", "Left", "400")) + 318
      .Top = Val(GetSetting("LYVBA", "Settings", "Top", "55")) - 2
      .Height = 30
      .width = .width - 20
    End With
    
    If OptBt.value Then
      frmSelectSame.Show 0
    Else
      CQLFindSame.CQLline_CM100
    End If
    Exit Sub
  End If
  CQL_FIND_UI.Hide
End Sub

Private Sub MADD_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
  If Button = 2 Then
    Store_Instruction 2, "add"
  ElseIf Shift = fmCtrlMask Then
    Store_Instruction 1, "add"
  Else
    Store_Instruction 3, "add"
  End If
  txtInfo.text = StoreCount
End Sub

Private Sub MSUB_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
  If Button = 2 Then
    Store_Instruction 2, "sub"
  ElseIf Shift = fmCtrlMask Then
    Store_Instruction 1, "sub"
  Else
    Store_Instruction 3, "sub"
  End If
  txtInfo.text = StoreCount
End Sub

Private Sub MRLW_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
  If Button = 2 Then
    Store_Instruction 2, "lw"
  ElseIf Shift = fmCtrlMask Then
    Store_Instruction 1, "lw"
  Else
    Store_Instruction 3, "lw"
  End If
  txtInfo.text = StoreCount
End Sub

Private Sub MZERO_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
  If Button = 2 Then
    Store_Instruction 2, "zero"
  ElseIf Shift = fmCtrlMask Then
    Store_Instruction 1, "zero"
  Else
    Store_Instruction 3, "zero"
  End If
  txtInfo.text = StoreCount
End Sub



Private Sub CQLSameSize()
  ActiveDocument.Unit = cdrMillimeter
  Dim s As Shape
  Set s = ActiveShape
  If s Is Nothing Then Exit Sub
    
  If OptBt.value = True Then
    ActiveDocument.ClearSelection
    OptBt.value = 0
    CQL_FIND_UI.Hide
    
    Dim x1 As Double, y1 As Double, x2 As Double, y2 As Double
    Dim Shift As Long
    Dim box As Boolean
    box = ActiveDocument.GetUserArea(x1, y1, x2, y2, Shift, 10, False, cdrCursorWeldSingle)
    If Not b Then
      ' MsgBox "选区范围: " & x1 & y1 & x2 & y2
      Set sh = ActivePage.SelectShapesFromRectangle(x1, y1, x2, y2, False)
      sh.Shapes.FindShapes(Query:="@width = {" & s.SizeWidth & " mm} and @height ={" & s.SizeHeight & "mm}").CreateSelection
    End If
  Else
    ActivePage.Shapes.FindShapes(Query:="@width = {" & s.SizeWidth & " mm} and @height ={" & s.SizeHeight & "mm}").CreateSelection
  End If
End Sub

Private Sub CQLSameOutlineColor()
  On Error GoTo err
  Dim colr As New Color, s As Shape
  Set s = ActiveShape
  If s Is Nothing Then Exit Sub
  colr.CopyAssign s.Outline.Color
  colr.ConvertToRGB
  ' 查找对象
  r = colr.RGBRed
  G = colr.RGBGreen
  b = colr.RGBBlue
  
  If OptBt.value = True Then
    ActiveDocument.ClearSelection
    OptBt.value = 0
    CQL_FIND_UI.Hide
    
    Dim x1 As Double, y1 As Double, x2 As Double, y2 As Double
    Dim Shift As Long
    Dim box As Boolean
    box = ActiveDocument.GetUserArea(x1, y1, x2, y2, Shift, 10, False, cdrCursorWeldSingle)
    If Not b Then
      ' MsgBox "选区范围: " & x1 & y1 & x2 & y2
      Set sh = ActivePage.SelectShapesFromRectangle(x1, y1, x2, y2, False)
      sh.Shapes.FindShapes(Query:="@Outline.Color.rgb[.r='" & r & "' And .g='" & G & "' And .b='" & b & "']").CreateSelection
    End If
  Else
    ActivePage.Shapes.FindShapes(Query:="@Outline.Color.rgb[.r='" & r & "' And .g='" & G & "' And .b='" & b & "']").CreateSelection
  End If
  
  Exit Sub
err:
    MsgBox "对象轮廓为空。"
End Sub

Private Sub CQLSameUniformColor()
  On Error GoTo err
  Dim colr As New Color, s As Shape
  Set s = ActiveShape
  If s Is Nothing Then Exit Sub
  If s.Fill.Type = cdrFountainFill Then MsgBox "不支持渐变色。": Exit Sub
  colr.CopyAssign s.Fill.UniformColor
  colr.ConvertToRGB
  ' 查找对象
  r = colr.RGBRed
  G = colr.RGBGreen
  b = colr.RGBBlue
  
  If OptBt.value = True Then
    ActiveDocument.ClearSelection
    OptBt.value = 0
    CQL_FIND_UI.Hide
    
    Dim x1 As Double, y1 As Double, x2 As Double, y2 As Double
    Dim Shift As Long
    Dim box As Boolean
    box = ActiveDocument.GetUserArea(x1, y1, x2, y2, Shift, 10, False, cdrCursorWeldSingle)
    If Not b Then
      '// MsgBox "选区范围: " & x1 & y1 & x2 & y2
      Set sh = ActivePage.SelectShapesFromRectangle(x1, y1, x2, y2, False)
      sh.Shapes.FindShapes(Query:="@fill.color.rgb[.r='" & r & "' And .g='" & G & "' And .b='" & b & "']").CreateSelection
    End If
  Else
    ActivePage.Shapes.FindShapes(Query:="@fill.color.rgb[.r='" & r & "' And .g='" & G & "' And .b='" & b & "']").CreateSelection
  End If
  Exit Sub
err:
  MsgBox "对象填充为空。"
End Sub

Private Sub X_EXIT_Click()
  Unload Me    '// 关闭
End Sub

Private Sub Close_Icon_Click()
  Unload Me    '// 关闭
End Sub