Attribute VB_Name = "modUtility"
''' GUInerd Standard Menu System
''' Version 4.1

'''

''' Common Miscellaneous Utility Routines


''' ****************************************************************************
''' *** Check the end of the file for copyright and distribution information ***
''' ****************************************************************************

Option Explicit
'' LOGFONT face size

Public Const LF_FACESIZE = 32
Public Const LF_FULLFACESIZE = 64

'' GetObject object constants

Public Const OBJ_BITMAP = 7
Public Const OBJ_BRUSH = 2
Public Const OBJ_DC = 3
Public Const OBJ_ENHMETADC = 12
Public Const OBJ_ENHMETAFILE = 13
Public Const OBJ_EXTPEN = 11
Public Const OBJ_FONT = 6
Public Const OBJ_MEMDC = 10
Public Const OBJ_METADC = 4
Public Const OBJ_METAFILE = 9
Public Const OBJ_PAL = 5
Public Const OBJ_PEN = 1
Public Const OBJ_REGION = 8

''' CreateFontIndirect

Public Type LOGFONT
        lfHeight As Long
        lfWidth As Long
        lfEscapement As Long
        lfOrientation As Long
        lfWeight As Long
        lfItalic As Byte
        lfUnderline As Byte
        lfStrikeOut As Byte
        lfCharSet As Byte
        lfOutPrecision As Byte
        lfClipPrecision As Byte
        lfQuality As Byte
        lfPitchAndFamily As Byte
        lfFaceName(1 To LF_FACESIZE) As Byte
End Type

'' UUID structure

Public Type GUID
    Data1 As Long
    Data2 As Integer
    Data3 As Integer
    Data4(0& To 7) As Byte
End Type
        
''' Used by OleCreateFontIndirect
        
Public Type FONTDESC

    cbSize As Long
    
    szName As Long
    cySize As Long
    
    sWeight As Integer
    sCharset As Integer
    
    fItalic As Long
    fUnderline As Long
    fStrikethrough As Long
    
End Type


Public Type PICTDESCBMP
    SizeofStruct As Long
    PicType As Long
    hBitmap As Long
    hPalette As Long
End Type

Public Type PICTDESCICON
    SizeofStruct As Long
    PicType As Long
    hIcon As Long
    lReserved As Long
End Type
' GetDeviceCaps parameters

Public Const LOGPIXELSX = 88
Public Const LOGPIXELSY = 90

' System Parameters info constants (to retrieve the current non-client font)

Public Const SPI_GETACCESSTIMEOUT = 60
Public Const SPI_GETANIMATION = 72
Public Const SPI_GETBEEP = 1
Public Const SPI_GETBORDER = 5
Public Const SPI_GETDEFAULTINPUTLANG = 89
Public Const SPI_GETDRAGFULLWINDOWS = 38
Public Const SPI_GETFASTTASKSWITCH = 35
Public Const SPI_GETFILTERKEYS = 50
Public Const SPI_GETFONTSMOOTHING = 74
Public Const SPI_GETGRIDGRANULARITY = 18
Public Const SPI_GETHIGHCONTRAST = 66
Public Const SPI_GETICONMETRICS = 45
Public Const SPI_GETICONTITLELOGFONT = 31
Public Const SPI_GETICONTITLEWRAP = 25
Public Const SPI_GETKEYBOARDDELAY = 22
Public Const SPI_GETKEYBOARDPREF = 68
Public Const SPI_GETKEYBOARDSPEED = 10
Public Const SPI_GETLOWPOWERACTIVE = 83
Public Const SPI_GETLOWPOWERTIMEOUT = 79
Public Const SPI_GETMENUDROPALIGNMENT = 27
Public Const SPI_GETMINIMIZEDMETRICS = 43
Public Const SPI_GETMOUSE = 3
Public Const SPI_GETMOUSEKEYS = 54
Public Const SPI_GETMOUSETRAILS = 94
Public Const SPI_GETNONCLIENTMETRICS = 41
Public Const SPI_GETPOWEROFFACTIVE = 84
Public Const SPI_GETPOWEROFFTIMEOUT = 80
Public Const SPI_GETSCREENREADER = 70
Public Const SPI_GETSCREENSAVEACTIVE = 16
Public Const SPI_GETSCREENSAVETIMEOUT = 14
Public Const SPI_GETSERIALKEYS = 62
Public Const SPI_GETSHOWSOUNDS = 56
Public Const SPI_GETSOUNDSENTRY = 64
Public Const SPI_GETSTICKYKEYS = 58
Public Const SPI_GETTOGGLEKEYS = 52
Public Const SPI_GETWINDOWSEXTENSION = 92
Public Const SPI_GETWORKAREA = 48

Public Const SPI_ICONHORIZONTALSPACING = 13
Public Const SPI_ICONVERTICALSPACING = 24

Public Const SPI_LANGDRIVER = 12

Public Const SPI_SCREENSAVERRUNNING = 97

Public Const SPI_SETACCESSTIMEOUT = 61
Public Const SPI_SETANIMATION = 73
Public Const SPI_SETBEEP = 2
Public Const SPI_SETBORDER = 6
Public Const SPI_SETCURSORS = 87
Public Const SPI_SETDEFAULTINPUTLANG = 90
Public Const SPI_SETDESKPATTERN = 21
Public Const SPI_SETDESKWALLPAPER = 20
Public Const SPI_SETDOUBLECLICKTIME = 32
Public Const SPI_SETDOUBLECLKHEIGHT = 30
Public Const SPI_SETDOUBLECLKWIDTH = 29
Public Const SPI_SETDRAGFULLWINDOWS = 37
Public Const SPI_SETDRAGHEIGHT = 77
Public Const SPI_SETDRAGWIDTH = 76
Public Const SPI_SETFASTTASKSWITCH = 36
Public Const SPI_SETFILTERKEYS = 51
Public Const SPI_SETFONTSMOOTHING = 75
Public Const SPI_SETGRIDGRANULARITY = 19
Public Const SPI_SETHANDHELD = 78
Public Const SPI_SETHIGHCONTRAST = 67
Public Const SPI_SETICONMETRICS = 46
Public Const SPI_SETICONS = 88
Public Const SPI_SETICONTITLELOGFONT = 34
Public Const SPI_SETICONTITLEWRAP = 26
Public Const SPI_SETKEYBOARDDELAY = 23
Public Const SPI_SETKEYBOARDPREF = 69
Public Const SPI_SETKEYBOARDSPEED = 11
Public Const SPI_SETLANGTOGGLE = 91
Public Const SPI_SETLOWPOWERACTIVE = 85
Public Const SPI_SETLOWPOWERTIMEOUT = 81
Public Const SPI_SETMENUDROPALIGNMENT = 28
Public Const SPI_SETMINIMIZEDMETRICS = 44
Public Const SPI_SETMOUSE = 4
Public Const SPI_SETMOUSEBUTTONSWAP = 33
Public Const SPI_SETMOUSEKEYS = 55
Public Const SPI_SETMOUSETRAILS = 93
Public Const SPI_SETNONCLIENTMETRICS = 42
Public Const SPI_SETPENWINDOWS = 49
Public Const SPI_SETPOWEROFFACTIVE = 86
Public Const SPI_SETPOWEROFFTIMEOUT = 82
Public Const SPI_SETSCREENREADER = 71
Public Const SPI_SETSCREENSAVEACTIVE = 17
Public Const SPI_SETSCREENSAVETIMEOUT = 15
Public Const SPI_SETSERIALKEYS = 63
Public Const SPI_SETSHOWSOUNDS = 57
Public Const SPI_SETSOUNDSENTRY = 65
Public Const SPI_SETSTICKYKEYS = 59
Public Const SPI_SETTOGGLEKEYS = 53
Public Const SPI_SETWORKAREA = 47
Public Declare Function GetDeviceCaps Lib "gdi32" (ByVal hDC As Long, ByVal nIndex As Long) As Long


'' Ole Functions

Public Declare Function OleCreateFontIndirect Lib "olepro32" (pFontDesc As Any, riid As GUID, pFont As StdFont) As Long
Public Declare Function OleCreatePictureIndirect Lib "olepro32" (ByVal Pict As Long, riid As GUID, fOwn As Boolean, ppvObj As Object) As Long
'' Muldiv
Public Declare Function MulDiv Lib "kernel32" (ByVal nNumber As Long, ByVal nNumerator As Long, ByVal nDenominator As Long) As Long
Public Type BITMAP
        bmType As Long
        bmWidth As Long
        bmHeight As Long
        bmWidthBytes As Long
        bmPlanes As Integer
        bmBitsPixel As Integer
        bmBits As Long
End Type

Public Type ICONINFO
        fIcon As Long
        xHotspot As Long
        yHotspot As Long
        hbmMask As Long
        hbmColor As Long
End Type
Public Declare Function GetIconInfo Lib "user32" (ByVal hIcon As Long, piconinfo As ICONINFO) As Long
Public 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
Public Const DI_MASK = &H1
Public Const DI_IMAGE = &H2
Public Const DI_NORMAL = &H3
Public Const DI_COMPAT = &H4
Public Const DI_DEFAULTSIZE = &H8

Public Declare Function DrawIconEx Lib "user32" (ByVal hDC As Long, ByVal xLeft As Long, ByVal yTop As Long, ByVal hIcon As Long, ByVal cxWidth As Long, ByVal cyWidth As Long, ByVal istepIfAniCur As Long, ByVal hbrFlickerFreeDraw As Long, ByVal diFlags As Long) As Long


Public Function GetOleFont(lfFont As LOGFONT) As StdFont

    Dim riid As GUID
    Dim vData As FONTDESC
    
    Dim vFont As StdFont
    Dim vName As String
    Dim hDC As Long
    
    With riid
    
        .Data1 = &HBEF6E003
        .Data2 = &HA874
        .Data3 = &H101A
        
        .Data4(0) = &H8B
        .Data4(1) = &HBA
        .Data4(2) = &H0
        .Data4(3) = &HAA
        .Data4(4) = &H0
        .Data4(5) = &H30
        .Data4(6) = &HC
        .Data4(7) = &HAB
        
    End With
    
    With vData
    
        .cbSize = Len(vData)
        
        hDC = GetDC(0&)
        .cySize = -(MulDiv(lfFont.lfHeight, 72, GetDeviceCaps(hDC, LOGPIXELSY)))
        ReleaseDC 0&, hDC
        
        .sWeight = lfFont.lfWeight
        
        .fStrikethrough = lfFont.lfStrikeOut
        .fUnderline = lfFont.lfUnderline
        .fItalic = lfFont.lfItalic
        vName = StrConv(lfFont.lfFaceName, vbUnicode)
        If (InStr(1, vName, ChrW(0)) <> 0) Then
            vName = Mid(vName, 1, InStr(1, vName, ChrW(0)) - 1)
        End If
        .szName = StrPtr(vName)
        .sCharset = lfFont.lfCharSet
                
    End With
    
    OleCreateFontIndirect vData, riid, vFont
    
    If (Not vFont Is Nothing) Then
        vFont.Name = vName
        vFont.Strikethrough = CBool(lfFont.lfStrikeOut)
        vFont.Underline = CBool(lfFont.lfUnderline)
        vFont.Weight = lfFont.lfWeight
        vFont.Bold = (lfFont.lfWeight >= 700)
        vFont.Italic = CBool(lfFont.lfItalic)
        
    End If
    
    ' Sometimes the OS has a difficult time with the size
    
    If Round(vFont.Size, 0) <> Round(vData.cySize, 0) Then
        vFont.Size = vData.cySize
    End If

    ' vFont.Strikethrough = lfFont.lfStrikeOut
    Set GetOleFont = vFont
    
End Function

Public Sub GetLogFont(OleFont As StdFont, lfData As LOGFONT, Optional ByVal hDC As Long)
    Dim pDC As Long, _
        fName As String

    If (hDC = 0&) Or (IsMissing(hDC) = True) Then
        pDC = GetDC(0)
        hDC = pDC
    End If

    With lfData
        If (OleFont Is Nothing) Then
            Set OleFont = New StdFont
        End If
        
        .lfCharSet = OleFont.Charset
        .lfItalic = OleFont.Italic
        .lfWeight = OleFont.Weight
        
        If OleFont.Bold Then
            .lfWeight = 700&
        End If
        
        .lfQuality = 2&
        .lfUnderline = (OleFont.Underline And 1)
        
        fName = StrConv(OleFont.Name, vbFromUnicode)
        CopyMemory .lfFaceName(1), ByVal StrPtr(fName), LenB(fName)
        
        .lfStrikeOut = (OleFont.Strikethrough And 1)
        .lfHeight = -(MulDiv(OleFont.Size, GetDeviceCaps(hDC, LOGPIXELSY), 72))
            
    End With

    If pDC <> 0& Then ReleaseDC 0&, pDC

End Sub


Public Function GetOlePicture(ByVal hImage As Long, ByVal ImageType As Long, Optional ByVal Own As Boolean) As StdPicture

    Dim varPicData As PICTDESCBMP, _
        varIconData As PICTDESCICON
        
    Dim varIPicture As StdPicture
    Dim varOLEID As GUID
    Dim varhBmp As Long
    
    With varOLEID
    
' {7BF80981-BF32-101A-8BBB-00AA00300CAB}
        
        .Data1 = &H7BF80981
        .Data2 = &HBF32
        .Data3 = &H101A
        .Data4(0&) = &H8B
        .Data4(1) = &HBB
        .Data4(3) = &HAA
        .Data4(5) = &H30
        .Data4(6) = &HC
        .Data4(7) = &HAB
        
    End With
    
    If (ImageType = IMAGE_BITMAP) Then
    
        varPicData.SizeofStruct = Len(varPicData)
        varPicData.hBitmap = hImage
        varPicData.PicType = 1
            
        OleCreatePictureIndirect VarPtr(varPicData), varOLEID, Own, varIPicture
    
    ElseIf (ImageType = IMAGE_ICON) Or (ImageType = IMAGE_CURSOR) Then
    
        varIconData.SizeofStruct = Len(varIconData)
        varIconData.hIcon = hImage
        varIconData.PicType = 3
            
        OleCreatePictureIndirect ByVal VarPtr(varIconData), varOLEID, True, varIPicture
    End If
        
    On Error Resume Next
    
    If Not varIPicture Is Nothing Then
        Set GetOlePicture = varIPicture
    End If

End Function

'' Copy one bitmap to another, changing the bitplanes from 24 to 1.

Public Function GetMonoPicture(ByVal hImage As Long, ByVal dwType As Long, _
                               Optional ByVal cx As Long = 16&, _
                               Optional ByVal cy As Long = 16&) As Long
    Dim hImageNew As Long
        
    If dwType = IMAGE_ICON Then
        
        hImageNew = CopyImage(hImage, IMAGE_ICON, cx, cy, &H41)
        
    Else
    
        hImageNew = CopyImage(hImage, IMAGE_BITMAP, cx, cy, &H41)
    
    End If
    
    GetMonoPicture = hImageNew
    
End Function

'' Function to get a 16x16 representation of the picture

Public Function GetSmallPicture(ByVal hImage As Long, ByVal dwType As Long, Optional ByVal cx As Long = 16&, Optional ByVal cy As Long = 16&, Optional ByVal crUnMask As Long = -1&, _
                               Optional ByVal fDropShadow As Boolean) As Long
    Dim hDC As Long, _
        nDC As Long
    
    Dim rcPicture As RECT
        
    GetSmallPicture = CopyImage(hImage, dwType, cx, cy, LR_COPYFROMRESOURCE)
    
    If (crUnMask <> -1&) Then
        If (dwType = IMAGE_BITMAP) Then
            hDC = GetDC(0&)
            nDC = CreateCompatibleDC(hDC)
            ReleaseDC 0&, hDC
            
            rcPicture.Right = cx
            rcPicture.Bottom = cy
            
            SelectObject nDC, GetSmallPicture
            
            Unmask nDC, rcPicture, &HC0C0C0, crUnMask
            DeleteDC nDC
        End If
    End If
    
End Function

Public Function MakePoints(ByVal lParam As Long) As POINTAPI

    Dim p As POINTAPI
    
    p.x = (lParam And &HFFFF&)
    p.y = lParam / &H10000
    
    MakePoints = p
    
End Function

Public Function CopyToBitmap(ByVal hImage As Long, ByVal ImageType As Integer) As StdPicture
    Dim newDC As Long, _
        newDC2 As Long, _
        newBitmap As Long, _
        dDC As Long
        
    Dim lpBitmap As BITMAP, _
        lpIcon As ICONINFO
        
    Dim iWidth As Long, _
        iHeight As Long
    
    dDC = GetDC(0&)
    newDC = CreateCompatibleDC(dDC)
    
    If (ImageType = 1&) Then        ' Bitmap
        GetObject hImage, Len(lpBitmap), lpBitmap
        
        iWidth = lpBitmap.bmWidth
        iHeight = lpBitmap.bmHeight
    Else                            ' Icon
        GetIconInfo hImage, lpIcon
        GetObject lpIcon.hbmColor, Len(lpBitmap), lpBitmap
    End If
    
    iWidth = lpBitmap.bmWidth
    iHeight = lpBitmap.bmHeight
    
    newBitmap = CreateCompatibleBitmap(dDC, iWidth, iHeight)
    
    SelectObject newDC, newBitmap
    
    If (ImageType = 1&) Then
        newDC2 = CreateCompatibleDC(dDC)
        SelectObject newDC2, hImage
        
        BitBlt newDC, 0&, 0&, iWidth, iHeight, newDC2, 0&, 0&, vbSrcCopy
        
        DeleteDC newDC2
    Else
    
        DrawIconEx newDC, 0&, 0&, hImage, iWidth, iHeight, 0&, 0&, DI_NORMAL
    
    End If
    
    DeleteDC newDC
    Set CopyToBitmap = GetOlePicture(newBitmap, IMAGE_BITMAP, True)
    
End Function

Public Function Unmask(ByVal hDC As Long, lpRect As RECT, ByVal MaskColor As Long, ByVal BackColor As Long)

    Dim i As Long, _
        j As Long
        
    Dim cx As Long, _
        cy As Long
        
    Dim x As Long, _
        y As Long
        
    Dim nPixel As Long
        
    x = lpRect.Left
    cx = lpRect.Right - x
    
    y = lpRect.Top
    cy = lpRect.Bottom - y
        
    For i = x To (x + cx)
        For j = y To (y + cy)
        
            nPixel = GetPixel(hDC, i, j)
            If (nPixel = MaskColor) Then
                SetPixel hDC, i, j, BackColor
            End If
        
        Next j
    Next i

End Function

''' Copyright (C) 2001 Nathan Moschkin

''' ****************** NOT FOR COMMERCIAL USE *****************
''' Inquire if you would like to use this code commercially.
''' Unauthorized recompilation and/or re-release for commercial
''' use is strictly prohibited.
'''
''' please send changes made to code to me at the address, below,
''' if you plan on making those changes publicly available.

''' e-mail questions or comments to nmosch@tampabay.rr.com



