jdsaver.bas

大量优秀的vb编程

Attribute VB_Name = "JDSAVER"

'-----------------------------------------------------------------------------
Option Explicit

Type RECT 'Used by GetClientRect and GetWindowRect
        Left As Long
        Top As Long
        Right As Long
        Bottom As Long
End Type

Type OsVersionInfo
    dwVersionInfoSize As Long
    dwMajorVersion As Long
    dwMinorVersion As Long
    dwBuildNumber As Long
    dwPlatform As Long
    szCSDVersion As String * 128
End Type

'--------------------------------------------------------------------------
'API declarations
'--------------------------------------------------------------------------
Declare Function BitBlt& Lib "gdi32" (ByVal hDestDC&, ByVal x&, ByVal Y&, ByVal nWidth&, ByVal nHeight&, ByVal hSrcDC&, ByVal XSrc&, ByVal YSrc&, ByVal dwRop&)
Private Declare Function CreateDC& Lib "gdi32" Alias "CreateDCA" (ByVal lpDriverName$, ByVal lpDeviceName$, ByVal lpOutput$, ByVal lpInitData&)
Private Declare Function DeleteDC& Lib "gdi32" (ByVal hDC&)
Private Declare Function FindWindow& Lib "user32" Alias "FindWindowA" (ByVal lpClassName$, ByVal lpWindowName$)
Public Declare Function GetClientRect& Lib "user32" (ByVal hwnd&, lpRect As RECT)
Private Declare Function GetVersionEx& Lib "kernel32" Alias "GetVersionExA" (lpStruct As OsVersionInfo)
Public Declare Function GetWindowRect& Lib "user32" (ByVal hwnd&, lpRect As RECT)
Public Declare Function GetWindowLong& Lib "user32" Alias "GetWindowLongA" (ByVal hwnd&, ByVal nIndex&)
Public Declare Function IsWindow& Lib "user32" (ByVal hwnd&)
Private Declare Function PwdChangePassword& Lib "mpr" Alias "PwdChangePasswordA" (ByVal lpcRegkeyname$, ByVal hwnd&, ByVal uiReserved1&, ByVal uiReserved2&)
Private Declare Function RegCloseKey& Lib "advapi32.dll" (ByVal HKey&)
Private Declare Function RegOpenKeyExA& Lib "advapi32.dll" (ByVal HKey&, ByVal lpszSubKey$, dwOptions&, ByVal samDesired&, lpHKey&)
Private Declare Function RegQueryValueExA& Lib "advapi32.dll" (ByVal HKey&, ByVal lpszValueName$, lpdwRes&, lpdwType&, ByVal lpDataBuff$, nSize&)
Public Declare Function SendMessage& Lib "user32" Alias "SendMessageA" (ByVal hwnd&, ByVal wMsg&, ByVal wParam&, ByVal lParam As Any)
Public Declare Function SetParent& Lib "user32" (ByVal hWndChild As Long, ByVal hWndNewParent As Long)
Public Declare Function SetWindowLong& Lib "user32" Alias "SetWindowLongA" (ByVal hwnd&, ByVal nIndex&, ByVal dwNewLong&)
Public Declare Function SetWindowPos Lib "user32" (ByVal h&, ByVal hb&, ByVal x&, ByVal Y&, ByVal cx&, ByVal cy&, ByVal f&) As Integer
Public Declare Function ShowCursor& Lib "user32" (ByVal bShow&)
Private 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&)
Public Declare Function SystemParametersInfo Lib "user32" Alias "SystemParametersInfoA" (ByVal uAction As Long, ByVal uParam As Long, lpvParam As Any, ByVal fuWinIni As Long) As Long
Public Declare Function VerifyScreenSavePwd Lib "password.cpl" (ByVal hwnd&) As Boolean

'-----------------------------------------------
'Stuff used to subclass using AddressOf
Private Declare Function CallWindowProc& Lib "user32" Alias "CallWindowProcA" (ByVal wndrpcPrev&, ByVal hwnd&, ByVal uMsg&, ByVal wParam&, lParam As Any)
Private Const GWL_WNDPROC = -4
Private m_wndprcNext&
'-----------------------------------------------

Public Const WM_CLOSE = &H10
Private Const WM_USER = &H400
Public Const SWP_NOMOVE = &H2
Public Const SWP_NOSIZE = 1
Public Const FLAGS = SWP_NOMOVE Or SWP_NOSIZE
Public Const HWND_TOPMOST = -1
Public Const SRCCOPY = &HCC0020
Public Const SRCAND = &H8800C6
Public Const SRCINVERT = &H660046
Public Const HKEY_CURRENT_USER = &H80000001

'Registry Read permissions:
Private Const KEY_QUERY_VALUE = &H1&
Private Const KEY_ENUMERATE_SUB_KEYS = &H8&
Private Const KEY_NOTIFY = &H10&
Private Const READ_CONTROL = &H20000
Private Const STANDARD_RIGHTS_READ = READ_CONTROL
Private Const Key_Read = STANDARD_RIGHTS_READ Or KEY_QUERY_VALUE Or KEY_ENUMERATE_SUB_KEYS Or KEY_NOTIFY

Private Const REG_DWORD = 4&       ' 32-bit number

Public Const SPI_SCREENSAVERRUNNING = 97&

Public tempLong&
Public tempString$
Public tempInt%
Public PWProtect%
Public MouseMoves%
Public PictureLoaded%
Public CPWindow&
Public CPRect As RECT
Public xPixel%
Public yPixel%
Public Size%
Public ScreenWidth%
Public ScreenHeight%
Private OsVers As OsVersionInfo
Public winOS&
Public Const Win95 = 1&
Public Const WinNT = 2&

Sub GetVersion32()
    OsVers.dwVersionInfoSize = 148&
    tempLong = GetVersionEx(OsVers)
    winOS = OsVers.dwPlatform
End Sub

Function RegGetValue$(MainKey&, SubKey$, value$)
   ' MainKey must be one of the Publicly declared HKEY constants.
   Dim sKeyType&       'returns the key type.  This function expects REG_SZ
   Dim ret&            'returned by registry functions, should be 0&
   Dim lpHKey&         'return handle to opened key
   Dim lpcbData&       'length of data in returned string
   Dim ReturnedString$ 'returned string value
    Dim fTempDbl!
   If MainKey >= &H80000000 And MainKey <= &H80000006 Then
      ' Open key
      ret = RegOpenKeyExA(MainKey, SubKey, 0&, Key_Read, lpHKey)
      If ret <> 0 Then
         RegGetValue = ""
         Exit Function     'No key open, so leave
      End If
      
      ' Set up buffer for data to be returned in.
      ' Adjust next value for larger buffers.
      lpcbData = 255
      ReturnedString = Space$(lpcbData)

      ' Read key
      ret& = RegQueryValueExA(lpHKey, value, ByVal 0&, sKeyType, ReturnedString, lpcbData)
      If ret <> 0 Then
         RegGetValue = ""   'Key still open, so finish up
      Else
        If sKeyType = REG_DWORD Then
            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)))
            ReturnedString = Format$(fTempDbl, "000")
        End If
        RegGetValue = Left$(ReturnedString, lpcbData - 1)
    End If
      ' Always close opened keys!
      ret = RegCloseKey(lpHKey)
   End If
End Function

Sub Centerform(FrmName As Form)
    FrmName.Top = Screen.Height / 2 - FrmName.Height / 2
    FrmName.Left = Screen.Width / 2 - FrmName.Width / 2
End Sub

Sub CopyScreen(canvas As Object)
Dim screendc&
    canvas.AutoRedraw = True
    screendc = CreateDC("DISPLAY", "", "", 0&)
    tempLong = StretchBlt(canvas.hDC, 0, 0, canvas.Width, canvas.Height, screendc, 0, 0, Screen.Width, Screen.Height, SRCCOPY)
    tempLong = DeleteDC(screendc)
    canvas.AutoRedraw = False

End Sub


Public Sub Draw(canvas As Object)
    'This small sub is the actual screen saver.  This sample
    'just draws colored circles on the screen.
    Dim x As Integer
    Dim Y As Integer
    Dim radius As Integer
    Dim Colr As Long
    Dim i As Integer
    ScreenWidth = canvas.Width
    ScreenHeight = canvas.Height
    'Draw circles
    For i = 1 To 200 / Size / Size 'Many small or fewer large circles
        x = Rnd * ScreenWidth
        Y = Rnd * ScreenHeight
        Colr = Rnd * &HFFFFFF
        radius = Rnd * ScreenWidth / 400 * Size * Size
        canvas.FillColor = Colr
        canvas.FillStyle = vbFSSolid
        canvas.Circle (x, Y), radius, Colr
    Next i
End Sub

Sub Main()
    'We start the screen saver from a sub main which arbitrates
    'the command line parameter and loads an appropriate form.
    Dim StartType$
    xPixel = Screen.TwipsPerPixelX
    yPixel = Screen.TwipsPerPixelY
    
    'Get the user's previous preference for Circle size, with a
    'default of half-size.
    Size = Val(GetSetting("Samples", "JD Screen Saver", "Size", "5"))
    'Make sure we are within allowable range.
    If Size < 1 Then Size = 1
    If Size > 9 Then Size = 9
    
    StartType = UCase(Left$(Command, 2))
    If StartType = "" Then
        'This will happen when a user right-clicks the .SCR
        'file and chooses "configure"
        StartType = "/C"
    End If
    Select Case StartType
        Case "/C"
            Configuration.Show
        Case "/S"
            '----------------------------------------------
            'The system may start more than one screensaver
            'session, so we need to check for a previous
            'instance.  The problem is that if the previous
            'instance is a "/P" instance, the control panel
            'will not close that instance before this one
            'starts.  Therefore we can't use App.Previnstance.
            'This routine looks for the Main form and exits if
            'it is present.
            '----------------------------------------------
            If CheckUnique("Screen Saver Main Form") = False Then
                Exit Sub
            End If
            MainForm.Show
        Case "/P"
            'A handle to the Preview window is passed following the
            '/p.  We will use this handle to place our output.
            CPWindow = Val(Right$(Command, Len(Command) - 2))
            Load ControlForm
        Case "/A"
            'A handle to the Display Properties main window is passed
            'following the /a.  This handle is part of the PwdChangePassword
            'function, and places the dialog over the properties dialog.
            CPWindow = Val(Right$(Command, Len(Command) - 2))
            tempLong = PwdChangePassword("SCRSAVE", CPWindow, 0, 0)
  
    End Select
End Sub
Function CheckUnique%(FormCaption$)
    'looks for a window with the same caption
    Dim HandleWin&
    HandleWin = FindWindow(vbNullString, FormCaption)
    If HandleWin = 0 Then
        CheckUnique = True
    Else
        CheckUnique = False
    End If
End Function
Public Function CtlProc(ByVal hwnd As Long, ByVal MsgVal As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
    'Example of a subclassed window using AddressOf.  Look at the
    'SubClass and UnSubClass functions to see how it is invoked.
    'Respond to the WM_CLOSE message sent to the picture box
    'when the Display Properties dialog has gone on to something
    'else or has gone away.
    If m_wndprcNext = 0 Then
        Exit Function  'This function may trigger after the window has gone away.
    End If
    Select Case MsgVal
        Case WM_CLOSE
            'Putting the picture box back where it started may not
            'be absolutely necessary, but it is good coding practice
            tempLong = SetParent(ControlForm.Picture1.hwnd, ControlForm.hwnd)
            
            'Unset the flag, so the timer will close the instance
            'rather than writing to the picture box
            PictureLoaded = False
            
            'Windows expects a zero return from any window processing a
            'WM_CLOSE message.
            CtlProc = 0
            Exit Function
    End Select
    'Pass all messages, except WM_CLOSE, back to the picture box's
    'default message handler
    CtlProc = CallWindowProc(m_wndprcNext, hwnd, MsgVal, wParam, ByVal lParam)
End Function


Public Sub subclass(hwnd&)
    m_wndprcNext = SetWindowLong(hwnd, GWL_WNDPROC, AddressOf CtlProc)
End Sub


Public Sub UnSubClass(hWndCur&)
    If m_wndprcNext Then
        SetWindowLong hWndCur, GWL_WNDPROC, m_wndprcNext
        m_wndprcNext = 0
    End If
End Sub