Working with Win64, VBA7 32bits on a simple combo of procedures to do things to an instance of Internet Explorer (IE instance), I've found that:
a. the function correctly identifies the IE instance type as IWebBrowser2;
b. the sub incorrectly identifies the IE instance type as String.
Would anyone gently share why?
Thanks in advance.
Sub SimpleTest()
Dim iemIE As InternetExplorer
Dim oDummy As Object
Set ieIE = New InternetExplorer
Set oDummy = mahFunction(ieIE)
mahSub (ieIE)
ieIE.Quit
End Sub
Function mahFunction(InternetExplorerThatHasMahObject As Variant) As Object
Dim sFunctionTypeName As String
Dim bFunctionTestIE As Boolean, bFunctionTestIEM As Boolean
sFunctionTypeName = TypeName(InternetExplorerThatHasMahObject) 'returns "IWebBrowser2"
bFunctionTestIE = TypeOf InternetExplorerThatHasMahObject Is InternetExplorer 'returns True
bFunctionTestIEM = TypeOf InternetExplorerThatHasMahObject Is InternetExplorerMedium 'returns True
MsgBox sFunctionTypeName & ", " & bFunctionTestIE & ", " & bFunctionTestIEM
Set mahFunction = Nothing
End Function
Sub mahSub(InternetExplorerToWaitFor As Variant)
Dim sSubTypeName As String
Dim bSubTestIE As Boolean, bSubTestIEM As Boolean
sSubTypeName = TypeName(InternetExplorerToWaitFor) 'returns "String"
bSubTestIE = TypeOf InternetExplorerToWaitFor Is InternetExplorer 'returns False
bSubTestIEM = TypeOf InternetExplorerToWaitFor Is InternetExplorerMedium 'returns False
MsgBox sSubTypeName & ", " & bSubTestIE & ", " & bSubTestIEM
End Sub
Related
i'm currently using below function to find a MS project task based on custom field value, it works perfectly when a parent task object is provided, it only loops through children tasks. The problem is that now in plan target task could be placed any where in plan and it takes some time looping through all the ~3k tasks in plan trying to find the correct task based on custom field value. Is there a way i could do this faster?
**'sub to test Function**
Public Sub TestFunction()
Dim TaskObject as Object
Dim MSapp as Object '<- MS project application
Dim ErrMsg as String
set TaskObject = funGetTaskByFieldRef(objMSPapp:=MSapp,
fieldValue:="Key1234",
fieldName:= "customForeingKeyField",
ErrMsg:= ErrMsg)
if TaskObject is nothing then
MsgBox ErrMsg
else
Debug.Print TaskObject.UniqueID & " - " & TaskObject.Name
end if
End Sub
**'Function - - -**
Public Function funGetTaskByFieldRef(ByRef objMSPapp As Object, ByVal fieldValue As String, _
ByVal fieldName As String, _
Optional ByRef objParentTask As Object, _
Optional ByRef ErrMsg As String = vbNullString) As Object
'<VARIABLES>
Dim obMSPprj As Object
Dim tsk As Object
Dim tmpValue As String
'</VARIABLES>
'<FUN> ---
'set temporal var Microsoft Project
Set obMSPprj = objMSPapp.ActiveProject
'using project
With obMSPprj
'check if parent task has been provided
If Not objParentTask Is Nothing Then
'loop through each child
For Each tsk In objParentTask.OutlineChildren
tmpValue = funSetGetMSPval(objMSPapp, tsk, 0, "Get", fieldName)
If tmpValue = fieldValue Then
'retunr UID
Set funGetTaskByFieldRef = tsk
'exit function
Exit Function
End If
Next tsk
Else
'loop through each task
For Each tsk In .Tasks
tmpValue = funSetGetMSPval(objMSPapp, tsk, 0, "Get", fieldName)
If tmpValue = fieldValue Then
'retunr UID
Set funGetTaskByFieldRef = tsk
'exit function
Exit Function
End If
Next tsk
End If
End With
'if there is no exact match for task name return -1
Set funGetTaskByFieldRef = Nothing
ErrMsg = "Task not found"
'<FUN> ---
End Function
**'Encapsulated sub-function **
Public Function funSetGetMSPval(ByRef objMSPapp As Object, ByRef objEntObj As Object, _
ByVal intPjFieldType As Integer, ByVal strAction As String, _
Optional ByVal strFldName As String, _
Optional ByVal strVal As String) As Variant
'pjProject = 2
'pjResource =1
'pjTask = 0
With objMSPapp
Select Case strAction
Case "Set"
On Error Resume Next
objEntObj.SetField .FieldNameToFieldConstant(strFldName, intPjFieldType), strVal
If Not Err.Number <> 0 Then
'catch error
End If
On Error GoTo 0
funSetGetMSPval = True
Case "Get"
funSetGetMSPval = objEntObj.getfield(.FieldNameToFieldConstant(strFldName, intPjFieldType))
End Select
End With
End Function
Hope there is someone that has a better way to do this.
thank you.
regards.
Is there a way i could do this faster?
Yes, use the Find method.
Public Sub FindTask()
Dim TaskObject As Object
Dim MSapp As Object
Set MSapp = Application
Dim found As Boolean
found = MSapp.Find(Field:="customForeingKeyField", Test:="equals", Value:="Key1234")
If found Then
Set TaskObject = MSapp.ActiveCell.Task
Debug.Print TaskObject.UniqueID & " - " & TaskObject.Name
Else
MsgBox "Task not found"
End If
End Sub
I got an issue with "casting" variants to defined objects.
At runtime my variant variable is of type "Variant/Object/Listbox", which i then want to set to a ListBox variable to route it as a parameter to another function (GetSelected) that requires a Listbox object.
But I get the error 13: types incompatible on command "Set lst = v".
Any ideas how to get it working?
Code:
Function GetEditableControlsValues(EditableControls As Collection) As Collection
'Gibt die Werte der editierbaren Felder zurück.
Dim v As Variant
Dim coll As New Collection
Dim lst As ListBox
For Each v In EditableControls
If TypeName(v) = "ListBox" Then
Set lst = v 'Fehler 13: Typen unverträglich. v zur Laufzeit: Variant/Object/Listbox.
coll.Add GetCollectionString(GetSelected(lst))
Else
coll.Add v.Value
End If
Next
End Function
This is what I have so far:
Imagine that you have a module with the following code in it:
Option Explicit
Public Sub TestMe()
Dim colInput As New Collection
Dim colResult As Collection
Dim lngCount As Long
Dim ufMyUf As UserForm
Set ufMyUf = UserForm1
Set colInput = GetListBoxObjects(ufMyUf)
For lngCount = 1 To colInput.Count
Debug.Print colInput(lngCount).Name
Next lngCount
End Sub
Function GetListBoxObjects(uf As UserForm) As Collection
Dim colResult As New Collection
Dim objObj As Object
Dim ctrCont As Control
For Each ctrCont In uf.Controls
If LCase(Left(ctrCont.Name, 7)) = "listbox" Then
Set objObj = ctrCont
colResult.Add objObj
End If
Next ctrCont
Set GetListBoxObjects = colResult
End Function
If you run TestMe, you would get a collection of the ListBox objects. Anyhow, I am not sure how do you pass them to the collection function, thus I have decided to iterate over the UserForm and thus to check all of the objects on it.
Cheers!
I had problems with casting controls myself and didn't find a general solution that I could use easy.
Eventually I found the way to do it: store as "Object" makes it easy to convert to whatever type the control actually is.
I tested (and use) it
The sub below shows that it works (here : 1 TextBox; 1 ListBox; 1 ComboBox; 1 CommandButton on a worksheet)
Sub Test_Casting()
Dim lis As MSForms.ListBox
Dim txt As MSForms.TextBox
Dim btn As MSForms.CommandButton
Dim com As MSForms.ComboBox
Dim numObjects As Integer: numObjects = Me.OLEObjects.Count
Dim obj() As Object
ReDim obj(1 To numObjects) As Object
Dim i As Integer: i = 0
Dim cttl As OLEObject
For Each ctrl In Me.OLEObjects
i = i + 1
Set obj(i) = ctrl.Object
Next ctrl
Dim result As String
For i = 1 To numObjects
If TypeOf obj(i) Is MSForms.ListBox Then
Set lis = obj(i): result = lis.Name
ElseIf TypeOf obj(i) Is MSForms.TextBox Then
Set txt = obj(i): result = txt.Name
ElseIf TypeOf obj(i) Is MSForms.CommandButton Then
Set btn = obj(i): result = btn.Name
ElseIf TypeOf obj(i) Is MSForms.ComboBox Then
Set ComboBox = obj(i): result = com.Name
Else
result = ""
End If
If (Not (result = "")) Then Debug.Print TypeName(obj(i)) & " name= " & result
Next i
For i = 1 To numObjects
Set lis = IsListBox(obj(i))
Set txt = IsTextBox(obj(i))
Set btn = IsCommandButton(obj(i))
Set com = IsComboBox(obj(i))
result = ""
If (Not (lis Is Nothing)) Then
result = "ListBox " & lis.Name
ElseIf (Not (txt Is Nothing)) Then
result = "TexttBox " & txt.Name
ElseIf (Not (btn Is Nothing)) Then
result = "CommandButton " & btn.Name
ElseIf (Not (com Is Nothing)) Then
result = "ComboBox " & com.Name
End If
Debug.Print result
Next i
End Sub
Function IsListBox(obj As Object) As MSForms.ListBox
Set IsListBox = IIf(TypeOf obj Is MSForms.ListBox, obj, Nothing)
End Function
Function IsTextBox(obj As Object) As MSForms.TextBox
Set IsTextBox = IIf(TypeOf obj Is MSForms.TextBox, obj, Nothing)
End Function
Function IsComboBox(obj As Object) As MSForms.ComboBox
Set IsComboBox = IIf(TypeOf obj Is MSForms.ComboBox, obj, Nothing)
End Function
Function IsCommandButton(obj As Object) As MSForms.CommandButton
Set IsCommandButton = IIf(TypeOf obj Is MSForms.CommandButton, obj, Nothing)
End Function
One use for it is a class for handling events in one class.
Private WithEvents intEvents As IntBoxEvents
Private WithEvents decEvents As DecBoxEvents
Private genEvents As Object
Private genControl as OLEobject
Public sub Delegate(ctrl As OLEObject)
set genControl = ctrl
' Code for creating intEvents or decEvents
if .... create intevents.... then set genEvents = new IntEvents ' pseudo code
if .... create decevents.... then set genEvents = new DecEvents ' pseudo code
end sub
I hope this helps others that struggle with casting controls
I want to get the shape information out of a state (UML Standard Stencil). You can see in the picture the title "Aktiv" and "Eintritt/" etc. I have no clue where to get this as a variable.
Edit:
To make it clear, I don't know how I can get the information out of a UML shape in Visio. Here is an example code:
Private Sub test()
Dim s As Shape
Dim vsoPage As Visio.Page
Dim getStateName As String
'I need the name for example "Aktiv" from the state
'and the name of the "Sub" information as "Eintritt" etc.
Set vsoPage = ThisDocument.Pages(1)
For Each s In vsoPage.Shapes
getStateName = s.????
Next s
End Sub
Okay I found a solution, I don't know if there is a nicer one though.
Private Sub test()
Dim s As Shape
Dim vsoPage As Visio.Page
Dim getStateTitle As String
Dim getStateSubTitle As String
Set vsoPage = ThisDocument.Pages(1)
For Each s In vsoPage.Shapes
If Contains(s) = False Then
'Not a Stateshape
Else
getStateTitle = getStateTitle & s.Shapes.Item(1).Text & vbCrLf
getStateSubTitle = getStateSubTitle & s.Text & vbCrLf
End If
Next s
End Sub
with
Public Function Contains(s As Shape) As Boolean
Dim DummyString As String
On Error GoTo err
Contains = True
DummyString = s.Shapes.Item(1)
Exit Function
err:
Contains = False
End Function
So the state shape contains actually two shapes thus you can get the information from Item 1 or 2.
I'm trying to use IEdmEnumeratorVariable5::SetVar to update some file card variables based on user input into a windows form. My code executes, there are no error messages, the file is checked out and checked back in and the appropriate comment is added to the history; however the variables on the card are not updated.
I have verified by stepping through code at runtime that all variables are populated with the correct (as expected) data. The SetVar procedures all go off without a hitch, but the variables on the data card do not change value - even manually refreshing the folder view has no effect.
Below is my code.
This is an add-in application, written as a class-library project in VB using VS Community 2015, with target framework .NET 4.0.
In efforts to make this question more concise; immediately below I've included just the snippet of code doing the set variables work, then I've also included more code so you can get the whole picture if needed.
JUST THE TIP :
This is the code doing the set variables work:
Dim UserManager As IEdmUserMgr5 = .SourceVault
Dim User As IEdmUser5 = UserManager.GetLoggedInUser
CardComment = UserComment & CardComment
CardDate = Today().ToString("yyMMdd", Globalization.CultureInfo.InvariantCulture)
CardBy = User.Name
CardDisposition = UserDisposition
CardVariables.SetVar(DispositionVariable, "#", CardDisposition)
CardVariables.SetVar(CommentVariable, "#", CardComment)
CardVariables.SetVar(ByVariable, "#", CardBy)
CardVariables.SetVar(DateVariable, "#", CardDate)
CardVariables.Flush()
THE BROADER STROKES :
Class module level variables:
Private Structure CommandInfo
Dim SourceVault As IEdmVault11
Dim SourceCommand As EdmCmd
Dim SourceSelection As System.Array
Dim TargetTemplate As System.String
Dim VerifiedPaths As List(Of String)
End Structure
Private ReceivedCommand As CommandInfo
OnCmd procedure (caller):
Public Sub OnCmd(ByRef poCmd As EdmCmd,
ByRef ppoData As System.Array) Implements IEdmAddIn5.OnCmd
Dim CommandToRun As MenuCommand
Try
With ReceivedCommand
.SourceVault = poCmd.mpoVault
.SourceCommand = poCmd
.SourceSelection = ppoData
'Get the command structure for the command ID
Select Case poCmd.meCmdType
Case EdmCmdType.EdmCmd_Menu
CommandToRun = AvailableCommands(.SourceCommand.mlCmdID)
Case EdmCmdType.EdmCmd_CardButton
Select Case True
Case poCmd.mbsComment.ToString.ToUpper.Contains("DISPOSITION")
DispositionRequest()
Case Else : Exit Sub
End Select
Case Else : Exit Sub
End Select
'...... (End Try, End Sub, Etc.)
DispositionRequest procedure (callee):
Private Sub DispositionRequest()
Dim UserDisposition As String
Using Disposition As New DispositionForm
With Disposition
If Not .ShowDialog() = System.Windows.Forms.DialogResult.OK Then Exit Sub
Select Case True
Case .Approve.Checked
UserDisposition = "Approved"
Case .Reject.Checked
UserDisposition = "Rejected"
Case Else : Exit Sub
End Select
End With
End Using
Dim UserComment As String
Using Explanation As New DispositionExplanation
With Explanation
If Not .ShowDialog() = System.Windows.Forms.DialogResult.OK Then Exit Sub
If .ListView1.Items.Count > 0 Then
'do some stuff not relevant to this question...
End If
UserComment = .Comments.Text
End With
End Using
'This next procedure just gets a list of paths from ReceivedCommand.SourceSelection - which is just the ppoData argument from the OnCmd procedure - see code block above!
Dim RequestPaths As List(Of String) = GetSelectedFilePaths()
For Each Path As String In RequestPaths
With ReceivedCommand
Dim RequestFile As IEdmFile5 = .SourceVault.GetFileFromPath(Path)
Dim ParentFolder As IEdmFolder6 = .SourceVault.GetFolderFromPath(System.IO.Path.GetDirectoryName(Path))
Dim UnlockLater As Boolean = False
If Not RequestFile.IsLocked Then
UnlockLater = True
RequestFile.LockFile(ParentFolder.ID, .SourceCommand.mlParentWnd, CInt(EdmLockFlag.EdmLock_Simple))
End If
Dim CardVariables As IEdmEnumeratorVariable5 = RequestFile.GetEnumeratorVariable
'We allow users to re-disposition a request so we want to keep any previous disposition information so it is not lost
Dim CardComment As String = String.Empty
Dim CardBy As String = String.Empty
Dim CardDate As String = String.Empty
Dim CardDisposition As String = String.Empty
Dim Success As Boolean
Const CommentVariable As String = "DispComm"
Const ByVariable As String = "DisposedBy"
Const DateVariable As String = "DisposedDate"
Const DispositionVariable As String = "Disposition"
Success = CardVariables.GetVar(DispositionVariable, "#", CardDisposition)
If Success Then
Success = CardVariables.GetVar(CommentVariable, "#", CardComment)
If Success Then Success = CardVariables.GetVar(ByVariable, "#", CardBy)
If Success Then Success = CardVariables.GetVar(DateVariable, "#", CardDate)
If Success Then CardComment = "Previously dispositioned as: """ & CardDisposition & """ by: " & CardBy & " on: " & CardDate & vbNewLine &
"---------Previous disposition explanation---------" & vbNewLine & CardComment
End If
Dim UserManager As IEdmUserMgr5 = .SourceVault
Dim User As IEdmUser5 = UserManager.GetLoggedInUser
CardComment = UserComment & CardComment
CardDate = Today().ToString("yyMMdd", Globalization.CultureInfo.InvariantCulture)
CardBy = User.Name
CardDisposition = UserDisposition
CardVariables.SetVar(DispositionVariable, "#", CardDisposition)
CardVariables.SetVar(CommentVariable, "#", CardComment)
CardVariables.SetVar(ByVariable, "#", CardBy)
CardVariables.SetVar(DateVariable, "#", CardDate)
CardVariables.Flush()
If UnlockLater Then RequestFile.UnlockFile(lParentWnd:= .SourceCommand.mlParentWnd,
bsComment:="Dispositioned as " & CardDisposition,
lEdmUnlockFlags:=0)
.SourceVault.RefreshFolder(ParentFolder.LocalPath)
End With
Next
End Sub
From the documentation:
bsCfgName : Name of configuration or layout to which to store the variable value; empty string for folders and file types that do not support configurations
I was working with a virtual file, which did not support configurations.
I saw a C example working with a virtual file and they were passing null references, so I reread the documentation and saw that excerpt above, so I changed my code from "#" to String.Empty for the mboconfiguration argument and now it is working!
CardVariables.SetVar(DispositionVariable, String.Empty, CardDisposition)
CardVariables.SetVar(CommentVariable, String.Empty, CardComment)
CardVariables.SetVar(ByVariable, String.Empty, CardBy)
CardVariables.SetVar(DateVariable, String.Empty, CardDate)
CardVariables.Flush()
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