利用gdi函数可以实现在屏幕上写字，结合其它的函数可以做出在电脑屏幕上倒计时的效果，代码如下：
|
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 |
Declare Function GetDC Lib "user32" (ByVal hWnd As Long) As Long Declare Function ReleaseDC Lib "user32" (ByVal hWnd As Long, ByVal hdc As Long) As Long Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long Declare Function CreateFontIndirect Lib "gdi32" Alias "CreateFontIndirectA" (lpLogFont As LOGFONT) As Long Declare Function SetTextColor Lib "gdi32" (ByVal hdc As Long, ByVal crColor As Long) As Long Declare Function SetBkColor Lib "gdi32" (ByVal hdc As Long, ByVal crColor As Long) As Long Declare Function TextOut Lib "gdi32" Alias "TextOutA" (ByVal hdc As Long, ByVal nXStart As Long, ByVal nYStart As Long, ByVal lpString As String, ByVal cchString As Long) As Long Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long Declare Function UpdateWindow Lib "user32" (ByVal hWnd As Long) As Long Public Declare Function GetDesktopWindow Lib "user32" () As Long Public Declare Function InvalidateRect Lib "user32" (ByVal hWnd As Long, lpRect As RECT, bErase As Long) As Long Declare Function GetTextExtentPoint32 Lib "gdi32" Alias "GetTextExtentPoint32A" (ByVal hdc As Long, ByVal lpsz As String, ByVal cbString As Long, lpSize As SIZE) As Long Declare Function GetWindowDC Lib "user32" (ByVal hWnd As Long) As Long Declare Function WindowFromDC Lib "user32" (ByVal hdc As Long) As Long Const WM_ERASEBKGND = &H14 Const WM_PAINT = &HF Const SM_CXSCREEN = 0 Const SM_CYSCREEN = 1 Public Const LF_FACESIZE = 32 Public Const DEFAULT_CHARSET = 1 Type LOGFONT lfHeight As Long lfWidth As Long lfEscapement As Long lfOrientation As Long lfWeight As Long lfItalic As Byte lfUnderline As Byte lfStrikeOut As Byte lfCharSet As Byte lfOutPrecision As Byte lfClipPrecision As Byte lfQuality As Byte lfPitchAndFamily As Byte ' lfFaceName(0 To LF_FACESIZE - 1) As Byte lfFaceName As String End Type Type RECT left As Long top As Long right As Long bottom As Long End Type Type SIZE cx As Long cy As Long End Type Sub QQ1722187970() Dim oFont As LOGFONT Dim tRect As RECT '设置要使用的字体的格式 With oFont .lfFaceName = "微软雅黑" .lfHeight = 100 .lfWidth = 100 .lfWeight = 700 End With Dim tSize As SIZE Dim x, y x = GetSystemMetrics(SM_CXSCREEN) y = GetSystemMetrics(SM_CYSCREEN) Dim hdc As Long hdc = GetDC(Excel.Application.hWnd) Dim str As String '用红色书写文字 SetTextColor hdc, vbRed '设置字体的背景色 SetBkColor hdc, vbYellow '创建字体 hFont = CreateFontIndirect(oFont) '将创建的字体添加到DC中 SelectObject hdc, hFont For i = 10 To 1 Step -1 Excel.Application.Wait Now + TimeValue("0:0:1") str = i TextOut hdc, x / 3, y / 4, str, Len(str) Debug.Print InvalidateRect(0, tRect, True) ' UpdateWindow Excel.Application.hWnd Next i DeleteObject hFont ReleaseDC 0, hdc Excel.Application.Wait Now + TimeValue("0:0:1") UpdateWindow Excel.Application.hWnd End Sub |
[……]
阅读全文>>>
