frmmain.frm

vb源码大全

VERSION 5.00
Begin VB.Form frmMain 
   BorderStyle     =   1  'Fixed Single
   Caption         =   "判断文件是否存在？"
   ClientHeight    =   2460
   ClientLeft      =   1125
   ClientTop       =   1515
   ClientWidth     =   5025
   LinkTopic       =   "Form1"
   MaxButton       =   0   'False
   MinButton       =   0   'False
   ScaleHeight     =   2460
   ScaleWidth      =   5025
   StartUpPosition =   3  '窗口缺省
   Begin VB.CommandButton cmdMakeError 
      Caption         =   "模拟一个错误"
      Height          =   375
      Left            =   2760
      TabIndex        =   4
      Top             =   1920
      Width           =   2055
   End
   Begin VB.CommandButton cmdCentral 
      Caption         =   "集中化的错误处理"
      Height          =   375
      Left            =   480
      TabIndex        =   3
      Top             =   1920
      Width           =   2055
   End
   Begin VB.TextBox txtFileSpec 
      Height          =   375
      Left            =   480
      TabIndex        =   2
      Text            =   "*:\error.xyz"
      Top             =   600
      Width           =   3255
   End
   Begin VB.CommandButton cmdInline 
      Caption         =   "进行错误处理"
      Height          =   375
      Left            =   2760
      TabIndex        =   1
      Top             =   1320
      Width           =   2055
   End
   Begin VB.CommandButton cmdNone 
      Caption         =   "不进行错误处理"
      Height          =   375
      Left            =   480
      TabIndex        =   0
      Top             =   1320
      Width           =   2055
   End
   Begin VB.Label Label1 
      AutoSize        =   -1  'True
      Caption         =   "此处输入一个无效的文件名:"
      Height          =   180
      Left            =   480
      TabIndex        =   5
      Top             =   360
      Width           =   2250
   End
End
Attribute VB_Name = "frmMain"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit

'定义文件错误代码的常数
Const mnErrBadFileNameOrNumber = 52
Const mnErrBadFileMode = 54
Const mnErrFileAlreadyOpen = 55
Const mnErrDeviceIO = 57
Const mnErrDiskFull = 61
Const mnErrInputPastEndOfFile = 62
Const mnErrBadFileName = 64
Const mnErrDeviceUnavailable = 68
Const mnErrDiskNotReady = 71
Const mnErrPathDoesNotExist = 76

'集中化的错误处理
Private Sub cmdCentral_Click()
    Dim strErrnum As String
    Dim intErr As Integer
    Dim intReturn As Integer
    
    On Error GoTo errHandler
    '取得错误代码
    strErrnum = InputBox("请输入错误号", "错误", "68")
    intErr = Val(strErrnum)
    Err.Raise Number:=intErr
    Exit Sub
    
errHandler:
    '调用FileErrors函数判断错误代码
    intReturn = FileErrors()
    '根据不同的返回值，进行不同的操作
    If intReturn = 0 Then
        '若返回值为0，则重新执行出错的语句
        Resume
    ElseIf intReturn = 1 Then
        '若返回值为1，则继续执行出错语句的下一条语句
        Resume Next
    ElseIf intReturn = 2 Then
        MsgBox "无法恢复的错误"
        End
    Else
        MsgBox "未知错误"
        Resume Next
    End If
        
End Sub

Private Sub cmdInline_Click()
    Dim strFileName As String
    strFileName = txtFileSpec.Text
    
    Dim Msg As String
    '启动错误陷井，如果检测到任何错误，错误处理程序均响应
    On Error GoTo errHandler
        Open strFileName For Binary As #1
        '如果未发生错误，就退出过程，以免执行错误处理程序
        Exit Sub

errHandler:      '错误处理程序
    If (Err.Number = mnErrDiskNotReady) Then
        Msg = "在驱动器中插入一张软盘并关好驱动器。"
        '显示有惊叹号图标以及【确定】和【取消】按钮的消息框
        If MsgBox(Msg, vbExclamation & vbOKCancel) = vbOK Then
            Resume
        Else
            Resume Next
        End If
    ElseIf Err.Number = mnErrDeviceUnavailable Then
        Msg = "驱动器或路径不存在： " & strFileName
        MsgBox Msg, vbExclamation
        Resume Next
    Else
        Msg = "未知的错误 #" & Str(Err.Number) & " 发生: " & Err.Description
        '显示有停止符号图标以及【确定】按钮的消息框
        MsgBox Msg, vbCritical
        
        Resume Next
    End If

    Resume
End Sub

Private Sub cmdMakeError_Click()
   '模拟“磁盘未准备好”错误
    Err.Raise Number:=71
End Sub

'不进行错误处理
Private Sub cmdNone_Click()
    '若txtFileSpec.Text所指定的文件路径不存在，则VB会中断程序的运行
    Open txtFileSpec.Text For Binary As #1
End Sub

Function FileErrors() As Integer
    Dim intMsgType As Integer
    Dim strMsg As String
    Dim intResponse As Integer
    ''intResponse定义了返回值
    ''若返回值为0，表示继续当前的操作
    ''若返回值为1，表示继续下一个操作
    ''若返回值为2，表示当前错误不可恢复
    ''若返回值为3，表示当前错误无法辨认

    intMsgType = vbExclamation
    Select Case Err.Number
        Case mnErrDeviceUnavailable             '错误 68
            strMsg = "设备不可用。"
            intMsgType = vbExclamation + vbOKCancel
        Case mnErrDiskNotReady                  '错误 71
            strMsg = "在驱动器中插入一张软盘并关好驱动器。"
            intMsgType = vbExclamation + vbOKCancel
        Case mnErrDeviceIO                      '错误 57
            strMsg = "内部磁盘错误。"
            intMsgType = vbExclamation + vbOKOnly
        Case mnErrDiskFull                      '错误 61
            strMsg = "磁盘已满。继续吗？"
            intMsgType = vbExclamation + vbAbortRetryIgnore
        Case mnErrBadFileName, mnErrBadFileNameOrNumber ' 错误 64 & 52
            strMsg = "文件名非法。"
            intMsgType = vbExclamation + vbOKCancel
        Case mnErrPathDoesNotExist                '错误 76
            strMsg = "路径不存在。"
            intMsgType = vbExclamation + vbOKCancel
        Case mnErrBadFileMode                     '错误 54
            strMsg = "不能以此访问类型打开文件。"
        Case mnErrFileAlreadyOpen                 '错误 55
            strMsg = "文件已被打开。"
            intMsgType = vbExclamation + vbOKOnly
        Case mnErrInputPastEndOfFile              '错误 62
            strMsg = "文件有一个不标准的文件结束标志，"
            strMsg = strMsg & "或企图读文件结束标志之后 "
            strMsg = strMsg & "的内容。"
            intMsgType = vbExclamation + vbAbortRetryIgnore
        Case Else
            FileErrors = 3
            Exit Function
    End Select
    
    intResponse = MsgBox(strMsg, intMsgType, "磁盘错误")
    Select Case intResponse
        Case 1, 4       '【确定】，【重试】按钮
            FileErrors = 0
        Case 2, 5       '【取消】，【忽略】按钮
            FileErrors = 1
        Case 3          '【中止】按钮
            FileErrors = 2
        Case Else
            FileErrors = 3
    End Select
End Function