Archive Browser
Download matrixscreensaver.zip, last updated 07/07/2000 (34.72 KB)
Download- md5: 26afc89285581880adcea85741a89874
VERSION 5.00
Begin VB.Form frmScreenSaver
BorderStyle = 0 'None
ClientHeight = 5670
ClientLeft = 2370
ClientTop = 1575
ClientWidth = 6585
ControlBox = 0 'False
BeginProperty Font
Name = "Courier New"
Size = 14.25
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Icon = "Matrix1.frx":0000
KeyPreview = -1 'True
LinkTopic = "Form1"
ScaleHeight = 378
ScaleMode = 3 'Pixel
ScaleWidth = 439
ShowInTaskbar = 0 'False
Begin VB.Timer tmrUpdate
Interval = 75
Left = 2925
Top = 2070
End
End
Attribute VB_Name = "frmScreenSaver"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
DefInt A-Z
Private LastX As Single
Private LastY As Single
Private ScrW%, ScrH%
Private TxtHght%, TxtWdth%
Private hMemDc&, hBmp&, hBmpOld&
Private hFont&, hFontOld&
Private MaxHeight
Private MinHeight
Private Type RECT
rLeft As Long
rTop As Long
rRight As Long
rBottom As Long
End Type
Private Rct As RECT
Private Type StringData
CurX As Integer
CurY As Integer
Dy As Integer
NumChars As Integer
End Type
Private Mtrx(1 To 100) As StringData ' One Hundred Output Strings.
Private Declare Function BitBlt& Lib "gdi32" (ByVal hDestDC&, ByVal x1&, ByVal y1&, ByVal nWidth&, ByVal nHeight&, ByVal hSrcDC&, ByVal xSrc&, ByVal ySrc&, ByVal dwRop&)
Private Declare Function CreateCompatibleBitmap& Lib "gdi32" (ByVal hDC&, ByVal nWidth&, ByVal nHeight&)
Private Declare Function CreateCompatibleDC& Lib "gdi32" (ByVal hDC&)
Private Declare Function CreateSolidBrush& Lib "gdi32" (ByVal crColor As Long)
Private Declare Function DeleteDC& Lib "gdi32" (ByVal hDC&)
Private Declare Function DeleteObject& Lib "gdi32" (ByVal hObject&)
Private Declare Function FillRect& Lib "user32" (ByVal hDC&, lpRect As RECT, ByVal hBrush&)
Private Declare Function GetSystemMetrics& Lib "user32" (ByVal nIndex&)
Private Declare Function SelectObject& Lib "gdi32" (ByVal hDC&, ByVal hObject&)
Private Declare Function SendMessage& Lib "user32" Alias "SendMessageA" (ByVal hWnd&, ByVal wMsg&, ByVal wParam&, lParam As Any)
Private Declare Function SetBkMode& Lib "gdi32" (ByVal hDC&, ByVal nBkMode&)
Private Declare Function SetRect& Lib "user32" (lpRect As RECT, ByVal x1&, ByVal y1&, ByVal x2&, ByVal y2&)
Private Declare Function SetTextColor& Lib "gdi32" (ByVal hDC&, ByVal crColor&)
Private Declare Function TextOut& Lib "gdi32" Alias "TextOutA" (ByVal hDC&, ByVal x1&, ByVal y1&, ByVal lpString$, ByVal nCount&)
Private Const TRANSPARENT = 1
Private Const WM_GETFONT = &H31
'--------------------------------------------------
'Name : UpdateFont
'Created : 07/07/2000 08:07
'--------------------------------------------------
'Author : Richard James Moss
'Organisation: Ariad Software
'--------------------------------------------------
'Description : Updates the font of the back buffer
'--------------------------------------------------
'Updates :
'
'--------------------------------------------------
' Ariad Procedure Builder Add-In 1.00.0036
Public Sub UpdateFont()
Attribute UpdateFont.VB_Description = "Updates the font of the back buffer"
'##BD Updates the font of the back buffer
If hFontOld Then
DeleteObject SelectObject(hMemDc, hFontOld)
End If
' Get The Form's Font (Courier, Regular, 15)... (Just Call Me Spock!).
hFont = SendMessage(hWnd, WM_GETFONT, 0, 0&)
' Select It Into Our Back Buffer So We Can Output Text.
hFontOld = SelectObject(hMemDc, hFont)
End Sub '(Public) Sub UpdateFont ()
Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer)
Form_KeyPress KeyCode
End Sub
Private Sub Form_KeyPress(KeyAscii As Integer)
If PreviewMode = 0 Then
Unload Me
End If
End Sub
Private Sub Form_Load()
Dim Cols
Dim K
'setup values
BackColor = BackgroundClr
tmrUpdate.Interval = Speed
Set Font = StringToFont(FontData$)
'now screensaver
' Aquire The Screen Width And Height In Pixels.
ScrW = GetSystemMetrics(0)
ScrH = GetSystemMetrics(1)
' Setup A RECT Structure The Size Of The Screen.
' This Will Be Used Later With The API Function "FillRect"
' To Clear The Back Buffer.
SetRect Rct, 0, 0, ScrW, ScrH
' Create An Off Screen Drawing Area In Memory (Back Buffer)... (Backbuffer,.. That Picture NoOne Can See).
hMemDc = CreateCompatibleDC(0)
hBmp = CreateCompatibleBitmap(hDC, ScrW, ScrH)
hBmpOld = SelectObject(hMemDc, hBmp)
SetBkMode hMemDc, TRANSPARENT
UpdateFont
TxtWdth = TextWidth("A")
TxtHght = TextHeight("A")
MaxHeight = ScrH - TxtHght
' Seed Random Number Generator.
Randomize
For K = 1 To 100
Cols = Int(ScrW / TxtWdth)
Mtrx(K).CurX = Int(Rnd * Cols) * TxtWdth 'Rnd * (ScrW - TxtWdth)
Mtrx(K).NumChars = Int((20 - 5 + 1) * Rnd + 5)
Mtrx(K).Dy = TxtHght + Rnd * TxtHght
MinHeight = -2 * Mtrx(K).Dy * Mtrx(K).NumChars
Mtrx(K).CurY = Int((MaxHeight - MinHeight + 1) * Rnd + MinHeight)
Next 'showtime...
If PreviewMode = 0 Then
ScreenSaverActive = -1
WindowState = 2
CursorVisible = 0
Show
End If
End Sub
Private Sub Form_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
If PreviewMode = 0 Then
' Unload Me
End If
End Sub
Private Sub Form_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
If PreviewMode = 0 Then
If (LastX = 0 And LastY = 0) Or (Abs(LastX - X) < 2 And Abs(LastY - Y) < 2) Then
' Small Mouse Movement...
LastX = X
LastY = Y
Else
' Massive Mouse-Movement (Rat'ssssssssss)... End.
Unload Me
End If
End If
End Sub
Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
' Delete The Font We Created.
DeleteObject SelectObject(hMemDc, hFontOld)
' Delete The Back Buffer.
DeleteObject SelectObject(hMemDc, hBmpOld)
DeleteDC hMemDc
CursorVisible = -1
ScreenSaverActive = 0
End
End Sub
Private Sub tmrUpdate_Timer()
Dim hBrush As Long
Dim Char$
Dim Cols
Dim K, N
Dim CY
Dim MX
' Clear The BackBuffer.
hBrush = CreateSolidBrush(BackgroundClr)
FillRect hMemDc, Rct, hBrush
DeleteObject hBrush
' Output Our Strings.
For K = 1 To 100
CY = Mtrx(K).CurY
MX = Mtrx(K).NumChars
For N = 1 To MX
If N = MX Then ' Last Char In String.
SetTextColor hMemDc, HighlightTextClr ' The Brightest Letter.
Else
SetTextColor hMemDc, DimmedTextClr ' The Darker Letters.
End If
' OutPut The Character On The Back Buffer.
Select Case CharacterSet
Case 0 'complete
Char$ = Chr$(Int((255 - 33 + 1) * Rnd + 33))
Case 1 'binary
Char$ = Chr$((Rnd * 1) + 48)
Case Else 'custom
If Len(CharacterSetChar) Then
Char$ = Mid$(CharacterSetChar, Int(Rnd * (Len(CharacterSetChar & " ") - 1) + 1), 1)
Else
Char$ = Chr$((Rnd * 1) + 48)
End If
End Select
TextOut hMemDc, Mtrx(K).CurX, CY, Char$, 1
'End If
CY = CY + Mtrx(K).Dy
Next
Mtrx(K).CurY = Mtrx(K).CurY + Mtrx(K).Dy
If Mtrx(K).CurY > ScrH Then
' A String Has Now Left The Screen So
' Need To Initialize Another One.
Cols = Int(ScrW / TxtWdth)
Mtrx(K).CurX = Int(Rnd * Cols) * TxtWdth 'Rnd * (ScrW - TxtWdth)
' Mtrx(K).CurX = Rnd * (ScrW - TxtWdth)
Mtrx(K).NumChars = Int((20 - 5 + 1) * Rnd + 5)
Mtrx(K).Dy = TxtHght + Rnd * (TxtHght \ 2)
Mtrx(K).CurY = -2 * Mtrx(K).Dy * Mtrx(K).NumChars
End If
Next
' Now That The Off Screen Drawing Is Complete,
' Blit The Finished Frame Onto The Screen.
BitBlt hDC, 0, 0, ScrW, ScrH, hMemDc, 0, 0, vbSrcCopy
End Sub
Donate
This software may be used free of charge, but as with all free software there are costs involved to develop and maintain.
If this site or its services have saved you time, please consider a donation to help with running costs and timely updates.
Donate