Visual Basic Explorer
Visual Basic Explorer
 Navigation
 Home


 Coding
 Source Code

 FAQ Center

 VB Tips

 Downloads

 ToolBox

 Tutorials

 VB Games

 VB News

 VB Award

 VB Forums



 Affiliates
 Planet Source Code

 Rent a Coder

 DirectX4VB


 Misc
 Search

 Feedback

 Advertise

 About


Need to hire
a VB coder?

Please support our sponsor:

 Home 
 Site Map 
 Forums 
 News 
 Feedback 

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).

Got a useful snippet you'd like to share? Submit it here.


Back to top

'------------------------------------------------------
'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

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



Back to top '******************************************************* '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)
Back to top '**************** '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
Back to top '----------------------------------------------------- '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
Back to top '------------------------------------------------------------------------ ' 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
Back to top '----------------------------------------------------- '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.
Back to top '------------------------------------------------------------------ '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
Back to top '------------------------------------------------------------------- '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
Back to top '------------------------------------------------------------------- '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
Back to top '------------------------------------------------------------------- '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
Back to top
'------------------------------------------------------------------- '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")
Back to top '------------------------------------------------------------------- '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.
Back to top '------------------------------------------------------------------- '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.
Back to top '------------------------------------------------------------------- '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.
Back to top '------------------------------------------------------------------- '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)

Back to top




Home | About | What's New | Source Code | FAQ | Tips & Tricks | Downloads | ToolBox | Tutorials | Game Programming | VB Award | Search | VB Forums | Feedback | VBNews | Copyright & Disclaimer | Advertise | Privacy Policy |

Quick searches: Site Search | Advanced Site Search 

Copyright 2002 by Exhedra Solutions, Inc.
By using this site you agree to its terms and conditions
VB Explorer and VBExplorer.com are trademarks of Exhedra Solutions, Inc.