assoutil.bas

很不错的vb源码

Attribute VB_Name = "basAssoUtil"
' AssoUtil.bas
'
' Note: In VB, any code to call a function pointer must be placed in a BAS module. Because
' a function pointer is used to enable passing the address of one of our functions as an
' argument to another function, the functions contained herein must stay in this BAS.
' One can pass a function pointer to an argument that is typed As Any or As Long. (If you
' create your own call-back function prototypes in DLLs compiled with VC or a similar tool,
' to work with AddressOf your prototype must use the __stdcall calling convention, not the
' default _cdecl.)
'
' Default ShowInTaskBar property of the form is True, don't change it to False, so that if
' the user does not set the icon in system tray, the minimized form is visible.
'
Option Explicit

Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" _
    (ByVal lpPrevWndFunc As Long, ByVal hwnd As Long, ByVal Msg As Long, _
    ByVal wParam As Long, ByVal lParam As Long) As Long
Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" _
    (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Declare Function Shell_NotifyIconA Lib "SHELL32" (ByVal dwMessage As Long, _
    lpData As NOTIFYICONDATA) As Long
Declare Sub SHChangeNotify Lib "shell32.dll" (ByVal wEventId As Long, _
            ByVal uFlags As Long, dwItem1 As Any, dwItem2 As Any)
            
Global Const WM_MOUSEMOVE = &H200
Public Const WM_LBUTTONUP = &H202
Public Const WM_RBUTTONUP = &H205
Public Const WM_MBUTTONUP = &H208
Public Const WM_USER = &H400
Public Const GWL_WNDPROC = (-4)
Public Const GWL_USERDATA = (-21)
Public Const MSG_ADD = &H0
Public Const MSG_MODIFY = &H1
Public Const MSG_DELETE = &H2
Public Const NIF_MESSAGE = &H1
Public Const NIF_ICON = &H2
Public Const NIF_TIP = &H4
Public Const TRAY_CALLBACK = (WM_USER + 1001&)
Public Const ICON_IDLIST = &H0
Public Const ICON_ASSOCCHANGED = &H8000000

Type NOTIFYICONDATA
    cbSize As Long
    hwnd As Long
    uID As Long
    uFlags As Long
    uCallbackMessage As Long
    hIcon As Long
    szTip As String * 64
End Type

Dim theFormWinState As Integer
Dim theWindProc As Long
Dim theForm As Form
Dim theMenu As Menu
Dim typNID As NOTIFYICONDATA




Sub AddIconToTray(inWinState As Integer, inForm As Form, inMenu As Menu, inTip As String)
      ' Note down the values of WindowState,form and menu first
    theFormWinState = inWinState
    Set theForm = inForm
    Set theMenu = inMenu
      ' Install the new WindowProc.
      ' SetWindowLong creates the subclass by changing the window procedure associated
      ' with a particular window, causing the system to call the new window procedure
      ' instead of the previous one. An application must pass any messages not
      ' processed by the new window procedure to the previous window procedure by
      ' calling CallWindowProc. This allows the application to create a chain of
      ' window procedures.
    theWindProc = SetWindowLong(inForm.hwnd, GWL_WNDPROC, AddressOf NewWindowProc)
    
      ' Install the form's icon in the tray.
    With typNID
        .cbSize = Len(typNID)
        .hwnd = inForm.hwnd
        .uID = 0
        .uFlags = NIF_ICON Or NIF_MESSAGE Or NIF_TIP
        .uCallbackMessage = TRAY_CALLBACK
        .hIcon = inForm.Icon.Handle          '  Or just .hIcon = inForm.Icon
        .szTip = inTip & vbNullChar
    End With
    Shell_NotifyIconA MSG_ADD, typNID
End Sub



   ' A replacement of window procedure.
   ' Use CallWindowProc for window subclassing (Usually, all windows with the same class
   ' share one window procedure. A subclass is a window or set of windows with the same
   ' class whose messages are intercepted and processed by another window procedure
   ' before being passed to the window procedure of the class).
Function NewWindowProc(ByVal hwnd As Long, ByVal Msg As Long, _
        ByVal wParam As Long, ByVal lParam As Long) As Long
    If Msg = TRAY_CALLBACK Then
         If lParam = WM_LBUTTONUP Then           ' Left click icon
             If theForm.WindowState = vbMinimized Then
                  theForm.WindowState = vbNormal
             Else
                  theForm.WindowState = theFormWinState
             End If
                ' As we have the form hidden when minimized, ensure to show it again
             theForm.Show
             theForm.SetFocus
             Exit Function
         End If
         If lParam = WM_RBUTTONUP Then           ' Right click icon
             theForm.PopupMenu theMenu           ' Make use of a menu as popup
             Exit Function
         End If
    End If
      ' Pass info to the specified window procedure
    NewWindowProc = CallWindowProc(theWindProc, hwnd, Msg, wParam, lParam)
End Function



Sub RemoveIconFromTray()
    With typNID
        .uFlags = 0
    End With
    Shell_NotifyIconA MSG_DELETE, typNID
       ' Restore the original window procedure
    SetWindowLong theForm.hwnd, GWL_WNDPROC, theWindProc
End Sub



Function IsFileThere(inFileSpec As String) As Boolean
    On Error Resume Next
    Dim i
    i = FreeFile
    Open inFileSpec For Input As i
    If Err Then
        IsFileThere = False
    Else
        Close i
        IsFileThere = True
    End If
End Function



Sub ErrMsgProc(mMsg As String)
    MsgBox mMsg & vbCrLf & Err.Number & Space(5) & Err.Description
End Sub