开发工具:
文件大小: 10kb
下载次数: 0
上传时间: 2011-02-26
详细说明： 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 Lo ng, _ 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 使用方法: 本帖隐藏的内容 Sub text() Call displayMessage("输入需要警示的内容~") End Sub ...展开收缩
(系统自动生成,下载前可以参看下载内容)
下载文件列表
相关说明
- 本站资源为会员上传分享交流与学习,如有侵犯您的权益,请联系我们删除.
- 本站是交换下载平台，提供交流渠道，下载内容来自于网络，除下载问题外，其它问题请自行百度。
- 本站已设置防盗链，请勿用迅雷、QQ旋风等多线程下载软件下载资源，下载后用WinRAR最新版进行解压.
- 如果您发现内容无法下载，请稍后再次尝试；或者到消费记录里找到下载记录反馈给我们.
- 下载后发现下载的内容跟说明不相乎，请到消费记录里找到下载记录反馈给我们，经确认后退回积分.
- 如下载前有疑问，可以通过点击"提供者"的名字，查看对方的联系方式，联系对方咨询.
