高分求解

Question

怎样改变VB菜单中的字体大小？

Answer 1

源代码下载
http://www.vbaspnew.com/ziyuan/y/ct/其中
menuchangefont.zip 改变菜单的字体(5KB)  就是你要的效果

Answer 2

模块中：
Option Explicit
DefLng A-Z
Const MFT_STRING = 0
Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End TypeType Size
    cx As Long
    cy As Long
End Type'MENUITEMINFO
Public 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' MEASUREITEMSTRUCT for ownerdraw
Type MEASUREITEMSTRUCT
    CtlType As Long
    CtlID As Long
    itemID As Long
    itemWidth As Long
    itemHeight As Long
    itemData As Long
End Type' DRAWITEMSTRUCT for ownerdraw
Type DRAWITEMSTRUCT
    CtlType As Long
    CtlID As Long
    itemID As Long
    itemAction As Long
    itemState As Long
    hwndItem As Long
    hdc As Long
    rcItem As RECT
    itemData As Long
End TypePublic Declare Function GetMenu Lib "user32" _
   (ByVal hWnd As Long) As LongPublic Declare Function GetSubMenu Lib "user32" _
   (ByVal hMenu As Long, ByVal nPos As Long) As LongPublic Declare Function GetMenuItemCount Lib "user32" _
   (ByVal hMenu As Long) As LongPublic Declare Function GetMenuItemInfo Lib "user32" _
    Alias "GetMenuItemInfoA" _
   (ByVal hMenu As Long, ByVal un As Long, _
    ByVal b As Boolean, lpmii As MENUITEMINFO) As LongDeclare Function GetMenuItemID Lib "user32" _
    (ByVal hMenu As Long, ByVal nPos As Long) As LongPublic Declare Function SetMenuItemInfo Lib "user32" _
    Alias "SetMenuItemInfoA" _
   (ByVal hMenu As Long, ByVal uItem As Long, _
    ByVal fByPosition As Long, lpmii As MENUITEMINFO) As LongDeclare Function AppendMenu Lib "user32" _
    Alias "AppendMenuA" (ByVal hMenu As Long, _
    ByVal wFlags As Long, ByVal wIDNewItem As Long, _
    ByVal lpNewItem As Any) As LongDeclare Function RemoveMenu Lib "user32" _
    (ByVal hMenu As Long, ByVal nPosition As Long, _
    ByVal wFlags As Long) As LongDeclare Function CreateFont Lib "gdi32" _
    Alias "CreateFontA" (ByVal H As Long, _
    ByVal W As Long, ByVal E As Long, ByVal O As Long, _
    ByVal W As Long, ByVal I As Long, ByVal U As Long, _
    ByVal S As Long, ByVal C As Long, ByVal OP As Long, _
    ByVal CP As Long, ByVal Q As Long, ByVal PAF As Long, _
    ByVal F As String) As LongDeclare Function DeleteObject Lib "gdi32" _
    (ByVal hObject As Long) As Long'MENUITEMINFO
Public Const MIIM_STATE = &H1
Public Const MIIM_ID = &H2
Public Const MIIM_SUBMENU = &H4
Public Const MIIM_CHECKMARKS = &H8
Public Const MIIM_TYPE = &H10
Public Const MIIM_DATA = &H20'menustyle
Public Const MF_BYCOMMAND = &H0&
Public Const MF_BYPOSITION = &H400&Public Const MF_STRING = &H0&
Public Const MF_BITMAP = &H4&
Public Const MF_OWNERDRAW = &H100&'textout style
Public Const ETO_OPAQUE = 2' Owner draw state
Public Const ODS_SELECTED = &H1
Public Const ODS_GRAYED = &H2
Public Const ODS_DISABLED = &H4
Public Const ODS_CHECKED = &H8
Public Const ODS_FOCUS = &H10'messages:
Public Const WM_COMMAND = &H111
Public Const WM_SYSCOMMAND = &H112
Public Const WM_MENUSELECT = &H11F
Public Const WM_LBUTTONUP = &H202
Public Const WM_MBUTTONUP = &H208
Public Const WM_RBUTTONUP = &H205
Public Const WM_USER = &H400
Public Const WM_CREATE = &H1
Public Const WM_DESTROY = &H2
Public Const WM_DRAWITEM = &H2B
Public Const WM_MEASUREITEM = &H2C
Public Const WM_SYSCOLORCHANGE = &H15Declare Sub MemCopy Lib "kernel32" Alias _
        "RtlMoveMemory" (dest As Any, src As Any, _
        ByVal numbytes As Long)Public Const GWL_WNDPROC = (-4)
Public Const GWL_USERDATA = (-21)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 LongDeclare Function SetWindowLong Lib "user32" _
    Alias "SetWindowLongA" (ByVal hWnd As Long, _
    ByVal nIndex As Long, ByVal dwNewLong As Long) As LongDeclare Function TextOut Lib "gdi32" Alias "TextOutA" _
    (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, _
    ByVal lpString As String, ByVal nCount As Long) As LongDeclare Function ExtTextOut Lib "gdi32" Alias _
    "ExtTextOutA" (ByVal hdc As Long, ByVal x As _
    Long, ByVal y As Long, ByVal wOptions As Long, _
    lpRect As RECT, ByVal lpString As String, _
    ByVal nCount As Long, lpDx As Long) As LongDeclare Function GetDC Lib "user32" (ByVal hWnd As Long) As Long
Declare Function ReleaseDC Lib "user32" (ByVal hWnd As Long, ByVal hdc As Long) As Long
Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Declare Function SetBkColor Lib "gdi32" (ByVal hdc As Long, ByVal crColor As Long) As Long
Declare Function SetTextColor Lib "gdi32" (ByVal hdc As Long, ByVal crColor As Long) As Long
Declare Function GetSysColor Lib "user32" (ByVal nIndex As Long) As Long
Declare Function GetTextExtentPoint Lib "gdi32" _
    Alias "GetTextExtentPointA" (ByVal hdc As Long, _
    ByVal lpszString As String, ByVal cbString As Long, _
    lpSize As Size) As LongPublic Const COLOR_MENU = 4
Public Const COLOR_MENUTEXT = 7
Public Const COLOR_HIGHLIGHT = 13
Public Const COLOR_HIGHLIGHTTEXT = 14
Public Const COLOR_GRAYTEXT = 17'consts MenuItem IDs.
Public Const IDM_CHARACTER = 10
Public Const IDM_REGULAR = 11
Public Const IDM_BOLD = 12
Public Const IDM_ITALIC = 13
Public Const IDM_UNDERLINE = 14Type myItemType
    cchItemText As Integer
    szItemText As String * 32
End TypePublic OldWindowProc
Public hMenu, hSubMenu
Public iNoOfMenuItems, MyItem() As myItemType
Public clrPrevText, clrPrevBkgnd
Public hfntPrevPublic Const ODT_MENU = 1
Public hFont As Long

Answer 3

接上，
Public Function NewWindowProc(ByVal hWnd As Long, ByVal msg As Long, ByVal wParam As Long, lParam As Long) As Long
    Dim mM As MEASUREITEMSTRUCT
    Dim dM As DRAWITEMSTRUCT
    Select Case msg
        Case WM_DRAWITEM
            MemCopy dM, lParam, Len(dM)
            If dM.CtlType = ODT_MENU Then
                OnDrawMenuItem hWnd, dM
            End If
        Case WM_MEASUREITEM
            MemCopy mM, lParam, Len(mM)
            If mM.CtlType = ODT_MENU Then
                mM = OnMeasureItem(hWnd, mM)
                MemCopy lParam, mM, Len(mM)
            End If
    End Select
    NewWindowProc = CallWindowProc(OldWindowProc, hWnd, msg, wParam, VarPtr(lParam))
End FunctionSub CreateMenus(hWnd As Long)
    hMenu = GetMenu(Form1.hWnd)
    hFont = CreateFont(20, 0, 0, 0, 0, 0, 0, 0, 106, 0, 16, 0, 0, "隶书") '"Arial")
    Dim iNoOfMenu%, iNoOfSubMenu%
    Dim iCounter1%, iCounter2%
    iNoOfMenu = GetMenuItemCount(hMenu)
    ReDim MyItem(1 To 7)
    If iNoOfMenu Then
        For iCounter1 = 0 To iNoOfMenu - 1
            CreateOwnerDrawMenus hMenu, iCounter1
            hSubMenu = GetSubMenu(hMenu, iCounter1)
            iNoOfSubMenu = GetMenuItemCount(hSubMenu)
            If iNoOfSubMenu Then
                For iCounter2 = 0 To iNoOfSubMenu - 1
                    CreateOwnerDrawMenus hSubMenu, iCounter2
                Next iCounter2
            End If
        Next iCounter1
    End If
End Sub
Sub CreateOwnerDrawMenus(hdMenu As Long, iMenuID As Integer)
    Dim minfo As MENUITEMINFO, r As Long
    iNoOfMenuItems = iNoOfMenuItems + 1
    minfo.cbSize = Len(minfo)
    minfo.fMask = MIIM_TYPE
    minfo.fType = MFT_STRING
    minfo.dwTypeData = Space$(256)
    minfo.cch = Len(minfo.dwTypeData)
     'get menuitem data
    r = GetMenuItemInfo(hdMenu, iMenuID, True, minfo)
     'and save into user array
    MyItem(iNoOfMenuItems).cchItemText = minfo.cch 'menuitem length
    MyItem(iNoOfMenuItems).szItemText = Trim(minfo.dwTypeData) 'text
     'change menu type
    minfo.fType = MF_OWNERDRAW
    minfo.fMask = MIIM_TYPE Or MIIM_DATA
    minfo.dwItemData = iNoOfMenuItems
     'into MF_OWNERDRAW
    r = SetMenuItemInfo(hdMenu, iMenuID, True, minfo)
End SubFunction OnMeasureItem(hWnd As Long, lpmis As MEASUREITEMSTRUCT) As MEASUREITEMSTRUCT
    On Error GoTo E2
    Dim xM As MEASUREITEMSTRUCT, hfntOld As Long
    Dim S As Size, hdc As Long
    hdc = GetDC(hWnd)
    hfntOld = SelectObject(hdc, hFont)
    GetTextExtentPoint hdc, MyItem(lpmis.itemData).szItemText, _
            MyItem(lpmis.itemData).cchItemText, S
    xM.itemWidth = S.cx + 10
    xM.itemHeight = S.cy
    SelectObject hdc, hfntOld
    ReleaseDC hWnd, hdc
    LSet OnMeasureItem = xM
    Exit Function
E2:
    Form1.Caption = lpmis.itemData
    Exit Function
End FunctionSub OnDrawMenuItem(hWnd As Long, lpdis As DRAWITEMSTRUCT)
    On Error GoTo E1
    Dim x, y
    If (lpdis.itemState And ODS_SELECTED) Then 'if selected
        clrPrevText = SetTextColor(lpdis.hdc, GetSysColor(COLOR_HIGHLIGHTTEXT))
        clrPrevBkgnd = SetBkColor(lpdis.hdc, GetSysColor(COLOR_HIGHLIGHT))
    Else
        clrPrevText = SetTextColor(lpdis.hdc, GetSysColor(COLOR_MENUTEXT))
        clrPrevBkgnd = SetBkColor(lpdis.hdc, GetSysColor(COLOR_MENU))
    End If
    x = lpdis.rcItem.Left + 20
    y = lpdis.rcItem.Top
    hfntPrev = SelectObject(lpdis.hdc, hFont)
    ExtTextOut lpdis.hdc, x, y, ETO_OPAQUE, lpdis.rcItem, Trim(" "), 1&, 0&
    TextOut lpdis.hdc, x, y, MyItem(lpdis.itemData).szItemText, MyItem(lpdis.itemData).cchItemText
    SelectObject lpdis.hdc, hfntPrev
    SetTextColor lpdis.hdc, clrPrevText
    SetBkColor lpdis.hdc, clrPrevBkgnd
    Exit Sub
E1:
    Form1.Caption = lpdis.itemData
    Exit Sub
End Sub
Sub OnDestroy()
    Dim r As Long
   'do some clean works
    Dim minfo As MENUITEMINFO, id As Integer
    Dim iNoOfMenu%, iNoOfSubMenu%
    Dim iCounter1%, iCounter2%
    iNoOfMenu = GetMenuItemCount(hMenu)
    'iMenuItemBound
    If iNoOfMenu Then
        For iCounter1 = 0 To iNoOfMenu - 1
            minfo.fMask = MIIM_DATA
            r = GetMenuItemInfo(hMenu, iCounter1, True, minfo)
            DeleteObject minfo.dwItemData
            r = SetMenuItemInfo(hMenu, iCounter1, True, minfo)
            hSubMenu = GetSubMenu(hMenu, iCounter1)
            iNoOfSubMenu = GetMenuItemCount(hSubMenu)
            If iNoOfSubMenu Then
                For iCounter2 = 0 To iNoOfSubMenu - 1
                    minfo.fMask = MIIM_DATA
                    r = GetMenuItemInfo(hSubMenu, iCounter2, True, minfo)
                    DeleteObject minfo.dwItemData
                    r = SetMenuItemInfo(hSubMenu, iCounter2, True, minfo)
                Next iCounter2
            End If
        Next iCounter1
    End If
    DeleteObject hFont
    Erase MyItem
End Sub
窗体：
Option ExplicitPrivate Sub Form_Load()
    Call CreateMenus(Me.hWnd)
    'set Callback
    OldWindowProc = SetWindowLong(Me.hWnd, GWL_WNDPROC, AddressOf NewWindowProc)
End SubPrivate Sub Form_Unload(Cancel As Integer)
    'do some clean work
    Call OnDestroy
End Sub

Answer 4

参考一下这个代码,是你所要的效果
http://insoft.51.net/soft/menufont.zip

Answer 5

谢谢上面各位，下载的代码我放在MDI主窗口会出错，但是如果不是MDI主窗口不为出错，
出错代码处为MyItem(iNoOfMenuItems).cchItemText = minfo.cch 'menuitem length
当minfo.cch超过16时为出错，请问我应该改掉那个参数

Answer 6

不好意思，上面写得有些错误，当MyItem(iNoOfMenuItems)超过8时就出错