作者：未知 来源：月光软件站 加入时间：2005-5-13　月光软件站

'类中的各种属性与方法，主要用于外部调用
Friend Property Let BorderColor(ByVal vData As Long)
    If m_lngBrdColor <> vData Then
        m_lngBrdColor = vData
        If m_lngBrdStyle > 3 Then Refresh
    End If
End Property
Friend Property Get BorderColor() As Long
    BorderColor = m_lngBrdColor
End Property
Friend Property Let BackPicture(ByVal vData As String)
    If vData <> "" And Dir(vData) <> "" Then
        If LCase(m_strBkPicture) <> LCase(vData) Then
            m_strBkPicture = vData
            Set mpicBk = LoadPicture(m_strBkPicture)
            Refresh
        End If
    Else
        Set mpicBk = Nothing
        m_strBkPicture = ""
    End If
End Property
Friend Property Get BackPicture() As String
    BackPicture = m_strBkPicture
End Property
Friend Property Let FontName(ByVal vData As String)
    Dim s As String, i As Long
    vData = Trim(vData)
    s = StrConv(Font.lfFaceName, vbUnicode)
    i = InStr(1, s, Chr(0))
    If i > 0 Then
        s = Left$(s, i - 1)
    End If
    If s <> vData Then
        CopyMemory Font.lfFaceName(0), ByVal vData, lstrlen(vData)
        Refresh
    End If
End Property
Friend Property Get FontName() As String
    Dim s As String, i As Long
    s = StrConv(Font.lfFaceName, vbUnicode)
    i = InStr(1, s, Chr(0) - 1)
    If i > 0 Then
        FontName = Left$(s, i - 1)
    Else
        FontName = s
    End If
End Property

Friend Property Let FontUnderline(ByVal vData As Boolean)
    Dim i As Long
    i = IIf(vData, 1, 0)
    If Font.lfUnderline <> i Then
        Font.lfUnderline = i
        Refresh
    End If
End Property
Friend Property Get FontUnderline() As Boolean
    FontUnderline = (Font.lfUnderline = 1)
End Property
Friend Property Let FontItalic(ByVal vData As Boolean)
    Dim i As Long
    i = IIf(vData, 1, 0)
    If Font.lfItalic <> i Then
        Font.lfItalic = i
        Refresh
    End If
End Property
Friend Property Get FontItalic() As Boolean
    FontItalic = (Font.lfItalic = 1)
End Property
Friend Property Let FontBold(ByVal vData As Boolean)
    Dim i As Long
    i = IIf(vData, 700, 400)
    If Font.lfWeight <> i Then
        Font.lfWeight = i
        Refresh
    End If
End Property
Friend Property Get FontBold() As Boolean
    FontBold = (Font.lfWeight = 700)
End Property
Friend Property Let FontSize(ByVal vData As Long)
    If Font.lfHeight <> vData And vData >= 7 And vData <= 16 Then
        Font.lfHeight = vData
        Font.lfWidth = 0
        Refresh
    End If
End Property
Friend Property Get FontSize() As Long
    FontSize = Font.lfHeight
End Property
Friend Property Let BorderStyle(ByVal vData As Long)
    If m_lngBrdStyle <> vData Then
        m_lngBrdStyle = vData
        Refresh
    End If
End Property
Friend Property Get BorderStyle() As Long
    BorderStyle = m_lngBrdStyle
End Property
Friend Property Let TextHiColor(ByVal vData As Long)
    m_lngTextHiColor = vData
End Property
Friend Property Get TextHiColor() As Long
    TextHiColor = m_lngTextHiColor
End Property
Friend Property Let TextColor(ByVal vData As Long)
    If m_lngTextColor <> vData Then
        m_lngTextColor = vData
        Refresh
    End If
End Property
Friend Property Get TextColor() As Long
    TextColor = m_lngTextColor
End Property
Friend Property Let BackColor(ByVal vData As Long)
    If m_lngBackColor <> vData Then
        m_lngBackColor = vData
        If mpicBk Is Nothing Then Refresh
    End If
End Property
Friend Property Get BackColor() As Long
    BackColor = m_lngBackColor
End Property
Friend Sub BindToolBar(ByVal hWnd As Long)
    If m_hWnd = 0 Then
        m_hWnd = hWnd
        If m_hWnd Then
          OldWindowProc = GetWindowLong(m_hWnd, GWL_WNDPROC)
          SetWindowLong m_hWnd, GWL_WNDPROC, AddressOf TBSubClass
        End If
        Refresh
    End If
End Sub
Private Sub Class_Initialize()
    Dim rc As RECT, hBrush As Long, i As Long
    m_lngTextColor = vbBlack
    m_lngTextHiColor = vbRed
    m_lngBackColor = &HD7E9EB
    m_lngBrdColor = &H0
    mlngBtnHiAlpha = 96
    mlngBtnDownAlpha = 192
    rc.Bottom = 128
    rc.Right = 128
    i = GetDC(0)
    mdcWhite = NewMyHdc(i, rc.Right, rc.Bottom)
    ReleaseDC 0, i
    hBrush = CreateSolidBrush(vbWhite)
    FillRect mdcWhite.hdc, rc, hBrush
    DeleteObject hBrush
    With Font
        .lfCharSet = 1
        .lfHeight = 12
        .lfWeight = 400
    End With
End Sub
Private Sub Class_Terminate()
    SetWindowLong m_hWnd, GWL_WNDPROC, OldWindowProc
    mdcWhite = DelMyHdc(mdcWhite)
    Set mpicBk = Nothing
End Sub
Friend Sub Refresh()
Dim rc As RECT
    If m_hWnd <> 0 Then
        ShowWindow m_hWnd, 0
        ShowWindow m_hWnd, 5
    End If
End Sub

相关软件：