mybutton.ctl

用Delphi写的网络聊天工具

    m_TextAlign = m_def_TextAlign
End Sub

Private Sub UserControl_KeyDown(KeyCode As Integer, Shift As Integer)
    RaiseEvent KeyDown(KeyCode, Shift)
    
    If KeyCode = vbKeySpace Then
        m_SpcDown = True
        DrawButton BTN_DOWN
    Else
        m_SpcDown = False
        DrawButton BTN_FOCUS
    End If
End Sub

Private Sub UserControl_KeyPress(KeyAscii As Integer)
    RaiseEvent KeyPress(KeyAscii)
    
    If KeyAscii = vbKeyReturn Then
        RaiseEvent Click
    End If
End Sub

Private Sub UserControl_KeyUp(KeyCode As Integer, Shift As Integer)
    RaiseEvent KeyUp(KeyCode, Shift)
    If KeyCode = 32 And m_SpcDown And m_State = BTN_DOWN Then
        m_SpcDown = False
        
        DrawButton BTN_NORMAL
        RaiseEvent Click
        DrawButton BTN_FOCUS
        
    End If
End Sub

Private Sub UserControl_LostFocus()
    m_HasFocus = False
    DrawButton BTN_NORMAL
End Sub

Private Sub UserControl_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
   RaiseEvent MouseDown(Button, Shift, X, Y)
   If Button = 1 Then m_BtnDown = True
   UserControl_MouseMove Button, Shift, X, Y
End Sub

Private Sub UserControl_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
    If m_SpcDown Then Exit Sub
    
    RaiseEvent MouseMove(Button, Shift, X, Y)
    SetCapture hWnd
    If PointInControl(X, Y) Then
        'if pointer is on control
        If m_BtnDown Then
            If m_State <> BTN_DOWN Then
                DrawButton BTN_DOWN
            End If
        Else
            If m_State <> BTN_HOVER Then
                RaiseEvent MouseHover
                DrawButton BTN_HOVER
            End If
            
        End If
    Else
        'if pointer is out of control
        If m_BtnDown Then
            
            RaiseEvent MouseHover
            DrawButton BTN_HOVER
            
        Else
            RaiseEvent MouseOut
            If m_HasFocus Then
                DrawButton BTN_FOCUS
            Else
                DrawButton BTN_NORMAL
            End If
            ReleaseCapture
        End If
    End If
End Sub

Private Sub UserControl_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
    
    m_BtnDown = False
'    If m_State <> BTN_NORMAL Then
        DrawButton BTN_NORMAL
'    End If
    
    RaiseEvent MouseUp(Button, Shift, X, Y)
    
    If Button = vbLeftButton Then
        If PointInControl(X, Y) Then RaiseEvent Click
'        If m_State <> BTN_FOCUS Then
            DrawButton BTN_FOCUS
'        End If
    End If
    
End Sub


Private Sub UserControl_Paint()
    Me.Refresh
End Sub

'Load property values from storage
Private Sub UserControl_ReadProperties(PropBag As PropertyBag)
    m_SizeCW = PropBag.ReadProperty("SizeCW", m_def_SizeCW)
    m_SizeCH = PropBag.ReadProperty("SizeCH", m_def_SizeCH)
    m_SkinPictureName = PropBag.ReadProperty("SPN", "")
   
    'Debug.Print "ReadProp SPN:"; m_SkinPictureName
   
    m_Text = PropBag.ReadProperty("Text", m_def_Text)
    m_FillWithColor = PropBag.ReadProperty("FillWithColor", m_def_FillWithColor)
    UserControl.Enabled = PropBag.ReadProperty("Enabled", True)
    UserControl.AccessKeys = PropBag.ReadProperty("AccessKey", "")
    m_TextColorEnabled = PropBag.ReadProperty("TextColorEnabled", m_def_TextColorEnabled)
    m_TextColorDisabled = PropBag.ReadProperty("TextColorDisabled", m_def_TextColorDisabled)
    Set UserControl.Font = PropBag.ReadProperty("Font", Ambient.Font)
    UserControl.MousePointer = PropBag.ReadProperty("MousePointer", 0)
    Set MouseIcon = PropBag.ReadProperty("MouseIcon", Nothing)
    m_DisableHover = PropBag.ReadProperty("DisableHover", m_def_DisableHover)
'    m_DownTextDX = PropBag.ReadProperty("DownTextDX", m_def_DownTextDX)
'    m_DownTextDY = PropBag.ReadProperty("DownTextDY", m_def_DownTextDY)
    m_DisplaceText = PropBag.ReadProperty("DisplaceText", m_def_DisplaceText)
    m_DrawFocus = PropBag.ReadProperty("DrawFocus", m_def_DrawFocus)
    m_TextColorDisabled2 = PropBag.ReadProperty("TextColorDisabled2", m_def_TextColorDisabled2)
    Set m_Picture = PropBag.ReadProperty("Picture", Nothing)
    m_PicturePos = PropBag.ReadProperty("PicturePos", m_def_PicturePos)
    m_PictureTColor = PropBag.ReadProperty("PictureTColor", m_def_PictureTColor)
    m_TextAlign = PropBag.ReadProperty("TextAlign", m_def_TextAlign)
    UserControl.BackColor = PropBag.ReadProperty("BackColor", &H8000000F)
End Sub

Private Sub UserControl_Resize()
    Refresh
End Sub

Private Sub UserControl_Show()
    
    SkinPictureName = m_SkinPictureName

   ' Refresh
End Sub

Private Sub UserControl_Terminate()
    Set m_SkinPicture = Nothing
    Set m_Picture = Nothing
    
    'Set UserControl = Nothing
    'Set Me = Nothing
    'Debug.Print "TERMINATE"
End Sub

'Write property values to storage
Private Sub UserControl_WriteProperties(PropBag As PropertyBag)
    Call PropBag.WriteProperty("SizeCW", m_SizeCW, m_def_SizeCW)
    Call PropBag.WriteProperty("SizeCH", m_SizeCH, m_def_SizeCH)
    
    'If m_SkinPicture Is Nothing = False Then
        Call PropBag.WriteProperty("SPN", m_SkinPictureName, "")
    'End If
    
    'Debug.Print "Write :"; m_SkinPictureName
    
    Call PropBag.WriteProperty("Text", m_Text, m_def_Text)
    Call PropBag.WriteProperty("FillWithColor", m_FillWithColor, m_def_FillWithColor)
    Call PropBag.WriteProperty("Enabled", UserControl.Enabled, True)
    Call PropBag.WriteProperty("AccessKey", UserControl.AccessKeys, "")
    Call PropBag.WriteProperty("TextColorEnabled", m_TextColorEnabled, m_def_TextColorEnabled)
    Call PropBag.WriteProperty("TextColorDisabled", m_TextColorDisabled, m_def_TextColorDisabled)
    Call PropBag.WriteProperty("Font", UserControl.Font, Ambient.Font)

    Call PropBag.WriteProperty("MousePointer", UserControl.MousePointer, 0)
    Call PropBag.WriteProperty("MouseIcon", MouseIcon, Nothing)
    Call PropBag.WriteProperty("DisableHover", m_DisableHover, m_def_DisableHover)
    Call PropBag.WriteProperty("DisplaceText", m_DisplaceText, m_def_DisplaceText)
    Call PropBag.WriteProperty("DrawFocus", m_DrawFocus, m_def_DrawFocus)
    Call PropBag.WriteProperty("TextColorDisabled2", m_TextColorDisabled2, m_def_TextColorDisabled2)
    Call PropBag.WriteProperty("Picture", m_Picture, Nothing)
    Call PropBag.WriteProperty("PicturePos", m_PicturePos, m_def_PicturePos)
    Call PropBag.WriteProperty("PictureTColor", m_PictureTColor, m_def_PictureTColor)
    Call PropBag.WriteProperty("TextAlign", m_TextAlign, m_def_TextAlign)
    Call PropBag.WriteProperty("BackColor", UserControl.BackColor, &H8000000F)
End Sub


Private Sub DrawButton(ByVal State As Integer)
    
    If m_DisableHover Then
        If State = BTN_HOVER Then Exit Sub
        'dont draw hover state if m_DisableHover is true
    End If
'    Debug.Print "State1 "; State

    On Error GoTo UnknownError

    Dim PicW As Long
    Dim PicH As Long 'width and height of picture

    Dim PicX As Long
    Dim PicY As Long 'picture pos

    Dim DH As Long  'button height
    Dim dw As Long  'button width
    Dim Align As Long 'text aligment
    Dim bDrawText As Boolean ' if picture is in center text is not drawn
    bDrawText = True

    Align = DT_VCENTER Or DT_SINGLELINE Or DT_END_ELLIPSIS

    Select Case m_TextAlign
        Case Is = vbLeftJustify:  Align = Align Or DT_LEFT
        Case Is = vbRightJustify: Align = Align Or DT_RIGHT
        Case Is = vbCenter:       Align = Align Or DT_CENTER
    End Select

    dw = UserControl.ScaleWidth
    DH = UserControl.ScaleHeight

    m_State = State
    'if skin picture is not set then just draw text on control
    If m_SkinPicture Is Nothing Then
        ClearRect hDC, SetRect(0, 0, dw, DH), TranslateColor(UserControl.BackColor)
        DrawText hDC, m_Text, SetRect(0, 0, dw, DH), Align
        If UserControl.AutoRedraw = True Then
            UserControl.Refresh
        End If
        Exit Sub
    End If


    m_SkinPicture.ScaleMode = vbPixels


    Dim SrcLeft As Long     'left cordinate of skin in skinpicture
    Dim SrcRight As Long    'right -II-
    Dim FillColor As Long   'color to fill middle area of button
                            'used if m_FillWithColor is true

    Dim H As Long           'height of skinpicture
    Dim W As Long           'width of button skin

    H = m_SkinPicture.ScaleHeight
    W = m_SkinPicture.ScaleWidth / 5
'Debug.Print H, W
'
    SrcLeft = (State - 1) * W
    SrcRight = State * W

    If m_FillWithColor Then
        'get color to fill with from (SrcLeft+m_SizeCW +1 , m_SizeCH+1) on
        'skin picture
        FillColor = m_SkinPicture.Point(SrcLeft + m_SizeCW + 1, m_SizeCH + 1)
    End If

'Exit Sub
    ClearRect hDC, SetRect(0, 0, dw, DH), TranslateColor(UserControl.BackColor)
    If m_FillWithColor Then
        'paint button with fillcolor
        'NOTE: it would be nice if there is gradient file
        ClearRect hDC, SetRect(m_SizeCW, m_SizeCH, dw - m_SizeCW, DH - m_SizeCH), FillColor
        'ABOUT ADDING GRADIENT FILL
        'read second color from skin at
        'point (srcleft+cw+1, H -m_sizeCH-1)
        'may be implemented in MyButton2
    Else
        'tile skin
         TilePicture SetRect(m_SizeCW, m_SizeCH, dw - m_SizeCW, DH - m_SizeCH), _
           SetRect(SrcLeft + m_SizeCW, m_SizeCH, SrcRight - m_SizeCW, H - m_SizeCH), _
           m_SkinPicture.hDC, False, SRCCOPY
    End If

    'draws borders
    If (m_SizeCH > 0 And m_SizeCW > 0) Then
        TilePicture SetRect(m_SizeCW, 0, dw, m_SizeCH), _
            SetRect(SrcLeft + m_SizeCW, 0, SrcRight - m_SizeCW, m_SizeCH), _
            m_SkinPicture.hDC, False, SRCCOPY

        TilePicture SetRect(m_SizeCW, DH - m_SizeCH, dw, DH), _
            SetRect(SrcLeft + m_SizeCW, H - m_SizeCH, SrcRight - m_SizeCW, H), _
            m_SkinPicture.hDC, False, SRCCOPY

        TilePicture SetRect(0, 0, m_SizeCW, DH), _
            SetRect(SrcLeft, m_SizeCH, SrcLeft + m_SizeCW, H - m_SizeCH), _
            m_SkinPicture.hDC, False, SRCCOPY

        TilePicture SetRect(dw - m_SizeCW, m_SizeCH, dw, DH - m_SizeCH), _
            SetRect(SrcRight - m_SizeCW, m_SizeCH, SrcRight, H - m_SizeCH), _
            m_SkinPicture.hDC, False, SRCCOPY

        'draws corners
        'NOTE: must chage to transparent blit (done)
        TransBlt hDC, 0, 0, m_SizeCW, m_SizeCH, m_SkinPicture.hDC, SrcLeft, 0, &HFF00FF
        TransBlt hDC, 0, DH - m_SizeCH, m_SizeCW, m_SizeCH, m_SkinPicture.hDC, SrcLeft, H - m_SizeCH, &HFF00FF

        TransBlt hDC, dw - m_SizeCW, 0, m_SizeCW, m_SizeCH, m_SkinPicture.hDC, SrcRight - m_SizeCW, 0, &HFF00FF
        TransBlt hDC, dw - m_SizeCW, DH - m_SizeCH, m_SizeCW, m_SizeCH, m_SkinPicture.hDC, SrcRight - m_SizeCW, H - m_SizeCH, &HFF00FF
    End If

    Dim PColor As Long 'previous color

    PColor = UserControl.ForeColor

    Dim TextRect As RECT
    If State = BTN_DOWN Then
        TextRect = SetRect(m_SizeCW + m_DisplaceText, m_SizeCH + m_DisplaceText, dw - m_SizeCW + m_DisplaceText - 3, DH - m_SizeCH + m_DisplaceText)
    Else
        TextRect = SetRect(m_SizeCW, m_SizeCH, dw - m_SizeCW - 3, DH - m_SizeCH)
    End If
        If m_Picture Is Nothing Then
            If m_State = BTN_DISABLED Then
                'draw text only
                'dont draw text2 if colors are the same
                If m_TextColorDisabled <> m_TextColorDisabled2 Then
                    UserControl.ForeColor = m_TextColorDisabled2
                    TextRect = ModifyRect(TextRect, 1, 1, 1, 1)
                    DrawText hDC, m_Text, TextRect, Align
                    TextRect = ModifyRect(TextRect, -1, -1, -1, -1)
                End If
                UserControl.ForeColor = m_TextColorDisabled
                DrawText hDC, m_Text, TextRect, Align
            Else
                'draw text only
                UserControl.ForeColor = m_TextColorEnabled
                DrawText hDC, m_Text, TextRect, Align
            End If
        Else

            GetBmpSize m_Picture, PicW, PicH
            PicY = (DH - PicH) / 2
            If m_State = BTN_DOWN Then
                PicY = PicY + m_DisplaceText
            End If



            Select Case m_PicturePos
                Case Is = ppLeft
                    PicX = TextRect.Left + 3
                    TextRect.Left = PicX + PicW + TextRect.Left
                Case Is = ppRight
                    PicX = TextRect.Right - PicW - 3 + TextRect.Left - m_SizeCW
                    TextRect.Right = PicX - 3
                Case Is = ppTop
                    PicX = (dw - PicW) / 2 + TextRect.Left - SizeCW
                    PicY = (DH - PicH - 3 - UserControl.TextHeight("I")) / 2 + TextRect.Top - SizeCH
                    TextRect.Top = PicY + PicW + 3
                    TextRect.Bottom = TextRect.Top + UserControl.TextHeight("I") * 1.2
                Case Is = ppBottom
                    TextRect.Top = (DH - PicH - 3 - UserControl.TextHeight("I")) / 2 + TextRect.Top - SizeCH
                    PicX = (dw - PicW) / 2 + TextRect.Left - SizeCW
                    TextRect.Bottom = TextRect.Top + UserControl.TextHeight("I") * 1.2
                    PicY = TextRect.Bottom + 3
                Case Is = ppCenter
                    PicX = (dw - PicW) / 2
                    If BTN_DOWN Then PicX = PicX + m_DisplaceText
                    bDrawText = False
            End Select

'            Debug.Print "State2 "; State

            If m_State = BTN_DISABLED Then
                'draw text and picture disabled
                DrawPictureDisabled m_Picture, PicX, PicY, PicW, PicH
                If m_TextColorDisabled <> m_TextColorDisabled2 Then
                    If bDrawText Then
                        UserControl.ForeColor = m_TextColorDisabled2
                        TextRect = ModifyRect(TextRect, 1, 1, 1, 1)