发信人: hunter__fox(雁回西楼)
整理人: winsy(2004-04-05 09:53:44), 站内信件
|
效果:类似黑客帝国里那些电脑屏幕里的动画。
建立一个Form,设置为无边框模式,放入两个Timer控件,在代码区放入下列代码,并编译为*.scr文件即可安装。
如需预览,请将它改名为exe文件并在运行对话框选择它,附带参数"/s"执行。
=====================代码===========================================
Option Explicit
Private Declare Function ExtTextOut Lib "gdi32" Alias "ExtTextOutA" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, ByVal wOptions As Long, lpRect As RECT, ByVal lpString As String, ByVal nCount As Long, lpDx As Long) As Long
Private Const ETO_CLIPPED = 4
Private Const ETO_GRAYED = 1
Private Const ETO_OPAQUE = 2
Private Type RECT
left As Long
top As Long
Right As Long
Bottom As Long
End Type
Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hdc As Long, ByVal nIndex As Long) As Long
Private Const HORZRES = 8 ' Horizontal width in pixels
Private Const VERTRES = 10 ' Vertical width in pixels
Private Declare Function SetTextColor Lib "gdi32" (ByVal hdc As Long, ByVal crColor As Long) As Long
Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function ShowCursor Lib "user32" (ByVal bShow As Long) 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 Const HWND_TOPMOST = -1
Private Const SWP_NOMOVE = &H2
Private Const SWP_NOSIZE = &H1
Private Const Flags = SWP_NOMOVE Or SWP_NOSIZE
Private Declare Function SystemParametersInfo Lib "user32" Alias "SystemParametersInfoA" (ByVal uAction As Long, ByVal uParam As Long, ByRef lpvParam As Any, ByVal fuWinIni As Long) As Long
Private Const SPI_SCREENSAVERRUNNING = 97
Private Const CHARTHEIGHT = 14 '单字符高度
Private Const CHARTWIDTH = 10 '单字符宽度
Private Const DROWCOUNT = 25 '尾线长度
Private Const STEPVAL = 0.96 '消逝速度
Private Const TIMMERVAL = 40 '刷新速度
Dim lngHDC As Long '输出设备句柄
Dim aData() As Long, pData() As Long '数据数组&指针数组
Dim NowGreenVal As Integer '当前绿色饱和度
Dim lEvents As Boolean
Private Sub Form_Activate()
SystemParametersInfo SPI_SCREENSAVERRUNNING, 1, 0, 0
ShowCursor 0
End Sub
Private Sub Form_Load()
Dim p1 As Long, p2 As Long
lEvents = False
'Dim a
'a = App.PrevInstance
'If App.PrevInstance Then End
' lngHDC = Command$
' Me.Caption = CStr(lngHDC)
Select Case Trim(Mid(Command$, 1, 2))
Case Is = "/s" '预览/运行
SetWindowPos Me.hwnd, HWND_TOPMOST, 0, 0, 0, 0, Flags
Me.WindowState = 2
Me.BorderStyle = 0
lngHDC = Me.hdc
FullMode
For p1 = LBound(pData) To UBound(pData)
For p2 = LBound(aData, 2) To UBound(aData, 2)
aData(p1, p2) = Int(Rnd + 0.5)
Next
pData(p1) = Int(Rnd * (UBound(aData, 2) + 1))
Next
Me.Timer1.Interval = 40
Case Else
End
End Select
End Sub
Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer)
Endme
End Sub
Private Sub Form_Mouseup(Button As Integer, Shift As Integer, x As Single, y As Single)
Endme
End Sub
Private Sub Form_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
Endme
End Sub
Sub Endme()
If lEvents Then
SystemParametersInfo SPI_SCREENSAVERRUNNING, 0, 0, 0
ShowCursor 1
End
End If
End Sub
Sub FullMode() '得到屏幕大小
Dim lngWidth As Long, lngHeight As Long
lngWidth = GetDeviceCaps(lngHDC, HORZRES)
lngHeight = GetDeviceCaps(lngHDC, VERTRES)
ReDim aData(lngWidth / CHARTWIDTH, lngHeight / CHARTHEIGHT - 1)
ReDim pData(lngWidth / CHARTWIDTH)
End Sub
Private Sub Timer1_Timer()
Dim p1 As Long, p2 As Long
For p1 = LBound(pData) To UBound(pData)
OutTextLine p1
pData(p1) = (pData(p1) + 1) Mod (UBound(aData, 2) + 1)
Next
End Sub
Sub OutTextLine(LineIndex As Long) '画一条纵线上的字符
Dim np As Long, n As Long, nn As Long
np = pData(LineIndex) 'order 2 for adata()
aData(LineIndex, np) = Int(Rnd + 0.5) 'new data input to adata()
NowGreenVal = 255
For n = np To np - DROWCOUNT Step -1
NowGreenVal = Int(NowGreenVal * STEPVAL)
nn = (n + UBound(aData, 2) - LBound(aData, 2) + 1) Mod (UBound(aData, 2) - LBound(aData, 2) + 1)
Call OutText(nn * CHARTHEIGHT, _
LineIndex * CHARTWIDTH, _
Trim(CStr(aData(LineIndex, nn))), _
RGB(0, NowGreenVal, 0))
Next
End Sub
Sub OutText(nTop As Long, nLeft As Long, cString As String, lngColor As Long) '画一个字符
Dim lhdc As Long, _
lX As Long, _
lY As Long, _
lwOptions As Long, _
llpRect As RECT, _
llpString As String, _
lnCount As Long, _
llpDx As Long
lhdc = Me.hdc
lwOptions = ETO_OPAQUE
lX = nLeft - CHARTWIDTH / 2
lY = nTop - CHARTHEIGHT / 2
llpRect.top = lY + 2
llpRect.left = lX
llpRect.Bottom = lY + CHARTHEIGHT + 2
llpRect.Right = lX + CHARTWIDTH
llpString = cString
lnCount = 1
llpDx = 0
SetTextColor lngHDC, lngColor
ExtTextOut lhdc, lX, lY, lwOptions, llpRect, llpString, lnCount, llpDx
End Sub
Private Sub Timer2_Timer()
lEvents = True
End Sub
---- 作者:hunter__fox【雁回西楼】
来源:网易虚拟社区广州站 VFP版
|
|