?? basmain.bas
字號:
strPath = strAppPath & strFileName
' Check application folder
If FileExists(strPath) Then
blnFoundIt = True
End If
If Not blnFoundIt Then
' Get the path to the Windows folder
' (Winnt, Windows, etc.)
strWinPath = Space$(MAX_SIZE) ' Pad with spaces
GetWindowsDirectory strWinPath, MAX_SIZE ' Make API call
strWinPath = RemoveTrailingNulls(strWinPath) ' Save just the return data
strPath = QualifyPath(strWinPath) & strFileName ' Append filename
' Check Windows folder
If FileExists(strPath) Then
blnFoundIt = True
End If
End If
If Not blnFoundIt Then
' Get the path to the Windows System folder
strSysPath = Space$(MAX_SIZE) ' Pad with spaces
GetSystemDirectory strSysPath, MAX_SIZE ' Make API call
strSysPath = RemoveTrailingNulls(strSysPath) ' Save just the return data
strPath = QualifyPath(strSysPath) & strFileName ' Append filename
' Check Windows System folder
If FileExists(strPath) Then
blnFoundIt = True
End If
End If
FindRequiredFile_CleanUp:
If blnFoundIt Then
strFullPath = strPath ' Return full path/filename
Else
InfoMsg "A required file that supports this application cannot be found." & _
vbCrLf & vbCrLf & _
Chr$(34) & StrConv(strFileName, vbUpperCase) & Chr$(34) & _
" is not in any of these folders:" & vbCrLf & vbCrLf & _
strAppPath & vbCrLf & _
strWinPath & vbCrLf & _
strSysPath, "File not found"
End If
FindRequiredFile = blnFoundIt ' Set status flag
On Error GoTo 0 ' Nullify this error trap
Exit Function
FindRequiredFile_Error:
ErrorMsg MODULE_NAME, "FindRequiredFile", Err.Description
blnFoundIt = False
Resume FindRequiredFile_CleanUp
End Function
' ***************************************************************************
' Routine: FileExists
'
' Description: Test to see if a file exists.
'
' Syntax: FileExists("C:\Program Files\Desktop.ini")
'
' Parameters: strFilename - Path\filename to be queried.
'
' Returns: True or False
'
' ===========================================================================
' DATE NAME / eMAIL
' DESCRIPTION
' ----------- --------------------------------------------------------------
' dd-mmm-1997 Bruce McKinney "Hardcore Visual Basic"
' http://vb.mvps.org/hardweb/mckinney.htm
' ***************************************************************************
Public Function FileExists(ByVal strFileName As String) As Boolean
Dim lngAttrib As Long
On Error GoTo FileExists_Exit
lngAttrib = GetFileAttributes(strFileName)
If (lngAttrib <> INVALID_HANDLE_VALUE) Then
FileExists = CBool((lngAttrib And vbDirectory) <> vbDirectory)
End If
FileExists_Exit:
End Function
' ***************************************************************************
' Routine: PathExists
'
' Description: Does a path exists. A trailing backslash is ignored.
'
' Syntax: PathExists("C:\Program Files")
'
' Parameters: strPath - Path to be queried.
'
' Returns: True or False
'
' ===========================================================================
' DATE NAME / eMAIL
' DESCRIPTION
' ----------- --------------------------------------------------------------
' dd-mmm-1997 Bruce McKinney "Hardcore Visual Basic"
' http://vb.mvps.org/hardweb/mckinney.htm
' ***************************************************************************
Public Function PathExists(ByVal strPath As String) As Boolean
Dim lngAttrib As Long
On Error GoTo PathExists_Exit
lngAttrib = GetFileAttributes(strPath)
If (lngAttrib <> INVALID_HANDLE_VALUE) Then
PathExists = CBool((lngAttrib And vbDirectory) = vbDirectory)
End If
PathExists_Exit:
End Function
' ***************************************************************************
' Routine: AlreadyRunning
'
' Description: This routine will determine if an application is already
' active, whether it be hidden, minimized, or displayed.
'
' Parameters: strTitle - partial/full name of application
'
' Returns: TRUE - Currently active
' FALSE - Inactive
'
' ===========================================================================
' DATE NAME / DESCRIPTION
' ----------- --------------------------------------------------------------
' 19-DEC-2004 Kenneth Ives kenaso@tx.rr.com
' Wrote routine
' ***************************************************************************
Public Function AlreadyRunning(ByVal strTitle As String) As Boolean
Dim hMutex As Long
On Error GoTo AlreadyRunning_Error
AlreadyRunning = False ' preset flag to FALSE
SetDebugMode ' attempt to set the debug flag
' if in the VB IDE we do not care
' about multiple versions executing.
If mblnIDE_Environment Then
Exit Function ' allows restarting of this application
End If
' Try to create a new Mutex handle
hMutex = CreateMutex(ByVal 0&, 1, strTitle)
' Did the mutex already exist?
If (Err.LastDllError = ERROR_ALREADY_EXISTS) Then
ReleaseMutex hMutex ' Release Mutex handle from memory
CloseHandle hMutex ' Close the Mutex handle
Err.Clear ' Clear any errors
AlreadyRunning = True ' prior version already active
Else
AlreadyRunning = False ' no prior versions are active
End If
AlreadyRunning_CleanUp:
On Error GoTo 0 ' Nullify this error trap
Exit Function
AlreadyRunning_Error:
ErrorMsg MODULE_NAME, "AlreadyRunning", Err.Description
Resume AlreadyRunning_CleanUp
End Function
Private Sub SetDebugMode()
' Set the DebugMode flag. This will only
' execute while in the VB IDE environment
Debug.Assert InDebugMode
End Sub
Private Function InDebugMode() As Boolean
' Set mblnIDE_Environment to true. This happens only
' if the Debug.Assert call is successful. It will
' only happen in the IDE environment.
mblnIDE_Environment = True
InDebugMode = True
End Function
' ***************************************************************************
' Routine: QualifyPath
'
' Description: Adds a trailing backslash to the path, if missing
'
' Parameters: strPath - Current folder being processed.
'
' Returns: Fully qualified path with trailing backslash
'
' ===========================================================================
' DATE NAME / DESCRIPTION
' ----------- --------------------------------------------------------------
' Unknown Randy Birch http://vbnet.mvps.org/index.htmll
' Original routine
' 14-MAY-2002 Kenneth Ives kenaso@tx.rr.com
' Modified/documented
' ***************************************************************************
Public Function QualifyPath(ByVal strPath As String) As String
strPath = Trim$(strPath) ' remove all leading and trailing blanks
' check for a trailing backslash
If Right$(strPath, 1) <> "\" Then
QualifyPath = strPath & "\" ' add a backslash
Else
QualifyPath = strPath ' already has a backslash
End If
End Function
' ***************************************************************************
' Routine: UnQualifyPath
'
' Description: Removes a trailing backslash to the path
'
' Parameters: strPath - Current folder being processed.
'
' Returns: Fully qualified path without a trailing backslash
'
' ===========================================================================
' DATE NAME / DESCRIPTION
' ----------- --------------------------------------------------------------
' Unknown Randy Birch http://vbnet.mvps.org/index.htmll
' Original routine
' 14-MAY-2002 Kenneth Ives kenaso@tx.rr.com
' Modified/documented
' ***************************************************************************
Public Function UnQualifyPath(ByVal strPath As String) As String
'removes any trailing slash from the path
strPath = Trim$(strPath)
If Right$(strPath, 1) = "\" Then
UnQualifyPath = Left$(strPath, Len(strPath) - 1)
Else
UnQualifyPath = strPath
End If
End Function
' ***************************************************************************
' Routine: SendEmail
'
' Description: When the email hyperlink is clicked, this routine will fire.
' It will create a new email message with the author's name in
' the "To:" box and the name and version of the application
' on the "Subject:" line.
'
' ===========================================================================
' DATE NAME / eMAIL
' DESCRIPTION
' ----------- --------------------------------------------------------------
' 23-FEB-2000 Kenneth Ives kenaso@tx.rr.com
' Routine created
' ***************************************************************************
Public Sub SendEmail()
Dim strMail As String
On Error GoTo SendEmail_Error
' open the URL using the default browser
strMail = "mailto:" & AUTHOR_EMAIL & "?subject=" & PGM_NAME & gstrVersion
' Send an email to the author by calling the ShellExecute API
ShellExecute 0&, vbNullString, strMail, _
vbNullString, vbNullString, vbNormalFocus
SendEmail_CleanUp:
On Error GoTo 0
Exit Sub
SendEmail_Error:
ErrorMsg MODULE_NAME, "SendEmail", Err.Description
Resume SendEmail_CleanUp
End Sub
?? 快捷鍵說明
復制代碼
Ctrl + C
搜索代碼
Ctrl + F
全屏模式
F11
切換主題
Ctrl + Shift + D
顯示快捷鍵
?
增大字號
Ctrl + =
減小字號
Ctrl + -