正文

vb菜单2005-09-25 22:40:00

【评论】 【打印】 【字体：大 中 小】 本文链接：http://blog.pfan.cn/iamben250/5336.html

分享到：

一、菜单类模块
'========================================================================================
' 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 Long
Private Declare Function CreatePopupMenu Lib "user32" () As Long
Private 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 Long
Private Declare Function GetMenu Lib "user32" (ByVal hWnd As Long) As Long
Private Declare Function GetSubMenu Lib "user32" (ByVal hMenu As Long, ByVal nPos As Long) As Long
Private 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 Long
Private Declare Function GetMenuItemInfo Lib "user32" Alias "GetMenuItemInfoA" (ByVal hMenu As Long, ByVal un As Long, ByVal b As Long, lpMenuItemInfo As MENUITEMINFO) As Long
Private Declare Function SetMenuItemInfoLong Lib "user32" Alias "SetMenuItemInfoA" (ByVal hMenu As Long, ByVal un As Long, ByVal bool As Boolean, lpcMenuItemInfo As MENUITEMINFOLONG) As Long
Private 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 Long
Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
Private 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 Long
Private Declare Function FillRect Lib "user32" (ByVal hdc As Long, lpRect As RECT, ByVal hBrush As Long) As Long
Private Declare Function GetWindowDC Lib "user32" (ByVal hWnd As Long) As Long
Private Declare Function DrawEdge Lib "user32" (ByVal hdc As Long, qrc As RECT, ByVal edge As Long, ByVal grfFlags As Long) As Long
Private 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 Long
Private Declare Function GetSysColor Lib "user32" (ByVal nIndex As Long) As Long
Private Declare Function GetSysColorBrush Lib "user32" (ByVal nIndex As Long) As Long
Private Declare Function SetTextColor Lib "gdi32" (ByVal hdc As Long, ByVal crColor As Long) As Long
Private Declare Function GetTextExtentPoint32 Lib "gdi32" Alias "GetTextExtentPoint32A" (ByVal hdc As Long, ByVal lpsz As String, ByVal cbString As Long, lpSize As SIZE) As Long
Private Declare Function GetDC Lib "user32" (ByVal hWnd As Long) As Long
Private 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 Long
Private Declare Function SetBkMode Lib "gdi32" (ByVal hdc As Long, ByVal nBkMode As Long) As Long
Private Declare Function ReleaseDC Lib "user32" (ByVal hWnd As Long, ByVal hdc As Long) As Long
Private Declare Function lstrlen Lib "kernel32" Alias "lstrlenA" (ByVal lpString As String) As Long
Private 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 Long
Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long


' Format Text
Private Const DT_LEFT = &H0
Private Const DT_SINGLELINE = &H20
Private Const DT_VCENTER = &H4

Private Const TPM_LEFTALIGN = &H0&
Private Const SM_CYMENU = 15
Private Const NEWTRANSPARENT = 3  '  use with SetBkMode()

Private Const COLOR_MENU = 4
Private Const COLOR_MENUTEXT = 7
Private Const COLOR_HIGHLIGHTTEXT = 14

Private Const BF_LEFT = &H1              '边界矩形
Private Const BF_TOP = &H2
Private Const BF_RIGHT = &H4
Private 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 Size
Private Type SIZE
        CX As Long
        CY As Long
End Type

Private Type RECT
        Left As Long
        Top As Long
        Right As Long
        Bottom As Long
End Type

' GetCursorPos(鼠标指针的位置)
Private Type POINTAPI
    X As Long
    Y As Long
End Type

' 自己的结构
Private Type MYITEM
    cchItemText As Long
    szItemText As String
    dwTypeData As Long
End Type

' InsertMenuItem
Private 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 GetMenuItemInfo
Private 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 Long
End Type

' Message WM_MEASUREITEM Menu Width and Height
Private Type MEASUREITEMSTRUCT
        CtlType As Long
        CtlID As Long
        itemID As Long
        itemWidth As Long
        itemHeight As Long
        itemData As Long
End Type

' Message WM_DRAWITEM Draw Menu
Private 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 InsertMenuItem
Private Const MIIM_STATE = &H1
Private Const MIIM_ID = &H2
Private Const MIIM_SUBMENU = &H4
Private Const MIIM_CHECKMARKS = &H8
Private Const MIIM_TYPE = &H10
Private Const MIIM_DATA = &H20
Private Const MIIM_STRING = &H40
Private Const MIIM_BITMAP = &H80
Private Const MIIM_FTYPE = &H100

' fType To InsertMenuItem
Private 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 InsertMenuItem
Private 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 = 1
Private Const ODS_SELECTED = &H1

'LoadImage
Private Const LR_LOADFROMFILE = &H10
Private Const LR_LOADMAP3DCOLORS = &H1000
Private Const IMAGE_BITMAP = 0

'Private SubhMenu As Long
Private mnuItemCound As Long
Private 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, lpcMenuItemInfo
End 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, hdc
End 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 If
End 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 If
End 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 WNDCLASSEX
Dim RegClass As Long
Dim Menu As clsMenu

'=============================================
' Menu Type
Private 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 = lngFnPtr
End 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, 388
End Sub
Public 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, 1
End Sub

'三、API 声明模块
Option Explicit

' Window Functions
Public 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 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 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 Long
Public Declare Function ShowWindow Lib "user32" (ByVal hWnd As Long, ByVal nCmdShow As Long) As Long
Public 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 Long
Public Declare Function GetWindowRect Lib "user32" (ByVal hWnd As Long, lpRect As RECT) As Long
Public Declare Function GetDesktopWindow Lib "user32" () As Long
' Message
Public Declare Function GetMessage Lib "user32" Alias "GetMessageA" (lpMsg As MSG, ByVal hWnd As Long, ByVal wMsgFilterMin As Long, ByVal wMsgFilterMax As Long) As Long
Public Declare Function TranslateMessage Lib "user32" (lpMsg As MSG) As Long
Public Declare Function DispatchMessage Lib "user32" Alias "DispatchMessageA" (lpMsg As MSG) As Long

Public Declare Function RegisterClassEx Lib "user32" Alias "RegisterClassExA" (pcWndClassEx As WNDCLASSEX) As Integer
Public Declare Function DefWindowProc Lib "user32" Alias "DefWindowProcA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Public 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 Del
Public 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 = &H20000
Public Const WS_MAXIMIZEBOX = &H10000
Public Const WS_CAPTION = &HC00000                  '  WS_BORDER Or WS_DLGFRAME
Public Const WS_OVERLAPPED = &H0&
Public Const WS_THICKFRAME = &H40000

Public Const WS_CHILD = &H40000000
Public Const WS_VISIBLE = &H10000000
Public Const WS_TABSTOP = &H10000
Public Const WS_DISABLED = &H8000000
Public Const WS_SYSMENU = &H80000
Public Const WS_POPUP = &H80000000
Public 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 Message
Public Const WM_TIMER = &H113
Public Const WM_USER = &H400
Public Const WM_NOTIFY = &H4E
Public Const WM_MOUSEMOVE = &H200
Public Const WM_RBUTTONUP = &H205
Public Const WM_COMMAND = &H111
Public Const WM_ENABLE = &HA
Public Const WM_INITDIALOG = &H110
Public Const WM_PAINT = &HF
Public Const WM_CLOSE = &H10
Public Const WM_CREATE = &H1
Public Const WM_LBUTTONDOWN = &H201
Public Const WM_LBUTTONDBLCLK = &H203
Public Const WM_RBUTTONDBLCLK = &H206
Public Const WM_RBUTTONDOWN = &H204
Public Const WM_SIZE = &H5

Public Const WM_MEASUREITEM = &H2C
Public Const WM_DRAWITEM = &H2B
Public Const WM_INITMENUPOPUP = &H117
Public Const WM_DESTROY = &H2

' WNDCLASSEX
Public Const CS_HREDRAW = &H2
Public Const CS_VREDRAW = &H1
Public Const CS_DBLCLKS = &H8

' Window Color
Public Const COLOR_WINDOW = 5

' DefSystem Cursor
Public Const IDC_HAND = 32649&

' ShowWindow
Public Const SW_NORMAL = 1

Public Const IMAGE_ICON = 1

' DefSystem Cursor
Public Const IDC_ARROW = 32512&

' Reg Window
Public 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 Long
End Type

Public Type POINTAPI
    X As Long
    Y As Long
End Type

Public Type MSG
    hWnd As Long
    message As Long
    wParam As Long
    lParam As Long
    Times As Long
    pt As POINTAPI
End Type

Public Type RECT
        Left As Long
        Top As Long
        Right As Long
        Bottom As Long
End Type


阅读(4863) | 评论(0)


版权声明：编程爱好者网站为此博客服务提供商，如本文牵涉到版权问题，编程爱好者网站不承担相关责任，如有版权问题请直接与本文作者联系解决。谢谢！

评论

暂无评论
您需要登录后才能评论，请 登录 或者 注册