home *** CD-ROM | disk | FTP | other *** search
/ Visual Basic 5 Developer's Kit / vb5 dev kit.iso / dev / jdsaver / jdsaver.bas < prev    next >
Encoding:
BASIC Source File  |  1996-09-13  |  10.5 KB  |  261 lines
  1. Attribute VB_Name = "JDSAVER"
  2. '---------------------------------------------------------------------------
  3. 'This is VB4/32 sample code which produces a Windows95/NT4 screen saver.  The
  4. 'program recognizes and properly deals with all of the command line parameters
  5. 'generated by the Display Options dialog, including running in the preview window
  6. 'and providing password dialogs.  The actual screen saver is a simple colored
  7. 'disk paint and is provided for demonstrations purposes.
  8. '
  9. 'Two .OCX 32-bit custom controls are required but not included.  They are
  10. 'COMCTL32.OCX, which is provided with VB4 Pro, and MSGHOO32.OCX, a message
  11. 'hooking control by Zane Thomas.  Zane has allowed free distribution of the
  12. 'control, and it is widely available online, including Zane's web page at
  13. 'http://www.activexpert.com
  14. '
  15. '⌐1996 by Don Bradner and Jim Deutch.  Freely distributable.  Released in
  16. 'September, 1996.  Don Bradner may be contacted at Compuserve 76130,1007 or
  17. 'dbirdman@arcatapet.com.  Jim Deutch may be contacted at Compuserve 103134,3516.
  18. '
  19. 'No warranty is expressed or implied concerning usability or errors within this
  20. 'code.  Bug reports should be made to Don Bradner at one of the addresses above.
  21. '
  22. 'If this program is updated, copies will normally be found in the VBPJFO and
  23. 'BASLANG forums on Compuserve, and via http://www.arcatapet.com/vb.html.
  24. '
  25. 'Compile this program to an .scr extension in
  26. 'your Windows\System directory.  You will need to provide the .scr extension
  27. 'each time the program is compiled.
  28. '-----------------------------------------------------------------------------
  29. Option Explicit
  30.  
  31. Type RECT 'Used by GetClientRect and GetWindowRect
  32.         Left As Long
  33.         Top As Long
  34.         Right As Long
  35.         Bottom As Long
  36. End Type
  37.  
  38. '--------------------------------------------------------------------------
  39. 'API declarations
  40. '--------------------------------------------------------------------------
  41. Declare Function BitBlt& Lib "gdi32" (ByVal hDestDC&, ByVal x&, ByVal Y&, ByVal nWidth&, ByVal nHeight&, ByVal hSrcDC&, ByVal XSrc&, ByVal YSrc&, ByVal dwRop&)
  42. Declare Function CreateDC& Lib "gdi32" Alias "CreateDCA" (ByVal lpDriverName$, ByVal lpDeviceName$, ByVal lpOutput$, ByVal lpInitData&)
  43. Declare Function DeleteDC& Lib "gdi32" (ByVal hDC&)
  44. Declare Function FindWindow& Lib "user32" Alias "FindWindowA" (ByVal lpClassName$, ByVal lpWindowName$)
  45. Declare Function GetClientRect& Lib "user32" (ByVal hWnd&, lpRect As RECT)
  46. Declare Function GetWindowRect& Lib "user32" (ByVal hWnd&, lpRect As RECT)
  47. Declare Function GetWindowLong& Lib "user32" Alias "GetWindowLongA" (ByVal hWnd&, ByVal nIndex&)
  48. Declare Function IsWindow& Lib "user32" (ByVal hWnd&)
  49. Declare Function RegCloseKey& Lib "advapi32.dll" (ByVal HKey&)
  50. Declare Function RegOpenKeyExA& Lib "advapi32.dll" (ByVal HKey&, ByVal lpszSubKey$, dwOptions&, ByVal samDesired&, lpHKey&)
  51. Declare Function RegQueryValueExA& Lib "advapi32.dll" (ByVal HKey&, ByVal lpszValueName$, lpdwRes&, lpdwType&, ByVal lpDataBuff$, nSize&)
  52. Declare Function SendMessage& Lib "user32" Alias "SendMessageA" (ByVal hWnd&, ByVal wMsg&, ByVal wParam&, ByVal lParam As Any)
  53. Declare Function SetParent& Lib "user32" (ByVal hWndChild As Long, ByVal hWndNewParent As Long)
  54. Declare Function setWindowLong& Lib "user32" Alias "SetWindowLongA" (ByVal hWnd&, ByVal nIndex&, ByVal dwNewLong&)
  55. Declare Function SetWindowPos Lib "user32" (ByVal h&, ByVal hb&, ByVal x&, ByVal Y&, ByVal cx&, ByVal cy&, ByVal f&) As Integer
  56. Declare Function ShowCursor& Lib "user32" (ByVal bShow&)
  57. Declare Function StretchBlt& Lib "gdi32" (ByVal hDestDC&, ByVal x&, ByVal Y&, ByVal nWidth&, ByVal nHeight&, ByVal hSrcDC&, ByVal XSrc&, ByVal YSrc&, ByVal nSrcWidth&, ByVal nSrcHeight&, ByVal dwRop&)
  58.  
  59. Public Const WM_CLOSE = &H10
  60. Private Const WM_USER = &H400
  61. Public Const EM_SETPASSWORDCHAR = WM_USER + 28
  62. Public Const ES_PASSWORD = &H20
  63. Public Const GWL_STYLE = -16
  64. Public Const SWP_NOMOVE = &H2
  65. Public Const SWP_NOSIZE = 1
  66. Public Const FLAGS = SWP_NOMOVE Or SWP_NOSIZE
  67. Public Const HWND_TOPMOST = -1
  68. Public Const SRCCOPY = &HCC0020
  69. Public Const SRCAND = &H8800C6
  70. Public Const SRCINVERT = &H660046
  71. Public Const HKEY_CURRENT_USER = &H80000001
  72.  
  73. 'Registry Read permissions:
  74. Const KEY_QUERY_VALUE = &H1&
  75. Const KEY_ENUMERATE_SUB_KEYS = &H8&
  76. Const KEY_NOTIFY = &H10&
  77. Const READ_CONTROL = &H20000
  78. Const STANDARD_RIGHTS_READ = READ_CONTROL
  79. Const Key_Read = STANDARD_RIGHTS_READ Or KEY_QUERY_VALUE Or KEY_ENUMERATE_SUB_KEYS Or KEY_NOTIFY
  80.  
  81. Const REG_DWORD = 4&       ' 32-bit number
  82.  
  83.  
  84. Public tempLong&
  85. Public tempString$
  86. Public tempInt%
  87. Public Password$
  88. Public PassChck%
  89. Public PWProtect%
  90. Public MouseMoves%
  91. Public PictureLoaded%
  92. Public CPWindow&
  93. Public CPRect As RECT
  94. Public xPixel%
  95. Public yPixel%
  96. Public Size%
  97. Public ScreenWidth%
  98. Public ScreenHeight%
  99. Function RegGetValue$(MainKey&, SubKey$, value$)
  100.    ' MainKey must be one of the Publicly declared HKEY constants.
  101.    Dim sKeyType&       'returns the key type.  This function expects REG_SZ
  102.    Dim ret&            'returned by registry functions, should be 0&
  103.    Dim lpHKey&         'return handle to opened key
  104.    Dim lpcbData&       'length of data in returned string
  105.    Dim ReturnedString$ 'returned string value
  106.     Dim fTempDbl!
  107.    If MainKey >= &H80000000 And MainKey <= &H80000006 Then
  108.       ' Open key
  109.       ret = RegOpenKeyExA(MainKey, SubKey, 0&, Key_Read, lpHKey)
  110.       If ret <> 0 Then
  111.          RegGetValue = ""
  112.          Exit Function     'No key open, so leave
  113.       End If
  114.       
  115.       ' Set up buffer for data to be returned in.
  116.       ' Adjust next value for larger buffers.
  117.       lpcbData = 255
  118.       ReturnedString = Space$(lpcbData)
  119.  
  120.       ' Read key
  121.       ret& = RegQueryValueExA(lpHKey, value, ByVal 0&, sKeyType, ReturnedString, lpcbData)
  122.       If ret <> 0 Then
  123.          RegGetValue = ""   'Key still open, so finish up
  124.       Else
  125.         If sKeyType = REG_DWORD Then
  126.             fTempDbl = Asc(Mid$(ReturnedString, 1, 1)) + &H100& * Asc(Mid$(ReturnedString, 2, 1)) + &H10000 * Asc(Mid$(ReturnedString, 3, 1)) + &H1000000 * CDbl(Asc(Mid$(ReturnedString, 4, 1)))
  127.             ReturnedString = Format$(fTempDbl, "000")
  128.         End If
  129.         RegGetValue = Left$(ReturnedString, lpcbData - 1)
  130.     End If
  131.       ' Always close opened keys!
  132.       ret = RegCloseKey(lpHKey)
  133.    End If
  134. End Function
  135.  
  136. Sub Centerform(FrmName As Form)
  137.     FrmName.Top = Screen.Height / 2 - FrmName.Height / 2
  138.     FrmName.Left = Screen.Width / 2 - FrmName.Width / 2
  139. End Sub
  140.  
  141. Sub CopyScreen(canvas As Object)
  142. Dim screendc&
  143.     canvas.AutoRedraw = True
  144.     screendc = CreateDC("DISPLAY", "", "", 0&)
  145.     tempLong = StretchBlt(canvas.hDC, 0, 0, canvas.Width, canvas.Height, screendc, 0, 0, Screen.Width, Screen.Height, SRCCOPY)
  146.     tempLong = DeleteDC(screendc)
  147.     canvas.AutoRedraw = False
  148.  
  149. End Sub
  150.  
  151. Public Function encrypt$(passString$)
  152. 'This is a simple encryption method for passwords so that they
  153. 'do not appear in the registry in plain text.  Changing the values
  154. '14 and 4 below would result in a different encryption.
  155. Dim x%
  156. If passString = "" Then
  157.     encrypt = ""
  158.     Exit Function
  159. End If
  160. passString = UCase(passString)
  161. If Len(passString) > 20 Then passString = Left$(passString, 20)
  162. tempString = Space$(Len(passString))
  163. For x = 1 To Len(passString)
  164.     tempInt = Asc(Mid$(passString, x, 1))
  165.     tempInt = tempInt + 14 + (4 * x)
  166.     'Shift all values to occur in the printable lower 128 ascii
  167.     'characters.
  168.     Do While tempInt > 126
  169.         tempInt = tempInt - 126
  170.     Loop
  171.     Do While tempInt < 33
  172.         tempInt = tempInt + 33
  173.     Loop
  174.     Mid$(tempString, x, 1) = Chr$(tempInt)
  175. Next x
  176. encrypt = tempString
  177.  
  178. End Function
  179.  
  180.  
  181. Public Sub Draw(canvas As Object)
  182.     'This small sub is the actual screen saver.  This sample
  183.     'just draws colored circles on the screen.
  184.     Dim x As Integer
  185.     Dim Y As Integer
  186.     Dim radius As Integer
  187.     Dim Colr As Long
  188.     Dim i As Integer
  189.     ScreenWidth = canvas.Width
  190.     ScreenHeight = canvas.Height
  191.     'Draw circles
  192.     For i = 1 To 200 / Size / Size 'Many small or fewer large circles
  193.         x = Rnd * ScreenWidth
  194.         Y = Rnd * ScreenHeight
  195.         Colr = Rnd * &HFFFFFF
  196.         radius = Rnd * ScreenWidth / 400 * Size * Size
  197.         canvas.FillColor = Colr
  198.         canvas.FillStyle = vbFSSolid
  199.         canvas.Circle (x, Y), radius, Colr
  200.     Next i
  201. End Sub
  202.  
  203. Sub main()
  204.     'We start the screen saver from a sub main which arbitrates
  205.     'the command line parameter and loads an appropriate form.
  206.     Dim StartType$
  207.     xPixel = Screen.TwipsPerPixelX
  208.     yPixel = Screen.TwipsPerPixelY
  209.     
  210.     'Get the user's previous preference for Circle size, with a
  211.     'default of half-size.
  212.     Size = Val(GetSetting("Samples", "JD Screen Saver", "Size", "5"))
  213.     'Make sure we are within allowable range.
  214.     If Size < 1 Then Size = 1
  215.     If Size > 9 Then Size = 9
  216.     
  217.     StartType = UCase(Left$(Command, 2))
  218.     Select Case StartType
  219.         Case "/C"
  220.             Configuration.Show
  221.         Case "/S"
  222.             '----------------------------------------------
  223.             'The system may start more than one screensaver
  224.             'session, so we need to check for a previous
  225.             'instance.  The problem is that if the previous
  226.             'instance is a "/P" instance, the control panel
  227.             'will not close that instance before this one
  228.             'starts.  Therefore we can't use App.Previnstance.
  229.             'This routine looks for the Main form and exits if
  230.             'it is present.
  231.             '----------------------------------------------
  232.             If CheckUnique("Screen Saver Main Form") = False Then
  233.                 Exit Sub
  234.             End If
  235.             MainForm.Show
  236.         Case "/P"
  237.             'A handle to the Preview window is passed following the
  238.             '/p.  We will use this handle to place our output.
  239.             CPWindow = Val(Right$(Command, Len(Command) - 2))
  240.             Load ControlForm
  241.         Case "/A"
  242.             'A handle to the Display Properties main window is passed
  243.             'following the /a.  We will use this handle to place the
  244.             'password configuration over the window.
  245.             CPWindow = Val(Right$(Command, Len(Command) - 2))
  246.             PassChange.Show
  247.   
  248.     End Select
  249. End Sub
  250. Function CheckUnique%(FormCaption$)
  251.     'looks for a window with the same caption
  252.     Dim HandleWin&
  253.     HandleWin = FindWindow(vbNullString, FormCaption)
  254.     If HandleWin = 0 Then
  255.         CheckUnique = True
  256.     Else
  257.         CheckUnique = False
  258.     End If
  259. End Function
  260.  
  261.