'=========================================================
'==            Visual Basic Sample Code From            ==
'==     Microsoft Excel/Visual Basic for Windows 95     ==
'==                  Programmer's Guide                 ==
'==                      Chapter 7                      ==
'=========================================================

' DISCLAIMER OF WARRANTY

' THIS FILE CONTAINS UNDOCUMENTED SAMPLE CODE. THIS SAMPLE CODE IS 
' PROVIDED "AS IS" WITHOUT WARRANTY OF ANY KIND. MICROSOFT FURTHER
' DISCLAIMS ALL IMPLIED WARRANTIES INCLUDING WITHOUT LIMITATION ANY
' IMPLIED WARRANTIES OF MERCHANTABILITY OR OF FITNESS FOR A PARTICULAR
' PURPOSE. THE ENTIRE RISK ARISING OUT OF THE USE OR PERFORMANCE OF THE
' SAMPLE CODE REMAINS WITH YOU.

' IN NO EVENT SHALL MICROSOFT OR ITS SUPPLIERS BE LIABLE FOR ANY DAMAGES
' WHATSOEVER (INCLUDING, WITHOUT LIMITATION, DAMAGES FOR LOSS OF
' BUSINESS PROFITS, BUSINESS INTERRUPTION, LOSS OF BUSINESS INFORMATION,
' OR OTHER PECUNIARY LOSS) ARISING OUT OF THE USE OF OR INABILITY TO USE
' THIS SAMPLE CODE, EVEN IF MICROSOFT HAS BEEN ADVISED OF THE POSSIBILITY
' OF SUCH DAMAGES. BECAUSE SOME STATES DO NOT ALLOW THE EXCLUSION OR
' LIMITATION OF LIABILITY FOR CONSEQUENTIAL OR INCIDENTAL DAMAGES, THE
' ABOVE LIMITATION MAY NOT APPLY TO YOU.






'=========================================================
'==                    From Page 123                    ==
'=========================================================

Function FileExists(filename)
	FileExists = (Dir(filename) <> "")
End Function





'=========================================================
'==                    From Page 124                    ==
'=========================================================

Function FileExists (filename)
On Error GoTo CheckError		' Turn on error trapping so error handler
					' responds if any error is detected.
	FileExists = (Dir(filename) <> "")
	Exit Function			' Avoid executing error handler 
					' if no error occurs.

CheckError:				' Branch here if error occurs.
	' Define constants to represent Visual Basic error code.
	Const ERR_DISKNOTREADY = 71, ERR_DEVICEUNAVAILABLE = 68
	FileExists = False
	If Err = ERR_DISKNOTREADY Then
		Msg = "Put a floppy disk in the drive and close the drive door."
		' Display message box with an exclamation mark icon and with OK
		' and Cancel buttons.
		If MsgBox(Msg, vbExclamation + vbOKCancel) = vbOK Then
			Resume
		Else
			Resume Next
		End If
	ElseIf Err = ERR_DEVICEUNAVAILABLE Then
		Msg = "This drive or path doesn't exist: " & filename
		MsgBox Msg, vbExclamation
		Resume Next
	Else
		Msg = "Unexpected error #" & Str(Err) & ": " & Error(Err)
		' Display message box with Stop sign icon and OK button.
		MsgBox Msg, vbCritical
		End
	End If
End Function





'=========================================================
'==                    From Page 128                    ==
'=========================================================

Function Divide(numer, denom)
Const ERR_DIV0 = 11, ERR_OVERFLOW = 6, ERR_ILLFUNC = 5	
On Error GoTo MathHandler
	Divide	= numer / denom
	Exit Function
MathHandler:
	If Err = ERR_DIV0 Or Err = ERR_OVERFLOW Or Err = ERR_ILLFUNC Then
		Divide = Null		' If error was Division by zero, Overflow,
					' or Illegal function call, return Null.
	Else
		MsgBox "Unanticipated error " & Err & ": " & Error, _ 
		  vbExclamation
		Divide = Null
	End If				' In all cases, Resume Next continues
	Resume Next				' execution at the Exit Function statement.

End Function





'=========================================================
'==                    From Page 129                    ==
'=========================================================

Sub ErrDemoSub()
On Error GoTo SubHandler
' Error trapping is enabled.
' Errors need to be caught and corrected here.
	Kill "OLDFILE.XYZ"
On Error GoTo 0				' Error trapping is turned off here.
	Kill "OLDFILE.XYZ"
On Error GoTo SubHandler		' Error trapping is enabled again.
	Kill "OLDFILE.XYZ"
Exit Sub
SubHandler:				' Error handler goes here.
	MsgBox "Caught error."
	Resume Next
End Sub





'=========================================================
'==                    From Page 130                    ==
'=========================================================

NoRadius = CVErr(50000)

NotANumber = 50001
InvalidArgument = CVErr(NotANumber)





'=========================================================
'==                 From Pages 130-131                  ==
'=========================================================

Public NoRadius, NotANumber

Sub AreaOfCircle()
	Const PI = 3.14
	NoRadius = CVErr(50000)
	NotANumber = CVErr(50001)
	Radius = CheckData(InputBox("Enter the radius"))
	If IsError(Radius) Then
		Select Case Radius
			Case NoRadius
				MsgBox "Error: No radius given."
			Case NotANumber
				MsgBox "Error: Radius isn't a number."
			Case Else
				MsgBox "Unknown error."
		End Select
	Else		' there's no error
		MsgBox "The area of the circle is " & (PI * Radius ^ 2)
	End If
End Sub

Function CheckData(TheRadius)
	If Not IsNumeric(TheRadius) Then
		CheckData = NotANumber
	ElseIf TheRadius = 0 Then
		CheckData = NoRadius
	Else
		CheckData = TheRadius
	End If
End Function

'-------------------------------------------------

Function Commission(SharesSold, PricePerShare)
	If Not (IsNumeric(SharesSold) And IsNumeric(PricePerShare)) Then
		Commission = CVErr(xlErrNum)		' xlErrNum corresponds to the 											' #NUM! error value.
		Exit Function
	Else
		TotalSalePrice = SharesSold * PricePerShare
		If TotalSalePrice <= 15000 Then
			Commission = 25 + 0.03 * SharesSold
		Else
			Commission = 25 + 0.03 * (0.9 * SharesSold)
		End If
	End If
End Function




'=========================================================
'==                    From Page 132                    ==
'=========================================================

If Not (IsNumeric(SharesSold) And IsNumeric(PricePerShare)) Then
	Commission = [#NUM!]
	Exit Function

'-------------------------------------------------

Error 71		' Simulate "Disk Not Ready" error.





'=========================================================
'==                    From Page 133                    ==
'=========================================================

Public Const RESUME_STATEMENT = 0		'Resume
Public Const RESUME_NEXT = 1			'Resume Next
Public Const UNRECOVERABLE = 2			'Unrecoverable error
Public Const UNRECOGNIZED = 3			'Unrecognized error
Public Const ERR_DEVICEUNAVAILABLE = 68
Public Const ERR_BADFILENAMEORNUMBER = 52, ERR_PATHDOESNOTEXIST = 76
Public Const ERR_BADFILEMODE = 54





'=========================================================
'==                    From Page 134                    ==
'=========================================================

Function FileErrors (errVal As Integer) As Integer
Dim MsgType As Integer, Msg As String, Response As Integer
	MsgType = vbExclamation
	Select Case errVal
		Case ERR_DEVICEUNAVAILABLE	' Error #68
			Msg = "That device appears unavailable."
			MsgType = MsgType + vbAbortRetryIgnore
		Case ERR_BADFILENAMEORNUMBER	' Errors #52
			Msg = "That filename is not valid."
			MsgType = MsgType + vbOKCancel
		Case ERR_PATHDOESNOTEXIST	' Error #76
			Msg = "That path doesn't exist."
			MsgType = MsgType + vbOKCancel
		Case ERR_BADFILEMODE		' Error #54
			Msg = "Can't open your file for that type of access."
			MsgType = MsgType + vbOKCancel
		Case Else
			FileErrors = UNRECOGNIZED
			Exit Function
	End Select
	Response = MsgBox(Msg, MsgType, "Disk Error")
	Select Case response
		Case vbOK, vbRetry
			FileErrors = RESUME_STATEMENT
		Case vbIgnore
			FileErrors = RESUME_NEXT
		Case vbCancel, vbAbort
			FileErrors = UNRECOVERABLE
		Case Else
			FileErrors = UNRECOGNIZED
	End Select

End Function





'=========================================================
'==                 From Pages 134-135                  ==
'=========================================================

Function FileOperationsDemo(FileName As String)
'Demo of how you would call the FileErrors Function
On Error GoTo ConfirmFileError

'Code that attempts some file operation

ConfirmFileError:
Action = FileErrors(Err)		'Call the FileErrors function
	Select Case Action
		Case RESUME_STATEMENT	'User chose OK or Retry when FileErrors 
					'displayed its message, so try again.
			Resume
		Case RESUME_NEXT	'User chose Ignore when FileErrors
					'displayed its message, so ignore error
					'and continue.
			Resume Next
		Case UNRECOVERABLE 	'User chose Cancel or Abort when
					'FileErrors displayed its message,
					'so abort procedure.
			Exit Function
		Case Else		'Cannot handle original run-time
					'error, so repeat it and display
					'the normal System error.
			Error Err
	End Select
End Function





'=========================================================
'==                    From Page 136                    ==
'=========================================================

Function FileExists(filename)
Dim Msg

Const ERR_DISKNOTREADY = 71, ERR_DEVICEUNAVAILABLE = 68

' Resets the Err code to zero; handles errors inline
On Error Resume Next

CheckOnFile:
	FileExists = (Dir(filename) <> "")
	If Err = ERR_DISKNOTREADY Then
		Msg = "Put a floppy disk in the drive and close the drive door."
		If MsgBox (Msg, vbExclamation + vbOKCancel) = vbOK Then
			GoTo CheckOnFile
		End If
		FileExists = False
	ElseIf Err = ERR_DEVICEUNAVAILABLE Then
		Msg = "This drive or path doesn't exist: " & filename
		MsgBox Msg, vbExclamation
		FileExists = False
	' If not successful, and if not one of the above errors, handle
	ElseIf Err <> 0 Then
		Msg = "Unexpected error #" & Str(Err) & ": " & Error(Err)
		MsgBox Msg, vbCritical
		FileExists = False
	End If

End Function





'=========================================================
'==                    From Page 137                    ==
'=========================================================

Sub ProcessData
	' Set up user interrupt trapping as a run-time error
	On Error GoTo UserInterrupt
	Application.EnableCancelKey = xlErrorHandler
	'Start a long duration task
	OpenDataFile
	For x = 1 To 1000000
		ProcessRecord x
		WriteOutRecord x
	Next x
	CloseDataFile
	Exit Sub

UserInterrupt:
	If Err = 18 Then
		If MsgBox ("Stop processing records?" , vbYesNo) = vbNo Then
			' Continue running at the point we were interrupted
			Resume
		Else
			' Close open files before returning
			CloseDataFile
			Exit Sub
		End If
	Else
		' Handle other errors that occur
		MsgBox Error(Err)
		Resume Next
	End If
End Sub


