|
- Option Compare Database
- Option Explicit
- 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
- Declare Function LoadIcon Lib "user32" Alias "LoadIconA" _
- (ByVal hInstance As Long, _
- ByVal lpIconName As String) As Long
- Declare Function LoadCursor Lib "user32" Alias "LoadCursorA" _
- (ByVal hInstance As Long, _
- ByVal lpCursorName As String) As Long
- Declare Function GetStockObject Lib "gdi32" (ByVal nIndex As Long) As Long
- Declare Function RegisterClassEx Lib "user32" Alias "RegisterClassExA" _
- (pcWndClassEx As WNDCLASSEX) As Integer
- Declare Function ShowWindow Lib "user32" (ByVal hwnd As Long, _
- ByVal nCmdShow As Long) As Long
- Declare Function UpdateWindow Lib "user32" (ByVal hwnd As Long) As Long
- Declare Function SetFocus Lib "user32" (ByVal hwnd As Long) As Long
- Declare Function PostMessage Lib "user32" Alias "ostMessageA" _
- (ByVal hwnd As Long, _
- ByVal wMsg As Long, _
- ByVal wParam As Long, _
- ByVal lParam As Long) As Long
- Declare Function DefWindowProc Lib "user32" Alias "DefWindowProcA" _
- (ByVal hwnd As Long, _
- ByVal wMsg As Long, _
- ByVal wParam As Long, _
- ByVal lParam As Long) As Long
- Declare Function GetMessage Lib "user32" Alias "GetMessageA" _
- (lpMsg As MSG, _
- ByVal hwnd As Long, _
- ByVal wMsgFilterMin As Long, _
- ByVal wMsgFilterMax As Long) As Long
- Declare Function TranslateMessage Lib "user32" (lpMsg As MSG) As Long
- Declare Function DispatchMessage Lib "user32" Alias "DispatchMessageA" (lpMsg As MSG) As Long
- Declare Sub PostQuitMessage Lib "user32" (ByVal nExitCode As Long)
- Declare Function BeginPaint Lib "user32" (ByVal hwnd As Long, lpPaint As PAINTSTRUCT) As Long
- Declare Function EndPaint Lib "user32" (ByVal hwnd As Long, lpPaint As PAINTSTRUCT) As Long
- Declare Function GetClientRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
- Declare Function DrawText Lib "user32" Alias "DrawTextA" (ByVal hdc As Long, _
- ByVal lpStr As String, _
- ByVal nCount As Long, _
- lpRect As RECT, _
- ByVal wFormat As Long) As Long
- Declare Function SetLayeredWindowAttributes Lib "user32" (ByVal hwnd As Long, _
- ByVal crKey As Long, _
- ByVal bAlpha As Byte, _
- ByVal dwFlags As Long) As Long
- Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" _
- (ByVal hwnd As Long, _
- ByVal nIndex As Long) As Long
- Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" _
- (ByVal hwnd As Long, _
- ByVal nIndex As Long, _
- ByVal dwNewLong As Long) As Long
- Type WNDCLASSEX
- cbSize As Long
- style As Long
- lpfnWndProc As Long
- cbClsExtra As Long
- cbWndExtra As Long
- hInstance As Long
- hIcon As Long
- hCursor As Long
- hbrBackground As Long
- lpszMenuName As String
- lpszClassName As String
- hIconSm As Long
- End Type
- Type POINTAPI
- x As Long
- y As Long
- End Type
- Type MSG
- hwnd As Long
- message As Long
- wParam As Long
- lParam As Long
- time As Long
- pt As POINTAPI
- End Type
- Type RECT
- Left As Long
- Top As Long
- Right As Long
- Bottom As Long
- End Type
- Type PAINTSTRUCT
- hdc As Long
- fErase As Long
- rcPaint As RECT
- fRestore As Long
- fIncUpdate As Long
- rgbReserved(32) As Byte
- End Type
- Public Const WS_VISIBLE As Long = &H10000000
- Public Const WS_VSCROLL As Long = &H200000
- Public Const WS_TABSTOP As Long = &H10000
- Public Const WS_THICKFRAME As Long = &H40000
- Public Const WS_MAXIMIZE As Long = &H1000000
- Public Const WS_MAXIMIZEBOX As Long = &H10000
- Public Const WS_MINIMIZE As Long = &H20000000
- Public Const WS_MINIMIZEBOX As Long = &H20000
- Public Const WS_SYSMENU As Long = &H80000
- Public Const WS_BORDER As Long = &H800000
- Public Const WS_CAPTION As Long = &HC00000
- Public Const WS_CHILD As Long = &H40000000
- Public Const WS_CHILDWINDOW As Long = (WS_CHILD)
- Public Const WS_CLIPCHILDREN As Long = &H2000000
- Public Const WS_CLIPSIBLINGS As Long = &H4000000
- Public Const WS_DISABLED As Long = &H8000000
- Public Const WS_DLGFRAME As Long = &H400000
- Public Const WS_EX_ACCEPTFILES As Long = &H10&
- Public Const WS_EX_DLGMODALFRAME As Long = &H1&
- Public Const WS_EX_NOPARENTNOTIFY As Long = &H4&
- Public Const WS_EX_TOPMOST As Long = &H8&
- Public Const WS_EX_TRANSPARENT As Long = &H20&
- Public Const WS_GROUP As Long = &H20000
- Public Const WS_HSCROLL As Long = &H100000
- Public Const WS_ICONIC As Long = WS_MINIMIZE
- Public Const WS_OVERLAPPED As Long = &H0&
- Public Const WS_OVERLAPPEDWINDOW As Long = (WS_OVERLAPPED Or _
- WS_CAPTION Or _
- WS_SYSMENU Or _
- WS_THICKFRAME Or _
- WS_MINIMIZEBOX Or _
- WS_MAXIMIZEBOX)
- Public Const WS_POPUP As Long = &H80000000
- Public Const WS_POPUPWINDOW As Long = (WS_POPUP Or WS_BORDER Or WS_SYSMENU)
- Public Const WS_SIZEBOX As Long = WS_THICKFRAME
- Public Const WS_TILED As Long = WS_OVERLAPPED
- Public Const WS_TILEDWINDOW As Long = WS_OVERLAPPEDWINDOW
- Public Const CW_USEDEFAULT As Long = &H80000000
- Public Const CS_HREDRAW As Long = &H2
- Public Const CS_VREDRAW As Long = &H1
- Public Const IDI_APPLICATION As Long = 32512&
- Public Const IDC_ARROW As Long = 32512&
- Public Const WHITE_BRUSH As Integer = 0
- Public Const BLACK_BRUSH As Integer = 4
- Public Const WM_KEYDOWN As Long = &H100
- Public Const WM_CLOSE As Long = &H10
- Public Const WM_DESTROY As Long = &H2
- Public Const WM_PAINT As Long = &HF
- Public Const SW_SHOWNORMAL As Long = 1
- Public Const DT_CENTER As Long = &H1
- Public Const DT_SINGLELINE As Long = &H20
- Public Const DT_VCENTER As Long = &H4
- Public Const WS_EX_PALETTEWINDOW As Long = &H188
- Public Const LWA_ALPHA = &H2
- Public Const GWL_EXSTYLE = (-20)
- Public Const WS_EX_LAYERED = &H80000
- Dim strMessage As String
- '-------------------------------------------------------------------------------
- Public Function displayMessage(mess As String) As Long
- strMessage = mess
- Const CLASSNAME = "我的信息提示~"
- Const TITLE = "透明提示框!"
- Dim hwnd As Long
- Dim wc As WNDCLASSEX
- Dim message As MSG
- wc.cbSize = Len(wc)
- wc.style = CS_HREDRAW Or CS_VREDRAW
- wc.lpfnWndProc = GetFuncPtr(AddressOf WindowProc)
- wc.cbClsExtra = 0&
- wc.cbWndExtra = 0&
- wc.hInstance = Application.hWndAccessApp
- wc.hIcon = LoadIcon(Application.hWndAccessApp, IDI_APPLICATION)
- wc.hCursor = LoadCursor(Application.hWndAccessApp, IDC_ARROW)
- wc.hbrBackground = GetStockObject(WHITE_BRUSH)
- wc.lpszMenuName = 0&
- wc.lpszClassName = CLASSNAME
- wc.hIconSm = LoadIcon(Application.hWndAccessApp, IDI_APPLICATION)
- RegisterClassEx wc
- hwnd = CreateWindowEx(WS_EX_PALETTEWINDOW, _
- CLASSNAME, _
- TITLE, _
- WS_OVERLAPPEDWINDOW, _
- 300, _
- 100, _
- 200, _
- 300, _
- 0&, _
- 0&, _
- Application.hWndAccessApp, _
- 0&)
- ShowWindow hwnd, SW_SHOWNORMAL
- UpdateWindow hwnd
- SetFocus hwnd
- Do While 0 <> GetMessage(message, 0&, 0&, 0&)
- TranslateMessage message
- DispatchMessage message
- Loop
- displayMessage = message.wParam
- End Function
- '--------------------------------------------------------------------------------
- Public Function WindowProc(ByVal hwnd As Long, _
- ByVal message As Long, _
- ByVal wParam As Long, _
- ByVal lParam As Long) As Long
- Dim ps As PAINTSTRUCT
- Dim rc As RECT
- Dim hdc As Long
- Select Case message
- Case WM_PAINT
- hdc = BeginPaint(hwnd, ps)
- Call GetClientRect(hwnd, rc)
- Call DrawText(hdc, strMessage, Len(strMessage), rc, DT_SINGLELINE Or _
- DT_CENTER Or DT_VCENTER)
- Call EndPaint(hwnd, ps)
- Dim Ret As Long
- Ret = GetWindowLong(hwnd, GWL_EXSTYLE)
- Ret = Ret Or WS_EX_LAYERED
- SetWindowLong hwnd, GWL_EXSTYLE, Ret
- SetLayeredWindowAttributes hwnd, 0, 200, LWA_ALPHA
- Exit Function
- Case WM_KEYDOWN
- Call PostMessage(hwnd, WM_CLOSE, 0, 0)
- Exit Function
- Case WM_DESTROY
- PostQuitMessage 0&
- Exit Function
- Case Else
- WindowProc = DefWindowProc(hwnd, message, wParam, lParam)
- End Select
- End Function
- '--------------------------------------------------------------------------------
- Function GetFuncPtr(ByVal lngFnPtr As Long) As Long
- GetFuncPtr = lngFnPtr
- End Function
复制代码 |
评分
-
查看全部评分
|