Strings, Files and Directories
Recursively search all files in directory structure.
Retrieve the old dos filenames from the Win95 or Win98 Long filenames
Automatically capitalise the first letter of each word in a text box as you type
Get strings on either side of special character.
Returns a specific "token" from a delimited string list.
Select text in a text box.
Read and write to an INI file.
How to create a file directory and subdirectories at runtime.
How to fill a listbox with files, directories and drives.
How to detect if a file already exists.
How to determine the size of a file.
How to parse the path, file name and extension from a string.
How to read a text file into a text box.
How to shorten a long directory name.
A collection of useful string rountines (soon to be sorted).
ReDim sArray(0) As String
Call DirWalk("OLE*.DLL", "C:\", sArray)
The procedure would accept the wild card in the first argument which is
search pattern for the file name. The second argument is the location
where to start. Third argument is an array of strings.
The procedure will recursively go to the deepest level in the directory
structure and get all the matching file names with full path in the array
sArray. This array is ReDimed from the function and will have as many
members as matches found.
To use DirWalk you will have to put two extra controls, FileListBox and
DirListBox, on the form. Following procedure is assumed to be on a form
on which there are two controls, FileListBox with name File1 and
DirListBox with name Dir1. Keep them invisible to improve the speed of
search. Putting these additional controls on a form does not cause any
overhead as they are part of basic libray of controls for VB.
Code
====
Sub DirWalk(ByVal sPattern As String, ByVal CurrDir As String, sFound()
As String)
Dim i As Integer
Dim sCurrPath As String
Dim sFile As String
Dim ii As Integer
Dim iFiles As Integer
Dim iLen As Integer
If Right$(CurrDir, 1) <> "\" Then
Dir1.Path = CurrDir & "\"
Else
Dir1.Path = CurrDir
End If
For i = 0 To Dir1.ListCount
If Dir1.List(i) <> "" Then
DoEvents
Call DirWalk(sPattern, Dir1.List(i), sFound)
Else
If Right$(Dir1.Path, 1) = "\" Then
sCurrPath = Left(Dir1.Path, Len(Dir1.Path) - 1)
Else
sCurrPath = Dir1.Path
End If
File1.Path = sCurrPath
File1.Pattern = sPattern
If File1.ListCount > 0 Then 'matching files found in the
directory
For ii = 0 To File1.ListCount - 1
ReDim Preserve sFound(UBound(sFound) + 1)
sFound(UBound(sFound) - 1) = sCurrPath & "\" &
File1.List(ii)
Next ii
End If
iLen = Len(Dir1.Path)
Do While Mid(Dir1.Path, iLen, 1) <> "\"
iLen = iLen - 1
Loop
Dir1.Path = Mid(Dir1.Path, 1, iLen)
End If
Next i
End Sub
'------------------------------------------------------
'Author:Atul Ganatra
'Posted:7/19/97
'
'Get all the matching files in the directory structure.
'------------------------------------------------------
This tip is useful for VB 3.0, 4.0 and 5.0 - 16 bit and 32 bit
There were some tips published for similar type of function before but
this one does better job, as it does not have any limitation. Moreover,
since this code does not use any API it could be easily ported between
16 - 32 bit applications.
Following procedure DirWalk will let you search the entire directory
structure starting at wherever you specify in the argument.
How to use
============
The procedure should be called as follows
'*******************************************************
'Joe Markowski
'jsmarko@eclipse.net
'
'Here's a code snippet to retrieve the old dos filenames
'from the Win95 or Win98 Long filenames. Occasionally,
'you may need this function.
'For example:
' C:\MyLongestPath\MyLongerPath\MyFilename.txt
'would return as
' C:\Mylong~1\MyLong~2\Myfile~1.txt
'*******************************************************
'Put the declaration in a .bas module
Declare Function GetShortPathName Lib "kernel32" Alias _
"GetShortPathNameA" (ByVal lpszLongPath As String, _
ByVal lpszShortPath As String, ByVal cchBuffer As Long) As Long
'Next comes the function (Place in a module):
Public Function GetDosPath(LongPath As String) As String
Dim s As String
Dim i As Long
Dim PathLength As Long
i = Len(LongPath) + 1
s = String(i, 0)
PathLength = GetShortPathName(LongPath, s, i)
GetDosPath = Left$(s, PathLength)
End Function
'Lastly call it like this:
DosPathName = GetDosPath(Long Path Goes in here)
'****************
'Tony Southwood
'Seagoing Software
'tony@seagoing.freeserve.co.uk
'Date 9 Jan 99
'
'Purpose:
'Automatically capitalise the first letter of each word
'in a text box as you type. Being inherently lazy, I have
'found this particularly useful entering address info...
'****************
'****************
'In the keypress event of the textbox
'control that autotype is to apply to
'enter the following line of code....
'****************
Private Sub YourTextBoxControl_KeyPress(KeyAscii As Integer)
KeyAscii = AutoType(Screen.ActiveControl, KeyAscii)
End Sub
'****************
'In a suitable module create the Public Funtion as listed below
'****************
Public Function AutoType(c As Control, KeyAscii As Integer) As Integer
AutoType = KeyAscii
If KeyAscii > 95 And KeyAscii <123 Then If c.SelStart="0" Then AutoType="AutoType" 32 ElseIf Mid$(c.Text, c.SelStart, 1) < "!" Then AutoType="AutoType" 32 End If End If End Function
'-----------------------------------------------------
'Author: Dr. John A. Nyhart
'work : john_nyhart@medicalogic.com
'home : jnyhart@spessart.com
'web : www.spessart.com/users/jnyhart/john1.htm
'Posted:7/22/97
'
'Here is a function that will get the string on each side of
'a string that is really two strings, with a special char in
'the center.
'-----------------------------------------------------
'********************************************************
Function GetString(tmpStr As String, tmpDiv As String, Mode As String) As
String
Dim tmpRetStr As String
Dim tmpLen As Integer
Dim tmpErr As Integer
' *****************************************************
' tmpString = The whole string
' tmpDiv = The Divider chr
' if mode = "F" then get the string in front of the div
' if mode = "B" then get the string in back of the div
'
' Return values:
' Errors
' Err1 = wrong mode ("F" & "B" ok)
' Err2 = No Div, did not found a divider
' Err3 = No F, did not find any string in front of the div
' Err4 = No B, did not find any string in back of the div
' Err5 = No String
' Normal
' String
' ******************************************************
' Example: GetString("Red=Green","=","F") will retrun "Red"
' *** for string
tmpErr = 0
If Len(tmpStr) = 0 Then
tmpErr = 5
GoTo GetStringErr
End If
' *** test for chr in tmpDiv
If Len(tmpDiv) = 0 Then
tmpErr = 2
GoTo GetStringErr
End If
' *** test for div in string
If InStr(1, tmpStr, tmpDiv) = 0 Then
tmpErr = 2
GoTo GetStringErr
End If
' *** process "F"
If Mode = "F" Then
tmpRetStr = Left(tmpStr, (InStr(1, tmpStr, tmpDiv) - 1))
If Len(tmpRetStr) > 0 Then
GetString = tmpRetStr
Exit Function
Else
tmpErr = 3
GoTo GetStringErr
End If
End If
If Mode = "B" Then
tmpRetStr = Right(tmpStr, Len(tmpStr) - (InStr(1, tmpStr, tmpDiv)))
If Len(tmpRetStr) > 0 Then
GetString = tmpRetStr
Exit Function
Else
tmpErr = 4
GoTo GetStringErr
End If
End If
tmpErr = 1
GoTo GetStringErr
Exit Function
GetStringErr:
GetString = "Err" & tmpErr
End Function
'------------------------------------------------------------------------
' Author : Troy DeMonbreun (vb@8x.com)
'
' Returns : [string] "Token" (section of data) from a list of
' delimited string data
'
' Requires : [string] delimited data,
' [integer] index of desired section,
' [string] delimiter (1 or more chars)
'
' Examples : GetToken("steve@hotmail.com", 2, "@") returns "hotmail.com"
' GetToken("123-45-6789", 2, "-") returns "45"
' GetToken("first,middle,last", 3, ",") returns "last"
'
' Revised : 12/22/1998
'
' Declare :Function GetToken(ByVal strVal As String, intIndex As Integer, _
' strDelimiter As String) As String
'------------------------------------------------------------------------
Dim strSubString() As String
Dim intIndex2 As Integer
Dim i As Integer
Dim intDelimitLen As Integer
intIndex2 = 1
i = 0
intDelimitLen = Len(strDelimiter)
Do While intIndex2 > 0
ReDim Preserve strSubString(i + 1)
intIndex2 = InStr(1, strVal, strDelimiter)
If intIndex2 > 0 Then
strSubString(i) = Mid(strVal, 1, (intIndex2 - 1))
strVal = Mid(strVal, (intIndex2 + intDelimitLen),
Len(strVal))
Else
strSubString(i) = strVal
End If
i = i + 1
Loop
If intIndex > (i + 1) Or intIndex <1 Then GetToken Else GetToken="strSubString(intIndex" 1) End If End Function
'-----------------------------------------------------
'Author: Dr. John A. Nyhart
'work : john_nyhart@medicalogic.com
'home : jnyhart@spessart.com
'web : www.spessart.com/users/jnyhart/john1.htm
'Posted:7/22/97
'
'Select text in a text box.
'-----------------------------------------------------
1. Put this code in a .bas file.
Sub SelectText()
Dim txtBox As Control
Set txtBox = Screen.ActiveForm.ActiveControl
End Sub
2. In the getfocus event of the text box call the sub.
'------------------------------------------------------------------
'Author: Dr. John A. Nyhart
'work : john_nyhart@medicalogic.com
'home : jnyhart@spessart.com
'web : www.spessart.com/users/jnyhart/john1.htm
'Posted:7/18/97
'
'How do I write and read to an INI file?
'------------------------------------------------------------------
'******************************************************************
Function ReadWriteINI(Mode As String, tmpSecname As String, tmpKeyname As
String, Optional tmpKeyValue) As String
Dim tmpString As String
On Error GoTo ReadWriteINIError
'
'******************************************************************
' Mode = "WRITE" or "GET"
'
'******************************************************************
'Here are the declare functions
'Declare Function GetPrivateProfileString Lib "kernel32" Alias
"GetPrivateProfileStringA" (ByVal lpApplicationName As String, ByVal
lpKeyName As Any, ByVal lpDefault As String, ByVal lpReturnedString As
String, ByVal nSize As Long, ByVal lpFileName As String) As Long
'Declare Function WritePrivateProfileString Lib "kernel32" Alias
"WritePrivateProfileStringA" (ByVal lpApplicationName As String, ByVal
lpKeyName As Any, ByVal lpString As Any, ByVal lpFileName As String) As
Long
' *** set the return value to OK
ReadWriteINI = "OK"
' *** test for good data to work with
If IsNull(Mode) Or Len(Mode) = 0 Then
ReadWriteINI = "ERROR MODE" ' Set the return value
Exit Function
End If
If IsNull(tmpSecname) Or Len(tmpSecname) = 0 Then
ReadWriteINI = "ERROR Secname" ' Set the return value
Exit Function
End If
If IsNull(tmpKeyname) Or Len(tmpKeyname) = 0 Then
ReadWriteINI = "ERROR Keyname" ' Set the return value
Exit Function
End If
' *** set the ini file name
filename = "C:\Vbasic\Test\WinPlace.ini" ' <<<<< put your file name here ' ' ' ******* WRITE MODE ************************************* If UCase(Mode)="WRITE" Then If IsNull(tmpKeyValue) Or Len(tmpKeyValue)="0" Then ReadWriteINI="ERROR KeyValue" Exit Function Else secname="tmpSecname" keyname="tmpKeyname" keyvalue="tmpKeyValue" anInt="WritePrivateProfileString(secname," keyname, keyvalue, filename) End If End If ' ******************************************************* ' ' ******* GET MODE ************************************* If UCase(Mode)="GET" Then secname="tmpSecname" keyname="tmpKeyname" defaultkey="Failed" keyvalue="String$(50," 32) anInt="GetPrivateProfileString(secname," keyname, defaultkey, keyvalue, Len(keyvalue), filename) If Left(keyvalue, 6) <> "Failed" Then ' *** got it
tmpString = keyvalue
tmpString = RTrim(tmpString)
tmpString = Left(tmpString, Len(tmpString) - 1)
End If
ReadWriteINI = tmpString
End If
Exit Function
' *******
ReadWriteINIError:
MsgBox Error
Stop
End Function
'-------------------------------------------------------------------
'Author: Gordon F. MacLeod
'web : www.cadvision.com
'Posted:11/01/97
'
'How to create a file directory and subdirectories at runtime.
'-------------------------------------------------------------------
' Here's how to create a file directory and subdirectories
' Add these 3 functions and the MakeDir subroutine:
' This function is used by MakeDir to validate if a
' directory already exists.
Function bValDir (ByVal sDirIn As String) As Integer
Dim iCheck As String, iErrResult As Integer
On Local Error GoTo ValDirError
sDirIn = sParsePath(sDirIn)
sDirIn = sFixDirString(sDirIn)
iCheck = Dir$(sDirIn)
If iErrResult <> 0 Then
bValDir = False
Else
bValDir = True
End If
Exit Function
ValDirError:
iErrResult = Err
Resume Next
End Function
' This procedure will add a \ to the end of the directory
' name if needed.
Function sFixDirString (sInComming As String) As String
Dim sTemp As String
sTemp = sInComming
If Right$(sTemp, 1) <> "\" Then
sFixDirString = sTemp & "\"
Else
sFixDirString = sTemp
End If
End Function
' This procedure will return just the path name from the
' string containing the path.
Function sParsePath (sPathIn As String) As String
Dim I As Integer
For I = Len(sPathIn) To 1 Step -1
If InStr(":\", Mid$(sPathIn, I, 1)) Then Exit For
Next
sParsePath = Left$(sPathIn, I)
End Function
' The MakeDir routine will create a directory even if the
' underlying directories do not exist.
Sub MakeDir (sDirName As String)
Dim iMouseState As Integer
Dim iNewLen As Integer
Dim iDirLen As Integer
'Get Mouse State
iMouseState = Screen.MousePointer
'Change Mouse To Hour Glass
Screen.MousePointer = 11
'Set Start Length To Search For [\]
iNewLen = 4
'Add [\] To Directory Name If Not There
sDirName = sFixDirString(sDirName)
'Create Nested Directory
While Not bValDir(sDirName)
iDirLen = InStr(iNewLen, sDirName, "\")
If Not bValDir(Left$(sDirName, iDirLen)) Then
MkDir Left$(sDirName, iDirLen - 1)
End If
iNewLen = iDirLen + 1
Wend
'Leave The Mouse The Way You Found It
Screen.MousePointer = iMouseState
End Sub
'Example:
' For instance, typing "C:\aaa\biggins" in Text1 will create
' the directory named "C:\aaa" and also create a subdirectory
' under "C:\aaa" called "biggins" (C:\aaa\biggins)
' Typing "\aaa" will create the directory on the current drive
Sub Command1_Click ()
Dim sDirString As String
'Use the string in Text1
sDirString = Text1.Text
'Trap for errors
On Error GoTo ErrHandle
'Call the MakeDir routine
MakeDir sDirString
ErrHandle:
MsgBox Error$
Exit Sub
End Sub
'-------------------------------------------------------------------
'Author: Gordon F. MacLeod
'web : www.cadvision.com
'Posted:11/01/97
'
'How to fill a listbox with files, directories and drives.
'Note: This has only been tested with VB 3 & VB 4-16, if you convert
'this for use with other versions please let me know.-Burt Abreu
'-------------------------------------------------------------------
' The SendMessage API provides a simple way to use a
' standard List Box to list files. By sending the LB_DIR
' message to the List Box, the list box automatically
' fills itself with a list of files, directories and drives.
' Create a new project. Add a List box (List1) and a
' Command button (Command1) to the form.
' In a .BAS module add the following declarations:
' Declare API
Declare Function SendMessage& Lib "User" (ByVal hWnd%, ByVal
wMsg%, ByVal wParam%, lParam As Any)
' Note**, The author defined these constants, so you
' won't find them in API documentation, although they
' are based on values used with LB_DIR.
Global Const WM_USER = &H400
Global Const LB_DIR = (WM_USER + 14)
Global Const DIR_NORMALFILES = &H0
Global Const DIR_READONLY = &H8001
Global Const DIR_HIDDEN = &H8002
Global Const DIR_SYSTEM = &H8004
Global Const DIR_DIRECTORIES = &H8010
Global Const DIR_ARCHIVED = &H8020
Global Const DIR_DRIVES = &HC000
' Add this routine to your Form's declaration section:
Sub ListFiles (sFileSpec As String)
Dim i As Long
' Clear existing data
List1.Clear
' Add files / directories of specified types
i = SendMessage(List1.hWnd, LB_DIR, DIR_DRIVES, ByVal sFileSpec)
i = SendMessage(List1.hWnd, LB_DIR, DIR_DIRECTORIES, ByVal sFileSpec)
i = SendMessage(List1.hWnd, LB_DIR, DIR_NORMALFILES, ByVal sFileSpec)
End Sub
' In Command1_Click call the ListFiles routine:
Sub Command1_Click ()
' List all files from C:\Windows directory
Call ListFiles("C:\WINDOWS\*.*")
' Or to list the whole tree for the current drive:
' Call ListFiles("*.*")
End Sub
'-------------------------------------------------------------------
'Author: Gordon F. MacLeod
'web : www.cadvision.com
'Posted:11/01/97
'
'How to detect if a file already exists.
'-------------------------------------------------------------------
' To detect an existing file, use the function below:
Function FileExists% (fname$)
On Local Error Resume Next
Dim ff%
ff% = FreeFile
Open fname$ For Input As ff%
If Err Then
FileExists% = False
Else
FileExists% = True
End If
Close ff%
End Function
' Add this code to the appropriate event:
success% = FileExists%("C:\vb\vb.exe") 'A full path and filename
' FileExists% returns True if file exists
If success% = True Then
MsgBox "This file already exists.", 48, File Error
End If
'-------------------------------------------------------------------
'Author: Gordon F. MacLeod
'web : www.cadvision.com
'Posted:11/01/97
'
'How to determine the size of a file.
'-------------------------------------------------------------------
' You can get the size of a file two ways.
' If you have the file open you can use the LOF function.
Dim nFileNum As Integer
Dim lFileSize As Long
'Get a new file number
nFileNum = FreeFile
'Open the file
Open "C:\SOMEFILE.TXT" For Input As nFileNum
'Get the Length
lFileSize = LOF(nFileNum)
'Close the file
Close nFileNum
' If you don't have the file open you can use the FileLen function.
Dim lFileSize As Long
lFileSize = FileLen("C:\SOMEFILE.TXT")
'-------------------------------------------------------------------
'Author: Gordon F. MacLeod
'web : www.cadvision.com
'Posted:11/01/97
'
'How to parse the path, file name and extension from a string.
'-------------------------------------------------------------------
' This function will return just the path name from a
' string containing a path and file name.
Function ParsePath (sPathIn As String) As String
Dim I As Integer
For I = Len(sPathIn) To 1 Step -1
If InStr(":\", Mid$(sPathIn, I, 1)) Then Exit For
Next
ParsePath = Left$(sPathIn, I)
End Function
' This function will return just the file name from a
' string containing a path and file name.
Function ParseFileName (sFileIn As String) As String
Dim I As Integer
For I = Len(sFileIn) To 1 Step -1
If InStr("\", Mid$(sFileIn, I, 1)) Then Exit For
Next
ParseFileName = Mid$(sFileIn, I + 1, Len(sFileIn) - I)
End Function
' This function will return the file extension from a
' string containing a path and file name.
Function GetFileExt (sFileName As String) As String
Dim P As Integer
For P = Len(sFileName) To 1 Step -1
'Find the last ocurrence of "." in the string
If InStr(".", Mid$(sFileName, P, 1)) Then Exit For
Next
GetFileExt = Right$(sFileName, Len(sFileName) - P)
End Function
' Example:
' Add a Textbox (Text1), add command button (Command1) and
' add 3 labels (Label1, 2, 3)
' Add this code to the Command1 click event:
Sub Command1_Click ()
Dim sTargetString As String
' Store the string
sTargetString = Text1.Text
'Display the path
Label1 = ParsePath(sTargetString)
'Display the filename
Label2 = ParseFileName(sTargetString)
'Display the file's extension
Label3 = GetFileExt(sTargetString)
End Sub
' Run the program and type a valid path and file name in the Text1
' textbox and click the Command1 button.
'-------------------------------------------------------------------
'Author: Gordon F. MacLeod
'web : www.cadvision.com
'Posted:11/01/97
'
'How to read a text file into a text box.
'-------------------------------------------------------------------
' Here's how to read a text file into a text box control in one gulp.
' Be aware however that for VB 3, that if the file exceeds 32K in size,
' you'll encounter an Out Of Memory error ( 7 ).
Dim FileName As String
Dim f As Integer
FileName = "C:\VB\README.TXT"
F = FreeFile 'Get a file handle
Open FileName For Input As F 'Open the file
Text1.Text = Input$(LOF(F), F) 'Read entire file into text box
Close F 'Close the file.
'-------------------------------------------------------------------
'Author: Gordon F. MacLeod
'web : www.cadvision.com
'Posted:11/01/97
'
'How to shorten a long directory name.
'-------------------------------------------------------------------
' This function will shorten a directory name to the
' length passed to the Max parameter.
' Add the function:
Function LongDirFix (TargetString As String, Max As Integer) As String
Dim i, LblLen, StringLen As Integer
Dim TempString As String
TempString = TargetString
LblLen = Max
If Len(TempString) <= LblLen Then
LongDirFix = TempString
Exit Function
End If
LblLen = LblLen - 6
For i = Len(TempString) - LblLen To Len(TempString)
If Mid$(TempString, i, 1) = "\" Then Exit For
Next
'On one line:
LongDirFix = Left$(TempString, 3) & "..." & Right$(TempString,
Len(TempString) - (i - 1))
End Function
' Example:
Dim DirName As String
DirName = "C:\DICKENS\DIVISION\RESTRNT\PAYROLL\JONES_D"
Label1.Caption = LongDirFix(DirName, 32)
' The second paramater is the max length of the returned string.
'-------------------------------------------------------------------
'Author: John Stendor
'E-mail: john.stendor@citicorp.com
'Posted: 12/20/98
'
' A variety of useful string routines from my library.
'-------------------------------------------------------------------
Attribute VB_Name = "modFORMAT_STRING"
Option Explicit
Enum ALIGN
iLEFT = 0
iCENTER = 1
iRIGHT = 2
End Enum
'==========================================
' Name...: sCleanUp
' Type...: Function
' Date...: 07/17/1998
' Author.: John Stendor
' Purpose: Clean a data field returned ...
' (This prevents a null field in a recordset
' from causing an error)
'
'==========================================
'
Public Function sCleanUp(sField As String) As String
sCleanUp = Trim$(sField & "")
End Function
'
'==========================================
'
' Name...: sCleanUpNumber()
' Type...: Function
' Date...: 03/20/1998
' Author.: John Stendor
' Purpose: Clean Up Amount using special formats ...
'
' Samples 10K = 10000
' Samples 55M360 = 360
'
'==========================================
'
Public Function sCleanUpNumber(sStrIn As String) As String
Dim sTemp As String
sTemp = sStrIn
If Right$(sTemp, 1) = "K" Then
sTemp = Left$(sStrIn, Len(sStrIn) - 1)
sTemp = sTemp & String$(3, "0")
End If
sCleanUpNumber = sTemp
End Function
'===========================================
'
' Name...: sDateFormat()
' Type...: Function
' Date...: 03/24/1998
' Author.: John Stendor
' Purpose: Date Format routine ...
'
'==========================================
'
Public Function sDateFormat(sStrIn As String) As String
sDateFormat = Format$(Right$(sStrIn, 4), "00/00")
End Function
'
'==========================================
'
' Name...: sFormat_Decimal
' Type...: Function
' Date...: 03/24/1998
' Author.: John Stendor
' Purpose: Format a number with Decimal Points ...
'
'==========================================
'
Public Function sFormatDecimal(sStrIn As String, _
sFillChar As String, iCharCtr As Integer) As String
Dim sTemp1 As String
Dim sTemp2 As String
sTemp1 = String$(iCharCtr, sFillChar)
If Val(sStrIn) Then
sTemp2 = Format$(Str$(Val(sStrIn) \ 1000), "###0.000")
'==========================================
' Append the underline field to the truncated
' low order digit ....
'==========================================
sTemp1 = sTemp1 & Left$(sTemp2, iCharCtr - 1)
End If
sFormatDecimal = Right$(sTemp1, iCharCtr)
End Function
'
'==========================================
'
' Name...: sFormatMMDDYY
' Type...: Function
' Date...: 03/24/1998
' Author.: John Stendor
' Purpose: Format Date MM/DD/YY ...
'
'==========================================
'
Public Function sFormatMMDDYY(sStrIn As String) As String
Dim sTemp As String
sTemp = ""
sStrIn = sStrIn & String$(8, "0")
'==========================================
' Make sure that you don't return zeros ...
'==========================================
If sStrIn <> String$(8, "0") Then
sTemp = Mid$(sStrIn, 5, 2) & "/" & Mid$(sStrIn, 7, 2) & _
"/" & Mid$(sStrIn, 3, 2)
End If
sFormatMMDDYY = sTemp
End Function
'============================================
'
' Name...: sFormatMMYY
' Type...: Function
' Date...: 03/24/1998
' Author.: John Stendor
' Purpose: Format Date MM/YY ...
'
'==========================================
'
Public Function sFormatMMYY(sStrIn As String) As String
Dim sTemp As String
sTemp = ""
sStrIn = sStrIn & String$(8, "0")
'==========================================
' Make sure that you don't return zeros ...
'==========================================
If Left$(sStrIn, 8) <> String$(8, "0") Then
sTemp = Mid$(sStrIn, 5, 2) & "/" & Mid$(sStrIn, 3, 2)
End If
sFormatMMYY = sTemp
End Function
'=========================================
'
' Name...: sFormatPhone
' Type...: Function
' Date...: 03/24/1998
' Author.: John Stendor
' Purpose: Format Phone Number (123) 546-9876 ...
'
'=========================================
'
Public Function sFormatPhone(sStrIn As String) As String
Dim sTemp As String
sTemp = ""
sStrIn = sStrIn & String$(10, "0")
'==========================================
' Make sure that you don't return zeros ...
'==========================================
If sStrIn <> String$(10, "0") Then
sStrIn = Left$(sStrIn, 10)
sTemp = "(" & Left$(sStrIn, 3) & ") " & _
Mid$(sStrIn, 4, 3) & "-" & Right$(sStrIn, 4)
End If
sFormatPhone = sTemp
End Function
'
'===========================================
'
' Name...: sPadField()
' Type...: Function
' Date...: 03/20/1998
' Author.: John Stendor
' Purpose: Open ACAPS Database and Tables ...
'
'==========================================
'
Public Function sPadField(sStringIn As String, iPad As Integer) As String
sPadField = Left$(sStringIn & Space$(iPad), iPad)
End Function
'
'==========================================
'
' Name...: sInsertString
' Type...: Function
' Date...: 07/29/1998
' Author.: John Stendor
' Purpose: Insert a String into another string,
' using ENUM (offset identifier)
'
'==========================================
'
Public Function sInsertString(sStrIn As String, _
sStrInsert As String, iAlign As Integer) As String
Dim sTemp As String
Dim iStrOffset As Integer
'==========================================
' Lets get busy and insert the string ....
'==========================================
If Len(sStrIn) Then
'==========================================
' If the input string is smaller than the
' insert string then pad the input string
'==========================================
If Len(sStrIn)