一、菜单类模块'========================================================================================' Alarm Clock 1.05' 版权所有(C) 2001-2002  江建及其两位女友' 本代码摘自我的 Alarm Clock' Alarm Clock 下载地址:http://h.7i24.com/vbcc/work/setup.exe'======================================================================================='=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=' 本程序可以看看 MSDN' 我建议大家参照 MSDN 然后自己写不要直接拷贝我的程序' 因为这样你可能学不到东西。' 用 VB 的集合来存储菜单的文字。(用API可以创建所有的菜单)' 如果用物主绘图可以创建任何风格的菜单(Office 97, OICQ, Windows XP)' (建议 从资源文件中创建菜单 你可以用 宝蓝的 Delphi 或 C++ 光盘中的' Resource Workshop)来创建资源文件和对话框(以及基本的控件)' 有那位能告诉我VB怎么从指针取结构的数据'=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=Private Declare Function CreateMenu Lib "user32" () As LongPrivate Declare Function CreatePopupMenu Lib "user32" () As LongPrivate Declare Function InsertMenuItem Lib "user32" Alias "InsertMenuItemA" (ByVal hMenu As Long, ByVal un As Long, ByVal bool As Boolean, ByRef lpcMenuItemInfo As MENUITEMINFO) As Long Private Declare Function SetMenu Lib "user32" (ByVal hWnd As Long, ByVal hMenu As Long) As LongPrivate Declare Function GetMenu Lib "user32" (ByVal hWnd As Long) As LongPrivate Declare Function GetSubMenu Lib "user32" (ByVal hMenu As Long, ByVal nPos As Long) As LongPrivate Declare Function DestroyMenu Lib "user32" (ByVal hMenu As Long) As Long Private Declare Function SetMenuItemInfo Lib "user32" Alias "SetMenuItemInfoA" (ByVal hMenu As Long, ByVal un As Long, ByVal bool As Boolean, lpcMenuItemInfo As MENUITEMINFO) As LongPrivate Declare Function GetMenuItemInfo Lib "user32" Alias "GetMenuItemInfoA" (ByVal hMenu As Long, ByVal un As Long, ByVal b As Long, lpMenuItemInfo As MENUITEMINFO) As LongPrivate Declare Function SetMenuItemInfoLong Lib "user32" Alias "SetMenuItemInfoA" (ByVal hMenu As Long, ByVal un As Long, ByVal bool As Boolean, lpcMenuItemInfo As MENUITEMINFOLONG) As LongPrivate Declare Function GetMenuItemInfoLong Lib "user32" Alias "GetMenuItemInfoA" (ByVal hMenu As Long, ByVal un As Long, ByVal b As Long, lpMenuItemInfo As MENUITEMINFOLONG) As Long Private Declare Function GetMenuItemCount Lib "user32" (ByVal hMenu As Long) As LongPrivate Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As LongPrivate Declare Function TrackPopupMenu Lib "user32" (ByVal hMenu As Long, ByVal wFlags As Long, ByVal X As Long, ByVal Y As Long, ByVal nReserved As Long, ByVal hWnd As Long, ByVal lprc As Any) As Long Private Declare Function BitBlt Lib "gdi32" (ByVal hDestDc As Long, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As LongPrivate Declare Function FillRect Lib "user32" (ByVal hdc As Long, lpRect As RECT, ByVal hBrush As Long) As LongPrivate Declare Function GetWindowDC Lib "user32" (ByVal hWnd As Long) As LongPrivate Declare Function DrawEdge Lib "user32" (ByVal hdc As Long, qrc As RECT, ByVal edge As Long, ByVal grfFlags As Long) As LongPrivate Declare Function DrawText Lib "user32" Alias "DrawTextA" (ByVal hdc As Long, ByVal lpStr As String, ByVal nCount As Long, lpRect As RECT, ByVal wFormat As Long) As LongPrivate Declare Function GetSysColor Lib "user32" (ByVal nIndex As Long) As LongPrivate Declare Function GetSysColorBrush Lib "user32" (ByVal nIndex As Long) As LongPrivate Declare Function SetTextColor Lib "gdi32" (ByVal hdc As Long, ByVal crColor As Long) As LongPrivate Declare Function GetTextExtentPoint32 Lib "gdi32" Alias "GetTextExtentPoint32A" (ByVal hdc As Long, ByVal lpsz As String, ByVal cbString As Long, lpSize As SIZE) As LongPrivate Declare Function GetDC Lib "user32" (ByVal hWnd As Long) As LongPrivate Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)Private Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As LongPrivate Declare Function SetBkMode Lib "gdi32" (ByVal hdc As Long, ByVal nBkMode As Long) As LongPrivate Declare Function ReleaseDC Lib "user32" (ByVal hWnd As Long, ByVal hdc As Long) As LongPrivate Declare Function lstrlen Lib "kernel32" Alias "lstrlenA" (ByVal lpString As String) As LongPrivate Declare Function LoadImage Lib "user32" Alias "LoadImageA" (ByVal hInst As Long, ByVal lpsz As String, ByVal un1 As Long, ByVal n1 As Long, ByVal n2 As Long, ByVal un2 As Long) As LongPrivate Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As LongPrivate Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As LongPrivate Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long ' Format TextPrivate Const DT_LEFT = &H0Private Const DT_SINGLELINE = &H20Private Const DT_VCENTER = &H4 Private Const TPM_LEFTALIGN = &H0&Private Const SM_CYMENU = 15Private Const NEWTRANSPARENT = 3  '  use with SetBkMode() Private Const COLOR_MENU = 4Private Const COLOR_MENUTEXT = 7Private Const COLOR_HIGHLIGHTTEXT = 14 Private Const BF_LEFT = &H1              '边界矩形Private Const BF_TOP = &H2Private Const BF_RIGHT = &H4Private Const BF_BOTTOM = &H8            '全部边阶矩形Private Const BF_RECT = (BF_LEFT Or BF_TOP Or BF_RIGHT Or BF_BOTTOM)Private Const BDR_RAISEDINNER = &H4      '菜单小按钮式Private Const BDR_SUNKENOUTER = &H2      '一种沉没外部的边阶式样Private Const EDGE_ETCHED = (BDR_SUNKENOUTER Or BDR_RAISEDINNER) ' Font SizePrivate Type SIZE        CX As Long        CY As LongEnd Type Private Type RECT        Left As Long        Top As Long        Right As Long        Bottom As LongEnd Type ' GetCursorPos(鼠标指针的位置)Private Type POINTAPI    X As Long    Y As LongEnd Type ' 自己的结构Private Type MYITEM    cchItemText As Long    szItemText As String    dwTypeData As LongEnd Type ' InsertMenuItemPrivate Type MENUITEMINFO    cbSize As Long    fMask As Long    fType As Long    fState As Long    wID As Long    hSubMenu As Long    hbmpChecked As Long    hbmpUnchecked As Long    dwItemData As Long    dwTypeData As String    cch As Long  End Type ' SetMenuItemInfo GetMenuItemInfoPrivate Type MENUITEMINFOLONG    cbSize As Long    fMask As Long    fType As Long    fState As Long    wID As Long    hSubMenu As Long    hbmpChecked As Long    hbmpUnchecked As Long    dwItemData As Long    dwTypeData As Long    cch As LongEnd Type ' Message WM_MEASUREITEM Menu Width and HeightPrivate Type MEASUREITEMSTRUCT        CtlType As Long        CtlID As Long        itemID As Long        itemWidth As Long        itemHeight As Long        itemData As LongEnd Type ' Message WM_DRAWITEM Draw MenuPrivate Type DRAWITEMSTRUCT        CtlType As Long                         CtlID As Long                   '对菜单没用        itemID As Long                  '菜单的索引ID        itemAction As Long              '定义要求的绘画的行动        itemState As Long               '绘画的行动发生以后，指定条款的视觉的状态 =选择        hwndItem As Long                '指定菜单的柄( HMENU )为菜单包含条款        hdc As Long                     '绘图的设备场景        RcItem As RECT                  '一个矩形定义控制的被画边界的 由hDC 成员指定。        itemData As Long                'CMenu::ModifyMenu        End Type ' fMask To InsertMenuItemPrivate Const MIIM_STATE = &H1Private Const MIIM_ID = &H2Private Const MIIM_SUBMENU = &H4Private Const MIIM_CHECKMARKS = &H8Private Const MIIM_TYPE = &H10Private Const MIIM_DATA = &H20Private Const MIIM_STRING = &H40Private Const MIIM_BITMAP = &H80Private Const MIIM_FTYPE = &H100 ' fType To InsertMenuItemPrivate Const MFT_BITMAP = &H4&Private Const MFT_MENUBARBREAK = &H20&Private Const MFT_OWNERDRAW = &H100&Private Const MFT_SEPARATOR = &H800&Private Const MFT_STRING = &H0& ' fState To InsertMenuItemPrivate Const MFT_CHECKED = &H8&Private Const MFT_DISABLED = &H2&Private Const MFT_ENABLED = &H0&Private Const MFT_GRAYED = &H1&Private Const MFT_UNCHECKED = &H0& Private Const ODT_MENU = 1Private Const ODS_SELECTED = &H1 'LoadImagePrivate Const LR_LOADFROMFILE = &H10Private Const LR_LOADMAP3DCOLORS = &H1000Private Const IMAGE_BITMAP = 0 'Private SubhMenu As LongPrivate mnuItemCound As LongPrivate MnuInfo() As MYITEM Public Function CreatePopMenu() As Long    CreatePopMenu = CreatePopupMenu()End Function Public Sub AddMenuItem(ID As Long, mnuText As String, fType As Long, Optional fState As Long, Optional subMenu As Boolean = False, Optional lngSubhMenu As Long, Optional hMenu As Long)    '=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=    ' 添加菜单项目    '=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=    Dim lpcMenuItemInfo As MENUITEMINFO    With lpcMenuItemInfo        .cbSize = Len(lpcMenuItemInfo)        .fMask = MIIM_STRING Or MIIM_FTYPE Or MIIM_STATE Or MIIM_SUBMENU Or MIIM_ID        .fType = fType        .fState = fState        .cch = Len(mnuText)        .dwTypeData = mnuText        .wID = ID        If subMenu Then: .hSubMenu = lngSubhMenu    End With    InsertMenuItem hMenu, ID, False, lpcMenuItemInfoEnd Sub Public Sub OnCreate(hMenu As Long)    'Msdn VC++    Dim nItem As Long, I As Long, N As Long    Dim hSubMenu As Long, sItem As Long    nItem = GetMenuItemCount(hMenu)    ReDim MnuInfo(18)            For I = 0 To nItem - 1            Call SetMenuOwnerDraw(hMenu, I)                     hSubMenu = GetSubMenu(hMenu, I)            sItem = GetMenuItemCount(hSubMenu)                           If hSubMenu <> 0 And sItem <> -1 Then ' 子菜单                    For N = 0 To sItem - 1                        Call SetMenuOwnerDraw(hSubMenu, N)                    Next                End If        Next I End Sub Private Function SetMenuOwnerDraw(lphMenu As Long, uItem As Long)    Dim lpcMenuItemInfo As MENUITEMINFO    With lpcMenuItemInfo        .cbSize = Len(lpcMenuItemInfo)        .fMask = MIIM_DATA Or MIIM_ID Or MIIM_TYPE        .dwTypeData = String$(256, 0)        .cch = Len(.dwTypeData)    End With       GetMenuItemInfo lphMenu, uItem, True, lpcMenuItemInfo            'Add Menu Type And Menu Text For MnuInfo    ' Set MFT_OWNERDRAW Type For Menu    MnuInfo(mnuItemCound).dwTypeData = lpcMenuItemInfo.fType    MnuInfo(mnuItemCound).szItemText = Left$(lpcMenuItemInfo.dwTypeData, lstrlen(ByVal lpcMenuItemInfo.dwTypeData))    MnuInfo(mnuItemCound).cchItemText = lpcMenuItemInfo.cch     'Debug.Print lpcMenuItemInfo.cch    lpcMenuItemInfo.fMask = lpcMenuItemInfo.fMask Or MIIM_TYPE    lpcMenuItemInfo.fType = MFT_OWNERDRAW    lpcMenuItemInfo.dwItemData = mnuItemCound    mnuItemCound = mnuItemCound + 1    Call SetMenuItemInfo(lphMenu, uItem, True, lpcMenuItemInfo)End Function Public Sub OnMeasureItem(hWnd As Long, lParam As Long)    ' 设置菜单的高度与宽度    Dim lpmis As MEASUREITEMSTRUCT    Dim hdc As Long, lpSize As SIZE    hdc = GetDC(hWnd)    CopyMemory lpmis, ByVal lParam, Len(lpmis)        If lpmis.CtlType And ODT_MENU Then                       Call GetTextExtentPoint32(hdc, MnuInfo(lpmis.itemData).szItemText, MnuInfo(lpmis.itemData).cchItemText, lpSize)            lpmis.itemWidth = (lpSize.CX + 19)                If MnuInfo(lpmis.itemData).dwTypeData <> MFT_SEPARATOR Then                    lpmis.itemHeight = GetSystemMetrics(SM_CYMENU)                Else                    lpmis.itemHeight = 6                End If        End If    CopyMemory ByVal lParam, lpmis, Len(lpmis)    ReleaseDC hWnd, hdcEnd Sub Public Sub OnDrawItem(lParam As Long)        Dim lpDrawInfo As DRAWITEMSTRUCT    CopyMemory lpDrawInfo, ByVal lParam, Len(lpDrawInfo)                If lpDrawInfo.CtlType And ODT_MENU Then                        SetBkMode lpDrawInfo.hdc, NEWTRANSPARENT                                ' 菜单小按钮                Dim RcButton As RECT                RcButton = lpDrawInfo.RcItem                RcButton.Right = 19                                ' 减去小按钮剩下的部分                Dim RcItemBox As RECT                RcItemBox = lpDrawInfo.RcItem                RcItemBox.Left = 20                                ' 菜单文字                Dim RcText As RECT                RcText = lpDrawInfo.RcItem                RcText.Left = 23                                ' 从数组中取菜单文字                Dim mnuText As String                Dim mnuTextSize As Long                Dim bSelected As Boolean                Dim bMenuButton As Boolean                Dim bSeparator As Boolean                                ' 取菜单文字及文字大小                mnuText = MnuInfo(lpDrawInfo.itemData).szItemText                mnuTextSize = MnuInfo(lpDrawInfo.itemData).cchItemText                                ' bSelected     菜单是否为选者状态(如果是则画菜单选者时的状态)                ' bMenuButton   通过判断菜单是否设置了 MFT_MENUBARBREAK 风格来决定是否该有菜单的小按钮                ' bSeparator    画菜单分隔符                bSelected = lpDrawInfo.itemState And ODS_SELECTED                bMenuButton = MnuInfo(lpDrawInfo.itemData).dwTypeData And MFT_MENUBARBREAK                bSeparator = MnuInfo(lpDrawInfo.itemData).dwTypeData And MFT_SEPARATOR                        If bSelected And mnuText <> vbNullString Then                Call SetTextColor(lpDrawInfo.hdc, GetSysColor(COLOR_HIGHLIGHTTEXT))                DrawText lpDrawInfo.hdc, mnuText, mnuTextSize, RcText, DT_LEFT Or DT_SINGLELINE Or DT_VCENTER                                If bMenuButton Then                    DrawEdge lpDrawInfo.hdc, lpDrawInfo.RcItem, BDR_SUNKENOUTER, BF_RECT                Else                    DrawEdge lpDrawInfo.hdc, RcButton, BDR_RAISEDINNER, BF_RECT                    DrawEdge lpDrawInfo.hdc, RcItemBox, BDR_SUNKENOUTER, BF_RECT                    BitBlt lpDrawInfo.hdc, (lpDrawInfo.RcItem.Left + 1), (lpDrawInfo.RcItem.Top + 1), 16, 16, CreateMenuBmphDc, (lpDrawInfo.itemID * 16), 0, vbSrcCopy                End If            Else                Call FillRect(lpDrawInfo.hdc, lpDrawInfo.RcItem, GetSysColorBrush(COLOR_MENU))                Call SetTextColor(lpDrawInfo.hdc, GetSysColor(COLOR_MENUTEXT))                Call DrawText(lpDrawInfo.hdc, mnuText, mnuTextSize, RcText, DT_LEFT Or DT_SINGLELINE Or DT_VCENTER)                                If bMenuButton = False And mnuText <> vbNullString Then                    BitBlt lpDrawInfo.hdc, (lpDrawInfo.RcItem.Left + 1), (lpDrawInfo.RcItem.Top + 1), 16, 16, CreateMenuBmphDc, (lpDrawInfo.itemID * 16), 0, vbSrcCopy                End If            End If                   If bSeparator Then      ' 画菜单分隔符                Dim RcSep As RECT                RcSep.Left = 3                RcSep.Right = lpDrawInfo.RcItem.Right - 3                RcSep.Top = lpDrawInfo.RcItem.Top + 2                DrawEdge lpDrawInfo.hdc, RcSep, EDGE_ETCHED, BF_TOP            End If        End IfEnd Sub  Public Function PopMenu(hWnd As Long, hMenu As Long)    Dim pt As POINTAPI    Call GetCursorPos(pt)    Call TrackPopupMenu(hMenu, TPM_LEFTALIGN, pt.X, pt.Y, 0, hWnd, ByVal 0&)End Function Public Function CreateMenuBmphDc() As Long    Dim hBmp As Long    Dim hdc As Long    hdc = GetDC(0)    CreateMenuBmphDc = CreateCompatibleDC(hdc)        Call ReleaseDC(0, hdc)    hBmp = LoadImage(0, App.Path & "\icon.bmp", IMAGE_BITMAP, 0, 0, LR_LOADFROMFILE Or LR_LOADMAP3DCOLORS)        If hBmp <> 0 Then        Call SelectObject(CreateMenuBmphDc, hBmp)     ' 将取得的图片选入设备场景    End IfEnd Function Public Sub SetMenuText(uItem As Long, mnuText As String, Optional uID As Long, Optional hMenu As Long)    ' 修该菜单文字和 ID (  :)可以当两个菜单使用)    Dim lpcMenuItemInfo As MENUITEMINFO    With lpcMenuItemInfo        .cbSize = Len(lpcMenuItemInfo)        .fMask = MIIM_ID        .wID = uID    End With    Call SetMenuItemInfo(hMenu, uItem, True, lpcMenuItemInfo)    MnuInfo(uItem).szItemText = mnuText    MnuInfo(uItem).cchItemText = LenB(StrConv(mnuText, vbFromUnicode))End Sub 'Public Sub OnInitMenuPopup(hMenuPopup As Long, nIndex As Long, Optional fSystemMenu As Boolean)    ' 取菜单的信息并添加至VB 的集合 Msdn VC++    ' 我开始是用的是 WM_INITMENUPOPUP 但不知为何会出现乱码.(而且集合不停的加) :(    ' 如过你连系统菜单都要自己画的话就用 OnInitMenuPopup 消息具体如何可以参见 MSDN    ' 原先我用集合来存储 菜单数据（因为要修改所以后改用数组）   ' Dim lpcMenuItemInfo As MENUITEMINFOLONG    'Dim MnuInfo As MYITEM   ' Dim nItem As Long, I&  ' '   ReDim MnuInfo.szItemText(44)'    nItem = GetMenuItemCount(hMenuPopup)        'If Not fSystemMenu Then     ' Not OwnerDraw System Menu   '     For I = 0 To nItem - 1  '        '  With lpcMenuItemInfo         '       .cbSize = Len(lpcMenuItemInfo)        '        .fMask = MIIM_DATA Or MIIM_ID Or MIIM_TYPE       '         .dwTypeData = VarPtr(MnuInfo.szItemText(0))      '          .cch = UBound(MnuInfo.szItemText)     '       End With    '     '   GetMenuItemInfo hMenuPopup, I, True, lpcMenuItemInfo                    ' Add Menu Type And Menu Text For VB Collection            ' Set MFT_OWNERDRAW Type For Menu        '    TypeMenu.Add lpcMenuItemInfo.fType       '     strTextMenu.Add Left$(StrConv(MnuInfo.szItemText, vbUnicode), lpcMenuItemInfo.cch)      '     '       lpcMenuItemInfo.fMask = lpcMenuItemInfo.fMask Or MIIM_TYPE    '        lpcMenuItemInfo.fType = MFT_OWNERDRAW   '   '         Call SetMenuItemInfo(hMenuPopup, I, True, lpcMenuItemInfo)  '      Next I '   End If'End Sub '二、主窗体标准模块Option Explicit '========================================================================================' ShadowMenu 1.05' 代码编号：000006'========================================================================================' 作者：江建' 网址： http://vbcc.126.com' 电子邮件： vbcc@sohu.com' 版权所有(C) 2001-2002  江建及其两位女友'======================================================================================== Dim lpwcx As WNDCLASSEXDim RegClass As LongDim Menu As clsMenu '=============================================' Menu TypePrivate Const MF_BITMAP = &H4&Private Const MF_MENUBARBREAK = &H20&Private Const MF_OWNERDRAW = &H100&Private Const MF_SEPARATOR = &H800&Private Const MF_STRING = &H0& Private Const MF_CHECKED = &H8&Private Const MF_DISABLED = &H2&Private Const MF_ENABLED = &H0&Private Const MF_GRAYED = &H1&Private Const MF_UNCHECKED = &H0&'============================================== Dim hMainMenu As Long Public Function RegWinClass(lpClassName As String)'功能：注册窗口类'参数：lpClassName 类名    With lpwcx        .cbSize = Len(lpwcx)        .Style = CS_HREDRAW Or CS_VREDRAW Or CS_DBLCLKS        .lpszClassName = lpClassName        .hInstance = App.hInstance        .cbClsExtra = 0        .cbWndExtra = 0        .hCursor = LoadCursor(0, IDC_ARROW)        .lpfnWndProc = FnPtrToLong(AddressOf MainWinProc)        .lpszMenuName = 0        .hbrBackground = COLOR_WINDOW    End With    Call RegisterClassEx(lpwcx)End Function Private Function MainWinProc(ByVal hWnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long    '这里是我们写程序最重要的部分 相当于 VB 中的事件    Select Case uMsg        Case WM_CREATE            SetPosition hWnd            Set Menu = New clsMenu            '=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=--=-==-=-=-=--=-=                        Dim hSubMenu1 As Long            Dim hSubMenu2 As Long                        hMainMenu = Menu.CreatePopMenu            hSubMenu1 = Menu.CreatePopMenu            hSubMenu2 = Menu.CreatePopMenu            Menu.AddMenuItem 0, "闹钟最小化(&M)", MF_STRING, , , , hMainMenu            Menu.AddMenuItem 10, vbNullString, MF_SEPARATOR, , , , hMainMenu            Menu.AddMenuItem 1, "闹钟选项(&O)...", MF_STRING, , , , hMainMenu            Menu.AddMenuItem 11, vbNullString, MF_SEPARATOR, , , , hMainMenu            Menu.AddMenuItem 2, "外挂程序", MF_STRING, , True, hSubMenu1, hMainMenu            Menu.AddMenuItem 12, "  无    ", MF_STRING Or MF_MENUBARBREAK, , , , hSubMenu1            Menu.AddMenuItem 3, "万年历(&W)...", MF_STRING, , , , hMainMenu            Menu.AddMenuItem 13, vbNullString, MF_SEPARATOR, , , , hMainMenu            Menu.AddMenuItem 4, "闹铃设置(&R)...", MF_STRING, , , , hMainMenu            Menu.AddMenuItem 14, vbNullString, MF_SEPARATOR, , , , hMainMenu            Menu.AddMenuItem 5, "时间设置(&S)...", MF_STRING, , , , hMainMenu            Menu.AddMenuItem 15, vbNullString, MF_SEPARATOR, , , , hMainMenu            Menu.AddMenuItem 6, "帮助(&H)", MF_STRING, , True, hSubMenu2, hMainMenu            Menu.AddMenuItem 7, "写信给我(&E)", MF_STRING, , , , hSubMenu2            Menu.AddMenuItem 8, "访问网站(&H)", MF_STRING, , , , hSubMenu2            Menu.AddMenuItem 9, "帮助内容(&C)", MF_STRING, , , , hSubMenu2            Menu.AddMenuItem 16, "关于本程序(&A)...", MF_STRING Or MF_MENUBARBREAK, , , , hMainMenu            Menu.AddMenuItem 17, vbNullString, MF_SEPARATOR, , , , hMainMenu            Menu.AddMenuItem 18, "退出(&X)", MF_STRING Or MF_MENUBARBREAK, , , , hMainMenu            Call Menu.OnCreate(hMainMenu)        Case WM_DRAWITEM            Menu.OnDrawItem lParam              ' 画菜单              Case WM_MEASUREITEM            Menu.OnMeasureItem hWnd, lParam     ' 设置菜单高度与宽度        Case WM_RBUTTONUP            Menu.PopMenu hWnd, hMainMenu        Case WM_DESTROY            Call PostQuitMessage(0)    End Select    MainWinProc = DefWindowProc(hWnd, uMsg, wParam, lParam)End Function Public Function FnPtrToLong(ByVal lngFnPtr As Long) As Long    '这个东东是微软定义的    FnPtrToLong = lngFnPtrEnd Function     Public Function CreateMainForm(title As String, nWidth As Long, nHeight As Long) As Long'功能：创建窗体'参数：title 窗体的标题文字 | nWidth 宽度 | nHeight 高度    Dim hWndMain  As Long    Dim lpMsg As MSG    Call RegWinClass("Form")             '注册窗口类        '创建窗体并返回其句柄    hWndMain = CreateWindowEx(0, "Form", title, WS_OVERLAPPEDWINDOW, 0, 0, nWidth, nHeight, 0, 0, App.hInstance, ByVal 0&)        '如果窗体创建成功则显示它并进如消息循环    If hWndMain <> 0 Then        ShowWindow hWndMain, SW_NORMAL        Do While GetMessage(lpMsg, 0, 0, 0)            TranslateMessage lpMsg            DispatchMessage lpMsg        Loop    End If    UnregisterClass "Form", App.hInstance '卸载注册类 很重要如果不卸载的话你自己试试就知道了 :)End Function Public Sub Main()    '程序开始    CreateMainForm "VB API For Window", 500, 388End SubPublic Sub SetPosition(hWnd As Long)    '功能：设置窗体在屏幕中间    '参数：hWnd 窗体句柄    Dim DesktopRect As RECT, hWndDesktop As Long        hWndDesktop = GetDesktopWindow          '取桌面句柄    GetWindowRect hWndDesktop, DesktopRect  '返回桌面 Rect    MoveWindow hWnd, (DesktopRect.Right - 500) / 2, (DesktopRect.Bottom - 388) / 2, 500, 388, 1End Sub '三、API 声明模块Option Explicit ' Window FunctionsPublic Declare Function CreateWindowEx Lib "user32" Alias "CreateWindowExA" (ByVal dwExStyle As Long, ByVal lpClassName As String, ByVal lpWindowName As String, ByVal dwStyle As Long, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hWndParent As Long, ByVal hMenu As Long, ByVal hInstance As Long, lpParam As Any) As LongPublic 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 LongPublic Declare Function LoadResImage Lib "user32" Alias "LoadImageA" (ByVal hInst As Long, ByVal lpsz As Long, ByVal un1 As Long, ByVal n1 As Long, ByVal n2 As Long, ByVal un2 As Long) As LongPublic Declare Function ShowWindow Lib "user32" (ByVal hWnd As Long, ByVal nCmdShow As Long) As LongPublic Declare Function MoveWindow Lib "user32" (ByVal hWnd As Long, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal bRepaint As Long) As LongPublic Declare Function GetWindowRect Lib "user32" (ByVal hWnd As Long, lpRect As RECT) As LongPublic Declare Function GetDesktopWindow Lib "user32" () As Long' MessagePublic Declare Function GetMessage Lib "user32" Alias "GetMessageA" (lpMsg As MSG, ByVal hWnd As Long, ByVal wMsgFilterMin As Long, ByVal wMsgFilterMax As Long) As LongPublic Declare Function TranslateMessage Lib "user32" (lpMsg As MSG) As LongPublic Declare Function DispatchMessage Lib "user32" Alias "DispatchMessageA" (lpMsg As MSG) As Long Public Declare Function RegisterClassEx Lib "user32" Alias "RegisterClassExA" (pcWndClassEx As WNDCLASSEX) As IntegerPublic Declare Function DefWindowProc Lib "user32" Alias "DefWindowProcA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As LongPublic Declare Sub PostQuitMessage Lib "user32" (ByVal nExitCode As Long)Public Declare Function DestroyWindow Lib "user32" (ByVal hWnd As Long) As Long Public Declare Function LoadCursor Lib "user32" Alias "LoadCursorA" (ByVal hInstance As Long, ByVal lpCursorName As Long) As Long ' Class Reg And DelPublic Declare Function UnregisterClass Lib "user32" Alias "UnregisterClassA" (ByVal lpClassName As String, ByVal hInstance As Long) As Long '---------------------------------------------------------'CreateWindowEx And Dialog Window Style'--------------------------------------------------------Public Const WS_MINIMIZEBOX = &H20000Public Const WS_MAXIMIZEBOX = &H10000Public Const WS_CAPTION = &HC00000                  '  WS_BORDER Or WS_DLGFRAMEPublic Const WS_OVERLAPPED = &H0&Public Const WS_THICKFRAME = &H40000 Public Const WS_CHILD = &H40000000Public Const WS_VISIBLE = &H10000000Public Const WS_TABSTOP = &H10000Public Const WS_DISABLED = &H8000000Public Const WS_SYSMENU = &H80000Public Const WS_POPUP = &H80000000Public Const WS_GROUP = &H20000 Public Const WS_OVERLAPPEDWINDOW = (WS_OVERLAPPED Or WS_CAPTION Or WS_SYSMENU Or WS_THICKFRAME Or WS_MINIMIZEBOX Or WS_MAXIMIZEBOX) ' Window MessagePublic Const WM_TIMER = &H113Public Const WM_USER = &H400Public Const WM_NOTIFY = &H4EPublic Const WM_MOUSEMOVE = &H200Public Const WM_RBUTTONUP = &H205Public Const WM_COMMAND = &H111Public Const WM_ENABLE = &HAPublic Const WM_INITDIALOG = &H110Public Const WM_PAINT = &HFPublic Const WM_CLOSE = &H10Public Const WM_CREATE = &H1Public Const WM_LBUTTONDOWN = &H201Public Const WM_LBUTTONDBLCLK = &H203Public Const WM_RBUTTONDBLCLK = &H206Public Const WM_RBUTTONDOWN = &H204Public Const WM_SIZE = &H5 Public Const WM_MEASUREITEM = &H2CPublic Const WM_DRAWITEM = &H2BPublic Const WM_INITMENUPOPUP = &H117Public Const WM_DESTROY = &H2 ' WNDCLASSEXPublic Const CS_HREDRAW = &H2Public Const CS_VREDRAW = &H1Public Const CS_DBLCLKS = &H8 ' Window ColorPublic Const COLOR_WINDOW = 5 ' DefSystem CursorPublic Const IDC_HAND = 32649& ' ShowWindowPublic Const SW_NORMAL = 1 Public Const IMAGE_ICON = 1 ' DefSystem CursorPublic Const IDC_ARROW = 32512& ' Reg WindowPublic Type WNDCLASSEX    cbSize As Long    Style As Long    lpfnWndProc As Long    cbClsExtra As Long    cbWndExtra As Long    hInstance As Long    hIcon As Long    hCursor As Long    hbrBackground As Long    lpszMenuName As String    lpszClassName As String    hIconSm As LongEnd Type Public Type POINTAPI    X As Long    Y As LongEnd Type Public Type MSG    hWnd As Long    message As Long    wParam As Long    lParam As Long    Times As Long    pt As POINTAPIEnd Type Public Type RECT        Left As Long        Top As Long        Right As Long        Bottom As LongEnd Type

评论