Option Base 1 Public Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long Public Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long Public Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal hwnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long Public Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long) Public 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 Public Declare Function TrackMouseEvent Lib "user32" (lpEventTrack As TRACKMOUSEEVENTTYPE) As Long '--------------------------------------------------------------------------------------------GDI相关函数 Public Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long Public Declare Function LoadImage Lib "user32" Alias "LoadImageA" (ByVal hInst As Long, ByVal lpsz As String, ByVal un1 As Long, ByVal n1 As Long, ByVal n2 As Long, ByVal un2 As Long) As Long Public Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long Public Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long Public Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long Public Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long Public Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long Public Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long '-------------------------------------------------------------------------------------------- Public Const TME_LEAVE = &H2& Public Const ODS_SELECTED = &H1 Public Const ODT_BUTTON = 4 Public Const WM_DRAWITEM = &H2B Public Const WM_MEASUREITEM = &H2C Public Const IMAGE_BITMAP = 0 Public Const LR_LOADFROMFILE = &H10 Public Const BS_OWNERDRAW = &HB& Public Const GWL_WNDPROC = (-4) Public Const WM_MOUSEMOVE = &H200 Public Const WM_MOUSELEAVE = &H2A3 Public Const WM_LBUTTONUP = &H202 Public Const WS_CHILD = &H40000000 Public Const WS_VISIBLE = &H10000000 Public Const SRCCOPY = &HCC0020 ' (DWORD) dest = source '-------------------------以下是自定义按钮状态常数

Public Const Leave = 1 '离开按钮范围 Public Const Click = 2 ' 按下按钮 Public Const Undo = 3 '松开按钮 Public Type RECT Left As Long Top As Long Right As Long Bottom As Long End Type Public Type DRAWITEMSTRUCT '自绘控件的绘图结构，另外由于它在VC里面是指向这个结构的指针，所以在VB里面要用到CopyMemory这个API函数 CtlType As Long CtlID As Long ItemID As Long itemAction As Long itemState As Long hwndItem As Long hdc As Long rcItem As RECT itemData As Long End Type Public Type MEASUREITEMSTRUCT '自绘控件时候获取菜单的大小

CtlType As Long CtlID As Long ItemID As Long itemWidth As Long itemHeight As Long itemData As Long End Type Public Type TRACKMOUSEEVENTTYPE cbSize As Long dwFlags As Long hwndTrack As Long dwHoverTime As Long End Type Public ImageHandle(3) As Long Public OldMainProc As Long Public OldButtonProc As Long Public CmdHwnd As Long Public MouseLeave As Boolean Public Sub Initialize() '初始化 LoadPic MouseLeave = True MainProc CreateOwnerDrawButton ButtonProc End Sub Public Sub MainProc() '窗口自类化（NewMainProc) OldMainProc = SetWindowLong(Form1.hwnd, GWL_WNDPROC, AddressOf NewMainProc) End Sub Public Sub ButtonProc() '按钮自类化(NewButtonProc) OldButtonProc = SetWindowLong(CmdHwnd, GWL_WNDPROC, AddressOf NewButtonProc) End Sub Public Sub CreateOwnerDrawButton() '创造一个自绘按钮 CmdHwnd = CreateWindowEx(0, "Button", "", WS_CHILD Or BS_OWNERDRAW Or WS_VISIBLE, 50, 60, 70, 25, Form1.hwnd, 0, App.hInstance, 0) Dim dc As Long dc = GetDC(CmdHwnd) drawPic Leave

End Sub Public Function NewMainProc(ByVal hwnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long '处理主窗口消息 Select Case Msg Case WM_DRAWITEM OnDrawItem lParam Exit Function Case WM_MEASUREITEM OnMeasureItem lParam End Select NewMainProc = CallWindowProc(OldMainProc, hwnd, Msg, wParam, lParam) End Function Public Function NewButtonProc(ByVal hwnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long '处理按钮消息 Select Case Msg Case WM_MOUSELEAVE Button_MouseLeave MouseLeave = True Case WM_MOUSEMOVE Button_MouseMove Case WM_LBUTTONUP Button_MouseLButtonUp End Select NewButtonProc = CallWindowProc(OldButtonProc, hwnd, Msg, wParam, lParam) End Function Public Sub Button_MouseMove() '鼠标移动事件 drawPic Undo If MouseLeave = True Then MouseLeave = False Dim MouseTrack As TRACKMOUSEEVENTTYPE With MouseTrack .cbSize = Len(MouseTrack) .dwFlags = TME_LEAVE .hwndTrack = CmdHwnd End With TrackMouseEvent MouseTrack End If End Sub Public Sub Button_MouseLButtonUp() '左键按下事件 Debug.Print "已按下左键" End Sub Public Sub Button_MouseLeave() '离开事件 drawPic Leave Debug.Print "已离开按钮的范围" End Sub Public Sub OnMeasureItem(lParam As Long) '设置的大小 Dim lpMIS As MEASUREITEMSTRUCT CopyMemory lpMIS, ByVal lParam, Len(lpMIS) lpMIS.itemHeight = 25 lpMIS.itemWidth = 70 CopyMemory ByVal lParam, lpMIS, Len(lpMIS) End Sub Public Sub OnDrawItem(lParam As Long) '为按钮绘制样貌 Dim lpDIS As DRAWITEMSTRUCT CopyMemory lpDIS, ByVal lParam, Len(lpDIS) Dim mem As Long Dim Object As Long mem = CreateCompatibleDC(hdc) If lpDIS.CtlType = ODT_BUTTON Then If lpDIS.itemState And ODS_SELECTED Then '按下时外貌 drawPic Click Else '松开时外貌 If MouseLeave = True Then drawPic Leave Else drawPic Undo End If End If End If CopyMemory ByVal lParam, lpDIS, Len(lpDIS) End Sub Public Sub LoadPic() '读取图片 ImageHandle(1) = LoadImage(App.hInstance, App.Path & "\" & "1.bmp", IMAGE_BITMAP, 0, 0, LR_LOADFROMFILE) ImageHandle(2) = LoadImage(App.hInstance, App.Path & "\" & "2.bmp", IMAGE_BITMAP, 0, 0, LR_LOADFROMFILE) ImageHandle(3) = LoadImage(App.hInstance, App.Path & "\" & "3.bmp", IMAGE_BITMAP, 0, 0, LR_LOADFROMFILE) End Sub Public Sub drawPic(State As Long) '为按钮绘制不同状态的图案 Dim hdc As Long Dim mem As Long Dim Object As Long hdc = GetDC(CmdHwnd) mem = CreateCompatibleDC(hdc) Object = SelectObject(mem, ImageHandle(State)) BitBlt hdc, 0, 0, 70, 25, mem, 0, 0, SRCCOPY DeleteObject Object DeleteDC mem End Sub

另外再只要按相应的状态加上适当的图片就行的了再只要按相应的状态加上适当的图片就行的

[此贴子已经被作者于2004-12-27 00:46:30编辑过]