I am trying to add a button to my worksheet during run-time. This button should just display different worksheet that is also created on during run-time. I added button like this:
Dim btnShowTable
Set btnShowTable = ActiveSheet.Buttons.Add(rowRange.Left + 10, rowRange.Top + 10, rowRange.Width - 20, rowRange.Height - 20)
btnShowTable.Caption = "Show table data"
btnShowTable.OnAction = AddClickHandler_ShowSheet("ClickModule", "TableView", tableSheet)
Function AddClickHandler_ShowSheet(ByVal moduleName As String, ByVal btnName As String, ws As Worksheet)
Dim methodName As String
methodName = btnName & "_" & AddClickHandler_GetId() & "_Click"
Dim LineNum As Long
Dim VBCodeMod As CodeModule
Set VBCodeMod = ThisWorkbook.VBProject.VBComponents(moduleName).CodeModule
With VBCodeMod
LineNum = .CountOfLines + 1
.InsertLines LineNum, _
"Sub " & methodName & "()" & Chr(13) & _
" " & ws.CodeName & ".Select" & Chr(13) & _
"End Sub"
End With
AddClickHandler_ShowSheet = moduleName & "." & methodName
End Function
Function that creates the button is in one module while AddClickHandler_ShowSheet is in another.
The idea is that I would have separate module that would contain all these click handlers so that I could easily delete all of them.
This works ok. The handlers are created and buttons work as expected. The issue that I have is that, when this InsertLines method is called, all of my module variables in a module that contains the function for button creation are lost.
I have 4 module variables
Dim xmldoc As New MSXML2.DOMDocument
Dim xmlDataMap() As DataNode
Dim xmlDataMapLast As Integer
Dim xmlTables As Collection
after a call to InsertLines all of them became empty except for xmlDataMapLast which contains correct value of 14.
If I try to debug this method when I step over InserLines call I get an error "Can't enter break mode at this time." and I can't debug anything until my function ends. If I comment out the call to AddClickHandler_ShowSheet my variables remain intact, so it must be something related to that call.
Am I trying to achieve the impossible or am I just doing it the wrong way?
It's no surprise the module is reset.
In fact, I would expect value types to reset, too. It's a bit of surprise
they survive.
Why would you need to store variables in the module you use for code generation?
Store them in a separate module and only use this module for code generation.
Having that said, why would you dynamically add code in the first place?
OnAction supports parameters:
Sub asdff()
Worksheets(1).Buttons(1).OnAction = "'Module1.ParametrizedHandler 5, ""Hi there""'"
End Sub
Public Sub ParametrizedHandler(ByVal foo As Long, ByVal bar As String)
MsgBox foo, vbInformation, bar
End Sub
Note the absence of parentheses in the call string, and the single quotes around it.
Related
I've created an event sink module using this code I found online (can't remember where it was now, it was from a tutorial). It's split into a class module and a standard module.
The standard module:
Option Explicit
Private mEventSink As clsEventSink
Dim vsoDocumentEvents As Visio.EventList 'Events of the Document class
'DOCUMENT-CLASS EVENTS
Dim vsoDocumentSavedEvent As Visio.Event
Dim vsoPageAddedEvent As Visio.Event
Dim vsoShapesDeletedEvent As Visio.Event
Private Const visEvtAdd% = &H8000
Public Sub CreateEventObjects()
'Create an instance of the clsEventSink class
'to pass to the AddAdvise method.
Set mEventSink = New clsEventSink
'Get the EventList collection of the active document.
Set vsoDocumentEvents = ActiveDocument.EventList
Set vsoAppEvents = Application.EventList
'Add an Event object for the BeforeShapeDelete event.
Set vsoShapesDeletedEvent = vsoDocumentEvents.AddAdvise(visEvtCodeShapeDelete, mEventSink, "", "Shapes deleted...")
'Add an Event object for the DocumentSaved event.
Set vsoDocumentSavedEvent = vsoDocumentEvents.AddAdvise(visEvtCodeDocSave, mEventSink, "", "Document saved...")
'Add an Event object for the PageAdded event.
Set vsoPageAddedEvent = vsoDocumentEvents.AddAdvise(visEvtAdd + visEvtPage, mEventSink, "", "Page added...")
End Sub
Public Sub DeleteEventObjects()
'Delete the Event object for the DocumentSaved event.
vsoDocumentSavedEvent.Delete
Set vsoDocumentSavedEvent = Nothing
'Delete the Event object for the PageAdded event.
vsoPageAddedEvent.Delete
Set vsoPageAddedEvent = Nothing
'Delete the Event object for the ShapesDeleted event.
vsoShapesDeletedEvent.Delete
Set vsoShapesDeletedEvent = Nothing
End Sub
And the class module:
Implements Visio.IVisEventProc
Private Const visEvtAdd% = &H8000
Private Function IVisEventProc_VisEventProc( _
ByVal nEventCode As Integer, _
ByVal pSourceObj As Object, _
ByVal nEventID As Long, _
ByVal nEventSeqNum As Long, _
ByVal pSubjectObj As Object, _
ByVal vMoreInfo As Variant) As Variant
''''''''''''''''''''''''''''''''''''''''''''''''
Select Case nEventCode
Case visEvtCodeDocSave
'YOUR CODE FOR WHAT HAPPENS WHEN THE USER SAVES THE DOCUMENT GOES HERE
Debug.Print "DocumentSaved (" & Hex(nEventCode) & ")"
''''''''''''''''''''''''''''''''''''''''''''''''
Case (visEvtPage + visEvtAdd)
Debug.Print "Page Added (" & Hex(nEventCode) & ")"
''''''''''''''''''''''''''''''''''''''''''''''''
Case visEvtCodeShapeDelete
'YOUR CODE FOR WHAT HAPPENS WHEN THE USER DELETES A SHAPE GOES HERE
'Debug.Print "ShapesDeleted(" & Hex(nEventCode) & ")"
Debug.Print pSubjectObj.PrimaryItem.Name
'returns Sheet.??? instead of the desired local name
''''''''''''''''''''''''''''''''''''''''''''''''
Case Else
'YOUR CODE FOR WHAT HAPPENS WHEN AN EVENT NOT LISTED ABOVE OCCURS, GOES HERE
Debug.Print "Other (" & Hex(nEventCode) & ")"
End Select
End Function
Now, my question in particular is about the BeforeShapeDelete event. When I delete a shape, I've set up the code to print to Visual Basic's debug window the name of the shape that will be deleted. The only issue is, it prints the global name (e.g. Sheet.1, Sheet.2, Sheet.3, etc.) If I were to create a shape, rename it using the Shape Name menu in the Developer tab to something else, e.g. "Square", and then delete that shape, it still prints a shape name of the form Shape.XX rather than whatever I renamed it to. How can I get the non-global shape name instead? I've tried pSubjectObj.PrimaryItem.LocalName but that doesn't come up as a valid property of the class object.
I don't know the answer to your question (why you don't get name there), but maybe I could suggest something. Please note that when you try to access the shape identifier, the shape is already deleted. If you want to be notified before deletion, you could use visEvtCodeBefSelDel code.
Or better yet, don't use AddAdvise/VisEventProc (unless you absolutely have to for whatever reason), and go with a simple straightforward approach of using "BeforeSelectionDelete" event. Meaning, remove the class module, and instead of your code, simply put in "ThisDocument":
Private Sub Document_BeforeSelectionDelete(selection)
Debug.Print selection.PrimaryItem.Name
End Sub
And it should work.
In a variable I stored a function name, but when I try to call it from a sub() I've got some errors "Type mismatch", maybe I'm doing it wrong.
Public Sub test()
Dim list As Collection
Dim functionName As String
functionName = "asBuiltComplete()"
Set list = functionName
For Each rs In list
Debug.Print rs.getId & " " & rs.getActualDate & " " & rs.getBlDate
Next
End Sub
You can use Application.Run:
functionName = "asBuiltComplete"
Set list = Application.Run(functionName)
While you could use Eval, Application.Run is somewhat more limited in functionality so has less chance of weirdness.
However, this is bad code. You generally want to avoid dynamic function names whenever feasible, and just call the function.
I need to iterate through a list of forms to see if they are open and then do something with them if they are. The following works:
Public Sub isloadedtester()
Dim iForm As Variant
For Each iForm In CurrentProject.AllForms
Debug.Print iForm.name & ": " & CurrentProject.AllForms(iForm.name).IsLoaded
Next
End Sub
but it loops through all forms. So I thought the following should work to loop through only the forms I care about:
Public Sub isloadedtester2()
Dim iForm As Variant
Dim list
list = Array(Form_some, Form_another)
For Each iForm In list
Debug.Print iForm.name
Debug.Print ".isloaded: " & CurrentProject.AllForms(iForm.name).IsLoaded
Debug.Print "direct: " & SysCmd(acSysCmdGetObjectState, acForm, iForm.name)
Debug.Print "by fn: " & IsLoaded(iForm.name)
Next
End Sub
Public Function IsLoaded(FormName As String, Optional aType As AcObjectType = acForm)
IsLoaded = (SysCmd(acSysCmdGetObjectState, aType, FormName) <> 0)
End Function
However, the second version always sees forms as loaded, no matter which of several ways to read loaded state I use:
.isloaded: True
direct: 1
by fn: True
It's almost like assigning a form to an array makes VBA load the form.
Should I use something other than an array for this? I realize I could do this as an array of names that I also loop through to see if one fits, but that seems awkward, so I first wanted to see if I am just doing something slightly different than it needs to be.
If you only want open forms, then use the Forms collection. It includes only open forms
Dim intFrm As Integer
If Forms.Count > 0 Then
For intFrm = 0 To Forms.Count - 1
'Debug.Print Forms(intFrm).NAME
If Forms(intFrm).Name IsInYourList Then
DoSomething
End IF
Next intFrm
End If
If you have a list of form names, you can do it the "old-fashioned" way with SysCmd
Public Function IsLoaded(FName As String, Optional aType As AcObjectType = acForm)
IsLoaded = (SysCmd(acSysCmdGetObjectState, aType, FName) <> 0)
End Function
and
For Each iForm In list
Debug.Print iForm.Name & ": " & IsLoaded(iForm.Name)
Next
I have a workbook with a very large amount of named ranges (well over 200). I really need a way to work quickly and easily with all of the named ranges so I can then work with / populate them using VBA.
My solution up until now has been to have code inside a bunch of get properties in my public NamedRanges module, to set the property equal to the named range, like so:
Public Property Get LotNumber49() As range
Set LotNumber49 = Common.GetRange(Strings.LotNumber49)
End Property
Where Strings.LotNumber49 is a property which contains the name of the named range as recorded in the workbook, and Common.GetRange is a method that returns a new instance of the desired range object.
While this solution works well (I can now access an instance of that named range by calling NamedRanges.LotNumber49) It is definitely time consuming and tedious to type up the property in the Strings class and another property in the NamedRanges class.
Is there a better way to accomplish this quick referencing of named ranges that anyone can think of? Perhaps iterating over the collection returned by the Workbook.Names property?
Thank you all, I have this workbook to work on as well as four others, which means a whole lot of named ranges!
Get Named Range by String
Why not a simple procedure like so:
Function GetNR(namedRange as String) as Range
Set GetNR = ActiveWorkbook.Names(namedRange).RefersToRange
End Function
Then simply get the named range like so:
Sub Example()
Debug.Print GetNR("NAME").Value
End Sub
Named Range Suggestion in VBA Project
Alternatively if you want the names to popup in your VBA project you need to redefine the Constants in the Strings class. Try this procedure:
Sub GetAllNames()
Dim res As String, n As Name
For Each n In ActiveWorkbook.Names
If InStr(n.Name, "!") = 0 Then res = res & "Const " & n.Name & "=""" & n.Name & """" & vbNewLine
Next n
Dim fFile As Long
fFile = FreeFile
Open "out.txt" For Output As #fFile
Print #fFile, res
Close #fFile
End Sub
You need to repeat this occasionally when modifying the named ranges:
Run the GetAllNames procedure
Open the out.txt file
Copy the outputs to your Strings class or whatever
Now to get a named range use your Common.GetRange method along with your Strings name or simply use the approach above to generate also the Getter code like so:
Sub GetAllGetters()
Dim res As String, n As Name
For Each n In ActiveWorkbook.Names
If InStr(n.Name, "!") = 0 Then res = res & "Public Property Get " & n.Name & "() As range" & vbNewLine & "Set " & n.Name & " = Common.GetRange(Strings." & n.Name & ")" & vbNewLine & "End Property"
Next n
Dim fFile As Long
fFile = FreeFile
Open "outGetters.txt" For Output As #fFile
Print #fFile, res
Close #fFile
End Sub
I have an Excel .xlam file that adds a button in the ribbon to do the following:
Scan the ActiveSheet for some pre-set parameters
Take my source text (a string value, hard coded directly in a VBA Module) and replace designated areas with the parameters retrieved from step 1
Generate a file containing the calculated text
I save the source text this way because it can be password protected and I don't need to drag another file around everywhere that the .xlam file goes. The source text is saved in a separate module called "Source" that looks something like this (Thanks VBA for not having Heredocs):
'Source Module
Public Function GetSource() As String
Dim s As String
s = ""
s = s & "This is the first line of my source text" & vbCrLf
s = s & "This is a parameter {par1}" & vbCrLf
s = s & "This is another line" & vbCrLf
GetSource = s
End Function
The function works fine. My problem is if I want to update the source text, I now have to manually do that in the .xlam file. What I would like to do is build something like a Sub ImportSource() in another module that will parse some file, rebuild the "Source" Module programatically, then replace that Module with my calculated source code. What I don't know is if/how to replace the source code of a module with some value in a string variable.
It's like metaprogramming at its very worst and philosophically I'm against doing this down to my very core. Practically, however, I would like to know if and how to do it.
I realize now that what you really want to do is store some values in your document in a way that is accessible to your VBA, but that is not readable to a user of the spreadsheet. Following Charles Williams's suggestion to store the value in a named range in a worksheet, and addressing your concern that you don't want the user to have access to the values, you would have to encrypt the string...
The "proper way" to do this is described in this article - but it's quite a bit of work.
A much shorter routine is found here. It just uses simple XOR encryption with a hard coded key - but it should be enough for "most purposes". The key would be "hidden" in your macro, and therefore not accessible to prying eyes (well, not easily).
Now you can use this function, let's call it encrypt(string), to convert your string to a value in the spreadsheet:
range("mySecretCell").value = encrypt("The lazy dog jumped over the fox")
and when you need to use it, you use
Public Function GetSource()
GetSource = decrypt(Range("mySecretCell").value)
End Function
If you use the XOR version (second link), encrypt and decrypt would be the same function...
Does that meet your needs better?
As #brettdj already pointed out with his link to cpearson.com/excel/vbe.aspx , you can programmatically change to code of a VBA module using the VBA Extensibility library! To use it, select the library in the VBA editor Tools->References. Note that you need to also change the options in your Trust center and select: Excel Options->Trust Center->Trust Center Settings->Macro Settings->Trust access to the VBA project object model
Then something like the following code should do the job:
Private mCodeMod As VBIDE.CodeModule
Sub UpdateModule()
Const cStrModuleName As String = "Source"
Dim VBProj As VBIDE.VBProject
Dim VBComp As VBIDE.VBComponent
Set VBProj = Workbooks("___YourWorkbook__").VBProject
'Delete the module
VBProj.VBComponents.Remove VBProj.VBComponents(cStrModuleName)
'Add module
Set VBComp = VBProj.VBComponents.Add(vbext_ct_StdModule)
VBComp.Name = cStrModuleName
Set mCodeMod = VBComp.CodeModule
'Add procedure header and start
InsertLine "Public Function GetSource() As String"
InsertLine "Dim s As String", 1
InsertLine ""
'Add text
InsertText ThisWorkbook.Worksheets("Sourcetext") _
.Range("___YourRange___")
'Finalize procedure
InsertLine "GetSource = s", 1
InsertLine "End Function"
End Sub
Private Sub InsertLine(strLine As String, _
Optional IndentationLevel As Integer = 0)
mCodeMod.InsertLines _
mCodeMod.CountOfLines + 1, _
Space(IndentationLevel * 4) & strLine
End Sub
Private Sub InsertText(rngSource As Range)
Dim rng As Range
Dim strCell As String, strText As String
Dim i As Integer
Const cLineLength = 60
For Each rng In rngSource.Cells
strCell = rng.Value
For i = 0 To Len(strCell) \ cLineLength
strText = Mid(strCell, i * cLineLength, cLineLength)
strText = Replace(strText, """", """""")
InsertLine "s = s & """ & strText & """", 1
Next i
Next rng
End Sub
You can "export" and "import" .bas files programmatically. To do what you are asking, that would have to be the approach. I don't believe it's possible to modify the code in memory. See this article