一个新奇和笨拙的VB屏保

感谢 link_hou@sina.com 为本站供稿

说它新奇是因为它要用一个叫FRMshell的窗体打开一个通用对话框来选择屏保用的声音和图片，生成一个文本文件来存放文件名，说它笨拙是因为还要“人工脱壳”——移除这个叫FRMshell的窗体，这样这个屏保第二次打开时直接调用那个存放文件名的文本文件，来执行屏保，新奇吧？笨拙吧？好了，OK，Let's go !
1、新建一个名称叫FRMshell的窗体，高为6300，宽为7000，其caption属性为“我的VB屏保”，StartupPosition属性设置为2，在窗体上添加一个图象框控件，名称为默认的image1,高为5000，宽为6667，点击“工程”“部件”，添加Microsft common dialog control 6.0这个通用对话框，名称叫Dlg1，在窗体上新建4个命令按钮，名称默认，style属性为1，四个命令按钮的caption属性分别为“选择声音和图片文件”“将这个文件存入屏保”“试试屏保效果”“完毕（先看看说明文件）”，它们的大小和位置自行安排。
2、新建两个模块，名称叫MODmain和MODconst
3、新建一个名称叫FRMmain的窗体，在窗体上添加一个时钟控件，名称用默认的名字timer1
4、在这个程序所在的文件夹里，放一个jpg图片，改名为“背景”，做为这个程序的背景。
5、写下如下代码（见文章的后面）
6、在“工程”菜单上选择“工程1属性”，出现一对话框，在“启动对象”下拉菜单中选择FRMshell，确定。
7、运行一下程序，出现一个画面，点击“选择声音和图片文件”按钮，选择图片和声音文件，打开的同时就能看到和听到效果了，你可以点击“将这个文件存入屏保”按钮，选择完毕，你可以点击“试试屏保效果”按钮，不满意可以继续增加图片和改变声音，满意的话，点击“完毕（先看看说明文件）”按钮，这时将回到VB编辑状态。
8、在编辑状态右边“工程资源管理器”中，在FRMshell项目上点击右键，选择移除showopen.frm。在“工程”菜单上选择“工程1属性”，出现一对话框，在“启动对象”下拉菜单中选择FRMmain，确定。
9、又回到编辑状态，在文件菜单下选择生成“工程1.exe”，出现一个新的对话框，将文件名改为你喜欢的名字，扩展名为“.scr”，存到c:\windows 或者\winnt\system32目录下。
10、下面的还问我吗？对了，别忘了关闭这个工程时电脑问你是否保存的时候要选否。 ^_^      link_hou@sina.com

附：源代码
    Option Explicit 'FRMmain
    Dim OldX As Integer '定义存放旧的鼠标水平坐标
    Dim OldY As Integer '定义存放旧的鼠标垂直坐标
    Dim pic_musicfile As String
    '在C盘亘目录下建立一个文件来存放选择的图片和声音文件名，这个变量是选择的声音或图片文件名
    Dim i As Integer '定义循环变量
    Dim music As String  '定义传递声音文件的变量
    Dim pic() As New StdPicture '定义一个图片类的动态数组
    Dim picnum As Integer  '定义动态数组的数目
    Private Sub Form_Load()
    OldX = -1 '为旧鼠标水平坐标赋初值
    OldY = -1 '为旧鼠标垂直坐标赋初值
    picnum = 0 '自己设置图片数目，先设置初值
    i = 1 '为循环变量赋初值
    Timer1.Interval = 2000
    music = ""
    FRMmain.BorderStyle = 0
    ReDim pic(100)
        '下面代码是在一个文本文件（硬盘中建立的存放图片和声音文件名字的文本文件）中选择图片和声音文件
        Open "c:\在屏保制作程序中你选择的图象和声音文件.txt" For Input As #1
        Do While Not EOF(1)
            Input #1, pic_musicfile
                If Right(pic_musicfile, 3) = "wav" Or Right(pic_musicfile, 3) = "WAV" Then
                    music = pic_musicfile
                Else
                    Set pic(picnum) = LoadPicture(pic_musicfile) '读取选择的图片
                    picnum = picnum + 1
                End If
        Loop
        Close #1
    ReDim Preserve pic(picnum)
    If music <> "" Then sndPlaySound music, 9 '播放声音
    MODmain.Main
    End Sub
      
    Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer)
    If MODmain.Scan_RUN Then MODmain.CloseSCR  '如果此时是在运行屏保则关闭屏保
    End Sub
     
    Private Sub Form_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
    If MODmain.Scan_RUN Then MODmain.CloseSCR  '如果此时是在运行屏保则关闭屏保
    End Sub
    
    Private Sub Form_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
    If MODmain.Scan_RUN Then
        If (OldX = -1) And (OldY = -1) Then
            OldX = X
            OldY = Y
        Else
            If Abs(X - OldX) >= 2 Then MODmain.CloseSCR
            '将鼠标当前的水平坐标和垂直坐标与旧鼠标的水平坐标和垂直坐标相减其绝对值如果大于2个像素则退出屏保
        End If
    End If
    End Sub
  
    Private Sub Form_Unload(Cancel As Integer)
    MODmain.CloseSCR '关闭屏保
    End Sub
  
    Private Sub Timer1_Timer()
    
    If (i >= picnum) Then
        i = 1 '如果循环变量大于图片的数量则变量赋为1
    Else
        i = i + 1 '否则循环变量加一
    End If
    On Error Resume Next
    FRMmain.PaintPicture pic(i - 1), 0, 0, Width, Height, 0, 0, ScaleX(pic(i - 1).Width, vbHimetric, vbTwips), ScaleY(pic(i - 1).Height, vbHimetric, vbTwips) '在FRMmain上画图
    End Sub

    Option Explicit 'MODconst
    Public Const WM_LOOK = "屏保预览(demo)"
    Public Const WM_RUN = "屏保运行(demo)"
    Public Const HWND_TOP = 0&
    Public Const WS_CHILD = &H40000000
    Public Const GWL_STYLE = (-16)
    Type RECT
        Left As Long
        Top As Long
        Right As Long
        Bottom As Long
    End Type
  
    Public Const SWP_NOZORDER = &H4
    Public Const SWP_NOACTIVATE = &H10
    Public Const SWP_SHOWWINDOW = &H40
  
    Public Const WM_CLOSE = &H10
    
    Declare Function GetClientRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
    Declare Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hwnd As Long, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long
    Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
    Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
    Declare Function SetParent Lib "user32" (ByVal hWndChild As Long, ByVal hWndNewParent As Long) As Long
    Public Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
    Public Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
    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
    Declare Function ShowCursor Lib "user32" (ByVal bShow As Long) As Long
    Declare Function sndPlaySound Lib "winmm.dll" Alias "sndPlaySoundA" (ByVal lpszSoundName As String, ByVal uFlags As Long) As Long

    'MODmain
    'Option Explicit  '为了在FRMshell卸载之后仍能运行，必须将这行注释掉
    Public preview As Boolean 'true是试试屏保效果，false是真正的屏保

    Sub Main() '程序运行入口
    Dim ClassName As String * 64  '存放窗口的类名
    Dim ExeCmd As String '存放命令行参数
    GetClassName FRMmain.hwnd, ClassName, 64 '取得窗口的类名
    ExeCmd = UCase(Command$) '将调用的屏保的参数转换成大写后存放在变量ExeCmd里
    If Not (InStr(ExeCmd, "/P") = 0) Then '检查屏保的调用参数中是否有"/P"参数
        If FindWindow(ClassName, WM_LOOK) <> 0 Then End  '如果找到已有同一个运行方式的实例存在则程序结束
        ClosePreWindow ClassName, WM_RUN '同上
        Scr_Look
    ElseIf Not (InStr(ExeCmd, "/S") = 0) Then
        If FindWindow(ClassName, WM_RUN) <> 0 Then End
        ClosePreWindow ClassName, WM_LOOK '同上
        Scr_Run
    Else
        ClosePreWindow ClassName, WM_LOOK '同上
        ClosePreWindow ClassName, WM_RUN '同上
        Scr_Run
    End If
    End Sub
    Public Sub ClosePreWindow(ClassName As String, WinCaption As String)
    Dim PreWnd As Long
    PreWnd = FindWindow(ClassName, WinCaption) '寻找类名为ClassName,标题为WinCaption的窗口
    If Not (PreWnd = 0) Then Call SendMessage(PreWnd, WM_CLOSE, 0, 0) '如果窗口已找到则关闭它
    End Sub
  
    Public Sub Scr_Look()
    Dim LookScrWnd As Long
    Dim Style As Long
    Dim LookRect As RECT
    FRMmain.Caption = WM_LOOK '赋上具有相应运行方式的标题
    LookScrWnd = Val(Right(Command$, Len(Command$) - 2)) '取得小屏幕的窗口句柄
    Style = GetWindowLong(FRMmain.hwnd, GWL_STYLE) '取得窗口的样式
    Style = Style Or WS_CHILD '在窗口的样式中加入子窗体常数
    SetWindowLong FRMmain.hwnd, GWL_STYLE, Style '改变窗体的样式
    SetParent FRMmain.hwnd, LookScrWnd '设置窗体的父窗体
    GetClientRect LookScrWnd, LookRect '取得小屏幕的大小
    SetWindowPos FRMmain.hwnd, HWND_TOP, 0, 0, LookRect.Right, LookRect.Bottom, SWP_NOZORDER Or SWP_NOACTIVATE Or SWP_SHOWWINDOW
    '显示窗体并将窗体的大小设置为小屏幕的大小以便覆盖小屏幕
    End Sub
  
    Public Sub Scr_Run()
    FRMmain.Caption = WM_RUN '赋上具有相应运行方式的标题
    ShowCursor False
    SetWindowPos FRMmain.hwnd, HWND_TOP, 0, 0, Screen.Width, Screen.Height, SWP_SHOWWINDOW
    '将屏保放在所有窗口的前面，并全屏幕显示
    End Sub
  
    Public Sub CloseSCR()
     ShowCursor True    '显示鼠标
    Unload FRMmain '同上
    If preview = True Then FRMshell.Show
    End Sub
    Public Function Scan_RUN() As Boolean '侦测当前屏保的运行方式
    If (FRMmain.Caption = WM_RUN) Then '如果屏保是以运行方式在运行则返回"真"，否则返回"假"
        Scan_RUN = True
    Else
        Scan_RUN = False
    End If
    End Function

  

Option Explicit 'FRMshell
Private Sub command1_Click()
Dlg1.DialogTitle = "请打开你喜欢的图象文件或声音文件"
Dlg1.FileName = "*.bmp;*.jpg;*.gif;*.wav"
Dlg1.ShowOpen
On Error GoTo exitpic
If Right(Dlg1.FileName, 3) = "wav" Or Right(Dlg1.FileName, 3) = "WAV" Then
    sndPlaySound Dlg1.FileName, 1  '播放选择的音乐
Else
    Image1.Picture = LoadPicture(Dlg1.FileName)
End If
Command2.Enabled = True
Exit Sub
exitpic: '错误捕捉——为了防止用户没有选择图象文件或声音文件就退出
End
End Sub

Private Sub Command2_Click()
    
Open "c:\在屏保制作程序中你选择的图象和声音文件.txt" For Append As #1 '建立并打开我的文档下的文件，为了把选择的图片和声音记录下来
Print #1, Dlg1.FileName
Close #1
Command2.Enabled = False
Command3.Enabled = True
Command4.Enabled = True
End Sub

Private Sub Command3_Click()
preview = True
ShowCursor False
FRMmain.Show
End Sub

Private Sub command4_Click()
Unload Me
End Sub

Private Sub Form_Load()
FRMshell.Caption = "新奇而笨拙的屏保"
Image1.Stretch = True
On Error Resume Next
Image1.Picture = LoadPicture(App.Path & "\背景.jpg")
Open "c:\在屏保制作程序中你选择的图象和声音文件.txt" For Output As #1 '建立并打开我的文档下的文件，为了把选择的图片和声音记录下来
Close #1 '清空上次运行本程序时存放在该文件里的图象和声音文件名
Command2.Enabled = False
Command3.Enabled = False
Command4.Enabled = False
End Sub

原文转自：http://www.ltesting.net