api.bas

这是一个整点报时的小程序

Attribute VB_Name = "API"
Public Sound As New math1        '调用声音类
'延时
Public Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
'Download by http://www.codefans.net
Public Declare Function GetMenu Lib "user32" _
                        (ByVal hwnd As Long) As Long

'取得一个弹出式菜单的句柄，它位于菜单中指定的位置
Public Declare Function GetSubMenu Lib "user32" _
                        (ByVal hMenu As Long, _
                        ByVal nPos As Long) As Long

'用于设置一幅特定位图，令其在指定的菜单项中使用，代替标准的复选标记(√)。
Public Declare Function SetMenuItemBitmaps Lib "user32" _
                        (ByVal hMenu As Long, _
                        ByVal nPosition As Long, _
                        ByVal wFlags As Long, _
                        ByVal hBitmapUnchecked As Long, _
                        ByVal hBitmapChecked As Long) As Long

Public Const MF_BYPOSITION = &H400&  '代表菜单条目在菜单中的位置
'---------------------------------------------------------------
'防止程序重复执行

Public Declare Function ReleaseSemaphore Lib "kernel32" (ByVal hSemaphore As Long, ByVal lReleaseCount As Long, lpPreviousCount As Long) As Long
Public Declare Function CreateSemaphore Lib "kernel32" Alias "CreateSemaphoreA" (lpSemaphoreAttributes As SECURITY_ATTRIBUTES, ByVal lInitialCount As Long, ByVal lMaximumCount As Long, ByVal lpName As String) As Long
Public Declare Function WaitForSingleObject Lib "kernel32" (ByVal hHandle As Long, ByVal dwMilliseconds As Long) As Long
Public Type SECURITY_ATTRIBUTES
    nLength As Long
    lpSecurityDescriptor As Long
    bInheritHandle As Long
End Type
'---------------------------------------------------------------

'-注册表 API 声明...
'---------------------------------------------------------------

Public Declare Function RegOpenKey Lib "advapi32.dll" Alias "RegOpenKeyA" (ByVal hKey As Long, ByVal lpSubKey As String, phkResult As Long) As Long
Public Declare Function RegCloseKey Lib "advapi32" (ByVal hKey As Long) As Long
Public Declare Function RegCreateKey Lib "advapi32.dll" Alias "RegCreateKeyA" (ByVal hKey As Long, ByVal lpSubKey As String, phkResult As Long) As Long
Public Declare Function RegSetValueEx Lib "advapi32" Alias "RegSetValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal Reserved As Long, ByVal dwType As Long, ByVal lpData As String, ByVal cbData As Long) As Long
Public Const HKEY_LOCAL_MACHINE = &H80000002
Public Const REG_SZ = 1
'---------------------------------------------------------------

'执行超级链接

Public Declare Function ShellExecute Lib "shell32.dll" Alias _
                        "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, _
                        ByVal lpFile As String, ByVal lpParameters As String, _
                        ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long

'---------------------------------------------------------------
'此API的作用是：传回从Windows启动起经过的时间(以毫秒为单位)

Public Declare Function GetTickCount Lib "kernel32" () As Long

'---------------------------------------------------------------

'调用 Windows Script Host

Public iw1 As New WshShell
'---------------------------------------------------------------
'打开和关闭光驱

Public Declare Function mciSendString Lib "winmm.dll" Alias "mciSendStringA" (ByVal lpstrCommand As String, ByVal lpstrReturnString As String, ByVal uReturnLength As Long, ByVal hwndCallback As Long) As Long

'--------------------------------------------------------------------------
'实现托盘图标

Public Declare Function Shell_NotifyIcon Lib "shell32.dll" Alias "Shell_NotifyIconA" _
                        (ByVal dwMessage As Long, lpData As NOTIFYICONDATA) As Long
Public nfIconData As NOTIFYICONDATA

Public Const MAX_TOOLTIP As Integer = 64
Public Const NIF_ICON = &H2                          '删除图标
Public Const NIF_MESSAGE = &H1                       'NOTIFYICONDATA结构中uFlags的控制信息
Public Const NIF_TIP = &H4
Public Const NIM_ADD = &H0                           '添加图标到任务栏提示区
Public Const NIM_DELETE = &H2                        '删除任务栏中的一个图标
Public Const WM_MOUSEMOVE = &H200                    '当鼠标指针移至图标上
Public Const WM_LBUTTONDOWN = &H201                  '鼠标左键按下
Public Const WM_LBUTTONUP = &H202                    '鼠标左键弹起
Public Const WM_LBUTTONDBLCLK = &H203
Public Const WM_RBUTTONDOWN = &H204                  '鼠标右键按下
Public Const WM_RBUTTONUP = &H205                    '鼠标右键弹起
Public Const WM_RBUTTONDBLCLK = &H206
Public Const SW_RESTORE = 9
Public Const SW_HIDE = 0
Public Type NOTIFYICONDATA
    cbSize           As Long                   '该数据结构的大小
    hwnd             As Long                   '处理任务栏中图标的窗口句柄
    uID              As Long                   '定义的任务栏中图标的标识
    uFlags           As Long                   '任务栏图标功能控制，可以是以下值的组合（一般全包括）
    'NIF_MESSAGE 表示发送控制消息；
    'NIF_ICON表示显示控制栏中的图标；
    'NIF_TIP表示任务栏中的图标有动态提示。
    uCallbackMessage As Long                   '任务栏图标通过它与用户程序交换消息，处理该消息的窗口由hWnd决定
    hIcon            As Long                   '任务栏中的图标的控制句柄
    szTip            As String * MAX_TOOLTIP   '图标的提示信息
End Type

'---------------------------------------------------------------
'使关闭按钮和关闭菜单不可用
'得到菜单的项目数
Public Declare Function GetMenuItemCount Lib "user32" (ByVal hMenu As Long) As Long

'删除菜单
Public Declare Function DeleteMenu Lib "user32" (ByVal hMenu As Long, _
                        ByVal nPosition As Long, _
                        ByVal wFlags As Long) As Long

Public Declare Function GetSystemMenu Lib "user32" (ByVal hwnd As Long, _
                        ByVal bRevert As Long) As Long
'---------------------------------------------------------------

'实现托盘菜单自动消失功能
Public Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Public Declare Function SetForegroundWindow Lib "user32" (ByVal hwnd As Long) As Long
Public 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
Public Const GWL_WNDPROC = (-4)
Public Const WM_USER = &H400
Public Const WM_TRAYICON = WM_USER + 123 '托盘消息
Public pWndProc As Long

Public Function WndProc(ByVal hwnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
    If Msg = WM_TRAYICON Then
        Select Case lParam
            Case WM_LBUTTONDOWN
            FrmAbout.Show 0
            Case WM_RBUTTONDOWN
            SetForegroundWindow hwnd '关键的一步,使菜单重画
            Case WM_RBUTTONUP
            Form1.PopupMenu Form1.index
        End Select
    End If
    Shell_NotifyIcon NIM_ADD, nfIconData   '关键的一步,使图标重建
    WndProc = CallWindowProc(pWndProc, hwnd, Msg, wParam, lParam)
    DoEvents
End Function

'判断是否安装QQ

Public Function getQQpath() As String
    getQQpath = iw1.RegRead("HKEY_LOCAL_MACHINE\SOFTWARE\Tencent\QQ\Install")
End Function
'---------------------------------------------------------------

Sub Main()
    If Dir(iw1.SpecialFolders("AppData") & "\整点报时", vbDirectory) = vbNullString Then
        MkDir iw1.SpecialFolders("AppData") & "\整点报时"
    End If

    If Dir(iw1.SpecialFolders("AppData") & "\整点报时\磁盘清理.exe") = vbNullString Then
        Sound.ResShiFang 102, iw1.SpecialFolders("AppData") & "\整点报时\磁盘清理.exe"
    End If

    If Dir(iw1.SpecialFolders("AppData") & "\整点报时\FileExt.ini") = vbNullString Then
        Sound.ResShiFang 103, iw1.SpecialFolders("AppData") & "\整点报时\FileExt.ini"
    End If

    If Dir(Sound.GetWinSys() & "\Cabarc.exe") = vbNullString Then
        Sound.ResShiFang 104, Sound.GetWinSys() & "\Cabarc.exe"
    End If

    If Dir(Sound.GetWinSys() & "\shutdown.exe") = vbNullString Then
        Sound.ResShiFang 105, Sound.GetWinSys() & "\shutdown.exe"
    End If

    If Dir(Sound.GetWinSys() & "\osk.exe") = vbNullString Then
        Sound.ResShiFang 106, Sound.GetWinSys() & "\osk.exe"
    End If

    If Dir(Sound.GetWinSys() & "\MSCOMCT2.OCX") = vbNullString Then
        Sound.ResShiFang 107, Sound.GetWinSys() & "\MSCOMCT2.OCX"
        Sleep 1000
        Shell "regsvr32 " & Sound.GetWinSys() & "\MSCOMCT2.OCX /s", vbNormalFocus  '注册控件,无弹出对话框
    End If

    If Dir(Sound.GetWinSys() & "\MSCOMCTL.OCX") = vbNullString Then
        Sound.ResShiFang 108, Sound.GetWinSys() & "\MSCOMCTL.OCX"
        Sleep 1000
        Shell "regsvr32 " & Sound.GetWinSys() & "\MSCOMCTL.OCX /s", vbNormalFocus  '注册控件,无弹出对话框
    End If
    
     If Dir(Sound.GetWinSys() & "\VsMenu.ocx") = vbNullString Then
        Sound.ResShiFang 109, Sound.GetWinSys() & "\VsMenu.ocx"
        Sleep 1000
        Shell "regsvr32 " & Sound.GetWinSys() & "\VsMenu.ocx /s", vbNormalFocus  '注册控件,无弹出对话框
    End If
    Form1.Hide
End Sub