Related
Unfortunately, sometimes when the if statements are more complex, behavior is quite strange, here is a copy of the line which doesnt work as expected when used like this
If someFunction(arg1, arg2, CreatedFromClass(arg3, arg4, arg5)) Then GoTo err1
someFunction(...) itself has return type long, but in this case is absolutely always evaluated as positive, even though someFunction before return contains 0 as a return value.
so, it can be wrapped as any of the following and result will be always true
If someFunction() = True Then
If someFunction() = False Then
If someFunction() = 0 Then
If someFunction() = 1 Then
If someFunction() <> 0 Then
If someFunction() <> 1 Then
If Not someFunction() = 0 Then
If Not someFunction() = 1 Then
If (someFunction() = 0) = False Then
If (someFunction() = 0) = True Then
If CBool(someFunction() = 0) = True Then
If CBool(someFunction() = 1) = True Then
but when is split into segments, and manually assigned to the variable, then works as expected
Dim rVal As Long
rVal = someFunction(arg1, arg2, CreatedFromClass(arg3, arg4, arg5))
If rVal Then GoTo err1
question is of course why the behavior is not the same? did someone experienced similar?
Additionally, after couple hours, i been able to isolate problematic piece of code!
Class: cls.cls
Option Explicit
Private mCol As Collection
Private Sub Class_Initialize()
Set mCol = New Collection
End Sub
Private Sub Class_Terminate()
Set mCol = Nothing
End Sub
Public Sub Add(iItem)
mCol.Add iItem
End Sub
Public Function DoCopy() As cls
Set DoCopy = New cls
Dim i As Long
For i = 1 To mCol.Count
DoCopy.Add mCol(i)
Next
End Function
and testing module
Option Explicit
Public Function CreateCls(ParamArray params()) As cls
Set CreateCls = New cls
If UBound(params) < 0 Then Exit Function
Dim i As Long
For i = LBound(params) To UBound(params)
CreateCls.Add params(i)
Next
End Function
Private Function doTest(iCls As cls) As Long
doTest = 0
End Function
Private Sub CATStart()
Dim x As cls
Set x = CreateCls("param1", "param2", "param3", "param4")
If doTest(x.DoCopy) = 0 Then Debug.Print "long_0"
If doTest(x.DoCopy) = 1 Then Debug.Print "long_1"
If CBool(doTest(x.DoCopy)) = True Then Debug.Print "bool_True"
If CBool(doTest(x.DoCopy)) = False Then Debug.Print "bool_False"
Set x = Nothing
End Sub
And of course all of them will be evaluated as True valid and result printed!
And yes, i found an answer on my question, in Catia, i have VBA version 7.1.1033, which doesn't work as expected, while the the same piece of code works in Excel, which uses newer VBA version, 7.1.1049...
So answer is, VBA has bug in that release..
Please help with the code error 424 below
Public counter As String
Private Sub Workbook_WindowActivate(ByVal Wn As Window)
If ActiveSheet1.Name = Sheet2.Name Then
If counter = 0 Or counter = Null Then
Call LLP_Hide
End If
End If
End Sub
Remove 1 from ActiveSheet1.
If counter is meant to count it should be declared as Integer type instead of String.
Anyway, this part of code will also cause error: counter = 0. Replace it with counter = "0" or change the type of counter.
Public counter As Integer
Private Sub Workbook_WindowActivate(ByVal Wn As Window)
If ActiveSheet.Name = Sheet2.Name Then
If counter = 0 Then
Call LLP_Hide
End If
End If
End Sub
I have an executable that I call using the shell command:
Shell (ThisWorkbook.Path & "\ProcessData.exe")
The executable does some computations, then exports results back to Excel. I want to be able to change the format of the results AFTER they are exported.
In other words, i need the Shell command first to WAIT until the executable finishes its task, exports the data, and THEN do the next commands to format.
I tried the Shellandwait(), but without much luck.
I had:
Sub Test()
ShellandWait (ThisWorkbook.Path & "\ProcessData.exe")
'Additional lines to format cells as needed
End Sub
Unfortunately, still, formatting takes place first before the executable finishes.
Just for reference, here was my full code using ShellandWait
' Start the indicated program and wait for it
' to finish, hiding while we wait.
Private Declare Function CloseHandle Lib "kernel32.dll" (ByVal hObject As Long) As Long
Private Declare Function WaitForSingleObject Lib "kernel32.dll" (ByVal hHandle As Long, ByVal dwMilliseconds As Long) As Long
Private Declare Function OpenProcess Lib "kernel32.dll" (ByVal dwDesiredAccessas As Long, ByVal bInheritHandle As Long, ByVal dwProcId As Long) As Long
Private Const INFINITE = &HFFFF
Private Sub ShellAndWait(ByVal program_name As String)
Dim process_id As Long
Dim process_handle As Long
' Start the program.
On Error GoTo ShellError
process_id = Shell(program_name)
On Error GoTo 0
' Wait for the program to finish.
' Get the process handle.
process_handle = OpenProcess(SYNCHRONIZE, 0, process_id)
If process_handle <> 0 Then
WaitForSingleObject process_handle, INFINITE
CloseHandle process_handle
End If
Exit Sub
ShellError:
MsgBox "Error starting task " & _
txtProgram.Text & vbCrLf & _
Err.Description, vbOKOnly Or vbExclamation, _
"Error"
End Sub
Sub ProcessData()
ShellAndWait (ThisWorkbook.Path & "\Datacleanup.exe")
Range("A2").Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select
With Selection
.HorizontalAlignment = xlLeft
.VerticalAlignment = xlTop
.WrapText = True
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
End Sub
Try the WshShell object instead of the native Shell function.
Dim wsh As Object
Set wsh = VBA.CreateObject("WScript.Shell")
Dim waitOnReturn As Boolean: waitOnReturn = True
Dim windowStyle As Integer: windowStyle = 1
Dim errorCode As Long
errorCode = wsh.Run("notepad.exe", windowStyle, waitOnReturn)
If errorCode = 0 Then
MsgBox "Done! No error to report."
Else
MsgBox "Program exited with error code " & errorCode & "."
End If
Though note that:
If bWaitOnReturn is set to false (the default), the Run method returns immediately after starting the program, automatically returning 0 (not to be interpreted as an error code).
So to detect whether the program executed successfully, you need waitOnReturn to be set to True as in my example above. Otherwise it will just return zero no matter what.
For early binding (gives access to Autocompletion), set a reference to "Windows Script Host Object Model" (Tools > Reference > set checkmark) and declare like this:
Dim wsh As WshShell
Set wsh = New WshShell
Now to run your process instead of Notepad... I expect your system will balk at paths containing space characters (...\My Documents\..., ...\Program Files\..., etc.), so you should enclose the path in "quotes":
Dim pth as String
pth = """" & ThisWorkbook.Path & "\ProcessData.exe" & """"
errorCode = wsh.Run(pth , windowStyle, waitOnReturn)
What you have will work once you add
Private Const SYNCHRONIZE = &H100000
which your missing. (Meaning 0 is being passed as the access right to OpenProcess which is not valid)
Making Option Explicit the top line of all your modules would have raised an error in this case
Shell-and-Wait in VBA (Compact Edition)
Sub ShellAndWait(pathFile As String)
With CreateObject("WScript.Shell")
.Run pathFile, 1, True
End With
End Sub
Example Usage:
Sub demo_Wait()
ShellAndWait ("notepad.exe")
Beep 'this won't run until Notepad window is closed
MsgBox "Done!"
End Sub
Adapted from (and more options at) Chip Pearson's site.
The WScript.Shell object's .Run() method as demonstrated in Jean-François Corbett's helpful answer is the right choice if you know that the command you invoke will finish in the expected time frame.
Below is SyncShell(), an alternative that allows you to specify a timeout, inspired by the great ShellAndWait() implementation. (The latter is a bit heavy-handed and sometimes a leaner alternative is preferable.)
' Windows API function declarations.
Private Declare Function OpenProcess Lib "kernel32.dll" (ByVal dwDesiredAccessas As Long, ByVal bInheritHandle As Long, ByVal dwProcId As Long) As Long
Private Declare Function CloseHandle Lib "kernel32.dll" (ByVal hObject As Long) As Long
Private Declare Function WaitForSingleObject Lib "kernel32.dll" (ByVal hHandle As Long, ByVal dwMilliseconds As Long) As Long
Private Declare Function GetExitCodeProcess Lib "kernel32.dll" (ByVal hProcess As Long, ByRef lpExitCodeOut As Long) As Integer
' Synchronously executes the specified command and returns its exit code.
' Waits indefinitely for the command to finish, unless you pass a
' timeout value in seconds for `timeoutInSecs`.
Private Function SyncShell(ByVal cmd As String, _
Optional ByVal windowStyle As VbAppWinStyle = vbMinimizedFocus, _
Optional ByVal timeoutInSecs As Double = -1) As Long
Dim pid As Long ' PID (process ID) as returned by Shell().
Dim h As Long ' Process handle
Dim sts As Long ' WinAPI return value
Dim timeoutMs As Long ' WINAPI timeout value
Dim exitCode As Long
' Invoke the command (invariably asynchronously) and store the PID returned.
' Note that this invocation may raise an error.
pid = Shell(cmd, windowStyle)
' Translate the PIP into a process *handle* with the
' SYNCHRONIZE and PROCESS_QUERY_LIMITED_INFORMATION access rights,
' so we can wait for the process to terminate and query its exit code.
' &H100000 == SYNCHRONIZE, &H1000 == PROCESS_QUERY_LIMITED_INFORMATION
h = OpenProcess(&H100000 Or &H1000, 0, pid)
If h = 0 Then
Err.Raise vbObjectError + 1024, , _
"Failed to obtain process handle for process with ID " & pid & "."
End If
' Now wait for the process to terminate.
If timeoutInSecs = -1 Then
timeoutMs = &HFFFF ' INFINITE
Else
timeoutMs = timeoutInSecs * 1000
End If
sts = WaitForSingleObject(h, timeoutMs)
If sts <> 0 Then
Err.Raise vbObjectError + 1025, , _
"Waiting for process with ID " & pid & _
" to terminate timed out, or an unexpected error occurred."
End If
' Obtain the process's exit code.
sts = GetExitCodeProcess(h, exitCode) ' Return value is a BOOL: 1 for true, 0 for false
If sts <> 1 Then
Err.Raise vbObjectError + 1026, , _
"Failed to obtain exit code for process ID " & pid & "."
End If
CloseHandle h
' Return the exit code.
SyncShell = exitCode
End Function
' Example
Sub Main()
Dim cmd As String
Dim exitCode As Long
cmd = "Notepad"
' Synchronously invoke the command and wait
' at most 5 seconds for it to terminate.
exitCode = SyncShell(cmd, vbNormalFocus, 5)
MsgBox "'" & cmd & "' finished with exit code " & exitCode & ".", vbInformation
End Sub
Simpler and Compressed Code with examples:
first declare your path
Dim path: path = ThisWorkbook.Path & "\ProcessData.exe"
And then use any one line of following code you like
1) Shown + waited + exited
VBA.CreateObject("WScript.Shell").Run path,1, True
2) Hidden + waited + exited
VBA.CreateObject("WScript.Shell").Run path,0, True
3) Shown + No waited
VBA.CreateObject("WScript.Shell").Run path,1, False
4) Hidden + No waited
VBA.CreateObject("WScript.Shell").Run path,0, False
I was looking for a simple solution too and finally ended up to make these two functions, so maybe for future enthusiast readers :)
1.) prog must be running, reads tasklist from dos, output status to
file, read file in vba
2.) start prog and wait till prog is closed with a wscript shell .exec waitonrun
3.) ask for confirmation to delete tmp file
Modify program name and path variables and run in one go.
Sub dosWOR_caller()
Dim pwatch As String, ppath As String, pfull As String
pwatch = "vlc.exe" 'process to watch, or process.exe (do NOT use on cmd.exe itself...)
ppath = "C:\Program Files\VideoLAN\VLC" 'path to the program, or ThisWorkbook.Path
pfull = ppath & "\" & pwatch 'extra quotes in cmd line
Dim fout As String 'tmp file for r/w status in 1)
fout = Environ("userprofile") & "\Desktop\dosWaitOnRun_log.txt"
Dim status As Boolean, t As Double
status = False
'1) wait until done
t = Timer
If Not status Then Debug.Print "run prog first for this one! then close it to stop dosWORrun ": Shell (pfull)
status = dosWORrun(pwatch, fout)
If status Then Debug.Print "elapsed time: "; Format(Timer - t, "#.00s")
'2) wait while running
t = Timer
Debug.Print "now running the prog and waiting you close it..."
status = dosWORexec(pfull)
If status = True Then Debug.Print "elapsed time: "; Format(Timer - t, "#.00s")
'3) or if you need user action
With CreateObject("wScript.Shell")
.Run "cmd.exe /c title=.:The end:. & set /p""=Just press [enter] to delete tmp file"" & del " & fout & " & set/p""=and again to quit ;)""", 1, True
End With
End Sub
Function dosWORrun(pwatch As String, fout As String) As Boolean
'redirect sdtout to file, then read status and loop
Dim i As Long, scatch() As String
dosWORrun = False
If pwatch = "cmd.exe" Then Exit Function
With CreateObject("wScript.Shell")
Do
i = i + 1
.Run "cmd /c >""" & fout & """ (tasklist |find """ & pwatch & """ >nul && echo.""still running""|| echo.""done"")", 0, True
scatch = fReadb(fout)
Debug.Print i; scatch(0)
Loop Until scatch(0) = """done"""
End With
dosWORrun = True
End Function
Function dosWORexec(pwatch As String) As Boolean
'the trick: with .exec method, use .stdout.readall of the WshlExec object to force vba to wait too!
Dim scatch() As String, y As Object
dosWORexec = False
With CreateObject("wScript.Shell")
Set y = .exec("cmd.exe /k """ & pwatch & """ & exit")
scatch = Split(y.stdout.readall, vbNewLine)
Debug.Print y.status
Set y = Nothing
End With
dosWORexec = True
End Function
Function fReadb(txtfile As String) As String()
'fast read
Dim ff As Long, data As String
'~~. Open as txt File and read it in one go into memory
ff = FreeFile
Open txtfile For Binary As #ff
data = Space$(LOF(1))
Get #ff, , data
Close #ff
'~~> Store content in array
fReadb = Split(data, vbCrLf)
'~~ skip last crlf
If UBound(fReadb) <> -1 Then ReDim Preserve fReadb(0 To UBound(fReadb) - 1)
End Function
I incorporated this into a routine, and it has worked fine (but not used very often) for several years - for which, many thanks !
But now I find it throws up an error :-
Run-time error '-2147024894 (80070002)':
Method 'Run' of object 'IWshSheB' failed
on the line -
ErrorCode = wsh.Run(myCommand, windowStyle, WaitOnReturn)
Very strange !
5 hours later !
I THINK the reason it fails is that dear MicroSoft ("dear" meaning expensive) has changed something radical - "Shell" USED to be "Shell to DOS", but has that been changed >=?
The "Command" that I want the Shell to run is simply DIR
In full, it is "DIR C:\Folder\ /S >myFIle.txt"
. . . . . . . . . . . . . . . . . . . . . .
An hour after that-
Yup !
I have "solved" it by using this Code, which works just fine :-
Sub ShellAndWait(PathFile As String, _
Optional Wait As Boolean = True, _
Optional Hidden As Boolean = True)
' Hidden = 0; Shown = 1
Dim Hash As Integer, myBat As String, Shown As Integer
Shown = 0
If Hidden Then Shown = 1
If Hidden <> 0 Then Hidden = 1
Hash = FreeFile
myBat = "C:\Users\Public\myBat.bat"
Open myBat For Output As #Hash
Print #Hash, PathFile
Close #Hash
With CreateObject("WScript.Shell")
.Run myBat, Shown, Wait
End With
End Sub
I would come at this by using the Timer function. Figure out roughly how long you'd like the macro to pause while the .exe does its thing, and then change the '10' in the commented line to whatever time (in seconds) that you'd like.
Strt = Timer
Shell (ThisWorkbook.Path & "\ProcessData.exe")
Do While Timer < Strt + 10 'This line loops the code for 10 seconds
Loop
UserForm2.Hide
'Additional lines to set formatting
This should do the trick, let me know if not.
Cheers, Ben.
Is there any way, in either VBA or C# code, to get a list of the existing macros defined in a workbook?
Ideally, this list would have a method definition signatures, but just getting a list of the available macros would be great.
Is this possible?
I haven't done vba for Excel in a long time, but if I remember well, the object model for the code was inaccessible through scripting.
When you try to access it, you receive the following error.
Run-time error '1004':
Programmatic access to Visual Basic Project is not trusted
Try:
Tools | Macro | Security |Trusted Publisher Tab
[x] Trust access to Visual Basic Project
Now that you have access to the VB IDE, you could probably export the modules and make a text search in them, using vba / c#, using regular expressions to find sub and function declarations, then delete the exported modules.
I'm not sure if there is an other way to do this, but this should work.
You can take a look the following link, to get started with exporting the modules.
http://www.developersdex.com/vb/message.asp?p=2677&ID=%3C4FCD0AE9-5DCB-4A96-8B3C-F19C63CD3635%40microsoft.com%3E
This is where I got the information about giving thrusted access to the VB IDE.
Building on Martin's answer, after you trust access to the VBP, you can use this set of code to get an array of all the public subroutines in an Excel workbook's VB Project. You can modify it to only include subs, or just funcs, or just private or just public...
Private Sub TryGetArrayOfDecs()
Dim Decs() As String
DumpProcedureDecsToArray Decs
End Sub
Public Function DumpProcedureDecsToArray(ByRef Result() As String, Optional InDoc As Excel.Workbook) As Boolean
Dim VBProj As Object
Dim VBComp As Object
Dim VBMod As Object
If InDoc Is Nothing Then Set InDoc = ThisWorkbook
ReDim Result(1 To 1500, 1 To 4)
DumpProcedureDecsToArray = True
On Error GoTo PROC_ERR
Set VBProj = InDoc.VBProject
Dim FuncNum As Long
Dim FuncDec As String
For Each VBComp In VBProj.vbcomponents
Set VBMod = VBComp.CodeModule
For i = 1 To VBMod.countoflines
If IsSubroutineDeclaration(VBMod.Lines(i, 1)) Then
FuncDec = RemoveBlanksAndDecsFromSubDec(RemoveAsVariant(VBMod.Lines(i, 1)))
If LCase(Left(VBMod.Lines(i, 1), Len("private"))) <> "private" Then
FuncNum = FuncNum + 1
Result(FuncNum, 1) = FindToLeftOfString(InDoc.Name, ".") '
Result(FuncNum, 2) = VBMod.Name
Result(FuncNum, 3) = GetSubName(FuncDec)
Result(FuncNum, 4) = VBProj.Name
End If
End If
Next i
Next VBComp
PROC_END:
Exit Function
PROC_ERR:
GoTo PROC_END
End Function
Private Function RemoveCharFromLeftOfString(TheString As String, RemoveChar As String) As String
Dim Result As String
Result = TheString
While LCase(Left(Result, Len(RemoveChar))) = LCase(RemoveChar)
Result = Right(Result, Len(Result) - Len(RemoveChar))
Wend
RemoveCharFromLeftOfString = Result
End Function
Private Function RemoveBlanksAndDecsFromSubDec(TheLine As String) As String
Dim Result As String
Result = TheLine
Result = RemoveCharFromLeftOfString(Result, " ")
Result = RemoveCharFromLeftOfString(Result, " ")
Result = RemoveCharFromLeftOfString(Result, "Public ")
Result = RemoveCharFromLeftOfString(Result, "Private ")
Result = RemoveCharFromLeftOfString(Result, " ")
RemoveBlanksAndDecsFromSubDec = Result
End Function
Private Function RemoveAsVariant(TheLine As String) As String
Dim Result As String
Result = TheLine
Result = Replace(Result, "As Variant", "")
Result = Replace(Result, "As String", "")
Result = Replace(Result, "Function", "")
If InStr(1, Result, "( ") = 0 Then
Result = Replace(Result, "(", "( ")
End If
RemoveAsVariant = Result
End Function
Private Function IsSubroutineDeclaration(TheLine As String) As Boolean
If LCase(Left(RemoveBlanksAndDecsFromSubDec(TheLine), Len("Function "))) = "function " Or LCase(Left(RemoveBlanksAndDecsFromSubDec(TheLine), Len("sub "))) = "sub " Then
IsSubroutineDeclaration = True
End If
End Function
Private Function GetSubName(DecLine As String) As String
GetSubName = FindToRightOfString(FindToLeftOfString(DecLine, "("), " ")
End Function
Function FindToLeftOfString(FullString As String, ToFind As String) As String
If FullString = "" Then Exit Function
Dim Result As String, ToFindPos As Integer
ToFindPos = InStr(1, FullString, ToFind, vbTextCompare)
If ToFindPos > 0 Then
Result = Left(FullString, ToFindPos - 1)
Else
Result = FullString
End If
FindToLeftOfString = Result
End Function
Function FindToRightOfString(FullString As String, ToFind As String) As String
If FullString = "" Then Exit Function
Dim Result As String, ToFindPos As Integer
ToFindPos = InStr(1, FullString, ToFind, vbTextCompare)
Result = Right(FullString, Len(FullString) - ToFindPos + 1 - Len(ToFind))
If ToFindPos > 0 Then
FindToRightOfString = Result
Else
FindToRightOfString = FullString
End If
End Function
How do I determine whether an object is a member of a collection in VBA?
Specifically, I need to find out whether a table definition is a member of the TableDefs collection.
Isn't it good enough?
Public Function Contains(col As Collection, key As Variant) As Boolean
Dim obj As Variant
On Error GoTo err
Contains = True
obj = col(key)
Exit Function
err:
Contains = False
End Function
Not exactly elegant, but the best (and quickest) solution i could find was using OnError. This will be significantly faster than iteration for any medium to large collection.
Public Function InCollection(col As Collection, key As String) As Boolean
Dim var As Variant
Dim errNumber As Long
InCollection = False
Set var = Nothing
Err.Clear
On Error Resume Next
var = col.Item(key)
errNumber = CLng(Err.Number)
On Error GoTo 0
'5 is not in, 0 and 438 represent incollection
If errNumber = 5 Then ' it is 5 if not in collection
InCollection = False
Else
InCollection = True
End If
End Function
Your best bet is to iterate over the members of the collection and see if any match what you are looking for. Trust me I have had to do this many times.
The second solution (which is much worse) is to catch the "Item not in collection" error and then set a flag to say the item does not exist.
This is an old question. I have carefully reviewed all the answers and comments, tested the solutions for performance.
I came up with the fastest option for my environment which does not fail when a collection has objects as well as primitives.
Public Function ExistsInCollection(col As Collection, key As Variant) As Boolean
On Error GoTo err
ExistsInCollection = True
IsObject(col.item(key))
Exit Function
err:
ExistsInCollection = False
End Function
In addition, this solution does not depend on hard-coded error values. So the parameter col As Collection can be substituted by some other collection type variable, and the function must still work. E.g., on my current project, I will have it as col As ListColumns.
You can shorten the suggested code for this as well as generalize for unexpected errors.
Here you go:
Public Function InCollection(col As Collection, key As String) As Boolean
On Error GoTo incol
col.Item key
incol:
InCollection = (Err.Number = 0)
End Function
In your specific case (TableDefs) iterating over the collection and checking the Name is a good approach. This is OK because the key for the collection (Name) is a property of the class in the collection.
But in the general case of VBA collections, the key will not necessarily be part of the object in the collection (e.g. you could be using a Collection as a dictionary, with a key that has nothing to do with the object in the collection). In this case, you have no choice but to try accessing the item and catching the error.
I created this solution from the above suggestions mixed with microsofts solution of for iterating through a collection.
Public Function InCollection(col As Collection, Optional vItem, Optional vKey) As Boolean
On Error Resume Next
Dim vColItem As Variant
InCollection = False
If Not IsMissing(vKey) Then
col.item vKey
'5 if not in collection, it is 91 if no collection exists
If Err.Number <> 5 And Err.Number <> 91 Then
InCollection = True
End If
ElseIf Not IsMissing(vItem) Then
For Each vColItem In col
If vColItem = vItem Then
InCollection = True
GoTo Exit_Proc
End If
Next vColItem
End If
Exit_Proc:
Exit Function
Err_Handle:
Resume Exit_Proc
End Function
I have some edit, best working for collections:
Public Function Contains(col As collection, key As Variant) As Boolean
Dim obj As Object
On Error GoTo err
Contains = True
Set obj = col.Item(key)
Exit Function
err:
Contains = False
End Function
For the case when key is unused for collection:
Public Function Contains(col As Collection, thisItem As Variant) As Boolean
Dim item As Variant
Contains = False
For Each item In col
If item = thisItem Then
Contains = True
Exit Function
End If
Next
End Function
this version works for primitive types and for classes (short test-method included)
' TODO: change this to the name of your module
Private Const sMODULE As String = "MVbaUtils"
Public Function ExistsInCollection(oCollection As Collection, sKey As String) As Boolean
Const scSOURCE As String = "ExistsInCollection"
Dim lErrNumber As Long
Dim sErrDescription As String
lErrNumber = 0
sErrDescription = "unknown error occurred"
Err.Clear
On Error Resume Next
' note: just access the item - no need to assign it to a dummy value
' and this would not be so easy, because we would need different
' code depending on the type of object
' e.g.
' Dim vItem as Variant
' If VarType(oCollection.Item(sKey)) = vbObject Then
' Set vItem = oCollection.Item(sKey)
' Else
' vItem = oCollection.Item(sKey)
' End If
oCollection.Item sKey
lErrNumber = CLng(Err.Number)
sErrDescription = Err.Description
On Error GoTo 0
If lErrNumber = 5 Then ' 5 = not in collection
ExistsInCollection = False
ElseIf (lErrNumber = 0) Then
ExistsInCollection = True
Else
' Re-raise error
Err.Raise lErrNumber, mscMODULE & ":" & scSOURCE, sErrDescription
End If
End Function
Private Sub Test_ExistsInCollection()
Dim asTest As New Collection
Debug.Assert Not ExistsInCollection(asTest, "")
Debug.Assert Not ExistsInCollection(asTest, "xx")
asTest.Add "item1", "key1"
asTest.Add "item2", "key2"
asTest.Add New Collection, "key3"
asTest.Add Nothing, "key4"
Debug.Assert ExistsInCollection(asTest, "key1")
Debug.Assert ExistsInCollection(asTest, "key2")
Debug.Assert ExistsInCollection(asTest, "key3")
Debug.Assert ExistsInCollection(asTest, "key4")
Debug.Assert Not ExistsInCollection(asTest, "abcx")
Debug.Print "ExistsInCollection is okay"
End Sub
It requires some additional adjustments in case the items in the collection are not Objects, but Arrays. Other than that it worked fine for me.
Public Function CheckExists(vntIndexKey As Variant) As Boolean
On Error Resume Next
Dim cObj As Object
' just get the object
Set cObj = mCol(vntIndexKey)
' here's the key! Trap the Error Code
' when the error code is 5 then the Object is Not Exists
CheckExists = (Err <> 5)
' just to clear the error
If Err <> 0 Then Call Err.Clear
Set cObj = Nothing
End Function
Source: http://coderstalk.blogspot.com/2007/09/visual-basic-programming-how-to-check.html
It works for me
Public Function contains(col As Collection, key As Variant) As Boolean
For Each element In col
If (element = key) Then
contains = True
Exit Function
End If
Next
contains = False
End Function
Not my code, but I think it's pretty nicely written. It allows to check by the key as well as by the Object element itself and handles both the On Error method and iterating through all Collection elements.
https://danwagner.co/how-to-check-if-a-collection-contains-an-object/
I'll not copy the full explanation since it is available on the linked page. Solution itself copied in case the page eventually becomes unavailable in the future.
The doubt I have about the code is the overusage of GoTo in the first If block but that's easy to fix for anyone so I'm leaving the original code as it is.
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'INPUT : Kollection, the collection we would like to examine
' : (Optional) Key, the Key we want to find in the collection
' : (Optional) Item, the Item we want to find in the collection
'OUTPUT : True if Key or Item is found, False if not
'SPECIAL CASE: If both Key and Item are missing, return False
Option Explicit
Public Function CollectionContains(Kollection As Collection, Optional Key As Variant, Optional Item As Variant) As Boolean
Dim strKey As String
Dim var As Variant
'First, investigate assuming a Key was provided
If Not IsMissing(Key) Then
strKey = CStr(Key)
'Handling errors is the strategy here
On Error Resume Next
CollectionContains = True
var = Kollection(strKey) '<~ this is where our (potential) error will occur
If Err.Number = 91 Then GoTo CheckForObject
If Err.Number = 5 Then GoTo NotFound
On Error GoTo 0
Exit Function
CheckForObject:
If IsObject(Kollection(strKey)) Then
CollectionContains = True
On Error GoTo 0
Exit Function
End If
NotFound:
CollectionContains = False
On Error GoTo 0
Exit Function
'If the Item was provided but the Key was not, then...
ElseIf Not IsMissing(Item) Then
CollectionContains = False '<~ assume that we will not find the item
'We have to loop through the collection and check each item against the passed-in Item
For Each var In Kollection
If var = Item Then
CollectionContains = True
Exit Function
End If
Next var
'Otherwise, no Key OR Item was provided, so we default to False
Else
CollectionContains = False
End If
End Function
i used this code to convert array to collection and back to array to remove duplicates, assembled from various posts here (sorry for not giving properly credit).
Function ArrayRemoveDups(MyArray As Variant) As Variant
Dim nFirst As Long, nLast As Long, i As Long
Dim item As Variant, outputArray() As Variant
Dim Coll As New Collection
'Get First and Last Array Positions
nFirst = LBound(MyArray)
nLast = UBound(MyArray)
ReDim arrTemp(nFirst To nLast)
i = nFirst
'convert to collection
For Each item In MyArray
skipitem = False
For Each key In Coll
If key = item Then skipitem = True
Next
If skipitem = False Then Coll.Add (item)
Next item
'convert back to array
ReDim outputArray(0 To Coll.Count - 1)
For i = 1 To Coll.Count
outputArray(i - 1) = Coll.item(i)
Next
ArrayRemoveDups = outputArray
End Function
I did it like this, a variation on Vadims code but to me a bit more readable:
' Returns TRUE if item is already contained in collection, otherwise FALSE
Public Function Contains(col As Collection, item As String) As Boolean
Dim i As Integer
For i = 1 To col.Count
If col.item(i) = item Then
Contains = True
Exit Function
End If
Next i
Contains = False
End Function
I wrote this code. I guess it can help someone...
Public Function VerifyCollection()
For i = 1 To 10 Step 1
MyKey = "A"
On Error GoTo KillError:
Dispersao.Add 1, MyKey
GoTo KeepInForLoop
KillError: 'If My collection already has the key A Then...
count = Dispersao(MyKey)
Dispersao.Remove (MyKey)
Dispersao.Add count + 1, MyKey 'Increase the amount in relationship with my Key
count = Dispersao(MyKey) 'count = new amount
On Error GoTo -1
KeepInForLoop:
Next
End Function