Visual Basic - How to use a variable from one function in another - function

I have checked Google, and the suggested answers here, but have had no luck unfortunately.
The last thing I need to do is have an email read the rateNbr variable into the email body, but it just comes up empty.
I tried to make Public Function FuncRateCheckFile read as Public Function FuncRateCheckFile(ByVal rateNbr As String), to try and enable it to be called outside the function, but this then breaks the function when it is called elsewhere. :(
Here is the code, with comments as to where I am referring:
Public Function FuncRateCheckFile()
Dim blnContinue As Boolean
Dim strLine As String
Dim strSearchFor, strSearchWrd, LineCount, objFSO, objTextFile, arrLines
Dim dteNow As Date
Dim newDate As String
'//==============================================================================================
'// DECLARED
Dim rateNbr As String
'//==============================================================================================
FuncRateCheckFile = False
blnContinue = True
If blnContinue Then
Const ForReading = 1
'Get todays date and reformat it
dteNow = DateValue(Now)
newDate = Format(dteNow, "dd/MM/yy")
strSearchWrd = newDate
'Read the whole file
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objTextFile = objFSO.OpenTextFile(m_RateCheckFile, ForReading)
LineCount = 0
Do Until objTextFile.AtEndOfStream
strLine = objTextFile.ReadLine()
If InStr(strLine, strSearchWrd) <> 0 Then
arrLines = Split(strLine, vbCrLf)
LineCount = LineCount + 1
End If
Loop
'Log a message to state how many lines have todays day, and if there are none, log an error
If LineCount <> 0 Then
'//==============================================================================================
'// "rateNbr" IS WHAT I AM TRYING TO GET TO PUT IN THE EMAIL
LogMessage "Rate file date is correct"
rateNbr = "Number of rates for " & newDate & " in the file recieved on " & newDate & " is " & LineCount
LogMessage rateNbr
EmailAdvice2
objTextFile.Close
'//==============================================================================================
Else
blnContinue = False
LogError "Failed to retrieve Current Rate date, please check rate file.."
EmailAdvice
objTextFile.Close
End If
End If
FuncRateCheckFile = blnContinue
LogMessage "Completed Check Rate file"
End Function
Private Function EmailAdvice2()
Dim strSMTPFrom As String
Dim strSMTPTo As String
Dim strSMTPRelay As String
Dim strTextBody As String
Dim strSubject As String
Dim oMessage As Object
'//==============================================================================================
'// DECLARED AGAIN
Dim rateNbr As String
'//==============================================================================================
Set oMessage = CreateObject("CDO.Message")
strSMTPFrom = "no-reply#work.com.au"
strSMTPTo = "me#work.com.au"
strSMTPRelay = "smtp.relay.com"
'//==============================================================================================
'// THIS MAKES THE TEXT BODY BLANK, BUT THE EMAIL STILL SENDS
strTextBody = rateNbr
'//==============================================================================================
strSubject = "Todays rates"
'strAttachment = "full UNC path of file"
oMessage.Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
oMessage.Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = strSMTPRelay
oMessage.Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 25
oMessage.Configuration.Fields.Update
oMessage.Subject = strSubject
oMessage.From = strSMTPFrom
oMessage.To = strSMTPTo
oMessage.textbody = strTextBody
'oMessage.AddAttachment strAttachment
oMessage.Send
End Function
I am positive that it is blank because I have declared rateNbr under EmailAdvice2() and then not given it anything to fill the variable with. But I don't know how to make it call the variable under FuncRateCheckFile().
Thanks to all for any assistance.

As Plutonix stated, this is a scope issue.
Move the declaration of your 'rateNbr' variable out to class level, and remove the local declarations inside your functions:
Dim rateNbr As String ' <-- out at class level it will be accessible from both functions
Public Function FuncRateCheckFile()
...
' REMOVE both the decalarations of "rateNbr" that are INSIDE your functions
...
End Function
Private Function EmailAdvice2()
...
' REMOVE both the decalarations of "rateNbr" that are INSIDE your functions
...
End Function

Related

Not in List Error after replacing Chr(), yet added to list correctly

I have some combo boxes with code for adding new items to the source table with a form when it doesn't exist.
The code will replace Chr(47) / and Chr(92) \ with Chr(45) - if present. This is done because a file name is created using concatenation later.
The problem is if a character is replaced, I get an Access error that the item is not in the list. This does not happen if a character is not replaced. In both instances the correct items are added to the corresponding tables.
I have tried replacing the character before passing it to OpenArgs, AfterUpdate, on the form after it opens, etc. The error does not break so the program is working, I just want to eliminate a unnecessary pop-up message.
Any help is greatly appreciated.
Private Sub cboManual_NotInList(NewData As String, Response As Integer)
Dim MyMessage As String
Dim myButtons As Integer
Dim myTitle As String
Dim strSQL As String
On Error GoTo ErrHandler
MyMessage = "This Manual does not exist. Create it?"
myButtons = vbYesNo + vbDefaultButton1 + vbQuestion + vbApplicationModal
myTitle = "Add Manual?"
MyChoice = MsgBox(MyMessage, myButtons, myTitle)
If MyChoice = 6 Then
If Not DBAuthority = "Admin" And Not DBAuthority = "Data Entry" Then
Response = acDataErrContinue
MsgBox "Sorry, authorized access only", _
vbOKOnly, "Important Information"
Exit Sub
Else
Response = acDataErrAdded
CallerField = "Manual"
CallerForm = "NewDocument"
NewData = Replace(NewData, Chr(47), Chr(45))
NewData = Replace(NewData, Chr(92), Chr(45))
DoCmd.OpenForm "AddManual", windowmode:=acDialog, OpenArgs:=NewData
Me.cboManual.RowSource = Me.cboManual.RowSource
Me.cboManual.value = strAddManual
strManual = Me.cboManual.value
strAddManual = vbNullString
Me.cboSection.value = strAddSection
strSection = Me.cboSection.value
strAddSection = vbNullString
Me.cboEngine.value = strAddEngine
strEngine = Me.cboEngine.value
strAddEngine = vbNullString
End If
ElseIf MyChoice = 7 Then
Response = acDataErrContinue
MsgBox "Select Manual from list.", vbOKOnly, "Select Manual"
Me.cboManual.Undo
Me.cboManual.SetFocus
Exit Sub
End If
Exit Sub
ErrHandler:
If Err = 20 Then
Response = acDataErrContinue
ElseIf Err = 94 Then
Response = acDataErrContinue
Resume Next
ElseIf Err = 2237 Then
Response = acDataErrContinue
Resume Next
ElseIf Err = 0 Then
Response = acDataErrContinue
Else
MsgBox "cboManual.NotInList Err = " & Err.Number & " :" & Err.Description
Exit Sub
End If
Exit Sub
End Sub
Option one
Replace while typing
Select Case KeyCode
Case vbKeyDown
Me![cboNewPart].Dropdown
Case 220, 191 ' / and \
KeyCode = 189 ' with -
Case Else
End Select
Option two
after adding the new value to the table. do
me.combo.undo, me.combo.requery. me.combo.value = newValue
followed by acDataErrContinue
this way you won't get error message but the list will flicker a and it's purely a hack.
Try using a different variable name (other than NewData) to store the modified version of the value passed to the NewData argument, i.e.:
Dim NewString as String
NewString = NewData
NewString = Replace(NewString, Chr(47), Chr(45))
NewString = Replace(NewString, Chr(92), Chr(45))
DoCmd.OpenForm "AddManual", windowmode:=acDialog, OpenArgs:=NewString
Since VBA arguments are passed ByRef unless otherwise stated, any modification to the argument value will be modifying the original value passed to your cboManual_NotInList event handler.
Given the above, you could alternatively try changing the NewData argument to be passed by value (ByVal):
Private Sub cboManual_NotInList(ByVal NewData As String, Response As Integer)

Error when looping through Image slideshow from pics in folder

I am trying to create a image slideshow by changing the Image control .picture property by looping through all images in a predefined folder
C:\Images
The code I am using:
Public pixpaths As Collection
Public pix_path As String
Public pixnum As Integer
Public fs As YtoFileSearch
Public k As Integer
Public Sub Image_set()
Set pixpaths = New Collection
pix_path = "C:\Images"
Set fs = New YtoFileSearch
With fs
.NewSearch
.LookIn = pix_path
.fileName = "*.jpg"
If fs.Execute() > 0 Then
For k = 1 To .FoundFiles.Count
pixpaths.Add Item:=.FoundFiles(k)
Next k
Else
MsgBox "No files found!"
DoCmd.OpenForm "Fr_Sketchpad" ' If no images found in folder the set image from another form 'Sketchpad' image control
Forms!Fr_Sketchpad.Visible = False
Forms!Fr_Main!imgPixHolder.Picture = "" 'Forms!Fr_Sketchpad!Img_Std.Picture Was getting another error here so commented this
pixnum = 0
Exit Sub
End If
End With
'load first pix
Forms!Fr_Main.imgPixHolder.Picture = pixpaths(1)
pixnum = 1
End Sub
Public Sub Image_loop()
If pixnum = pixpaths.Count Then
pixnum = 1
ElseIf pixnum = 0 Then
Exit Sub
Else
pixnum = pixnum + 1
Forms!Fr_Main!imgPixHolder.Picture = pixpaths(pixnum)
End If
End Sub
Private Sub Form_Open(Cancel As Integer)
Call Image_set
End Sub
Private Sub Form_Timer()
Call Image_loop
End Sub
The Image_Set(), Image_loop() and variables are in one module and are called in Form_open and Form_timer events
The code is working fine for one loop cycle but for the next loop cycle it is showing an error:
Error 91 object variable or with block variable not set
on
If pixnum = pixpaths.Count Then
In debug mode when I check value for pixnum it is 0
[Update]
Class Module YtoFileSearch
Option Compare Database
Option Explicit
' How this is not another proof that doing VBA is a bad idea?
' Nevertheless, we'll try to make the scripts relying on Application.FileSearch works again.
' The interface of this YtoFileSearch class aims to stick to the original
' Application.FileSearch class interface.
' Cf is https://msdn.microsoft.com/en-us/library/office/aa219847(v=office.11).aspx
' For now it do not handle recursive search and only search for files.
' More precisely the following filters are not implemented:
' * SearchSubFolders
' * MatchTextExactly
' * FileType
' If that's something you need, please create an issue so we have a look at it.
' Our class attributes.
Private pDirectoryPath As String
Private pFileNameFilter As String
Private pFoundFiles As Collection
' Set the directory in which we will search.
Public Property Let LookIn(directoryPath As String)
pDirectoryPath = directoryPath
End Property
' Allow to filter by file name.
Public Property Let fileName(fileName As String)
pFileNameFilter = fileName
End Property
'Property to get all the found files.
Public Property Get FoundFiles() As Collection
Set FoundFiles = pFoundFiles
End Property
' Reset the FileSearch object for a new search.
Public Sub NewSearch()
'Reset the found files object.
Set pFoundFiles = New Collection
' and the search criterions.
pDirectoryPath = ""
pFileNameFilter = ""
End Sub
' Launch the search and return the number of occurrences.
Public Function Execute() As Long
'Lance la recherche
doSearch
Execute = pFoundFiles.Count
End Function
' Do the nasty work here.
Private Sub doSearch()
Dim directoryPath As String
Dim currentFile As String
Dim filter As String
directoryPath = pDirectoryPath
If InStr(Len(pDirectoryPath), pDirectoryPath, "\") = 0 Then
directoryPath = directoryPath & "\"
End If
' If no directory is specified, abort the search.
If Len(directoryPath) = 0 Then
Exit Sub
End If
' Check that directoryPath is a valid directory path.
' http://stackoverflow.com/questions/15480389/excel-vba-check-if-directory-exists-error
If Dir(directoryPath, vbDirectory) = "" Then
Debug.Print "Directory " & directoryPath & " does not exists"
Exit Sub
Else
If (GetAttr(directoryPath) And vbDirectory) <> vbDirectory Then
Debug.Print directoryPath & " is not a directory"
Exit Sub
End If
End If
' We rely on the Dir() function for the search.
' cf https://msdn.microsoft.com/fr-fr/library/dk008ty4(v=vs.90).aspx
' Create the filter used with the Dir() function.
filter = directoryPath
If Len(pFileNameFilter) > 0 Then
' Add the file name filter.
filter = filter & "*" & pFileNameFilter & "*"
End If
' Start to search.
currentFile = Dir(filter)
Do While currentFile <> ""
' Use bitwise comparison to make sure currentFile is not a directory.
If (GetAttr(directoryPath & currentFile) And vbDirectory) <> vbDirectory Then
' Add the entry to the list of found files.
pFoundFiles.Add directoryPath & currentFile
End If
' Get next entry.
currentFile = Dir()
Loop
End Sub
Please advice how to resolve!
I have to answer your comment question you had for me here. This may not solve your issue, but it may help you find it, especially if the error is from you setting pixpaths = nothing in another function as #dbmitch suggested.
You would refer to .FoundFiles in Image_Set the same way you would pixpath, the collection gets populated by the doSearch sub from the .Execute function so the following code should work the same. Also, unless you are using your arguments in another module, you may want to consider making them Private like I did here.
Private pix_path As String
Private pixnum As Integer
Private fs As YtoFileSearch
Public Sub Image_set()
pix_path = "C:\Images"
Set fs = New YtoFileSearch
With fs
.NewSearch
.LookIn = pix_path
.fileName = "*.jpg"
If fs.Execute() > 0 Then
'load first pix
Forms!Fr_Main.imgPixHolder.Picture = .FoundFiles(1)
pixnum = 1
Else
MsgBox "No files found!"
DoCmd.OpenForm "Fr_Sketchpad" ' If no images found in folder the set image from another form 'Sketchpad' image control
Forms!Fr_Sketchpad.Visible = False
Forms!Fr_Main!imgPixHolder.Picture = ""
'Forms!Fr_Sketchpad!Img_Std.Picture Was getting another error here so commented this
pixnum = 0
End If
End With
End Sub
Public Sub Image_loop()
With fs
If pixnum = .FoundFiles.Count Then
pixnum = 1
ElseIf pixnum <> 0 Then
pixnum = pixnum + 1
Forms!Fr_Main!imgPixHolder.Picture = .FoundFiles(pixnum)
End If
End With
End Sub

Run time error 91-Object variable or With block variable not set

Run-time error '91':
Object variable or With block variable not set
Sub findfilmnameusingeventhandler()
Sheet1.Activate
Dim searchrange As Range
Dim filmname As String
Dim releasedate As Integer
Dim filmtofind As String
Set searchrange = Range("b3", Range("b2").End(xlDown))
filmname = InputBox("Type the movie")
filmtofind = searchrange.Find(what:=filmname)
'filmtofind = Range("b2:b15").Find(what:=filmname)
MsgBox filmtofind & " is the movie "
End Sub`
Hi, Thank you for reviewing my question. I've declared a range variable & use it to search a string "filmtofind = searchrange.Find(what:=filmname)" & it fails with run time error
Run-time error '91':
Object variable or With block variable not set
however I can search for same range with a declared range
filmtofind = Range("b2:b15").Find(what:=filmname) & can find a variable. COuld someone please point the mistake?
The film you are entering does not exist in the list, try an error check like this:
Sub something()
Dim searchrange As Range
Dim filmname As String
Dim releasedate As Integer
Dim filmtofind As String
Set searchrange = Range("B3", Range("B2").End(xlDown))
filmname = InputBox("Type the movie")
If WorksheetFunction.CountIf(searchrange, filmname) > 0 Then
filmtofind = searchrange.Find(what:=filmname)
Else
filmtofind = "Film not found!"
End If
'filmtofind = Range("b2:b15").Find(what:=filmname)
MsgBox filmtofind & " is the movie "
End Sub

vbscript error: Name Redifiined; Line 43: ExecuteGlobal sFileContents

Question from a amatuer scripter with informal coding background:
I've researched this on stack, msdn, random scripting websites but can't seem to glean a concrete solution. So please be advised this request for help is a last resort even if the solution is simple.
To put it simply, I'm trying to call a function that parses the last modified date of a file into an array of date formats. The filepath is the function parameter. These files are .vbs files in a client-side testing environment. This will be apparent if you look at the script.
My best guess is the "name redefined" error has something to do global variables being Dim'd in some way that's throwing the error.
Anyway, here's the calling sub:
Option Explicit
'=============================
'===Unprocessed Report========
'=============================
'*****Inputs: File Path*********************
dim strFolderPath, strFilename, strReportName, strFileExt, FullFilePath
strFolderPath = "C:\Users\C37745\Desktop\"
strFilename = "UNPROCESSED_REPORT"
strReportName = "Unprocessed"
strFileExt = ".xlsx"
'************************************
FullFilePath = strFolderPath & strFilename & strFilename & strFileExt
'************************************
Sub Include(MyFile)
Dim objFSO, oFileBeingReadIn ' define Objects
Dim sFileContents ' define Strings
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set oFileBeingReadIn = objFSO.OpenTextFile(MyFile, 1)
sFileContents = oFileBeingReadIn.ReadAll
oFileBeingReadIn.Close
ExecuteGlobal sFileContents
End Sub
Include "C:\Users\C37745\Desktop\VBStest\OtherTest\TEST_DLM.vbs"
''''''''''FOR TESTING''''''''''''''
Dim FilePath, varTEST
strFilePath = FullFilePath
varTEST = ParseDLMToArray(strFilePath)
msgbox varTESTtemp(0)
'''''''''''''''''''''''''''''''''
Here's the function I'm trying to call (or read, I guess):
Function ParseDLMtoArray(strFilePath)
Dim strFilePath, dlmDayD, dlmMonthM, dlmYearYY, dlmYearYYYY, DateFormatArray, dateDLM
Dim objFSO, File_Object
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set File_Object = objFSO.GetFile(strFilePath)
dateDLM = File_object.DateLastModified
dlmDayD = Day(dateDLM)
dlmMonthM = Month(dateDLM)
dlmYearYY = Right(Year(dateDLM),2)
dlmYearYYYY = Year(dateDLM)
'Adds a leading zero if a 1-digit month is detected
If(Len(Month(dlmDayD))=1) Then
dlmmonthMM ="0"& dlmMonthM
Else
dlmMonthMM = dlmMonthM
End If
'Adds a leading zero if a 1-digit day is detected
If(Len(Day(dlmDayD))=1) Then
dlmDayDD = "0" & dlmDayD
Else
dlmDayDD = dlmDayD
End If
varDLM_mmyyyy = dlmMonthMM & dlmYearYYYY
varDLM_mmddyy = dlmMonthMM & dlmDayDD & dlmYearYY
varDLM_mmddyyyy = dlmMonthMM & dlmDayDD & dlmYearYYYY
DateFormatArray = Array( _
varDLM_mmyyyy, _
varDLM_mmddyy, _
varDLM_mmddyyyy _
)
ParseDLMtoArray = DateFormatArray
End Function
Any advice is appreciated, including general feedback on best practices if you see an issue there. Thanks!
Your
Function ParseDLMtoArray(strFilePath)
Dim strFilePath
...
tries to declare/define strFilePath again. That obviously can't be allowed, because it would be impossible to decide whether that variable should contain Empty (because of the Dim) or the argument you passed.
At a first glance at your code, you can just delete the Dim strFilePath.

Type mismatch when comparing two variants, why?

I have written a function that’s sole purpose is to loop through all forms in a continuous form, grab the names from an "Owner" field, and then create a collection out of them which only contains unique values (no repeated names).
The code below is my current code, I realize that this may seems to be a roundabout way to do what I want but some unforeseen issues prevent me from doing this the way I would like to. So while I realize the code isn't super effective (and is very rough coding) I want to finish this path if only for a learning experience. This line of code always gives me a type mismatch error message. I have used a break line to see what those variables are in the local window, they both contain a string which should be the same therefore should return true. I can't seem to find a way to make that comparison actually work.
ElseIf var = o Then
The code (heavy commenting to make sure I am clear):
Private Sub Command39_Click()
Dim intRecordCount As Integer
Dim rs As DAO.Recordset
Dim colNames As Collection
Set colNames = New Collection
Set rs = Me.RecordsetClone
intRecordCount = rs.RecordCount
DoCmd.GoToRecord , , acFirst
If intRecordCount > 0 Then
Dim thisCol As Collection
Set thisCol = New Collection
'For each record on the form
Do While Not rs.EOF
Dim str As String
Dim o As Variant
str = Me.txtOwners.Value & ""
'If the textbox isn't empty
If Len(str) > 0 Then
'Send the string containing names ("Bob, Cheryl, Jeff, Tim")
Set thisCol = SplitNames(str)
'Loop through all of the names found
For Each o In thisCol
Dim var As Variant
Dim blnFound As Boolean
'Loop through all names in the main collection
For Each var In colNames
'If the collection is empty simply add the first name
If colNames.Count = 0 Then
blnFound = False
'If the collection has items check each one to see if the name is already in the collection
'This line is where the problem lies, I can't find anyway to compare var to o
ElseIf var = o Then
blnFound = True
End If
Next var
'If the name was not found in the collection add it
If Not blnFound Then
colNames.Add (o)
End If
Next o
End If
'Go to the next record in the continuous
DoCmd.GoToRecord , , acNext
rs.MoveNext
Loop
End If
End Sub
'Accepts the name of the owners to be split
Public Function SplitNames(strNames As String) As Collection
Dim colNames As Collection
Dim strThisName As String
Set colNames = New Collection
'Replaces ("Bob, Cheryl, Jeff, Tim") with ("Bob Cheryl Jeff Tim")
'I realize this isn't really needed simply my OCD requires I do
strNames = Trim(Replace(strNames, ", ", " "))
'Create the collection of names
colNames.Add (Split(strNames, " "))
'Send back the collection
Set SplitNames = colNames
End Function
Update - For some reason I need to access the var string propery by using var(0) so it seems like somehow var became its own array?
Here's an example of modifying your SplitNames function to a Dictionary object.
WHile there is an Exists method which you may make use of elsehwere in your code, you need not use that to ensure uniqueness. Merely referring to a Key will create it, so you can create a new key (or overwrite it if it exists) using the same method:
dict(key) = value
Note that this overwrites the value portion of the Key/Value pair. But since your SplitNames function is merely building the "list" of unique names, I don't think that will be an issue. For the sake of example, I simply assign nullstring to each value.
I added an optional parameter to this function to allow you to return either a Dictionary of unique names, or a Collection (converted from the Dictionary). Untested, but I think it should work. Let me know if you have any trouble with it.
Public Function SplitNames(strNames As String, Optional returnCollection as Boolean=False) As Object
'returns a Dictionary of unique names, _
' or a Collection of unique names if optional returnCollection=True
Dim dictNames as Object
Dim strThisName As Variant
Dim coll as Collection
Set dictNames = CreateObject("Scripting.Dictionary")
'Replaces ("Bob, Cheryl, Jeff, Tim") with ("Bob Cheryl Jeff Tim")
'I realize this isn't really needed simply my OCD requires I do
strNames = Trim(Replace(strNames, ", ", " "))
'Create the collection of names
For Each strThisName in Split(strNames, " ")
dictNames(strThisName) = ""
Next
If Not returnCollection Then
Set SplitNames = dictNames
Else
Set coll = New Collection
For each strThisName in dictNames.Keys()
coll.Add strThisName
Next
Set SplitNames = coll
End If
End Function
So I think you can reduce your procedure like so:
Private Sub Command39_Click()
Dim intRecordCount As Integer
Dim rs As DAO.Recordset
Dim dictNames As Object
Dim collNames as Collection
Dim str As String
Dim o As Variant
Set rs = Me.RecordsetClone
intRecordCount = rs.RecordCount
DoCmd.GoToRecord , , acFirst
rs.MoveFirst
If intRecordCount > 0 Then
'For each record on the form
Do While Not rs.EOF
str = Me.Controls("Text27").Value & ""
'If the textbox isn't empty
If Len(str) > 0 Then
'Send the string containing names ("Bob, Cheryl, Jeff, Tim")
Set dictNames = SplitNames(str)
'Alternatively, if you want to work with the Collection instead:
Set collNames = SplitNames(str, True)
End If
Loop
End If
End Sub
The following is the updated code that works for what I need it to do. I was adding a string array (being created by the Split() function) which was what I was adding instead of the string value itself.
Private Sub Command39_Click()
Dim intRecordCount As Integer
Dim rs As DAO.Recordset
Dim dictNames As New Collection
Set rs = Me.RecordsetClone
intRecordCount = rs.RecordCount
DoCmd.GoToRecord , , acFirst
rs.MoveFirst
If intRecordCount > 0 Then
Dim dictTheseNames As New Collection
'For each record on the form
Do While Not rs.EOF
Dim str As String
Dim o As Variant
str = Me.Controls("Text27").Value & ""
'If the textbox isn't empty
If Len(str) > 0 Then
'Send the string containing names ("Bob, Cheryl, Jeff, Tim")
Set dictTheseNames = SplitNames(str)
'Loop through all of the names found
For Each o In dictTheseNames
Dim var As Variant
Dim blnFound As Boolean
blnFound = False
'Loop through all names in the main collection
For Each var In dictNames
'If the collection is empty simply add the first name
If dictNames.Count = 0 Then
dictNames.Add (o)
'If the collection has items check each one to see if the name is already in the collection
'This line is where the problem lies, I can't find anyway to compare var to o
ElseIf o = var Then
blnFound = True
End If
Next var
'If the name was not found in the collection add it
If Not blnFound Then
dictNames.Add (o)
End If
Next o
End If
'Go to the next record in the continuous
rs.MoveNext
If (rs.RecordCount - rs.AbsolutePosition) > 2 Then
DoCmd.GoToRecord , , acNext
End If
Loop
End If
End Sub
'Accepts the name of the owners to be split
Public Function SplitNames(strNames As String) As Collection
Dim dictNames As New Collection
Dim strThisName As String
Dim strArray() As String
Set dictNames = New Collection
'Replaces ("Bob, Cheryl, Jeff, Tim") with ("Bob Cheryl Jeff Tim")
'I realize this isn't really needed simply my OCD requires I do
strNames = Trim(Replace(strNames, ", ", " "))
'Create the array of names
strArray = Split(strNames, " ")
Dim o As Variant
For Each o In strArray
dictNames.Add (o)
Next o
'Send back the collection
Set SplitNames = dictNames
End Function