I wrote two macros in MS Visio. The first macro hides all layers, the second macro selects a specific layer to be shown. Both macros work fine by themselves, but when I try to run the first macro in the second macro I received a compile error, that the sub cannot be found. Any ideas on how to call the private sub correctly?
First sub, which hides all layers:
Private Sub Deselect_layers()
Dim vsoPage As Visio.Page
Dim vsoShape As Visio.Shape
Dim vsoLayers As Visio.Layers
Dim vsoLayer As Visio.Layer
Set vsoPage = ActivePage
Set vsoLayers = vsoPage.Layers
For Each vsoLayer In vsoLayers
If vsoLayer.CellsC(visLayerVisible).FormulaU = "1" Then
vsoLayer.CellsC(visLayerVisible).FormulaU = "0"
End If
Next
End Sub
Second sub, which shows one specifc layer:
Sub Select18()
Dim vsoPage As Visio.Page
Dim vsoShape As Visio.Shape
Dim vsoLayers As Visio.Layers
Set vsoPage = ActivePage
Set vsoLayers = vsoPage.Layers
RUNMACRO ("SelectLayers.Deselect_layers") <-- Error occurs here
vsoLayers.Item("18").CellsC(visLayerVisible).FormulaU = "1"
End Sub
What I have tried so far:
RUNADDON ("ThisDocument.Deselect_layers")
RUNMACRO ("ThisDocument.Deselect_layers")
Callthis ("ThisDocument.Deselect_layers")
RUNADDON ("ThisDocument.SelectLayers.Deselect_layers")
RUNMACRO ("ThisDocument.SelectLayers.Deselect_layers")
Callthis ("ThisDocument.SelectLayers.Deselect_layers")
No of these commands worked. Any help would be much appriciated!
Try this:
Private Sub Deselect_layers()
Debug.Print "In Deselect_layers()"
End Sub
Sub Select18()
Call Deselect_layers
End Sub
Related
I have a user who in 2018 copied a macro from the web. After being upgraded to 2020 the macro can't get past the first line;
Set swApp = GetObject(,"Application.SldWorks")
The error is
Run-time error '429' ActiveX component can't create object
I tried to reset the libraries and have gone through multiple forum posts looking a solution. This post was the closest to my issue.
Below is the full code;
Dim swApp As SldWorks.SldWorks
Public Sub main()
Set swApp = GetObject(,"Application.SldWorks")
Dim ActiveDoc As ModelDoc2
Set ActiveDoc = GetObject(, "Sldworks.Application").ActiveDoc
If Not ActiveDoc Is Nothing Then
If ActiveDoc.GetType = 2 Then
GoTo Traverse
End If
End If
MsgBox ("This macro should be run, with an open assembly as the active document.")
Exit Sub
Traverse:
Dim myModel As ModelDoc2
Set myModel = ActiveDoc
Call Traverse(myModel, myModel.ConfigurationManager.ActiveConfiguration.Name)
MsgBox ("Done")
End Sub
You shouldn't use reserved names like ActiveDoc as a variable name. You don't need to use GetObject on objects that are already directly referenced by the host. You don't need Call anymore.
I only get the error that you see if I use the GetObject command that you have there.
I have tested this code in SolidWorks 2020:
Option Explicit
Dim swApp As Object
Sub main()
Set swApp = Application.SldWorks
Dim thisDoc As ModelDoc2
Set thisDoc = swApp.ActiveDoc
If Not thisDoc Is Nothing Then
If thisDoc.GetType = 2 Then
Dim myModel As ModelDoc2
Set myModel = thisDoc
Traverse myModel, myModel.ConfigurationManager.ActiveConfiguration.Name
MsgBox "Done"
Exit Sub
End If
End If
MsgBox "This macro should be run, with an open assembly as the active document."
End Sub
I want to add dynamically CommandButtons to my Userform within the For-Loop. How can i get add new CommandButtons in the For-Loop?
Dim CommandButtons(5) As clsCommandButtons
Private Sub UserForm_Initialize()
Dim zaehler As Integer
For zaehler = 0 To 4
Set CommandButtons(zaehler) = New clsCommandButtons
Set CommandButtons(zaehler).cmdCommandButton = Me.Controls(zaehler)
Next
End Sub
And This is my class:
Option Explicit
Public WithEvents cmdCommandButton As CommandButton
Private Sub cmdCommandButton_Click()
Dim sFilepath As String
With Application.FileDialog(msoFileDialogFilePicker)
.AllowMultiSelect = False
.InitialFileName = ActiveWorkbook.Path & "\"
.Filters.Add "TextFiles", "*.txt", 1
.FilterIndex = 1
If .Show = -1 Then
sFilepath = .SelectedItems(1)
End If
End With
Cells(c_intRowFilterPathStart, c_intClmnFilterPath) = sFilepath
End Sub
I don't know how to handle this Error. How can i fix this?
I assume you get the error because you're accessing a control that doesn't exist. Note that the controls are counted from 0 to Me.Controls.count-1, so probably your issue is solved with
Set CommandButtons(zaehler).cmdCommandButton = Me.Controls(zaehler-1)
But I guess a better solution is to name your buttons and assign them by name:
Set CommandButtons(zaehler).cmdCommandButton = Me.Controls("CommandButton" & zaehler)
Define the CommandButtons collection as a Variant:
Dim CommandButtons(15) As Variant, instead of Dim CommandButtons(15) As clsCommandButtons.
In this Variant, you would put your CommandButtons. This is some minimal code, that would help you get the basics of what I mean:
CustomClass:
Private Sub Class_Initialize()
Debug.Print "I am initialized!"
End Sub
In a module:
Private SomeCollection(4) As Variant
Public Sub TestMe()
Dim cnt As Long
For cnt = 1 To 4
Set SomeCollection(cnt) = New CustomClass
Next cnt
End Sub
From this small running code, you can start debugging further :)
I think your problem is in the Me.Controls(zaehler) part. zaehler starts at 1, but Me.Controls(...) starts at 0.
Set CommandButtons(zaehler).cmdCommandButton = Me.Controls(zaehler - 1)
would probably solve it
Dim a() As clsCommandButton
Private Sub UserForm_Initialize()
Dim c As Control
On Error GoTo eHandle
For Each c In Me.Controls
If TypeName(c) = "CommandButton" Then
ReDim Preserve a(UBound(a) + 1)
Set a(UBound(a)) = New clsCommandButton
Set a(UBound(a)).cmd = c
End If
Next c
Exit Sub
eHandle:
If Err.Number = 9 Then
ReDim a(0)
End If
Resume Next
End Sub
With a class as follows
Public WithEvents cmd As commandbutton
Private Sub cmd_Click()
MsgBox "test"
End Sub
I am trying to adapt the code found here (the third method, as that is what seems to be deemed best-practice), to suit my needs, but I'm not having any luck - the code I have so far, more or less copy-pastaed from that page is the following:
In the form-module:
Private calling_cell As Range
Property Set range_to_form(ByRef r As Range)
Set calling_cell = r
End Property
Private Sub UserForm_Activate()
Debug.Print calling_cell.Address
End Sub
In a worksheet_change-event:
Dim frm As ufRegLuft
If Not IsUserFormLoaded("ufRegLuft") Then
Set frm = New ufRegLuft
Else
Set frm = VBA.UserForms("ufRegLuft")
End If
Set frm.range_to_form = Target
ufRegLuft.Show
The problem:
This does not work - I get an error on the debug.print-line, saying "Run-time error '91': Object variable or With block variable not set". I must admit I'm pretty stumped at this point, I feel like I have tried every possible combination of set, let, get etc. So, can anyone here please help me figure out if it is possible to pass a Range-object to an userform, and if so, tell me what I'm doing wrong?
Your variable calling_cell is initialized in the form frm and not in ufRegLuft
Change the line ufRegLuft.Show to frm.Show ;)
Here is simple way to test it.
Form Module
Private calling_cell As Range
Property Set range_to_form(ByRef r As Range)
Set calling_cell = r
End Property
Private Sub UserForm_Activate()
MsgBox calling_cell.Address
End Sub
Normal Module
Sub ShowFormProp()
Dim frm As ufRegLuft
Set frm = New ufRegLuft
Set frm.range_to_form = Sheet1.Range("A1")
frm.Show
End Sub
You have to pass the variable to a sub in the form, (I believe user form_Initialize will fire)
I am not sure where r is set but create a public sub in the form that sets the range, call that before you show the form then show the form like below
In the form-module:
Private calling_cell As Range
public sub range_to_form(ByRef r As Range)
Set calling_cell = r
End Property
Private Sub UserForm_Activate()
Debug.Print calling_cell.Address
End Sub
In a worksheet_change-event:
Dim frm As ufRegLuft
If Not IsUserFormLoaded("ufRegLuft") Then
Set frm = New ufRegLuft
Else
Set frm = VBA.UserForms("ufRegLuft")
End If
frm.range_to_form r
'Could be "range_to_form r" not above
frm.Show
I'm trying to get a property value of a button control from inside the button's click event without using the button's name (since I want to use the same code for each of many buttons on the Excel sheet).
After much research, I see many references to try the following:
Me.ActiveControl.name
or
Me.Shapes(Application.Caller).Name
However, both of those throw an error when executed from within Excel. Note that I'm using Excel 2010.
Thanks for any help in advance.
Lee
What you want is possible but for that you need to create a Class
Do this.
Insert a Class Module and paste this code there.
Option Explicit
Public WithEvents MyButton As MSForms.CommandButton
Private Sub MyButton_Click()
MsgBox MyButton.Name
End Sub
Next Insert a module and place this code there
Dim shpButtons() As New Class1
Sub StartCode()
Dim shp As Shape
Dim btnCount As Long
ReDim shpButtons(1 To 1)
btnCount = 0
For Each shp In ActiveSheet.Shapes
If shp.OLEFormat.Object.OLEType = xlOLEControl Then
btnCount = btnCount + 1
ReDim Preserve shpButtons(1 To btnCount)
Set shpButtons(btnCount).MyButton = shp.OLEFormat.Object.Object
End If
Next
End Sub
Sub StopCode()
Dim iBtn As Long
On Error Resume Next
For iBtn = LBound(shpButtons) To UBound(shpButtons)
Set shpButtons(iBtn).TheText = Nothing
Next
End Sub
Now simply run the Sub StartCode()
Next when you click the ActiveX CommandButton then you will get it's name.
Try ActiveSheet.Shapes(Application.Caller).Name
I have a macro to export relevant field of emails in a subfolder but I need it to automatically run every time I receive a new email. In fact I only want the subject line exported, is there a script which will trigger that macro ('ExportMessagesToExcel') when an email lands in 'M_M_Asia'?
I'm in Outlook 2007.
I'll be forever grateful if anyone can help. Cheers guys.
You should be able to use the Application_NewMail (or NewMailEx) event in ThisOutlookSession module to call your own macro.
Another way is to create a rule that runs a VBA-script, but then you VBA sub needs to handle a MailItem parameter:
Option Explicit
Sub MyVBARule(poMail As MailItem)
End Sub
Or you could add 'ItemAdd' event handler, example here:
Option Explicit
Private Const ASIA_FOLDER_NAME As String = "M_M_Asia"
Private WithEvents m_outlookFolderItems As Outlook.Items
Private Sub Application_Startup()
Initialize_Handler
End Sub
Private Sub m_outlookFolderItems_ItemAdd(ByVal Item As Object)
' You have new mail in folder ASIA_FOLDER_NAME
RunExcelMacro
End Sub
Private Sub Initialize_Handler()
Dim outlookFolder As Outlook.MAPIFolder
Dim defaultInboxFolder As Outlook.MAPIFolder
Dim outlookNameSpace As Outlook.NameSpace
Set outlookNameSpace = Outlook.GetNamespace("MAPI")
Set defaultInboxFolder = outlookNameSpace.GetDefaultFolder(olFolderInbox)
Set outlookFolder = defaultInboxFolder.Folders(ASIA_FOLDER_NAME)
Set m_outlookFolderItems = outlookFolder.Items
End Sub
Public Sub RunExcelMacro()
On Error GoTo RunExcelMacro_Err
Const path As String = "C:\temp\Excel_VBA\"
Const fileName As String = "CallMeFromOutloouk.xlsm"
Const macroName As String = "CallMeFromOutlook"
Dim excelObject As Object
Dim workbookObject As Object
Set excelObject = CreateObject("Excel.Application")
On Error Resume Next
Set workbookObject = excelObject.Workbooks(fileName)
On Error GoTo RunExcelMacro_Err
If workbookObject Is Nothing Then
Set workbookObject = excelObject.Workbooks.Open(path & fileName)
End If
excelObject.Run fileName & "!" & macroName
Exit Sub
RunExcelMacro_Err:
MsgBox Err.Description
End Sub