一个屏幕保护程序代码

精华区

当前位置：网易精华区>>讨论区精华>>编程开发>>● VB和Basic>>一个屏幕保护程序代码

主题：一个屏幕保护程序代码

发信人: 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版
请来VFP版

[关闭][返回]