msupport.bas

一款Grid表格控件源代码,非常棒.不下你一定会后悔

    End If

End Function

Public Property Get SystemImlHandle(ByVal sFile As String, _
                                    ByVal eIconSize As EISIconSize) As Long

Dim lHandle As Long
Dim tFI     As SHFILEINFOA

    SystemImlHandle = -1
    If Not (Len(sFile) = 0) Then
        lHandle = SHGetFileInfoA(sFile, FILE_ATTRIBUTE_NORMAL, tFI, LenB(tFI), ICON_FLAGS Or eIconSize)
        If Not (lHandle = 0) Then
            SystemImlHandle = lHandle
        End If
    End If

End Property

Public Function SystemIconIndex(ByVal sFile As String, _
                                ByVal eIconSize As EISIconSize) As Long

Dim lFlags  As Long
Dim lResult As Long

    SystemIconIndex = -1
    lFlags = SHGFI_SYSICONINDEX Or SHGFI_USEFILEATTRIBUTES Or eIconSize
    
    If IsNT Then
        If Not (LenB(sFile) = 0) Then
            Dim tFW As SHFILEINFOW
            lResult = SHGetFileInfoW(StrPtr(sFile), FILE_ATTRIBUTE_NORMAL, tFW, Len(tFW), lFlags)
            If Not (lResult = 0) Then
                SystemIconIndex = tFW.iIcon
            End If
        End If
    Else
        If Not (Len(sFile) = 0) Then
            Dim tFA As SHFILEINFOA
            lResult = SHGetFileInfoA(sFile, FILE_ATTRIBUTE_NORMAL, tFA, Len(tFA), lFlags)
            If Not (lResult = 0) Then
                SystemIconIndex = tFA.iIcon
            End If
        End If
    End If

End Function

Public Function SystemIconHandle(ByVal sFile As String, _
                                 ByVal eIconSize As EISIconSize) As Long

Dim lFlags  As Long
Dim lResult As Long

    SystemIconHandle = -1
    lFlags = SHGFI_ICON Or SHGFI_USEFILEATTRIBUTES Or eIconSize
    
    If IsNT Then
        If Not (Len(sFile) = 0) Then
            Dim tFW As SHFILEINFOW
            lResult = SHGetFileInfoW(StrPtr(sFile), FILE_ATTRIBUTE_NORMAL, tFW, Len(tFW), lFlags)
            If Not (lResult = 0) Then
                SystemIconHandle = tFW.hIcon
            End If
        End If
    Else
        If Not (Len(sFile) = 0) Then
            Dim tFA As SHFILEINFOA
            lResult = SHGetFileInfoA(sFile, FILE_ATTRIBUTE_NORMAL, tFA, Len(tFA), lFlags)
            If Not (lResult = 0) Then
                SystemIconHandle = tFA.hIcon
            End If
        End If
    End If
   
End Function

Public Function EnumSystemFonts(ByVal lHdc As Long) As Variant

Dim vFonts As Variant

    m_lFontCount = 0
    ReDim vFonts(1, 0)
    EnumFontFamiliesA lHdc, vbNullString, AddressOf EnumFontFamProc, vFonts
    EnumSystemFonts = vFonts
    Erase vFonts

End Function

Public Function ShowColorDialog(ByVal lOwnerHwnd As Long, _
                                ByVal lDfltClr As Long, _
                                ByRef lCustomClr() As Long, _
                                Optional ByVal ShowMode As Integer = 0) As Long

Dim tCD As CHOOSECOLOR

On Error GoTo Handler

    With tCD
        .lStructSize = Len(tCD)
        .hwndOwner = lOwnerHwnd
        .hInstance = App.hInstance
        .flags = CC_ANYCOLOR
        Select Case ShowMode
        Case 1
            .flags = .flags Or CC_FULLOPEN
        Case 2
            .flags = .flags Or CC_PREVENTFULLOPEN
        End Select
        .flags = .flags Or CC_RGBINIT
        .rgbResult = lDfltClr
        .lpCustColors = VarPtr(lCustomClr(0))
        If ChooseColorA(tCD) = 1 Then
            ShowColorDialog = .rgbResult
        Else
            ShowColorDialog = -1
        End If
    End With

Handler:

End Function

Public Function ShowFontDialog(ByVal lOwnerHwnd As Long) As StdFont

Dim lhMem       As Long
Dim lPtr        As Long
Dim lRet        As Long
Dim lChar       As Long
Dim lHdc        As Long
Dim sDftFnt     As String
Dim tCF         As CHOOSEFONT
Dim tFont       As LOGFONT
Dim oStdFnt     As StdFont

On Error GoTo Handler

    sDftFnt = "MS Sans Serif" & Chr$(0)
    With tFont
        .lfHeight = 0
        .lfWidth = 0
        .lfEscapement = 0
        .lfOrientation = 0
        .lfWeight = FW_NORMAL
        .lfCharSet = DEFAULT_CHARSET
        .lfOutPrecision = OUT_DEFAULT_PRECIS
        .lfClipPrecision = CLIP_DEFAULT_PRECIS
        .lfQuality = DEFAULT_QUALITY
        .lfPitchAndFamily = DEFAULT_PITCH Or FF_ROMAN
        For lChar = 1 To Len(sDftFnt)
            .lfFaceName(lChar - 1) = CByte(Asc(Mid$(sDftFnt, lChar, 1)))
        Next lChar
    End With

    lhMem = GlobalAlloc(GMEM_MOVEABLE Or GMEM_ZEROINIT, Len(tFont))
    lPtr = GlobalLock(lhMem)
    CopyMemory ByVal lPtr, tFont, Len(tFont)
    lHdc = GetDC(lOwnerHwnd)
    
    With tCF
        .lStructSize = Len(tCF)
        .hwndOwner = lOwnerHwnd
        .hdc = lHdc
        .lpLogFont = lPtr
        .iPointSize = 120
        .flags = CF_BOTH Or CF_EFFECTS Or CF_FORCEFONTEXIST Or CF_INITTOLOGFONTSTRUCT Or CF_LIMITSIZE
        .rgbColors = RGB(0, 0, 0)
        .nFontType = REGULAR_FONTTYPE
        .nSizeMin = 10
        .nSizeMax = 72
    End With
    
    lRet = ChooseFontA(tCF)
    If Not (lRet = 0) Then
        CopyMemory tFont, ByVal lPtr, Len(tFont)
        Set oStdFnt = New StdFont
        With oStdFnt
            .Bold = (tFont.lfWeight >= FW_BOLD)
            .Charset = tFont.lfCharSet
            .Italic = CBool(tFont.lfItalic)
            .Name = StrConv(tFont.lfFaceName, vbUnicode)
            .Size = HeightToPoints(tFont.lfHeight)
            .Strikethrough = tFont.lfStrikeOut
            .Underline = tFont.lfUnderline
            .Weight = tFont.lfWeight
        End With
        Set ShowFontDialog = oStdFnt
        Set oStdFnt = Nothing
    End If

Handler:
    If Not (lHdc = 0) Then
        ReleaseDC lOwnerHwnd, lHdc
    End If
    If Not (lhMem = 0) Then
        GlobalUnlock lhMem
        GlobalFree lhMem
    End If

End Function

Private Function HeightToPoints(ByVal lNum As Long) As Single
   HeightToPoints = (-72 * lNum) / PixelsPerInchY
End Function

Private Function PixelsPerInchY() As Long

Dim lHwnd   As Long
Dim lHdc    As Long
   
   lHwnd = GetDesktopWindow()
   lHdc = GetDC(lHwnd)
   PixelsPerInchY = GetDeviceCaps(lHdc, LOGPIXELSY)
   ReleaseDC lHwnd, lHdc

End Function

Private Function EnumFontFamProc(lpLF As LOGFONT, _
                                 lpTM As NEWTEXTMETRIC, _
                                 ByVal lFontType As Long, _
                                 lParam As Variant) As Long

Dim sName As String

    sName = StrConv(lpLF.lfFaceName, vbUnicode)
    ReDim Preserve lParam(1, 0 To m_lFontCount)
    lParam(0, m_lFontCount) = Left$(sName, InStr(sName, vbNullChar) - 1)
    lParam(1, m_lFontCount) = lFontType
    m_lFontCount = m_lFontCount + 1
    EnumFontFamProc = 1

End Function