Following are some kewl samples of VB Code you can cut and paste right
into your VB Source. Credit is given where possible. Most are by me (AikoDude).
Some lines are long so be careful cutting and pasting.
Following are some kewl samples of VB Code you can cut and paste right
into your VB Source. Credit is given where possible. Most are by me (AikoDude).
Some lines are long so be careful cutting and pasting.
Notice:
I am not responsible for anything (bad!) that happens to you when you
use this code. Use and modify at your own risk. I am assuming you have a modicum of programming
skills here, so my standard discalimer applies:
Feel free to use and modify the following and please try to credit me - aikodude@aol.com - when you can (even in the comments if you have to, it makes me feel good!) If you can't <wink><wink>, oh well.
Good karma will follow you all the days of your life if you do.
If you pass it off as your own work without good reason (read Boss/Work/etc!)
then may you rot, well, somewhere...
<<<-- Previous Function | Next Function -->>>
Form Placement
LocateForm allows you to position a form in a predefined spot on the screen,
irregardless of the users screen resolution.
Public Sub LocateForm(frm As Form, Optional location)
' where location is:
' = C (center form)
' C = center
' TL = top left
' TR = top right
' BL = bottom left
' BR = bottom right
'
' example syntax loads calling form (Me) to the top left corner of the screen:
' LocateForm Me, "TL"
'
Dim a As Integer
Dim b As Integer
If IsMissing(location) Then location = "C"
Select Case UCase(location)
Case "C": 'works
If frm.WindowState <> 0 Then Exit Sub
a = (Screen.Height - frm.Height) \ 2
b = (Screen.Width - frm.Width) \ 2
frm.Move b, a
Case "TL": 'works
If frm.WindowState <> 0 Then Exit Sub
frm.Move 0, 0
Case "TR":
If frm.WindowState <> 0 Then Exit Sub
a = (Screen.Width - frm.Width)
b = 0
frm.Move a, b
Case "BL":
If frm.WindowState <> 0 Then Exit Sub
a = 0
b = (Screen.Height - frm.Height)
frm.Move a, b
Case "BR":
If frm.WindowState <> 0 Then Exit Sub
a = (Screen.Width - frm.Width)
b = (Screen.Height - frm.Height)
frm.Move a, b
Case Else:
Exit Sub
End Select
End Sub
<<<-- Previous Function | Next Function -->>>
Comm Port & Modem Checking
16-bit note: If you are compiling in 16-bit you need to write
your own sleep function as sleep() is a 32-bit api call. Otherwise everything
else should work out ok!
CommCheck is really 2 functions (FindComm and modemCheck) and some code to go into a calling function.
It allows you to check the presence of valid comm ports on your PC (ie. to load them
into a combo box). Then allows you to check the staus of any modems connected to those
ports.
Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Private Sub Command1_Click()
Dim i As Integer
Dim b As Boolean
Dim RETURN_CODE As Integer
Dim retarray(1 To 7) As Boolean
' retarray is a boolean array where retarray(i) = True
' if a com port exists at that location. ie. if
' retarray(1)=True then you have a valid port at com1:
b = FindComm(Me, retarray) ' locate com port
If b Then
MsgBox "a-ok"
Dim str1 As String
str1 = "Port(s) found on com: "
Dim i As Integer
For i = 1 To 7
If vararray(i) Then
str1 = str1 & i & ", "
End If
Next i
str1 = Left(str1, Len(str1) - 2) ' removes the comma
MsgBox str1
Else
MsgBox "Valid port not found"
' if a valid port not there,
' don't worry about checking for modems!
Exit Sub
End If
' you can use an select any port in the retarray(above)
' where retarray(i) = true (if any!).
' I set it to 1 here for simplicity sake. you can set it through
' a loop setup like the one I put in above (the "if b then" segment)!
Comm1.CommPort = 1
Comm1.Settings = "2400,N,8,1" ' set the baud rate to whatever you want 19200 is max
' test com port
RETURN_CODE = modemCheck(Me)
'reset port if still open
If Comm1.PortOpen = True Then
Comm1.PortOpen = False
End If
Select Case RETURN_CODE
Case 0
MsgBox "Modem Checks OK!"
Case 1
MsgBox "Modem Checks OK! No Dialtone Found."
Case 2
MsgBox "Modem Initialization Error."
Case 3
MsgBox "Unknown Modem Error Occurred"
Case Else
MsgBox "Unknown Error Occurred"
End Select
End Sub
Public Function FindComm(frm As form, ByRef retarray(1 To 7) As Boolean) As Boolean
' there must be an MSCommmunications Contorl called Comm1 on the form (frm) (modify to suit)
' locates a modem on com ports up to 7
'
Dim i As Integer, j As Integer
Dim PortFound As Boolean
Dim ports(1 To 7) As Boolean
Dim TempArray(1 To 7) As Integer
Dim CommFoundMsg As String
FindComm = False
PortFound = False
For i = 1 To 7
ports(i) = True
Next i
frm.Comm1.Settings = "300,N,8,1"
On Error GoTo CommError
For i = 1 To 7
frm.Comm1.CommPort = i
frm.Comm1.PortOpen = True
If frm.Comm1.PortOpen = True Then
frm.Comm1.PortOpen = False
End If
Next i
j = 0
For i = 1 To 7
If ports(i) = True Then
PortFound = True
FindComm = True
End If
Next i
If PortFound = False Then
FindComm = False
Else
For i = 1 To 7
retarray(i) = ports(i) ' valid assignment?
Debug.Print "ports(" & i & ") = " & ports(i)
Next i
FindComm = True
End If
Exit Function
CommError:
Select Case Err.Number
Case 68
ports(i) = False
Resume Next
Case 8000, 8005, 8007, 8012, 8013, 8019
Resume Next
Case 8002
Debug.Print "Invalid Port Number at com" & i & ":. ERROR: 8002"
' MsgBox "Invalid Port Number. ERROR: 8002", vbCritical + vbOKOnly, "CommTest"
ports(i) = False
Case 8006
Debug.Print "The device identifier is invalid or unsupported at com" & i & ":. ERROR: 8006"
' MsgBox "The device identifier is invalid or unsupported. ERROR: 8006", vbCritical + vbOKOnly, "CommTest"
ports(i) = False
Case 8010
Debug.Print "Port unavailable at com" & i & ":. ERROR: 8010"
' MsgBox "Port unavailable. ERROR: 8010", vbCritical + vbOKOnly, "CommTest"
ports(i) = False
Case 8020
Debug.Print "Error reading comm device at com" & i & ":. ERROR: 8020"
' MsgBox "Error reading comm device. ERROR: 8020", vbCritical + vbOKOnly, "CommTest"
ports(i) = False
Case Else:
Debug.Print "Other Comm Error at com" & i & ": - " & Err.Number & vbCrLf & Err.Description, vbCritical + vbOKOnly, "CommTest"
' MsgBox "Other Comm Error: " & Err.Number & vbCrLf & Err.Description, vbCritical + vbOKOnly, "CommTest"
ports(i) = False
End Select
Resume Next
End Function
Public Function modemCheck(frm As form) As Integer
' checks the operational status of a modem
' returns: 0 on success
' 1 on no dialtone
' 2 on other init error
' 3 on other error
Dim ni As Integer, nj As Integer
Dim sResponse As String
Dim sDialNum As String
Dim nHandleErr As Integer
On Error GoTo ErrorHandle
' Open the port.
If frm.Comm1.PortOpen = False Then
frm.Comm1.PortOpen = True
End If
frm.Comm1.InputLen = 0 ' set input length to read all!
' Send the attention command and init command to the modem.
frm.Comm1.Output = "ATQ0V1E1S0=0" + Chr$(13)
' Wait for data to come back to the serial port.
nj = 0
Do
nj = nj + 1
ni = DoEvents()
Loop Until frm.Comm1.InBufferCount >= 2 Or nj > 10
sResponse = frm.Comm1.Input
If sResponse = "" Then
' if no response... modem is off line
' MsgBox "No Response from modem. Make sure the modem is plugged in and turned on!"
' frm.cmdExit.Enabled = True
modemCheck = 2
Exit Function
End If
Call Sleep(5)
' call atdt or atdp to test for dial tone
' you may set up for pulse dialing
' here with an entry from an ini file
frm.Comm1.Output = "ATDT" + Chr$(13)
Call Sleep(5) ' was 7
nj = 0
Do
nj = nj + 1
ni = DoEvents()
Loop Until frm.Comm1.InBufferCount >= 2 Or nj > 10
sResponse = frm.Comm1.Input ' read the response buffer
' locate the no dialtone string in buffer if it exists!
If Right(UCase(sResponse), 13) = ("NO DIALTONE" & vbCrLf) Then
If frm.Comm1.PortOpen = True Then
frm.Comm1.PortOpen = False
End If
modemCheck = 1
' MsgBox "No Dialtone"
Exit Function
Else
If sResponse = "" Then
frm.Comm1.PortOpen = False
' MsgBox "No Response from modem." & vbCrLf & "Make sure the modem is plugged in and turned on!", vbOKOnly, "modemCheck"
modemCheck = 3
Exit Function
End If
End If
modemCheck = 0
Exit Function
ErrorHandle:
' this line for debug only! remove for production
' MsgBox "error: " & err.Number & vbCrLf & err.Description, vbOKOnly, "modemCheck"
modemCheck = 3
Exit Function
End Function
<<<-- Previous Function | Next Function -->>>
Modifying the System Menu
32-bit Only: There may be 16-bit equivilant API calls for GetSystemMenu
and DeleteMenu. You can look them up yourself if you need them!
This neat function removes the "Close" option from the system menu (the "-" box in the upper left corner of your app), forcing users to use your exit function(s). Great for when program cleanup is a must!
Declare Function DeleteMenu Lib "user32" (ByVal hMenu As Long, _
ByVal nPosition As Long, _
ByVal wFlags As Long) As Long
Declare Function GetSystemMenu Lib "user32" (ByVal hwnd As Long, _
ByVal bRevert As Long) As Long
Public Sub ModifySysMenu(form As form)
Const MF_BYPOSITION = &H400&
Const MF_SEPARATOR = &H800&
Const MF_BYCOMMAND = &H0&
Dim nRet As Integer
Dim nHndle As Long
nHndle& = GetSystemMenu(form.hwnd, False)
nRet = DeleteMenu(nHndle, 6, MF_BYPOSITION)
nRet = DeleteMenu(nHndle, 0, MF_SEPARATOR)
End Sub
Declare Function GetWindowsDirectory Lib "Kernel" (ByVal lpBuffer As String, _
ByVal nSize As Integer) As Integer
(32-bit declare)
Declare Function GetWindowsDirectory Lib "kernel32" Alias _
"GetWindowsDirectoryA" (ByVal lpBuffer As String, _
ByVal nSize As Long) As Long
Option Explicit
Declare Function GetWindowsDirectory Lib "kernel32" Alias "GetWindowsDirectoryA" (ByVal lpBuffer As String, ByVal nSize As Long) As Long
Dim winDirBuf As String, l As Long
Sub Main()
' call the clear function (which also
' inits the winDirBuf variable!)
AllClearMain
' call bland screen screen saver. it's installed
' in windows system dir by default. add your own
' error checking if you want.
l = Shell(winDirBuf & "\system\Blank Screen.scr /S", vbNormalFocus)
End
End Sub
Sub AllClearMain()
Dim temp As String
On Error GoTo errorrtn ' set up error handling
winDirBuf = Space(256) ' initialize the string with spaces. This is necessary
l = GetWindowsDirectory(winDirBuf, 256) ' call the API
winDirBuf = Left$(winDirBuf, InStr(winDirBuf, Chr(0)) - 1) 'strip off the NULL and extra spaces
' look for files in the recent file list directory, if there, kill them!
temp = Dir(winDirBuf & "\recent\*.*", vbNormal)
If temp <> "" Then
Kill winDirBuf & "\recent\*.*"
End If
Clipboard.Clear ' clear graphics and text clipboards.
' message re: clears. ask if user wants to start screen saver. if not, end pgm
l = MsgBox("Clipboard and RF List have been cleared!" & vbCrLf & "Activate Screen Saver?", vbYesNo, "AllClear98")
If l = vbNo Then
End
End If ' if l=vbYes then we will drop out of this function.
Exit Sub
errorrtn:
Clipboard.Clear
MsgBox Err.Description & ": " & Err.Number & vbCrLf & "Clipboard cleared." & vbCrLf & "temp =" & temp, vbOKOnly + vbCritical, "All Clear"
Exit Sub
End Sub
There's really 2 procedures here, a Sub and Function. The first is Sub checkCmdLine(). Call this to start checking the command line. It does the processing of command line options and calls Function GetCommandLine(), which handles the actual reading of the command line.
Public Function GetCommandLine(Optional MaxArgs As Variant) As Variant
'returns an array of command line args (as a variant)
On Error GoTo gclErr
'Declare variables.
Dim C, i As Integer
Dim CmdLnLen As Integer, NumArgs As Integer
Dim CmdLine As String
Dim InArg As Boolean
NumArgs = 0
InArg = False
' See if MaxArgs was provided.
If IsMissing(MaxArgs) Then
MaxArgs = 10 ' set this as necessary
End If
' Make array of the correct size.
ReDim ArgArray(MaxArgs)
' Get command line arguments.
CmdLine = Command()
CmdLnLen = Len(CmdLine)
'Go thru command line one character
'at a time.
For i = 1 To CmdLnLen
C = Mid(CmdLine, i, 1)
' Test for space or tab.
If (C <> " " And C <> vbTab) Then
' Neither space nor tab.
' Test if already in argument.
If Not InArg Then
' New argument begins.
' Test for too many arguments.
If NumArgs = MaxArgs Then Exit For
NumArgs = NumArgs + 1
InArg = True
End If
' Concatenate character to current argument.
ArgArray(NumArgs) = ArgArray(NumArgs) & C
Else
'Found a space or tab.
'Set InArg flag to False.
InArg = False
End If
Next i
' Resize array just enough to hold arguments.
ReDim Preserve ArgArray(NumArgs)
' Return Array in Function name.
GetCommandLine = ArgArray()
Exit Function
gclErr:
MsgBox "ERROR:GetCommandLine" ' add your own error handling if necessary.
Resume Next
End Function
Sub checkCmdLine()
On Error GoTo mainerr
' Returns an array of command line args.
' Call with max number of args you want to get back
vCmdArgs = GetCommandLine(1)
'checking if there are command line Arguments
'if no then showing the form if yes then creating
'the output file
' if no args then
If Command$() = "" Then
Debug.Print "No command line args found"
Exit Sub
Else
' modify this section to taste! I've got it set up to call a
' configuration form, and a brief Help (syntax) message box.
Select Case vCmdArgs(1)
Case "-c"
Debug.Print "-c command line arg found"
frmConfig.Show 1
End
Case "-?"
Debug.Print "-? command line arg found"
MsgBox "USAGE: myProggie [-c; -?]" & vbCrLf & vbCrLf & _
"Where:" & vbCrLf & _
"-c: Allows the user to set up Blah, blah and yadda, yadda." & vbCrLf & _
"-?: Shows this message."
End
Case Else
MsgBox "Unknown command line argument supplied: '" & vCmdArgs(1) & "'"
Debug.Print "Unknown command line argument supplied: '" & vCmdArgs(1) & "'"
MsgBox "USAGE: myProggie [-c; -?]" & vbCrLf & vbCrLf & _
"Where:" & vbCrLf & _
"-c: Allows the user to set up Blah, blah and yadda, yadda." & vbCrLf & _
"-?: Shows this message."
End
End Select
End If
Exit Sub
mainerr:
MsgBox "ERROR:checkCmdLine" ' set up error handling if necessary
Exit Sub
End Sub
Function by function listing. Don't forget to include this line:
Public sData() As StringSub PopulateINIArray(ByVal lpFile As String) Function MyGetINI(ByVal Application As String, ByVal key As String, ByVal Default As String, ByVal lpFile As String) As Variant Function WriteToINI(ByVal Application As String, ByVal key As String, ByVal value As String, ByVal lpFile As String) As Boolean Function ListINI(lpFile As String, frmName As Form) As Boolean Function DeleteKeyFromINI(ByVal Application As String, ByVal key As String, ByVal lpFile As String) As Boolean
Public Sub PopulateINIArray(ByVal lpFile As String)
Dim hFile As Integer
Dim i As Integer
Dim sTemp As String
If (Dir(lpFile)) = "" Then
Debug.Print "File: " & lpFile & " not found."
Exit Sub
End If
On Error GoTo PopINIErr
hFile = FreeFile(0) ' allocate a file handle
' Open the file to read it
Open lpFile For Input As hFile
' Loop through the file, ignoring blank lines.
' when done, all data will be in the sData() array.
'note: include blank lines
Do While Not EOF(hFile)
Line Input #hFile, sTemp
' If Len(Trim$(sTemp)) > 0 Then
ReDim Preserve sData(0 To i) As String
sData(i) = Trim$(sTemp)
i = i + 1
' End If
Loop
Close
Exit Sub
PopINIErr:
MsgBox "Populate INI"
If Err.Number = 53 Then
Debug.Print "File " & lpFile & " not found."
Exit Sub
Else
Debug.Print "An Error occurred. Error #" & Err.Number & vbCrLf & Err.Description
Exit Sub
End If
End Sub
Public Function MyGetINI(ByVal Section As String, ByVal key As String, _
ByVal Default As String, ByVal lpFile As String) As Variant
Dim hFile As Integer
Dim i As Integer, pos As Integer
Dim sTemp As String
Dim bSectionFound As Boolean
Dim bKeyFound As Boolean
If (Dir(lpFile)) = "" Then
Debug.Print "File: " & lpFile & " not found."
Exit Function
End If
On Error GoTo GetINIErr
hFile = FreeFile(0) ' allocate a file handle
PopulateINIArray lpFile
' Start the search for the correct section.
' UCase$() is used here to be sure that upper and lower case does
' not interfere with our search.
For i = 0 To UBound(sData)
If UCase$(sData(i)) = "[" & UCase$(Section) & "]" Then
bSectionFound = True
Exit For ' we found the Section, so no need to continue.
End If
Next i
' Now we loop until we either find the key, hit another INI application
' section or reach the end of the array.
If bSectionFound Then
Do
i = i + 1
' Look for the = separator.
pos = InStr(sData(i), "=")
If pos <> 0 Then
If UCase$(key) = UCase$(Left$(sData(i), pos - 1)) Then
bKeyFound = True
Exit Do
End If
End If
If i = UBound(sData) Then
Exit Do ' no more data, so quit.
End If
Loop While (Left$(sData(i + 1), 1) <> "[")
Else
Debug.Print "Section not Found"
End If
Close hFile
' If we found the key, we trim off the value and return it
' Otherwise, we return the default value.
If bKeyFound Then
MyGetINI = Mid$(sData(i), pos + 1)
Else
MyGetINI = Default
End If
Exit Function
GetINIErr:
MsgBox "MyGetINI"
If Err.Number = 53 Then
Debug.Print "File " & lpFile & " not found."
Exit Function
Else
Debug.Print "An Error occurred. Error #" & Err.Number & vbCrLf & Err.Description
Exit Function
End If
End Function
Public Function WriteToINI(ByVal Application As String, ByVal key As String, _
ByVal value As String, ByVal lpFile As String) As Boolean
' WriteToINI(Application, Key, Value, iniFile)
Dim hFile As Integer ' read file
Dim i As Integer, pos As Integer ' ints
Dim sTemp As String ' temp str var
Dim bSectionFound As Boolean ' section found
Dim bKeyFound As Boolean ' key found
Dim tStr As String, j As Integer ' temp str and loop counter
Dim wFile As Integer, LineNum As Integer ' output file and line number
Dim thisLine As Boolean
On Error GoTo WriteINIErr
LineNum = 0 ' init line number
hFile = FreeFile(0) ' allocate a file handle
'add code to see if file doesn't exist,
'ask then create it!
If (Dir(lpFile)) = "" Then
Open lpFile For Append As hFile
Print #hFile, " "
Close hFile
End If
PopulateINIArray lpFile ' update the ini array
' Start the search for the correct section.
' UCase$() is used here to be sure that upper and lower casse does
' not interfere with our search.
For i = 0 To UBound(sData)
If UCase$(sData(i)) = "[" & UCase$(Application) & "]" Then
bSectionFound = True
Exit For ' we found the application, so no need to continue.
End If
Next i
' Now we loop until we either find the key,
' hit another INI section or reach the end
' of the array.
If bSectionFound Then
Do
i = i + 1 ' go to the next line in array
' Look for the = separator.
pos = InStr(sData(i), "=")
If pos > 0 Then
If UCase$(key) = UCase$(Left$(sData(i), pos - 1)) Then
' key found, this is an update
bKeyFound = True
LineNum = i + 1 'set line number
Close
' open read file
Open lpFile For Input As hFile
' open output file
wFile = FreeFile(1) ' allocate a file handle
Open "temp.dat" For Output As wFile
tStr = "" ' init temp string var
j = 0 ' init loop/line counter
thisLine = False
' copy file over and change the
' appropriate key
Do While Not EOF(hFile)
j = j + 1
Line Input #hFile, tStr ' read line
If tStr <> "" Then
pos = InStr(tStr, "=")
If pos > 0 Then
If UCase$(key) = UCase$(Left$(tStr, pos - 1)) Then
thisLine = True
End If
End If
End If
' if not the right line,
' copy to temp file...
If thisLine = False Then
If tStr <> "" Then Print #wFile, tStr
Else ' if it is, write the new value in instead
Print #wFile, key & "=" & value
End If
thisLine = False
Loop
Close ' close all open files
Kill lpFile ' erase the old ini file
Name "temp.dat" As lpFile ' rename the temp file to the ini file name... maybe we should back up here?
WriteToINI = True
Exit Function
End If
End If
If i = UBound(sData) Then
Exit Do ' no more data, so quit.
End If
Loop While (Left$(sData(i + 1), 1) <> "[")
Else ' section not found... add to bottom
Open lpFile For Append As hFile
Print #hFile, vbCrLf & "[" & Application & "]" & vbCrLf
Print #hFile, key & "=" & value
WriteToINI = True
Close
Exit Function
End If
' If we found the key, we trim off the value and return it
' Otherwise, we return the default value.
If bKeyFound = False Then
Open lpFile For Input As hFile ' open read file
' open temp write file
wFile = FreeFile(1) ' allocate a file handle
Open "temp.dat" For Output As wFile ' open it
tStr = "" ' initialize temp string var
' search for section in read file
Do While Not EOF(hFile)
Line Input #hFile, tStr ' read a line
If tStr <> "" Then Print #wFile, tStr ' write it to temp
' when we find the section,
' add new key and value
If UCase$(tStr) = "[" & UCase$(Application) & "]" Then
Print #wFile, vbCrLf & key & "=" & value
End If
Loop
Close
Kill lpFile
Name "temp.dat" As lpFile
WriteToINI = True
Close
Exit Function
End If
Exit Function
WriteINIErr:
MsgBox "ERROR:WriteToINI"
If Err.Number = 53 Then
Debug.Print "File " & lpFile & " not found."
Exit Function
Else
If Err.Number = 9 Then
Resume Next
Else
Debug.Print "An Error occurred. Error #" & Err.Number & vbCrLf & Err.Description
Exit Function
End If
End If
End Function
Public Function ListINI(lpFile As String, frmName As form) As Boolean
' must add a text box txtINIContents to form
' before calling this function.
Dim i As Integer
If (Dir(lpFile)) = "" Then
Debug.Print "File: " & lpFile & " not found."
Exit Function
End If
On Error GoTo ListINIErr
PopulateINIArray lpFile
frmName.txtINIContents.Text = ""
For i = 0 To UBound(sData)
If frmName.txtINIContents.Text <> "" Then
frmName.txtINIContents.Text = frmName.txtINIContents.Text & vbCrLf & sData(i)
Else
frmName.txtINIContents.Text = sData(i)
End If
Next i
ListINI = True
Exit Function
ListINIErr:
MsgBox "ERROR:ListINI"
ListINI = False
If Err.Number = 53 Then
Debug.Print "File " & lpFile & " not found."
Exit Function
Else
Debug.Print "An Error occurred. Error #" & Err.Number & vbCrLf & Err.Description
Exit Function
End If
End Function
Public Function DeleteKeyFromINI(ByVal Application As String, ByVal key As String, _
ByVal lpFile As String) As Boolean
' DeleteKeyFromINI(Application, Key, iniFile)
Dim hFile As Integer ' read file
Dim i As Integer, pos As Integer ' ints
Dim sTemp As String ' temp str var
Dim bSectionFound As Boolean ' section found
Dim bKeyFound As Boolean ' key found
Dim tStr As String, j As Integer ' temp str and loop counter
Dim wFile As Integer, LineNum As Integer ' output file and line number
Dim thisLine As Boolean
On Error GoTo DeleteKeyErr
LineNum = 0 ' init line number
hFile = FreeFile(0) ' allocate a file handle
'check to see if file exists
If (Dir(lpFile)) = "" Then
MsgBox "INI File: " & lpFile & " not found. Cannot Delete Key: " & key & "."
DeleteKeyFromINI = False
Exit Function
End If
PopulateINIArray lpFile ' update the ini array
' Start the search for the correct section.
' UCase$() is used here to be sure that upper and lower casse does
' not interfere with our search.
For i = 0 To UBound(sData)
If UCase$(sData(i)) = "[" & UCase$(Application) & "]" Then
bSectionFound = True
Exit For ' we found the section (Application), so no need to continue.
End If
Next i
' Now we loop until we either find the key,
' hit another INI section or reach the end
' of the array.
If bSectionFound Then
Do
i = i + 1 ' go to the next line in array
' Look for the = separator.
pos = InStr(sData(i), "=")
If pos > 0 Then
If UCase$(key) = UCase$(Left$(sData(i), pos - 1)) Then
' key found, this is an update
bKeyFound = True
LineNum = i + 1 'set line number
Close
' open read file
Open lpFile For Input As hFile
' open output file
wFile = FreeFile(1) ' allocate a file handle
Open "temp.dat" For Output As wFile
tStr = "" ' init temp string var
j = 0 ' init loop/line counter
thisLine = False
' copy file over and delete the
' appropriate key
Do While Not EOF(hFile)
j = j + 1
Line Input #hFile, tStr ' read line
If tStr <> "" Then
pos = InStr(tStr, "=")
If pos > 0 Then
If UCase$(key) = UCase$(Left$(tStr, pos - 1)) Then
thisLine = True
End If
End If
End If
' if not the right line,
' copy to temp file...
' if it is the right line,
' skip it! (delete the key!)
If thisLine = False Then
If tStr <> "" Then Print #wFile, tStr ' if not blank print it!
End If
thisLine = False
Loop
Close ' close all open files
Kill lpFile ' erase the old ini file
Name "temp.dat" As lpFile ' rename the temp file to the ini file name... maybe we should back up here?
DeleteKeyFromINI = False
Exit Function
End If
End If
If i = UBound(sData) Then
Exit Do ' no more data, so quit.
End If
Loop While (Left$(sData(i + 1), 1) <> "[")
Else ' section not found.
Close
MsgBox "Section: " & Application & " not found. Unable to delete key: " & key & "."
DeleteKeyFromINI = False
Exit Function
End If
' If we found the key, we trim off the value and return it
' Otherwise, we return the default value.
If bKeyFound = False Then
MsgBox "Key: " & key & " not found."
Close
DeleteKeyFromINI = False
Exit Function
End If
Exit Function
DeleteKeyErr:
If Err.Number = 53 Then
MsgBox "File " & lpFile & " not found."
Exit Function
Else
If Err.Number = 9 Then 'subscript out of range. - attempt to read past the end of the array
Resume Next
Else
MsgBox "An Error occurred. Error #" & Err.Number & vbCrLf & Err.Description
Exit Function
End If
End If
End Function
