robutton.ctl

类似木马和qq的一个vb程序

VERSION 5.00
Begin VB.UserControl ROButton 
   AutoRedraw      =   -1  'True
   BackColor       =   &H00D7D7D7&
   ClientHeight    =   4785
   ClientLeft      =   0
   ClientTop       =   0
   ClientWidth     =   4350
   ScaleHeight     =   4785
   ScaleWidth      =   4350
   ToolboxBitmap   =   "ROButton.ctx":0000
   Begin VB.PictureBox Pback 
      AutoRedraw      =   -1  'True
      BackColor       =   &H00D7D7D7&
      BorderStyle     =   0  'None
      Height          =   735
      Left            =   0
      ScaleHeight     =   735
      ScaleWidth      =   1455
      TabIndex        =   0
      Top             =   0
      Width           =   1455
   End
   Begin VB.Image IM1 
      Height          =   375
      Left            =   2040
      Top             =   2520
      Visible         =   0   'False
      Width           =   375
   End
   Begin VB.Image im 
      Height          =   315
      Index           =   0
      Left            =   1680
      Picture         =   "ROButton.ctx":0532
      Top             =   2520
      Visible         =   0   'False
      Width           =   270
   End
   Begin VB.Image im 
      Height          =   315
      Index           =   1
      Left            =   600
      Picture         =   "ROButton.ctx":0A68
      Top             =   2520
      Visible         =   0   'False
      Width           =   270
   End
   Begin VB.Image im 
      Height          =   315
      Index           =   3
      Left            =   1320
      Picture         =   "ROButton.ctx":0F9E
      Top             =   2520
      Visible         =   0   'False
      Width           =   270
   End
   Begin VB.Image im 
      Height          =   315
      Index           =   2
      Left            =   960
      Picture         =   "ROButton.ctx":1478
      Top             =   2520
      Visible         =   0   'False
      Width           =   270
   End
End
Attribute VB_Name = "ROButton"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
'
'
Enum Kstyle
Left
Top
End Enum



Dim m_style As Kstyle

Private Declare Function CreateWindowEx Lib "user32" Alias "CreateWindowExA" (ByVal dwExStyle As Long, ByVal lpClassName As String, ByVal lpWindowName As String, ByVal dwStyle As Long, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hWndParent As Long, ByVal hMenu As Long, ByVal hInstance As Long, lpParam As Any) As Long
Private Declare Function SetWindowPos Lib "user32" (ByVal hwnd As Long, ByVal hWndInsertAfter As Long, ByVal X As Long, ByVal Y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Private Declare Function GetClientRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
Private Declare Function DestroyWindow Lib "user32" (ByVal hwnd As Long) As Long

Private Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type

Private Type TOOLINFO
    cbSize As Long
    uFlags As Long
    hwnd As Long
    uid As Long
    RECT As RECT
    hinst As Long
    lpszText As String
    lParam As Long
End Type

Private Const CW_USEDEFAULT = &H80000000
Private Const SWP_NOMOVE = &H2
Private Const SWP_NOACTIVATE = &H10
Private Const SWP_NOSIZE = &H1
Private Const HWND_TOPMOST = -1
Private Const WM_USER = &H400
Private Const TTF_CENTERTIP = &H2
Private Const TTF_SUBCLASS = &H10
Private Const TTM_ADDTOOLA = (WM_USER + 4)
Private Const TTM_GETTEXTA = (WM_USER + 11)
Private Const TTM_SETMAXTIPWIDTH = (WM_USER + 24)
Private Const TTM_SETTIPBKCOLOR = (WM_USER + 19)
Private Const TTM_SETTIPTEXTCOLOR = (WM_USER + 20)
Private Const TTM_UPDATETIPTEXTA = (WM_USER + 12)
Private Const TTS_ALWAYSTIP = &H1
Private Const TTS_BALLOON = &H40
Private Const TOOLTIPS_CLASSA = "tooltips_class32"

Private mBackColor As OLE_COLOR
Private mForeColor As OLE_COLOR
'
'
'



Const m_def_caption = "0"
Dim m_caption As String
Dim ifon As Boolean
Dim If2 As Boolean
Private Declare Function SetCapture Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function ReleaseCapture Lib "user32" () As Long
'事件声明:
Event Click()
Event MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single) 'MappingInfo=Pback,Pback,-1,MouseDown
Event MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single) 'MappingInfo=Pback,Pback,-1,MouseDown
Event MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single) 'MappingInfo=Pback,Pback,-1,MouseDown

Public Property Get Picture() As Picture
    Set Picture = IM1.Picture
End Property

Public Property Set Picture(ByVal New_Picture As Picture)
    Set IM1.Picture = New_Picture
PrintB 1
    PropertyChanged "Picture"
End Property

Public Property Get style() As Kstyle
    style = m_style
End Property

Public Property Let style(ByVal New_style As Kstyle)
    m_style = New_style
PrintB 1
    PropertyChanged "style"
End Property

Public Property Get Font() As Font
    Set Font = Pback.Font
End Property

Public Property Set Font(ByVal New_Font As Font)
    Set Pback.Font = New_Font
    PropertyChanged "Font"
PrintB 1
End Property

Public Property Get ForeColor() As OLE_COLOR
    ForeColor = Pback.ForeColor
End Property

Public Property Let ForeColor(ByVal New_ForeColor As OLE_COLOR)
    Pback.ForeColor() = New_ForeColor
    PropertyChanged "ForeColor"
PrintB 1
End Property

Public Property Get Enabled() As Boolean
 
    Enabled = Pback.Enabled
End Property

Public Property Let Enabled(ByVal New_Enabled As Boolean)
    Pback.Enabled() = New_Enabled
    PropertyChanged "Enabled"
    PrintB 1
End Property

Public Property Get caption() As String
    caption = Pback.Tag
End Property

Public Property Let caption(ByVal New_caption As String)
    Pback.Tag = New_caption
    PrintB 1
    PropertyChanged "caption"
End Property

Public Property Get MyToolTip() As String
    MyToolTip = im(1).Tag
End Property

Public Property Let MyToolTip(ByVal New_MyToolTip As String)
    im(1).Tag = New_MyToolTip
     AssignToolTip Pback, im(1).Tag
    PropertyChanged "MyToolTip"
End Property

Private Sub Pback_KeyDown(KeyCode As Integer, Shift As Integer)
If KeyCode = 13 Then Pback_Click
End Sub


'为用户控件初始化属性
Private Sub UserControl_InitProperties()
    m_caption = m_def_caption
End Sub

'从存贮器中加载属性值
Private Sub UserControl_ReadProperties(PropBag As PropertyBag)
    m_style = PropBag.ReadProperty("style", m_def_style)
     Pback.Enabled = PropBag.ReadProperty("Enabled", m_def_Enabled)
     Pback.Tag = PropBag.ReadProperty("caption", m_def_caption)
         Set Pback.Font = PropBag.ReadProperty("Font", Ambient.Font)
        Set Picture = PropBag.ReadProperty("Picture", Nothing)
    Pback.ForeColor = PropBag.ReadProperty("ForeColor", &H80000012)
    im(1).Tag = PropBag.ReadProperty("MyToolTip", "")
End Sub

Private Sub UserControl_Show()
    AssignToolTip Pback, im(1).Tag
PrintB 1
End Sub

'将属性值写到存储器
Private Sub UserControl_WriteProperties(PropBag As PropertyBag)
    Call PropBag.WriteProperty("style", m_style, m_def_style)
    Call PropBag.WriteProperty("Picture", Picture, Nothing)
    Call PropBag.WriteProperty("caption", Pback.Tag, m_def_caption)
    Call PropBag.WriteProperty("Font", Pback.Font, Ambient.Font)
    Call PropBag.WriteProperty("ForeColor", Pback.ForeColor, &H80000012)
    Call PropBag.WriteProperty("MyToolTip", im(1).Tag, "")
    Call PropBag.WriteProperty("Enabled", Pback.Enabled, "")
    
End Sub

Public Sub UserControl_Resize()
Pback.Width = UserControl.Width
Pback.Height = UserControl.Height
PrintB 1
End Sub

Private Sub UserControl_Initialize()
PrintB 1
End Sub

Private Sub Pback_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
       RaiseEvent MouseMove(Button, Shift, X, Y)

    Dim MouseOver As Boolean
    '判断当前鼠标位置是否在控件上
    MouseOver = (0 <= X) And (X <= Pback.Width) And (0 <= Y) And (Y <= Pback.Height)
    If MouseOver Then
If ifon = False Then
PrintB 2

ifon = True
End If
SetCapture Pback.hwnd
Else

PrintB 1

ifon = False
ReleaseCapture
End If
End Sub

Private Sub Pback_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
    RaiseEvent MouseDown(Button, Shift, X, Y)

If Button = 1 Then
PrintB 3
If2 = True
Else
If2 = False
End If

End Sub

Private Sub Pback_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
    RaiseEvent MouseUp(Button, Shift, X, Y)
ifon = False
PrintB 1

End Sub

Private Sub Pback_Click()
If If2 = False Then Exit Sub
    RaiseEvent Click
End Sub


Public Sub PrintB(VV)
Pback.Cls
If VV = 1 Then
    If Pback.Enabled = False Then
    Z = 0
    Else
    Z = 1
    End If
Else
Z = VV
End If
    
    brx = Pback.Width - 45
    bry = Pback.Height - 45
    bw = Pback.Width - 90
    bh = Pback.Height - 90
    
    Pback.PaintPicture im(Z).Picture, 0, 0, 45, 45, 0, 0, 45, 45
    Pback.PaintPicture im(Z).Picture, brx, 0, 45, 45, 225, 0, 45, 45
    Pback.PaintPicture im(Z).Picture, brx, bry, 45, 45, 225, 270, 45, 45
    Pback.PaintPicture im(Z).Picture, 0, bry, 45, 45, 0, 270, 45, 45
    Pback.PaintPicture im(Z).Picture, 45, 0, bw, 45, 45, 0, 180, 45
    Pback.PaintPicture im(Z).Picture, brx, 45, 45, bh, 225, 45, 45, 225
    Pback.PaintPicture im(Z).Picture, 0, 45, 45, bh, 0, 45, 45, 225
    Pback.PaintPicture im(Z).Picture, 45, bry, bw, 45, 45, 270, 180, 45
    Pback.PaintPicture im(Z).Picture, 45, 45, bw, bh, 45, 45, 180, 225

'If Pback.Tag <> "" Then
'Pback.CurrentX = (Pback.Width - Pback.TextWidth(caption)) / 2
'Pback.CurrentY = (Pback.Height - Pback.TextHeight(caption)) / 2
'Pback.Print Pback.Tag
'End If
SetText Pback.Tag
End Sub


Public Sub SetText(caption)
On Error Resume Next
X = IM1.Width: Y = IM1.Height

If caption = "" And IM1.Picture = LoadPicture() Then Exit Sub
If caption = "" Then Pback.PaintPicture IM1.Picture, (Pback.Width - X) / 2, (Pback.Height - Y) / 2, IM1.Width, IM1.Height: Exit Sub
If IM1.Picture = LoadPicture("") Then
With Pback
.CurrentX = (.Width - TextWidth(caption)) / 2
.CurrentY = (.Height - TextHeight(caption)) / 2
End With
Pback.Print caption
Exit Sub
End If


If m_style = 0 Then
Pback.PaintPicture IM1.Picture, (Pback.Width - X - TextWidth(caption)) / 3, (Pback.Height - Y) / 2, IM1.Width, IM1.Height
With Pback
.CurrentX = X + 2 * (.Width - X - TextWidth(caption)) / 3
.CurrentY = (.Height - TextHeight(caption)) / 2
End With
Pback.Print caption
Exit Sub
End If

If m_style = 1 Then
Pback.PaintPicture IM1.Picture, (Pback.Width - X) / 2, (Pback.Height - Y - TextHeight(caption)) / 3, IM1.Width, IM1.Height
With Pback
.CurrentX = (.Width - TextWidth(caption)) / 2
.CurrentY = Y + 2 * (.Height - TextHeight(caption) - Y) / 3
End With
Pback.Print caption
Exit Sub
End If

End Sub





'按钮提示

Public Sub AssignToolTip(ByRef hTarget As Object, ByRef sMessage As String)
    Dim TipWindow As Long
    Dim ti As TOOLINFO
    Dim uid As Long
    Dim ToolTipText As String
    Dim RECT As RECT
    uid = 0
    
    TipWindow = CreateWindowEx(0&, TOOLTIPS_CLASSA, "", _
     TTS_ALWAYSTIP Or TTS_BALLOON, 0, 0, _
    0, 0, _
    hTarget.hwnd, 0&, App.hInstance, 0&)

    SetWindowPos TipWindow, HWND_TOPMOST, 0, 0, 0, 0, _
    SWP_NOMOVE Or SWP_NOSIZE Or SWP_NOACTIVATE
    GetClientRect hTarget.hwnd, RECT

    'Fill the TOOLINFO structure with info about
    'our tooltip control's tool
    With ti
        .cbSize = Len(ti)
        .uFlags = TTF_CENTERTIP + TTF_SUBCLASS
        .hwnd = hTarget.hwnd
        .hinst = App.hInstance
        .uid = uid
        .lpszText = sMessage
        .RECT = RECT
        .lpszText = sMessage
    End With

    SendMessage TipWindow, TTM_ADDTOOLA, 0, ti
    SendMessage TipWindow, TTM_SETMAXTIPWIDTH, 0, 80
    SendMessage TipWindow, TTM_SETTIPBKCOLOR, vbYellow, 0
    SendMessage TipWindow, TTM_SETTIPTEXTCOLOR, 0, 0
End Sub