Projects

MSN/Windows Messenger Popup Effects

January 23, 2003 by Java

Browsing vb/MainMod.bas (4.68 KB)

Attribute VB_Name = "MainMod"

Public Declare Function SetHook Lib "cbtcwhk.dll" (ByVal hWnd As Long) As Long
Public Declare Function RemoveHook Lib "cbtcwhk.dll" () As Long

Private Declare Function GetVersionEx Lib "kernel32" Alias "GetVersionExA" (lpVersionInformation As OSVERSIONINFO) As Long

Private Type OSVERSIONINFO
    dwOSVersionInfoSize As Long
    dwMajorVersion As Long
    dwMinorVersion As Long
    dwBuildNumber As Long
    dwPlatformId As Long
    szCSDVersion As String * 128
End Type

Private Const WM_USER = &H400

Private Declare Function SetLayeredWindowAttributes Lib "user32" (ByVal hWnd As Long, ByVal crKey As Long, ByVal bAlpha As Long, ByVal dwFlags As Long) As Long
Private Const LWA_COLORKEY = &H1&
Private Const LWA_ALPHA = &H2&

Private Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal hWnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam 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 Const GWL_WNDPROC = (-4)
Private Const GWL_EXSTYLE = (-20)
Private Const WS_EX_LAYERED = &H80000

Private Declare Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hWnd As Long, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long
Private Declare Function GetParent Lib "user32" (ByVal hWnd As Long) As Long
Private Declare Function IsWindowVisible Lib "user32" (ByVal hWnd As Long) As Long
Private Declare Function PostMessage Lib "user32" Alias "PostMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long

Private Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long

Private Const SM_SWAPBUTTON = 23

Private Const WM_LBUTTONDOWN = &H201
Private Const WM_LBUTTONUP = &H202
Private Const WM_RBUTTONDOWN = &H204
Private Const WM_RBUTTONUP = &H205

Private OldWindowProc As Long

Public NewWnd As Long

Public Function IsMouseSwapped() As Boolean
    IsMouseSwapped = GetSystemMetrics(SM_SWAPBUTTON)
End Function

Public Sub ClosePopup(hWnd As Long)
    If IsMouseSwapped() = False Then
        PostMessage hWnd, WM_RBUTTONDOWN, 0&, ByVal 0&
        PostMessage hWnd, WM_RBUTTONUP, 0&, ByVal 0&
    Else
        PostMessage hWnd, WM_LBUTTONDOWN, 0&, ByVal 0&
        PostMessage hWnd, WM_LBUTTONUP, 0&, ByVal 0&
    End If
End Sub


Public Function GetWndClassName(hWnd As Long) As String
Dim sTmp As String
    sTmp = String(100, vbNullChar)
    GetClassName hWnd, sTmp, Len(sTmp)
    If InStr(sTmp, vbNullChar) Then sTmp = Left(sTmp, InStr(sTmp, vbNullChar) - 1)
    GetWndClassName = sTmp
End Function


Public Function WindowProc(ByVal hWnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
On Error Resume Next
    If Msg = WM_USER + &H3039 Then
        NewWnd = wParam
        MainForm.PostCreateTimer.Enabled = True
        WindowProc = 0
        Exit Function
    End If
    WindowProc = CallWindowProc(OldWindowProc, hWnd, Msg, wParam, lParam)
End Function

Public Function SetWindowTranslucency(ByVal hWnd As Long, ByVal Alpha As Byte) As Boolean
Dim nStyle As Long
    hWnd = GetTopLevel(hWnd)
    nStyle = GetWindowLong(hWnd, GWL_EXSTYLE) Or WS_EX_LAYERED
    If SetWindowLong(hWnd, GWL_EXSTYLE, nStyle) Then
        SetWindowTranslucency = CBool(SetLayeredWindowAttributes(hWnd, 0, CLng(Alpha), LWA_ALPHA))
    End If
End Function

Private Function GetTopLevel(ByVal hChild As Long) As Long
Dim hWnd As Long
   hWnd = hChild
   Do While IsWindowVisible(GetParent(hWnd))
      hWnd = GetParent(hChild)
      hChild = hWnd
   Loop
   GetTopLevel = hWnd
End Function

Public Sub SubClass(hWnd As Long)
On Error Resume Next
    OldWindowProc = SetWindowLong(hWnd, GWL_WNDPROC, AddressOf WindowProc)
End Sub

Public Sub UnSubClass(hWnd As Long)
    If OldWindowProc <> 0 Then SetWindowLong hWnd, GWL_WNDPROC, OldWindowProc
    OldWindowProc = 0
End Sub


Public Function IsCompatible() As Boolean
Dim verinfo As OSVERSIONINFO
    verinfo.dwOSVersionInfoSize = Len(verinfo)
    GetVersionEx verinfo
    If verinfo.dwMajorVersion >= 5 Then
        IsCompatible = True
    Else
        IsCompatible = False
    End If
End Function

Sub Main()
    If IsCompatible() = False Then
        MsgBox "You cannot use this program with Windows 95/98/ME." + vbCrLf + vbCrLf + "Upgrade to Windows 2000/XP.", vbExclamation
        Exit Sub
    Else
        MainForm.Show
    End If
End Sub

Download vb/MainMod.bas

Back to file list

---

Back to project page