楼上朋友代码可行,已通过验证,
真不错,用此代码该工程至少省了三分之二的代码,
欢迎对奥运邮集软件代码多提宝贵意见!

在悬浮窗的软件中采用上述方案,(即多了下面12行)会出现"自变量未定义"错误，问题出在何处？那位能指正一下？（出错处见图）
Option Explicit '以下是悬浮窗用,加了此段,会出错"编译错误,自变量未定义"
Private 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
Private Const Swp_nomove = &H2
Private Const Swp_nosize = &H1
Private Const HWND_NOTOPMOST = -2
Private Const hwnd_topmost = -1
Private Declare Function GetCursorPos Lib "USER32" (lpPoint As POINTAPI) As Long
Private Declare Function WindowFromPoint Lib "USER32" (ByVal xPoint As Long, ByVal yPoint As Long) As Long
Private Declare Function GetParent Lib "USER32" (ByVal hWnd As Long) As Long
Private Type POINTAPI
    x As Long
    y As Long
End Type '悬浮窗体止
Private Declare Function FindWindow Lib "USER32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long '以下均常(0)

Private Declare Function TerminateProcess Lib "kernel32" (ByVal hProcess As Long, ByVal uExitCode As Long) As Long
Private Declare Function GetWindowThreadProcessId Lib "USER32" (ByVal hWnd As Long, lpdwProcessId As Long) As Long
Private Declare Function OpenProcess Lib "kernel32" (ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal dwProcessId As Long) As Long
Const PROCESS_TERMINATE = 1
Private Sub Command1_Click()
For i = 1 To 30 '有几届n就写几
   strWinName = "第" & i & "届"
   hLong = FindWindow(vbNullString, strWinName)
   If hLong Then
   GetWindowThreadProcessId hLong, LpID
   Ltem = OpenProcess(PROCESS_TERMINATE, False, LpID)
   TerminateProcess Ltem, 0
   hLong = 0
   End If
Next
Shell "rundll32.exe url.dll,FileProtocolHandler " & App.Path & "\xj1.exe", vbMaximizedFocus
''UnloadMe False, True '关闭钮用(补)
End Sub

Private Sub Command10_Click()
For i = 1 To 30 '有几届n就写几
   strWinName = "第" & i & "届"
   hLong = FindWindow(vbNullString, strWinName)
   If hLong Then
   GetWindowThreadProcessId hLong, LpID
   Ltem = OpenProcess(PROCESS_TERMINATE, False, LpID)
   TerminateProcess Ltem, 0
   hLong = 0
   End If
Next
Shell "rundll32.exe url.dll,FileProtocolHandler " & App.Path & "\xj10.exe", vbMaximizedFocus
'UnloadMe False, True '关闭钮用(补)
End Sub

Private Sub Command11_Click()
For i = 1 To 30 '有几届n就写几
   strWinName = "第" & i & "届"
   hLong = FindWindow(vbNullString, strWinName)
   If hLong Then
   GetWindowThreadProcessId hLong, LpID
   Ltem = OpenProcess(PROCESS_TERMINATE, False, LpID)
   TerminateProcess Ltem, 0
   hLong = 0
   End If
Next
Shell "rundll32.exe url.dll,FileProtocolHandler " & App.Path & "\xj11.exe", vbMaximizedFocus
'UnloadMe False, True '关闭钮用(补)
End Sub

还不行,请看附件,
还是变量未定义

[[it] 本帖最后由 jrs123 于 2008-5-7 11:11 编辑 [/it]]

通过了,谢谢wangtuan7788

(3)系统退出;
    系统退出分为两个内容；一是各届单独退出，一是奥运邮集软件整体退出，下面分别讲解：
    ***各届单独退出——各届退出的钮只有一个，就是在每页的下面，点击该钮，会弹出“系统询问”对话框，问您是否在退出？（见图）
    当点击“是”后，要求关闭该届所有已打开的窗体。代码如下：（如要退出第17届奥运会）
Private Sub Command19_Click() '退出钮
If MsgBox("你要退出《第17届奥运会邮票集》吗?", vbYesNo + vbExclamation, "系统询问") = vbYes Then
   Unload Me
   End
   Else
   Cancel = True
    End If
End Sub
Private Sub UnloadMe(bQuestion As Boolean, bEnd As Boolean, Optional ByRef Cancel As Integer)
Dim Ltem As Long
Dim LpID As Long
Dim hLong     As Long
Dim strWinName     As String
strWinName = "第17届(1)"
hLong = FindWindow(vbNullString, strWinName)
If hLong Then
GetWindowThreadProcessId hLong, LpID
Ltem = OpenProcess(PROCESS_TERMINATE, False, LpID)
TerminateProcess Ltem, 0
hLong = 0
End If
strWinName = "第17届(2)"
hLong = FindWindow(vbNullString, strWinName)
If hLong Then
GetWindowThreadProcessId hLong, LpID
Ltem = OpenProcess(PROCESS_TERMINATE, False, LpID)
TerminateProcess Ltem, 0
hLong = 0
End If
    . '如果有多页面，则要重复上述代码
    .
    .
End Sub   
提示：如果点击窗体右上角的关闭钮也要求弹出“系统询问”框，就需要加下面一段代码：（奥运邮集软件各届退出均未选用此代码，而是保留关闭本窗体的功能）
Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer) '关闭钮用弹出“系统询问”
    If UnloadMode = 0 Then bQuestion = True
End Sub

***软件整体退出——整体退出需要返回到“主页面”，可以通过三个钮来实现，见图。代码如下：
'整体退出声明
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function TerminateProcess Lib "kernel32" (ByVal hProcess As Long, ByVal uExitCode As Long) As Long
Private Declare Function GetWindowThreadProcessId Lib "user32" (ByVal Hwnd As Long, lpdwProcessId As Long) As Long
Private Declare Function OpenProcess Lib "kernel32" (ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal dwProcessId As Long) As Long
Const PROCESS_TERMINATE = 1
Private bQuestion As Boolean
Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer) '从窗体关闭钮用此段
    If UnloadMode = 0 Then bQuestion = True
End Sub
Private Sub Command1_Click() '“退出系统”钮用此段
bQuestion = True
    Unload Me
End Sub
Private Sub cdtc_Click() '菜单栏上“退出系统”钮用此段
bQuestion = True
    Unload Me
End Sub
Private Sub Form_Unload(Cancel As Integer) '关闭钮共用部分
     If bQuestion Then
        If MsgBox("您确实要退出《奥林匹克运动会邮票集》吗?", vbYesNo + vbExclamation, "系统询问") <> vbYes Then
            Cancel = True
            Exit Sub
        Else
            hLong = FindWindow(vbNullString, strWinName)
            If hLong Then
                GetWindowThreadProcessId hLong, LpID
                Ltem = OpenProcess(PROCESS_TERMINATE, False, LpID)
                TerminateProcess Ltem, 0
                hLong = 0
            End If
        End If
    End If
    UnHook Me.Hwnd '鼠标滚轮事件用
    For Each pForm In Forms
        Unload pForm
    Next
     Dim i As Integer '循环关闭各窗体用
For i = 1 To 30 '有几届n就写几届
   strWinName = "第" & i & "届"
   hLong = FindWindow(vbNullString, strWinName)
   If hLong Then
   GetWindowThreadProcessId hLong, LpID
   Ltem = OpenProcess(PROCESS_TERMINATE, False, LpID)
   TerminateProcess Ltem, 0
   hLong = 0
   End If
Next
strWinName = "olp" '关闭“悬浮窗体”用
hLong = FindWindow(vbNullString, strWinName)
If hLong Then
GetWindowThreadProcessId hLong, LpID
Ltem = OpenProcess(PROCESS_TERMINATE, False, LpID)
TerminateProcess Ltem, 0
hLong = 0
End If
End Sub

本讲“七、《奥运邮集》软件的多工程结构”小结：
   应知：（1）单工程和多工程的软件结构各有什么特点？何时采用单工程、何时采用多工程结构？
         （2）在多工程软件exe窗体之间的转换与工程内的窗体之间转换代码有何不同之处？
   应会：（1）单工程系统退出代码（含该工程所有窗体的进程退出）；
         （2）多工程系统退出代码（含所有工程的进程退出）；
   实践：请您也设计一个（单工程或多工程）系统退出代码，要求能弹出系统询问框的（参见上一帖的图例）；

八、悬浮窗体的功能与代码
      奥运邮集有夏季29届、冬季20届，因为需要向用户提供一个友好的、操作方便的换届方式。为此，偶在奥运邮集软件中采用了几种不同的窗体切换方式：
    1、主页上的菜单——即通过主页上的菜单（见图a1-tp3）。打开任一届奥运邮集。该方式的特点是，通过该菜单可以连续打开各届奥运邮集；
    2、各届奥运邮集的换页钮和换届钮——该方式的特点是：
    (1)可以连续打开本届各页邮票或相邻届的奥运邮集的第一页；
    (2)点击窗体右上角的关闭钮，可单独关闭该窗体；
    (3)点击退出本届奥运邮集时，可同时关闭本届所有已打开的窗体；（注：这组代码上面39楼已介绍过了）
    3、采用隐藏在屏幕左边的悬浮窗体切换各届奥运邮集——这一方式的特点是打开一届，即关闭已打开的其余各届（注：此代码上面31楼已介绍过了）；
    下面，向大家介绍一组下拉式悬浮窗的代码：（悬浮窗隐藏在屏幕上方：）
    Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
Private Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
Private Declare Function PtInRect Lib "user32" (lpRect As RECT, ByVal ptx As Long, ByVal pty As Long) As Long
Private 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
Private Declare Function MoveWindow Lib "user32" (ByVal hwnd As Long, ByVal X As Long, _
    ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal bRepaint As Long) As Long
Const HWND_TOPMOST = -1
Private Type POINTAPI
        X As Long
        Y As Long
End Type
Private Type RECT
        Left As Long
        Top As Long
        Right As Long
        Bottom As Long
     End Type
Private Is_Move_B As Boolean
Private Is_Movestar_B As Boolean
Private MyRect As RECT
Private MyPoint As POINTAPI
Private Movex As Long, Movey As Long
Private max As Long
Private Sub Form_Load()
        Timer1.Interval = 50: Timer2.Interval = 1000
        Form1.BackColor = vbBlue
        Get_Windows_Rect
        Picture1.Width = 10700
        Form1.Width = 10770
     End Sub
Sub Get_Windows_Rect()
        Dim dl&
        max = 2200: Form1.Height = max '窗体高度调整
        Form1.Top = 0
        dl& = GetWindowRect(Form1.hwnd, MyRect)
        End Sub
Private Sub Form_Paint()
        If PtInRect(MyRect, MyPoint.X, MyPoint.Y) = 0 Then
             SetWindowPos Me.hwnd, HWND_TOPMOST, Me.Left / Screen.TwipsPerPixelX, _
                  Me.Top \ Screen.TwipsPerPixelY, Me.Width \ Screen.TwipsPerPixelX, _
                  Form1.Height \ Screen.TwipsPerPixelY, 0
        End If
End Sub
Private Sub Timer1_Timer()
       Dim dl&
       dl& = GetCursorPos(MyPoint)
           If (PtInRect(MyRect, MyPoint.X, MyPoint.Y) And _
                     Form1.Height = max) Or MyPoint.Y <= 30 Then
                         Form1.BackColor = vbBlue
                Form1.Height = max
                         If MyPoint.X - MyRect.Left <= 10 Or Is_Movestar_B Then
                   Screen.MousePointer = 15
                   Is_Move_B = True
                Else
                   Screen.MousePointer = 0
                   Is_Move_B = False
          End If
                Else
               If Not Is_Movestar_B Then
                  Form1.Height = 30
               End If
            End If
 End Sub

九、窗体中的邮票
   历届奥运会邮票有着不同的发行年代，不同的题材和不同的风格以及不同的价值。而奥运邮集软件除了体现这些内容外，还要在邮票的观赏性方面有突出的表现。为此，本邮集除了选用了全新的邮票外，所有邮票提供放大缩小的功能以满足用户对观赏性方面的要求；
    1、邮票的放大缩小方法之一——用鼠标拖动图片边框或角来放大缩小单枚或整组邮票；要求在拖放中，邮票不变形（即高宽比例不变）代码如下：
Dim x0, y0 As Long
Sub form_initialize()
    x0 = Me.Width
    y0 = Me.Height
End Sub
Sub Form_Load()
Dim itemx As Object
    For Each itemx In Form1
        itemx.Tag = itemx.Left & "," & itemx.Top & "," & itemx.Width & "," & itemx.Height
    Next
End Sub
Sub form_resize()
Dim itemx As Object
    For Each itemx In Form1
        itemx.Move Split(itemx.Tag, ",")(0) * Me.Width / x0, Split(itemx.Tag, ",")(1) * Me.Width / x0, Split(itemx.Tag, ",")(2) * Me.Width / x0, Split(itemx.Tag, ",")(3) * Me.Width / x0
    Next
End Sub
    2、如果要求用鼠标滚轮也能操作邮票放大缩小，还需要添加一个模块，代码如下：
Option Explicit
Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal Hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal Hwnd As Long, ByVal MSG As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private Const GWL_WNDPROC = (-4)
Private Const WM_GETTEXT = &HD
Private Const WM_MOUSEWHEEL = &H20A
Dim theForm As Form
Dim PrevWndProc As Long
Public Function SubWndProc(ByVal Hwnd As Long, ByVal MSG As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
    On Error Resume Next      
    Select Case MSG   
    Case WM_MOUSEWHEEL
        With theForm
            If wParam > 0 Then
                .Height = .Height + .Height * 0.2      
                .Width = .Width + .Width * 0.2
            ElseIf wParam < 0 Then
                .Height = .Height - .Height * 0.2
                .Width = .Width - .Width * 0.2
            End If
        End With
    End Select
    SubWndProc = CallWindowProc(PrevWndProc, Hwnd, MSG, wParam, lParam)   
End Function
Public Function SetSubClass(ByVal FormObject As Form)
    Set theForm = FormObject
    PrevWndProc = SetWindowLong(theForm.Hwnd, GWL_WNDPROC, AddressOf SubWndProc)
End Function
Public Function UnSubClass()
    On Error Resume Next            
    SetWindowLong theForm.Hwnd, GWL_WNDPROC, PrevWndProc   
End Function

[[it] 本帖最后由 jrs123 于 2008-5-16 12:28 编辑 [/it]]

在窗体中有以下几种文字说明：
    1、留言式的奥运问答题——单击文字框，在弹出的文字输入框，在此框内可输入答案（见图）。该方案代码由二部分组成：
    '第一部分：
    Private Sub Form_Load()
    Text1.Text = GetSetting("MyApp101", "保存留言", "内容", "")
    Text2.Text = GetSetting("MyApp102", "保存留言", "内容", "")
    End Sub
    '第二部分：
    Private Sub Text1_Click()
    Dim message, title, defaultValue As String
    Dim myValue As String
    message = ""   '设置提示信息
    title = "请输入您的答案"                      '设置标题
    defaultValue = ""                           '设置默认值
    myValue = InputBox(message, title, defaultValue, 100, 100)
   '显示输入对话框
   If myValue = "" Then
    Else
        Text1.Text = myValue
        SaveSetting "MyApp101", "保存留言", "内容", myValue
    End If
   End Sub
提示:每个留言框有自己的代号,如MyApp101、 MyApp102等，二组代码的代号要一致。

[[it] 本帖最后由 jrs123 于 2008-5-21 07:05 编辑 [/it]]