DP Tool Club 22/CD_ASCQ_22_0695.iso/win/prg/psmmm11.exe/SAMPLE.DEU/BMPMNU/BASIC/BMPMNU.BAS

BASIC Source File | 1995-03-19 | 11KB | 283 lines

Option Explicit

Global Const MF_BYPOSITION = &H400
Global Const MF_SEPARATOR = &H800
Global Const MF_ENABLED = &H0
Global Const MF_GRAYED = &H1
Global Const MF_DISABLED = &H2
Global Const MF_UNCHECKED = &H0
Global Const MF_CHECKED = &H8
Global Const MF_BITMAP = &H4
Global Const MF_POPUP = &H10
Global Const MF_MENUBARBREAK = &H20
Global Const MF_MENUBREAK = &H40

Global Const WHITE_BRUSH = 0
Global Const LF_FACESIZE = 32

Type RECT
    left   As Integer
    top    As Integer
    right  As Integer
    bottom As Integer
End Type

Type LOGFONT
    lfHeight         As Integer
    lfWidth          As Integer
    lfEscapement     As Integer
    lfOrientation    As Integer
    lfWeight         As Integer
    lfItalic         As String * 1
    lfUnderline      As String * 1
    lfStrikeOut      As String * 1
    lfCharSet        As String * 1
    lfOutPrecision   As String * 1
    lfClipPrecision  As String * 1
    lfQuality        As String * 1
    lfPitchAndFamily As String * 1
    lfFaceName       As String * LF_FACESIZE
End Type

Type TEXTMETRIC
    tmHeight           As Integer
    tmAscent           As Integer
    tmDescent          As Integer
    tmInternalLeading  As Integer
    tmExternalLeading  As Integer
    tmAveCharWidth     As Integer
    tmMaxCharWidth     As Integer
    tmWeight           As Integer
    tmItalic           As String * 1
    tmUnderlined       As String * 1
    tmStruckOut        As String * 1
    tmFirstChar        As String * 1
    tmLastChar         As String * 1
    tmDefaultChar      As String * 1
    tmBreakChar        As String * 1
    tmPitchAndFamily   As String * 1
    tmCharSet          As String * 1
    tmOverhang         As Integer
    tmDigitizedAspectX As Integer
    tmDigitizedAspectY As Integer
End Type

Declare Function DestroyMenu Lib "User" (ByVal hMenu As Integer) As Integer
Declare Function DrawMenuBar Lib "USER" (ByVal hWnd As Integer) As Integer
Declare Function GetMenu Lib "User" (ByVal hWnd As Integer) As Integer
Declare Function GetMenuItemCount Lib "User" (ByVal hMenu As Integer) As Integer
Declare Function GetMenuItemID Lib "User" (ByVal hMenu As Integer, ByVal nPos As Integer) As Integer
Declare Function GetMenuState Lib "User" (ByVal hMenu As Integer, ByVal wID As Integer, ByVal wFlags As Integer) As Integer
Declare Function GetMenuString Lib "User" (ByVal hMenu As Integer, ByVal wIDItem As Integer, ByVal lpString As String, ByVal nMaxCount As Integer, ByVal wFlag As Integer) As Integer
Declare Function GetSubMenu Lib "User" (ByVal hMenu As Integer, ByVal nPos As Integer) As Integer
Declare Function ModifyMenu Lib "User" (ByVal hMenu As Integer, ByVal nPosition As Integer, ByVal wFlags As Integer, ByVal wIDNewItem As Integer, ByVal lpString As Any) As Integer

Declare Function CreateBitmap Lib "GDI" (ByVal nWidth As Integer, ByVal nHeight As Integer, ByVal nPlanes As Integer, ByVal nBitCount As Integer, ByVal lpBits As Any) As Integer
Declare Function CreateCompatibleDC Lib "GDI" (ByVal hDC As Integer) As Integer
Declare Function CreateFontIndirect Lib "GDI" (lpLogFont As LOGFONT) As Integer
Declare Function CreateIC Lib "GDI" (ByVal lpDriverName As String, ByVal lpDeviceName As String, ByVal lpOutput As String, ByVal lpInitData As String) As Integer
Declare Function DeleteDC Lib "GDI" (ByVal hDC As Integer) As Integer
Declare Function DeleteObject Lib "GDI" (ByVal hObject As Integer) As Integer
Declare Function ExtTextOut Lib "GDI" (ByVal hDC As Integer, ByVal x As Integer, ByVal y As Integer, ByVal wOptions As Integer, lpRect As Any, ByVal lpString As String, ByVal nCount As Integer, lpDx As Any) As Integer
Declare Function FillRect Lib "User" (ByVal hDC As Integer, lpRect As RECT, ByVal hBrush As Integer) As Integer
Declare Function GetStockObject Lib "GDI" (ByVal nIndex As Integer) As Integer
Declare Function GetTextExtent Lib "GDI" (ByVal hDC As Integer, ByVal lpString As String, ByVal nCount As Integer) As Long
Declare Function GetTextMetrics Lib "GDI" (ByVal hDC As Integer, lpMetrics As TEXTMETRIC) As Integer
Declare Function SelectObject Lib "GDI" (ByVal hDC As Integer, ByVal hObject As Integer) As Integer
Declare Function TextOut Lib "GDI" (ByVal hDC As Integer, ByVal x As Integer, ByVal y As Integer, ByVal lpString As String, ByVal nCount As Integer) As Integer


Global gszFaceName   As String  'Name of the font that it will be used in the menu
Global ghBitmap()    As Integer 'Array of handle of bitmap
Global gnBitmapCount As Integer 'Number of handle in the array

'-------------------------------------------------------------------
'This procedure frees the bitmaps created for each menu item.
'This is necessary because, unlike the Juliet's rose(1) that will
'smell as well with another name, a bitmap menu item is quit different
'of a string menu item. With the first, you have to deal with bitmaps
'that are owned by the system so you have to delete them before ending
'the program. If you do not, a lot of resource will be lost.
'
' Parameters
'   No parameter
'
'(1) Romeo and Juliet, William SHAKESPEARE
'-------------------------------------------------------------------
Sub CleanBitmapMenu ()

    Dim i As Integer
    Dim dummy As Integer

    On Error Resume Next
    For i = 0 To gnBitmapCount
        dummy = DeleteObject(ghBitmap(i))
    Next i

    Erase ghBitmap

End Sub

'-------------------------------------------------------------------
' This function create a bitmap image of a text with the given font.
'
' Parameters
'    szText     : Text of the menu item
'    fTopLevel  : Indicate if the menu is a top level menu
'    szFaceName : Name of the font that will be used
'
' Returns
'    The return values is the handle of the bitmap image of
'    the menu Item if the function is successful. Otherwise, it is
'    0.
'-------------------------------------------------------------------
Function GetBitmapMenu (szText As String, fTopLevel As Integer, szFaceName As String) As Integer

    Dim lf      As LOGFONT
    Dim tm      As TEXTMETRIC
    Dim rc      As RECT
    Dim dwSize  As Long
    Dim wCX     As Long
    Dim wCY     As Long
    Dim hBitmap As Integer
    Dim hDC     As Integer
    Dim hdcMem  As Integer
    Dim hFont   As Integer
    Dim dummy   As Integer

    hDC = CreateIC("DISPLAY", Chr$(0), Chr$(0), Chr$(0))
    dummy = GetTextMetrics(hDC, tm)

    lf.lfHeight = 1 * tm.tmHeight
    lf.lfFaceName = szFaceName + Chr$(0)

    hdcMem = CreateCompatibleDC(hDC)
    hFont = CreateFontIndirect(lf)
    dummy = SelectObject(hdcMem, hFont)
    dwSize = GetTextExtent(hdcMem, szText, Len(szText))

    wCX = dwSize And 65535
    wCY = (dwSize / 65536)
    'If the menu is a top level menu, we add a little space before and
    'after the text.
    If fTopLevel Then
        hBitmap = CreateBitmap(wCX + 18, wCY, 1, 1, CLng(0))
        dummy = SelectObject(hdcMem, hBitmap)

        rc.left = 0
        rc.top = 0
        rc.right = wCX + 18
        rc.bottom = wCY

        dummy = FillRect(hdcMem, rc, GetStockObject(WHITE_BRUSH))
        dummy = TextOut(hdcMem, 8, 0, szText, Len(szText))
    Else
        hBitmap = CreateBitmap(wCX, wCY, 1, 1, CLng(0))
        dummy = SelectObject(hdcMem, hBitmap)

        rc.left = 0
        rc.top = 0
        rc.right = wCX
        rc.bottom = wCY

        dummy = FillRect(hdcMem, rc, GetStockObject(WHITE_BRUSH))
        dummy = TextOut(hdcMem, 0, 0, szText, Len(szText))
    End If

    dummy = DeleteDC(hdcMem)
    dummy = DeleteDC(hDC)
    dummy = DeleteObject(hFont)

    GetBitmapMenu = hBitmap

End Function

'-------------------------------------------------------------------
' This call the procedure TranslateMenu witch change recursively
' all the "string" menu items in "bitmap" menu item. It also
' initialize some global variables.
'
' Parameters
'    hWnd       : Handle of the window that it owns the menu to
'                 translate.
'    szFaceName : Name of the font that will be used
'-------------------------------------------------------------------
Sub TranslateAllMenu (hWnd As Integer, szFaceName As String)

    Dim hMenu As Integer
    Dim dummy As Integer

    If gnBitmapCount > 0 Then
        Call CleanBitmapMenu
    End If

    gnBitmapCount = 0
    gszFaceName = szFaceName
    hMenu = GetMenu(hWnd)

    Call TranslateMenu(hMenu, True)
    dummy = DrawMenuBar(hWnd)

End Sub

'-------------------------------------------------------------------
' This procedure translate recursively all the menu and submenu of
' a window given to the "TranslateAllMenu".
'
' Parameters
'    hMenu      : Handle of the menu to translate.
'    fTopLevel  : Indicate if the menu is a top level menu
'-------------------------------------------------------------------
Sub TranslateMenu (hMenu As Integer, fTopLevel As Integer)

    Dim NumberOfItem As Integer
    Dim ItemNumber   As Integer
    Dim hSubMenu     As Integer
    Dim fMenuSate    As Integer
    Dim dummy        As Integer
    Dim hBmpMenu     As Integer
    Dim menuId       As Integer
    Dim nTextLen     As Integer
    Dim szText       As String

    NumberOfItem = GetMenuItemCount(hMenu)
    For ItemNumber = 0 To NumberOfItem - 1
        hSubMenu = GetSubMenu(hMenu, ItemNumber)
        If hSubMenu Then
            Call TranslateMenu(hSubMenu, False)
        End If

        fMenuSate = GetMenuState(hMenu, ItemNumber, MF_BYPOSITION)
        'Do nothing if the menu item is already a bitmap or if it
        'is a separator.
        If (fMenuSate And MF_BITMAP) = MF_BITMAP Then
        ElseIf (fMenuSate And MF_MENUBARBREAK) = MF_MENUBARBREAK Then
        ElseIf (fMenuSate And MF_MENUBREAK) = MF_MENUBREAK Then
        ElseIf (fMenuSate And MF_SEPARATOR) = MF_SEPARATOR Then
        Else
            'Get the text of the menu item and create a bitmap image of it.
            szText = String$(70, Chr$(0))
            nTextLen = GetMenuString(hMenu, ItemNumber, szText, Len(szText), MF_BYPOSITION)
            szText = Left$(szText, nTextLen)

            hBmpMenu = GetBitmapMenu(szText, fTopLevel, gszFaceName)
            'Save the handle of the bitmap with the aim to free the bitmap at the end
            'of the program.
            ReDim Preserve ghBitmap(gnBitmapCount + 1)
            ghBitmap(gnBitmapCount) = hBmpMenu
            gnBitmapCount = gnBitmapCount + 1

            'Change the menu item in a bitmap menu item. The way to do this is a little bit different if the menu
            'is a "popup" menu or if it is a "submenu".
            If hSubMenu Then
                dummy = ModifyMenu(hMenu, ItemNumber, fMenuSate Or MF_BITMAP Or MF_BYPOSITION Or MF_POPUP, hSubMenu, CLng(hBmpMenu))
            Else
                menuId = GetMenuItemID(hMenu, ItemNumber)
                dummy = ModifyMenu(hMenu, ItemNumber, fMenuSate Or MF_BITMAP Or MF_BYPOSITION, menuId, CLng(hBmpMenu))
            End If
        End If
    Next ItemNumber

End Sub