candybutton.ctl

支持监控包括传输控制协议和 UDP 的所有的互联网传输协议。同时程序具有实时文件防修改监控功能

'/ Init_Style                                                                       /
'/ -------------------                                                              /
'/ Description:                                                                     /
'/                                                                                  /
'/ Init_Style will create the window region according to the button style           /
'/ and will be responsible of storing the same region (but without the border)      /
'/ in hButtonRegion. This will be used later to determine if a point                /
'/ is inside the button region.                                                     /
'/----------------------------------------------------------------------------------/
Private Sub Init_Style()
Dim lCornerRad As Long
'Remove the older Region
    If hButtonRegion Then
        DeleteObject hButtonRegion
    End If
    Select Case m_Style
    Case Crystal, WMP, Mac_Variation
        lCornerRad = SetBound(ScaleHeight \ 2 + 1, 1, ScaleWidth \ 2)
    Case Mac
        lCornerRad = 12
    Case Iceblock
        lCornerRad = SetBound(ScaleHeight \ 4 + 1, 1, ScaleWidth \ 4)
    Case Plastic
        lCornerRad = SetBound(ScaleHeight \ 3, 1, ScaleWidth \ 3)
    End Select
    If m_Style = Crystal Or m_Style = WMP Or m_Style = Mac Or m_Style = Mac_Variation Or m_Style = Plastic Or m_Style = Iceblock Then
        hButtonRegion = CreateRoundedRegion(0, 0, ScaleWidth, ScaleHeight, lCornerRad)
'Set the Button Region
        Call SetWindowRgn(hWnd, hButtonRegion, True)
        DeleteObject hButtonRegion
'Store the region but exclude the border
        hButtonRegion = CreateRoundedRegion(1, 1, ScaleWidth - 2, ScaleHeight - 2, lCornerRad)
    Else
        Call SetWindowRgn(hWnd, 0, True)
    End If
    UserControl.Picture = LoadPicture("")
End Sub
'Determine if the passed function is supported
Private Function IsFunctionExported(ByVal sFunction As String, _
                                    ByVal sModule As String) As Boolean
Dim hMod       As Long
Dim bLibLoaded As Boolean
    hMod = GetModuleHandleA(sModule)
    If hMod = 0 Then
        hMod = LoadLibraryA(sModule)
        If hMod Then
            bLibLoaded = True
        End If
    End If
    If hMod Then
        If GetProcAddress(hMod, sFunction) Then
            IsFunctionExported = True
        End If
    End If
    If bLibLoaded Then
        FreeLibrary hMod
    End If
End Function
Private Function IsInCircle(ByRef X As Long, _
                            ByRef Y As Long, _
                            ByRef r As Long) As Boolean
Dim lResult As Long
'/* this detect a circunference centered on y=-r and x=0
    lResult = (r * r) - (X * X)
    If lResult >= 0 Then
        lResult = Sqr(lResult)
        If Abs(Y - r) < lResult Then
            IsInCircle = True
        End If
    End If
End Function
Private Function IsInRoundRect(i As Long, _
                               j As Long, _
                               X As Long, _
                               Y As Long, _
                               lWidth As Long, _
                               lHeight As Long, _
                               Radius As Long) As Boolean
Dim offX As Long
Dim offY As Long
    offX = i - X
    offY = j - Y
    If offY > Radius And offY + Radius < lHeight And offX > Radius And offX + Radius < lWidth Then
'/* This is to catch early most cases
        IsInRoundRect = True
    ElseIf offX < Radius And offY <= Radius Then
        If IsInCircle(offX - Radius, offY, Radius) Then
            IsInRoundRect = True
        End If
    ElseIf offX + Radius > lWidth And offY <= Radius Then
        If IsInCircle(offX - lWidth + Radius, offY, Radius) Then
            IsInRoundRect = True
        End If
    ElseIf offX < Radius And offY + Radius >= lHeight Then
        If IsInCircle(offX - Radius, offY - lHeight + Radius * 2, Radius) Then
            IsInRoundRect = True
        End If
    ElseIf offX + Radius > lWidth And offY + Radius >= lHeight Then
        If IsInCircle(offX - lWidth + Radius, offY - lHeight + Radius * 2, Radius) Then
            IsInRoundRect = True
        End If
    Else
        If offX > 0 Then
            If offX < lWidth Then
                If offY > 0 Then
                    If offY < lHeight Then
                        IsInRoundRect = True
                    End If
                End If
            End If
        End If
    End If
End Function
Private Function LoWord(lDWord As Long) As Integer
    If lDWord And &H8000& Then
        LoWord = lDWord Or &HFFFF0000
    Else
        LoWord = lDWord And &HFFFF&
    End If
End Function
Public Property Get Picture() As StdPicture
    Set Picture = m_StdPicture
End Property
Public Property Set Picture(Value As StdPicture)
    Set m_StdPicture = Value
    PropertyChanged "Picture"
    DrawButton (eNormal)
End Property
Public Property Get PictureAlignment() As eAlignment
    PictureAlignment = m_PictureAlignment
End Property
Public Property Let PictureAlignment(eVal As eAlignment)
    If eVal <> m_PictureAlignment Then
        m_PictureAlignment = eVal
        PropertyChanged "PictureAlignment"
        DrawButton (eNormal)
    End If
End Property
'Add the message value to the window handle's specified callback table
Private Sub sc_AddMsg(ByVal lng_hWnd As Long, _
                      ByVal uMsg As Long, _
                      Optional ByVal When As eMsgWhen = eMsgWhen.MSG_AFTER)
    If IsBadCodePtr(zMap_hWnd(lng_hWnd)) = 0 Then
                             'Ensure that the thunk hasn't already released its memory
        If When And MSG_BEFORE Then
                                             'If the message is to be added to the before original WndProc table...
            zAddMsg uMsg, IDX_BTABLE
                                              'Add the message to the before table
        End If
        If When And MSG_AFTER Then
                                              'If message is to be added to the after original WndProc table...
            zAddMsg uMsg, IDX_ATABLE
                                              'Add the message to the after table
        End If
    End If
End Sub
'Call the original WndProc
Private Function sc_CallOrigWndProc(ByVal lng_hWnd As Long, _
                                    ByVal uMsg As Long, _
                                    ByVal wParam As Long, _
                                    ByVal lParam As Long) As Long
    If IsBadCodePtr(zMap_hWnd(lng_hWnd)) = 0 Then
                             'Ensure that the thunk hasn't already released its memory
        sc_CallOrigWndProc = CallWindowProcA(zData(IDX_WNDPROC), lng_hWnd, uMsg, wParam, lParam)
 'Call the original WndProc of the passed window handle parameter
    End If
End Function
'Delete the message value from the window handle's specified callback table
Private Sub sc_DelMsg(ByVal lng_hWnd As Long, _
                      ByVal uMsg As Long, _
                      Optional ByVal When As eMsgWhen = eMsgWhen.MSG_AFTER)
    If IsBadCodePtr(zMap_hWnd(lng_hWnd)) = 0 Then
                             'Ensure that the thunk hasn't already released its memory
        If When And MSG_BEFORE Then
                                             'If the message is to be deleted from the before original WndProc table...
            zDelMsg uMsg, IDX_BTABLE
                                              'Delete the message from the before table
        End If
        If When And MSG_AFTER Then
                                              'If the message is to be deleted from the after original WndProc table...
            zDelMsg uMsg, IDX_ATABLE
                                              'Delete the message from the after table
        End If
    End If
End Sub
'Get the subclasser lParamUser callback parameter
Private Property Get sc_lParamUser(ByVal lng_hWnd As Long) As Long
    If IsBadCodePtr(zMap_hWnd(lng_hWnd)) = 0 Then
                             'Ensure that the thunk hasn't already released its memory
        sc_lParamUser = zData(IDX_PARM_USER)
                                    'Get the lParamUser callback parameter
    End If
End Property
'Let the subclasser lParamUser callback parameter
Private Property Let sc_lParamUser(ByVal lng_hWnd As Long, _
                                   ByVal NewValue As Long)
    If IsBadCodePtr(zMap_hWnd(lng_hWnd)) = 0 Then
                             'Ensure that the thunk hasn't already released its memory
        zData(IDX_PARM_USER) = NewValue
                                         'Set the lParamUser callback parameter
    End If
End Property
'-SelfSub code------------------------------------------------------------------------------------
Private Function sc_Subclass(ByVal lng_hWnd As Long, _
                             Optional ByVal lParamUser As Long = 0, _
                             Optional ByVal nOrdinal As Long = 1, _
                             Optional ByVal oCallback As Object = Nothing, _
                             Optional ByVal bIdeSafety As Boolean = True) As Boolean 'Subclass the specified window handle
'*************************************************************************************************
'* lng_hWnd   - Handle of the window to subclass
'* lParamUser - Optional, user-defined callback parameter
'* nOrdinal   - Optional, ordinal index of the callback procedure. 1 = last private method, 2 = second last private method, etc.
'* oCallback  - Optional, the object that will receive the callback. If undefined, callbacks are sent to this object's instance
'* bIdeSafety - Optional, enable/disable IDE safety measures. NB: you should really only disable IDE safety in a UserControl for design-time subclassing
'*************************************************************************************************
Const CODE_LEN     As Long = 260                             'Thunk length in bytes
Const MEM_LEN      As Long = CODE_LEN + (8 * (MSG_ENTRIES + 1))
  'Bytes to allocate per thunk, data + code + msg tables
Const PAGE_RWX     As Long = &H40&                           'Allocate executable memory
Const MEM_COMMIT   As Long = &H1000&                         'Commit allocated memory
Const MEM_RELEASE  As Long = &H8000&                         'Release allocated memory flag
Const IDX_EBMODE   As Long = 3
                               'Thunk data index of the EbMode function address
Const IDX_CWP      As Long = 4
                               'Thunk data index of the CallWindowProc function address
Const IDX_SWL      As Long = 5
                               'Thunk data index of the SetWindowsLong function address
Const IDX_FREE     As Long = 6
                               'Thunk data index of the VirtualFree function address
Const IDX_BADPTR   As Long = 7
                               'Thunk data index of the IsBadCodePtr function address
Const IDX_OWNER    As Long = 8
                               'Thunk data index of the Owner object's vTable address
Const IDX_CALLBACK As Long = 10
                              'Thunk data index of the callback method address
Const IDX_EBX      As Long = 16
                              'Thunk code patch index of the thunk data
Const SUB_NAME     As String = "sc_Subclass"                 'This routine's name
Dim nAddr          As Long
Dim nID            As Long
Dim nMyID          As Long
    If IsWindow(lng_hWnd) = 0 Then
                                            'Ensure the window handle is valid
        zError SUB_NAME, "Invalid window handle"
        Exit Function
    End If
    nMyID = GetCurrentProcessId
                                               'Get this process's ID
    GetWindowThreadProcessId lng_hWnd, nID
                                    'Get the process ID associated with the window handle
    If nID <> nMyID Then
                                                      'Ensure that the window handle doesn't belong to another process
        zError SUB_NAME, "Window handle belongs to another process"
        Exit Function
    End If
    If oCallback Is Nothing Then
                                              'If the user hasn't specified the callback owner
        Set oCallback = Me                                                      'Then it is me
    End If
    nAddr = zAddressOf(oCallback, nOrdinal)
                                   'Get the address of the specified ordinal method
    If nAddr = 0 Then
                                                         'Ensure that we've found the ordinal method
        zError SUB_NAME, "Callback method not found"
        Exit Function
    End If
    If z_Funk Is Nothing Then
                                                 'If this is the first time through, do the one-time initialization
        Set z_Funk = New Collection
                                             'Create the hWnd/thunk-address collection
        z_Sc(14) = &HD231C031
        z_Sc(15) = &HBBE58960
        z_Sc(17) = &H4339F631
        z_Sc(18) = &H4A21750C
        z_Sc(19) = &HE82C7B8B
        z_Sc(20) = &H74&
        z_Sc(21) = &H75147539
        z_Sc(22) = &H21E80F
        z_Sc(23) = &HD2310000
        z_Sc(24) = &HE8307B8B
        z_Sc(25) = &H60&
        z_Sc(26) = &H10C261
        z_Sc(27) = &H830C53FF
        z_Sc(28) = &HD77401F8
        z_Sc(29) = &H2874C085
        z_Sc(30) = &H2E8&
        z_Sc(31) = &HFFE9EB00
        z_Sc(32) = &H75FF3075
        z_Sc(33) = &H2875FF2C
        z_Sc(34) = &HFF2475FF
        z_Sc(35) = &H3FF2473
        z_Sc(36) = &H891053FF
        z_Sc(37) = &HBFF1C45
        z_Sc(38) = &H73396775
        z_Sc(39) = &H58627404
        z_Sc(40) = &H6A2473FF
        z_Sc(41) = &H873FFFC
        z_Sc(42) = &H891453FF
        z_Sc(43) = &H7589285D
        z_Sc(44) = &H3045C72C