mybutton.ctl

用Delphi写的网络聊天工具

    End With
    
    'color palete
    With BI
        .bmiColors(0) = rgbBlack
        .bmiColors(1) = rgbWhite
    End With
    
    Dim hMonoSec As Long
    Dim pBits As Long
    Dim hdcMono As Long
    
    hMonoSec = CreateDIBSection(hDC, BI, 0, pBits, 0&, 0&)
    'Debug.Print "MonoSec:"; hMonoSec
    hdcMono = CreateCompatibleDC(hDC)
    SelectObject hdcMono, hMonoSec
    
    'create dc for picture
    hPicDc = CreateCompatibleDC(hDC)
    If P.Type = vbPicTypeIcon Then
        hPicBmp = CreateCompatibleBitmap(hDC, W, H)
        SelectObject hPicDc, hPicBmp
        DeleteObject hPicBmp
        ClearRect hPicDc, SetRect(0, 0, W, H), TranslateColor(m_PictureTColor)
        DrawIconEx hPicDc, 0, 0, P.handle, W, H, 0, 0, DI_NORMAL
        'Debug.Print "DRAW ICON"
    ElseIf P.Type = vbPicTypeBitmap Then
        SelectObject hPicDc, P.handle
    End If
    
    'copy  hPicDc to hdcMono
    BitBlt hdcMono, 0, 0, W, H, hPicDc, 0, 0, SRCCOPY
    
    DeleteDC hPicDc
    
    Dim R As Integer, G As Integer, B   As Integer
    GetRgb cHiglight, R, G, B
    
    'change black color in palete to highlight(r,g,b) color
    ColPal(0) = GetRgbQuad(R, G, B)
    ColPal(1) = rgbBlack    'change white color in palete to black color
    
    SetDIBColorTable hdcMono, 0, 2, ColPal(0)   'set new palete
    RealizePalette hdcMono                      'update it
    'BitBlt Me.hdc, 1, 1, W, H, hdcMono,  0, 0, SRCCOPY
      
    'transparent blit to dest hDC using black as transparent colour
    'x+1 and y+1 - moves down and left for 1 pixel
    TransBlt hDC, X + 1, Y + 1, W, H, hdcMono, 0, 0, 0
    
    'get rgb components of shadow color
    GetRgb cShadow, R, G, B
    'change black color to shadow color in palete
    ColPal(0) = GetRgbQuad(R, G, B)
    ColPal(1) = rgbWhite 'change back to white
    
    'set new palete
    SetDIBColorTable hdcMono, 0, 2, ColPal(0)
    RealizePalette hdcMono ' then update
    
    'transparent blit do dest hdc using white color as transparent
    TransBlt hDC, X, Y, W, H, hdcMono, 0, 0, RGB(255, 255, 255)
    
    'BitBlt Me.hDC, 0, 0, W, H, hdcMono, 0, 0, SRCCOPY
    
    'Debug.Print DeleteObject(hMonoSec)
    'Debug.Print DeleteObject(hdcMono)
   
End Function
Sub GetRgb(Color As Long, R As Integer, G As Integer, B As Integer)
       R = Color And 255            'clear bites from 9 to 32
       G = (Color \ 256) And 255    'shift right 8 bits and clear
       B = (Color \ 65536) And 255  'shift 16 bits and clear for any case
End Sub

Private Function GetBmpSize(Bmp As StdPicture, W As Long, H As Long) As Long
'    Dim B As BITMAP
'    GetBmpSize = GetObject(Bmp, Len(B), B)
    
    W = ScaleX(Bmp.Width, vbHimetric, vbPixels)
    H = ScaleY(Bmp.Height, vbHimetric, vbPixels)
        
'    Debug.Print W, H
    
    
'    W = B.bmWidth
'    H = B.bmHeight
'    Debug.Print B.bmType
'    Debug.Print W, H
End Function

Private Sub DrawPicture(hDC As Long, P As StdPicture, X As Long, Y As Long, W As Long, H As Long, TOleCol As Long)
    
    'check picture format
    If P.Type = vbPicTypeIcon Then
        DrawIconEx hDC, X, Y, P.handle, W, H, 0, 0, DI_NORMAL
        Exit Sub
    End If
    
    'creting dc with the same format as screen dc
    Dim MemDC As Long
    MemDC = CreateCompatibleDC(0)
    
    'select a picture into memdc
    SelectObject MemDC, P.handle '
    
    'tranparent blit memdc on usercontrol
    TransBlt UserControl.hDC, X, Y, W, H, MemDC, 0, 0, TranslateColor(TOleCol)
    
    DeleteDC MemDC 'its clear, heh
End Sub


Private Function ModifyRect(lpRect As RECT, ByVal Left As Long, ByVal Top As Long, _
               ByVal Right As Long, ByVal Bottom As Long) As RECT
    With ModifyRect
        .Left = lpRect.Left + Left
        .Top = lpRect.Top + Top
        .Right = lpRect.Right + Right
        .Bottom = lpRect.Bottom + Bottom
    End With
End Function
Private Function TranslateColor(ByVal Ole_Color As Long) As Long
        apiTranslateColor Ole_Color, 0, TranslateColor
End Function
Private Function SetRect(ByVal Left As Long, ByVal Top As Long, ByVal Right As Long, ByVal Bottom As Long) As RECT
  With SetRect
    .Left = Left
    .Top = Top
    .Right = Right
    .Bottom = Bottom
  End With
End Function
Private Sub NormalizeRect(R As RECT)
    Dim c As Long
    If R.Left > R.Right Then
        c = R.Right
        R.Right = R.Left
        R.Left = c
    End If
    If R.Top > R.Bottom Then
        c = R.Top
        R.Top = R.Bottom
        R.Bottom = c
    End If
End Sub
Private Function RoundUp(ByVal num As Single) As Long
    If Int(num) < num Then
        RoundUp = Int(num) + 1
    Else
        RoundUp = num
    End If
End Function
Private Function RectHeight(R As RECT) As Long
    RectHeight = R.Bottom - R.Top
End Function
Private Function RectWidth(R As RECT) As Long
    RectWidth = R.Right - R.Left
End Function
Private Sub DrawText(ByVal hDC As Long, ByVal strText As String, R As RECT, ByVal Format As Long)
    apiDrawText UserControl.hDC, strText, Len(strText), R, Format
End Sub
Private Sub TilePicture(DestRect As RECT, SrcRect As RECT, ByVal SrcDC As Long, Optional UseCliper As Boolean = True, Optional ROp As Long = SRCCOPY)
    
    Dim i As Integer
    Dim J As Integer
    Dim rows As Integer
    Dim ColS As Integer
    Dim destW As Long
    Dim destH As Long
    Dim hDC As Long
    hDC = UserControl.hDC
    
    NormalizeRect DestRect
    NormalizeRect SrcRect
       
    'calculates row and cols
    rows = RoundUp(RectHeight(DestRect) / RectHeight(SrcRect))
    ColS = RoundUp(RectWidth(DestRect) / RectWidth(SrcRect))
    
    destW = RectWidth(SrcRect)
    destH = RectHeight(SrcRect)
   
    'prevents drawing out of specified rectangle
    If UseCliper Then
        SelectClipRgn hDC, ByVal 0
        BeginPath hDC
            With DestRect
                 Rectangle hDC, .Left, .Top, .Right + 1, .Bottom + 1
            End With
        EndPath hDC
        SelectClipPath hDC, RGN_AND
    End If
    
    For i = 0 To rows - 1
        For J = 0 To ColS - 1
            BitBlt hDC, J * destW + DestRect.Left, i * destH + DestRect.Top, destW, destH, SrcDC, _
            SrcRect.Left, SrcRect.Top, ROp
        Next
    Next
    
    If UseCliper Then
        SelectClipRgn hDC, ByVal 0
    End If
End Sub

Private Sub ClearRect(ByVal hDC As Long, lRect As RECT, ByVal Color As Long)
    Dim Brush As Long
    Dim pBrush As Long
    Brush = CreateSolidBrush(Color)
    pBrush = SelectObject(hDC, Brush)
    
    FillRect hDC, lRect, Brush
    DeleteObject SelectObject(hDC, pBrush)
End Sub
'//END GDI####################################
'#############################################

'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MemberInfo=8,0,0,3
Public Property Get SizeCW() As Long
Attribute SizeCW.VB_Description = "Corner width."
Attribute SizeCW.VB_ProcData.VB_Invoke_Property = ";Position"
    SizeCW = m_SizeCW
End Property

Public Property Let SizeCW(ByVal New_SizeCW As Long)
        m_SizeCW = New_SizeCW
        PropertyChanged "SizeCW"
        Refresh
End Property

'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MemberInfo=8,0,0,3
Public Property Get SizeCH() As Long
Attribute SizeCH.VB_Description = "Corner height."
Attribute SizeCH.VB_ProcData.VB_Invoke_Property = ";Position"
    SizeCH = m_SizeCH
End Property

Public Property Let SizeCH(ByVal New_SizeCH As Long)
        m_SizeCH = New_SizeCH
        PropertyChanged "SizeCH"
        Refresh
End Property

'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MemberInfo=9,0,0,0
Public Property Get SkinPicture() As Object
Attribute SkinPicture.VB_Description = "Reference to picture box object."
    Set SkinPicture = m_SkinPicture
End Property

Public Property Set SkinPicture(New_SkinPicture As Object)
    
    
    If (TypeName(New_SkinPicture) <> "PictureBox") And _
       (New_SkinPicture Is Nothing = False) Then
        
        Err.Raise 5, "MyButton::SkinPicture", Err.Description
        Exit Property
    End If
               
    Set m_SkinPicture = New_SkinPicture
    
    If m_SkinPicture Is Nothing = False Then
        m_SkinPictureName = m_SkinPicture.name
    Else
        m_SkinPictureName = ""
    End If
    
    Refresh
    PropertyChanged "SPN"
End Property

'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MemberInfo=13,0,0,
Public Property Get Text() As String
Attribute Text.VB_Description = "Button text."
Attribute Text.VB_ProcData.VB_Invoke_Property = ";Text"
    Text = m_Text
End Property

Public Property Let Text(ByVal New_Text As String)
    m_Text = New_Text
    Refresh
    PropertyChanged "Text"
    
    'setting access key (allows alt + accesskey)
    
    Dim i As Long
    Dim c As String
    
    For i = 1 To Len(New_Text) - 1
        If Mid(New_Text, i, 1) = "&" Then
            c = Mid(New_Text, i + 1, 1)
            If c <> "&" Or c <> " " Then
                UserControl.AccessKeys = c
                PropertyChanged "AccessKey"
            End If
        End If
        
    Next
   
End Property

'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MemberInfo=13,0,0,
Public Property Get SkinPictureName() As String
Attribute SkinPictureName.VB_Description = "Allows you to set reference at design time."
Attribute SkinPictureName.VB_ProcData.VB_Invoke_Property = ";Appearance"
    'If m_SkinPicture Is Nothing = False Then
        'SkinPictureName = m_SkinPicture.Name
        SkinPictureName = m_SkinPictureName
    'End If
End Property

Public Property Let SkinPictureName(ByVal New_SkinPictureName As String)
    On Error GoTo NotLegalName
    Dim P As Object
    'Debug.Print New_SkinPictureName
    If New_SkinPictureName <> "" Then
        
        Set P = UserControl.Parent.Controls(New_SkinPictureName)
        
        If P Is Nothing = False Then
            Set SkinPicture = P
            'Debug.Print "Setting p"; P.Name
        End If
    Else
        Set m_SkinPicture = Nothing
        'Debug.Print "P is nothing"
        Refresh
    End If
   
'    m_SkinPictureName = New_SkinPictureName
    PropertyChanged "SPN"
NotLegalName:
End Property

Private Sub UserControl_DblClick()
    DrawButton BTN_DOWN
End Sub

Private Sub UserControl_GotFocus()
    m_HasFocus = True
    If m_BtnDown = False Then DrawButton BTN_FOCUS
End Sub

Private Sub UserControl_Initialize()
'    SkinPictureName = m_SkinPictureName
'    MsgBox "Initialize..." + m_SkinPictureName
End Sub

'Initialize Properties for User Control
Private Sub UserControl_InitProperties()
    m_SizeCW = m_def_SizeCW
    m_SizeCH = m_def_SizeCH
    m_Text = Extender.name
    m_FillWithColor = m_def_FillWithColor
    m_TextColorEnabled = m_def_TextColorEnabled
    m_TextColorDisabled = m_def_TextColorDisabled
    Set UserControl.Font = Ambient.Font
    m_DisableHover = m_def_DisableHover

    m_DisplaceText = m_def_DisplaceText
    m_DrawFocus = m_def_DrawFocus
    m_TextColorDisabled2 = m_def_TextColorDisabled2
    Set m_Picture = LoadPicture("")
    m_PicturePos = m_def_PicturePos
    m_PictureTColor = m_def_PictureTColor
    m_SkinPictureName = "MyButtonDefSkin"