' ManyThng.BAS -- This is my attempt at a variable screen saver
' It is based on an example in "Learn Programming and Visual Basic 2.0"
' by John Socha and Sybex Inc., (highly recommended)
' first written 4-15-93 Bruce McLean
'
Option Explicit
'
' These variables support saving the maximum number of lines
' in the CONTROL.INI file, which is where the Windows 3.1
' screen savers save setup information.
'
Global MaxLines As Integer ' Lines to show before CLS
Global RepeatCount As Integer ' # of lines the same color
Global MaxChangeMinutes As Single ' minutes to go before changing color
Global MaxCums As Integer ' total number of lines before clearing screen
Global BitmapsDir As String ' place to look for bitmaps
Global BmpSeconds As Integer ' seconds between bitmaps on slide show
Global RandomFlag As Integer ' non-zero means pick saver at random, else go in sequence
Global StartSaver As Integer ' zero means pick 1st saver at random, else start with saver the corresponds to value
Global ErrorTrace As Integer ' flag to log data for error tracing
Global LowMemoryFlag As Integer 'set this to run special low memory mode
Global TestMode As Integer 'this mode is for debugging code
Global Const iniName = "CONTROL.INI"
Global Const secName = "Screen Saver.Many Things"
Global Const keyName = "MaxLines"
Global Const RepeatName = "RepeatCount"
Global Const ChangeMinutesName = "MaxChangeMinutes"
Global Const MaxCumsName = "MaxCumLines"
Global Const BmpsDirName = "BitmapsDir"
Global Const BmpSecondsName = "BmpSeconds"
Global Const RandomFlagName = "RandomFlag"
Global Const LowMemoryFlagName = "LowMemoryFlag"
Global Const StartSaverName = "StartSaver"
Global Const ErrorTraceName = "ErrorTrace"
' windows defines
Type RECT
left As Integer
top As Integer
right As Integer
bottom As Integer
End Type
'Polygon routine that draws any arbitray polygon using fill, etc.
Type POINTAPI
X As Integer
Y As Integer
End Type
' Windows API Routines used:
Declare Function ShowCursor Lib "USER" (ByVal fShow As Integer) As Integer
Declare Sub BitBlt Lib "GDI" (ByVal DestDC As Integer, ByVal X As Integer, ByVal Y As Integer, ByVal BWidth As Integer, ByVal BHeight As Integer, ByVal SourceDC As Integer, ByVal X As Integer, ByVal Y As Integer, ByVal Constant As Long)
Declare Function StretchBlt Lib "GDI" (ByVal hDC As Integer, ByVal X As Integer, ByVal Y As Integer, ByVal nWidth As Integer, ByVal nHeight As Integer, ByVal hSrcDC As Integer, ByVal XSrc As Integer, ByVal YSrc As Integer, ByVal nSrcWidth As Integer, ByVal nSrcHeight As Integer, ByVal dwRop As Long) As Integer
Declare Function CopyRect Lib "User" (lpDestRect As RECT, lpSourceRect As RECT) As Integer
Declare Function CreateDC Lib "GDI" (ByVal Driver As Any, ByVal Dev As Any, ByVal O As Any, ByVal Init As Any) As Integer
Declare Sub DeleteDC Lib "GDI" (ByVal hDC As Integer)
Declare Sub DrawIcon Lib "User" (ByVal hDC As Integer, ByVal X As Integer, ByVal Y As Integer, ByVal hIcon As Integer)
Declare Function GetCursor Lib "User" () As Integer
Declare Sub GetCursorPos Lib "User" (lpPNT As Integer)
Declare Function GetDeviceCaps Lib "GDI" (ByVal hDC As Integer, ByVal nIndex As Integer) As Integer
Declare Function LockResource Lib "Kernel" (ByVal hRes As Integer) As Long
Declare Sub UnlockResource Lib "Kernel" Alias "GlobalUnlock" (ByVal hRes As Integer)
Declare Sub FloodFill Lib "GDI" (ByVal hDC As Integer, ByVal X As Integer, ByVal Y As Integer, ByVal color As Long)
Declare Function Polygon Lib "GDI" (ByVal hDC As Integer, lpPoints As POINTAPI, ByVal nCount As Integer) As Integer
Declare Function SetPolyFillMode Lib "GDI" (ByVal hDC As Integer, ByVal nPolyFillMode As Integer) As Integer
Declare Function GetNearestColor Lib "GDI" (ByVal hDC As Integer, ByVal crColor As Long) As Long
Declare Function GetDeviceCaps Lib "GDI" (ByVal hDC As Integer, ByVal nIndex As Integer) As Integer
Declare Function SetSysModalWindow Lib "User" (ByVal hWND As Integer) As Integer
'routines for reading profile data in 'CONTROL.INI'
Declare Function GetPrivateProfileInt Lib "KERNEL" (ByVal lpszSectionName As String, ByVal lpszKeyName As String, ByVal nDefault As Integer, ByVal lpszFileName As String) As Integer
Declare Function GetPrivateProfileString Lib "Kernel" (ByVal lpApplicationName As String, ByVal lpKeyName As String, ByVal lpDefault As String, ByVal lpReturnedString As String, ByVal nSize As Integer, ByVal lpFileName As String) As Integer
Declare Function WritePrivateProfileString Lib "KERNEL" (ByVal lpszSectionName As String, ByVal lpszKeyName As String, ByVal nString As String, ByVal lpszFileName As String) As Integer
Declare Function SystemParametersInfo Lib "User" (ByVal uAction%, ByVal uParam%, lpvParam As Any, ByVal fuWinIni%) As Integer
' variables and constants to be used for screen capture
Global ScrnWidth As Integer, ScrnHeight As Integer
Dim RECT(3) As Integer
Global Const PI = 3.141592654
'Device Parameters for GetDeviceCaps()
Global Const DRIVERVERSION = 0 ' Device driver version
Global Const TECHNOLOGY = 2 ' Device classification
Global Const HORZSIZE = 4 ' Horizontal size in millimeters
Global Const VERTSIZE = 6 ' Vertical size in millimeters
Global Const HORZRES = 8 ' Horizontal width in pixels
Global Const VERTRES = 10 ' Vertical width in pixels
Global Const BITSPIXEL = 12 ' Number of bits per pixel
Global Const PLANES = 14 ' Number of planes
Global Const NUMBRUSHES = 16 ' Number of brushes the device has
Global Const NUMPENS = 18 ' Number of pens the device has
Global Const NUMMARKERS = 20 ' Number of markers the device has
Global Const NUMFONTS = 22 ' Number of fonts the device has
Global Const NUMCOLORS = 24 ' Number of colors the device supports
Global Const PDEVICESIZE = 26 ' Size required for device descriptor
Global Const CURVECAPS = 28 ' Curve capabilities
Global Const LINECAPS = 30 ' Line capabilities
Global Const POLYGONALCAPS = 32 ' Polygonal capabilities
Global Const TEXTCAPS = 34 ' Text capabilities
Global Const CLIPCAPS = 36 ' Clipping capabilities
Global Const RASTERCAPS = 38 ' Bitblt capabilities
Global Const ASPECTX = 40 ' Length of the X leg
Global Const ASPECTY = 42 ' Length of the Y leg
Global Const ASPECTXY = 44 ' Length of the hypotenuse
Global Const LOGPIXELSX = 88 ' Logical pixels/inch in X
Global Const LOGPIXELSY = 90 ' Logical pixels/inch in Y
Global Const SIZEPALETTE = 104 ' Number of entries in physical palette
Global Const NUMRESERVED = 106 ' Number of reserved entries in palette
Global Const COLORRES = 108 ' Actual color resolution
Global Const SPI_SETSCREENSAVEACTIVE = 17
Sub EndScrnsave ()
Dim i As Integer
ShowMouse ' Make mouse pointer visible again
LogFile ("ManyThng done") ' make log
'tell windows to enable screen savers
i = SystemParametersInfo(SPI_SETSCREENSAVEACTIVE, True, 0, 0)
End ' And exit
End Sub
Sub HideMouse ()
While ShowCursor(False) >= 0
Wend
End Sub
Sub LogFile (A As String)
'to enable logging comment out next line
If Not ErrorTrace Then
Exit Sub
End If
Open "c:\manythng.log" For Append Access Write As #1
Print #1, Date; " "; Time; " "; A
Close #1
End Sub
Sub main ()
Dim i As Integer
Dim DC As Integer
Dim temp As String
Dim temp2 As String * 128
'see if error tracing is enabled
' to enable, edit "control.ini" in windows directory
' in section "[Screen Saver.Many Things]"
' add line: "ErrorTrace=ON"
' to disable delete line
i = GetPrivateProfileString(secName, ErrorTraceName, "OFF", temp2, 125, iniName)
