I having autocad project where is 1 dynamic block which I'm trying to change from excel.
Here is vba script which I'm using to change block:
Dim dybprop As Variant, i As Integer
Dim bobj As AcadEntity
For Each bobj In ACADApp.ModelSpace
If bobj.ObjectName = "AcDbBlockReference" Then
If bobj.IsDynamicBlock Then
If bobj.EffectiveName = "AdjBlock" Then
dybprop = bobj.GetDynamicBlockProperties
For i = LBound(dybprop) To UBound(dybprop)
If dybprop(i).PropertyName = "Distance1" Then
dybprop(i).Value = 50.75
Acad.Application.Update
End If
Next i
End If
End If
End If
Next
End With
When I'm running it in AutoCAD VBA it works excellent. Than I'm creating Excel VBA project and copying this code. Before running it I creating connection to existing AutoCad project like this:
On Error Resume Next
Dim ACADApp As AcadApplication
Dim a As Object
Set a = GetObject(, "AutoCAD.Application")
If a Is Nothing Then
Set a = CreateObject("AutoCAD.Application")
If a Is Nothing Then
MsgBox "AutoCAD must be running before performing this action.", vbCritical
Exit Sub
End If
End If
Set ACADApp = a
Set ACADApp.ActiveDocument = ACADApp.Documents.Open("c:\KIRILL\Programming\Drawing1_VBATest.dwg")
When I'm running it from Excel VBA - AutoCAD project appears but nothing change. Honestly I don't have any idea why in Excel VBA it doesn't works while in AutoCAD it work. May be somebody had this problem before? Thanks in advance.
P.S. Full Excel VBA code:
Sub Button9_Click()
On Error Resume Next
Dim ACADApp As AcadApplication
Dim a As Object
Set a = GetObject(, "AutoCAD.Application")
If a Is Nothing Then
Set a = CreateObject("AutoCAD.Application")
If a Is Nothing Then
MsgBox "AutoCAD must be running before performing this action.", vbCritical
Exit Sub
End If
End If
Set ACADApp = a
Set ACADApp.ActiveDocument = ACADApp.Documents.Open("c:\KIRILL\Programming\Drawing1_VBATest.dwg")
Dim dybprop As Variant, i As Integer
Dim bobj As AcadEntity
For Each bobj In ACADApp.ModelSpace
If bobj.ObjectName = "AcDbBlockReference" Then
If bobj.IsDynamicBlock Then
If bobj.EffectiveName = "AdjBlock" Then
dybprop = bobj.GetDynamicBlockProperties
For i = LBound(dybprop) To UBound(dybprop)
If dybprop(i).PropertyName = "Distance1" Then
dybprop(i).Value = 50.75
Acad.Application.Update
End If
Next i
End If
End If
End If
Next
End Sub
Have you tried adding the reference library?
You can go to:
Tools->References
And add:
[AutoCAD 20xx Type Library]
Related
I am trying to suppress the message which pops up on deletion of sheet in the embedded excel of a PPT chart, using this code snippet:
POP-UP MESSAGE
CODE-SNIPPET:
Sub MainSub()
' Some code here
' reference to excel has been added
If SelShape.HasChart = True Then
Dim SelChart As PowerPoint.Chart
Set SelChart = SelShape.Chart
Dim Selchtdat As PowerPoint.ChartData
Set Selchtdat = SelChart.ChartData
On Error Resume Next
Selchtdat.Activate
On Error GoTo 0
Dim EmbdExcel As Excel.Workbook
Set EmbdExcel = Selchtdat.Workbook
Call FilterRequiredData (EmbdExcel, "Data")
End If
' Some code here
End Sub
'-----------------------------------------------------------------------------------------------------
Private Sub FilterRequiredData(ChrtWbk As Excel.Workbook, stname As String)
ChrtWbk .Activate
On Error Resume Next
Excel.Application.DisplayAlerts = False
ChrtWbk.Sheets("TempSheet").Delete
Excel.Application.DisplayAlerts = True
On Error GoTo 0
ChrtWbk.Sheets.Add(After:=ChrtWbk.Sheets(ChrtWbk.Sheets.count)).Name = "TempSheet"
'Some other code
End Sub
This code works perfectly in the native Excel VBA environment, but when invoked in PPT VBA Environment, it doesn't suppress the message. Can anybody tell me why this doesn't work ? Are there any other ways to tackle this ?
How do I integrate my code that activates a reference (if it's not already activated) into the beginning of a code I've already got? The problem seems to be the newly added reference isn't recognized as active if I try activating and calling them within the same sub... any suggestions? When I run them separately they run just fine. I'm getting a 4120 Run-time Error (bad parameter) which also happens when reference isn't activated
Sub test ()
Dim strGUID As String, theRef As Variant, i As Long
'Update the GUID you need below.
strGUID = "{00020905-0000-0000-C000-000000000046}"
'Remove any missing references
For i = ThisWorkbook.VBProject.References.Count To 1 Step -1
Set theRef = ThisWorkbook.VBProject.References.Item(i)
If theRef.isbroken = True Then
ThisWorkbook.VBProject.References.Remove theRef
End If
'Check if the reference isn't already activatet - can cause issues when stepping through but works just fine
If ThisWorkbook.VBProject.References.Item(i).GUID = strGUID Then
GoTo ContinueSub
End If
Next i
'Add the reference
ThisWorkbook.VBProject.References.AddFromGuid _
GUID:=strGUID, Major:=1, Minor:=0
Run "ContractPrep"
ContinueSub:
Dim wdApp As Object, wdDoc As Object
'Bunch of code here and then the error occurs here:
Set wdApp = CreateObject("Word.Application")
Set wdDoc = wdApp.Documents.Open(Temp)
'show the word document - put outside of loop for speed later
wdApp.Visible = True
wdDoc.Application.Selection.Wholestory
openxml = wdDoc.Application.Selection.WordOpenXML
wdDoc.Application.Selection.Delete
'Rest of code
End Sub
I need to run a PowerPoint sub from R via:
shell(shQuote(normalizePath("C:/.../VBA_Script.vbs"))).
The script VBA_Script should trigger a sub called request_bank, which should open amsgboxwith the value of the variablebank(=J. P. Morgan`).
I get the error:
Application.Run: Invalid request. Sub or function not defined, Code: 80048240, MS PowerPoint 2013.
I just tried all the different Run.-Paths mentioned in this thread Run PowerPoint Sub from Excel. I still get the error. I wonder why the same code is working if I run the same Sub in Excel or if I add the rows:
Dim PSlide
Set PSlide = PPres.Slides(1).Duplicate
But that's no clean solution for me. There must be a better way.
VBS-Script:
Option Explicit
CallPMacro
Sub CallPMacro()
Dim PApp
Dim PPres
'Dim PSlide
Set PApp = CreateObject("PowerPoint.Application")
Set PPres = PApp.Presentations.Open("C:\...\test.pptm", 0, True)
'Set PSlide = PPres.Slides(1).Duplicate
PApp.Visible = True
PApp.Run "request_bank"
PApp.Quit
Set PPres = Nothing
Set PApp = Nothing
End Sub
VBA-Code from the Sub request_bank in the test.pptm:
Sub request_bank()
Dim bank As String
bank = "J.P. Morgan"
MsgBox ("bank: " & bank)
End Sub
Any idea how to fix it?
this is an example sub to programatically install a type library for API. Why is the error handling routine failing? I attempted to follow the try...except...finally strategy I am familiar with from Python.
Sub CopyViewLayout():
'TRY:
On Error GoTo addReference
Dim App As femap.model
'COMPILE ERROR: USER TYPE NOT DEFINED
ResumeSub:
Dim App As femap.model
Set App = GetObject(, "femap.model")
Dim rc As Variant
Dim feView As femap.View
Set feView = App.feView
rc = feView.Get(0)
Exit Sub
'EXCEPT:
addReference:
Dim vbaEditor As VBIDE.VBE
Dim vbProj As VBIDE.VBProject
Dim checkRef As VBIDE.Reference
Dim filepath As String
Set vbaEditor = Application.VBE
Set vbProj = ActiveWorkbook.VBProject
filepath = "C:\apps\FEMAPv11\"
On Error GoTo Failure
vbProj.References.AddFromFile (filepath & "femap.tlb")
Set vbProj = Nothing
Set vbaEditor = Nothing
GoTo ResumeSub
'FINALLY
Failure:
MsgBox ("couldn't find type library, exiting sub")
End Sub
EDIT
I broke out this section from main because Error handling is just ridiculous in VBA... A better approach for me was to implement a finite-state-machine using Booleans.
answer
Sub refcheck()
Dim i As Long
Dim FEMAP_GUID As String
FEMAP_GUID = "{08F336B3-E668-11D4-9441-001083FFF11C}"
With ActiveWorkbook.VBProject.references
For i = 1 To .Count
If .Item(i).GUID = FEMAP_GUID Then
Exit For
Else
'note: filepath is determined using Dir() elsewhere...
.AddFromFile (filepath & "femap.tlb")
Exit For
End If
Next
End With
End Sub
Error handling only handles runtime errors; not compile time errors. Use
Dim App as Object
And make sure you only Dim App once in your code.
By using As Object, you can late bind any object to it. You lose Intellisense while youre coding thought.
Like Dick mentioned, use Late Binding but that alone is not enough. You will have to use it with proper Error Handling.
For example
Dim App As Object
On Error Resume Next
Set App = GetObject(, "femap.model")
On Error GoTo 0
If App Is Nothing Then
MsgBox "Please check if femap is installed"
Exit Sub
End If
'
'~~> Rest of the code
'
If you are sure that it is installed then you are getting the error because the relevant library is not referenced. For that I would recommend having a look at How to add a reference programmatically
I would however still suggest that you take the Late Binding route.
I have created a VB add-in for excel with the below code. However, when I open a new excel workbook and attempt to add the reference to the newly created dll, I get an error: "Can't add a reference to the specified path." I am using Excel 2010 on a 32 bit machine. The add-in was created with Visual Studio 2010.
Public Class Utils
'!Deletes old reference and adds new reference. Must be used when switching to new machine.
Function addReference() As Boolean
If Dir("C:\refname.dll") <> "" Then
Dim ref
For Each ref In Application.ActiveWorkbook.VBProject.VBE.ActiveVBProject.References
If ref.name = "refname" Then
Application.ActiveWorkbook.VBProject.VBE.ActiveVBProject.References.Remove(ref)
End If
Next
Application.ActiveWorkbook.VBProject.VBE.ActiveVBProject.References.AddFromFile("C:\refname.dll")
addReference = True
Else
addReference = False
End If
End Function
End Class
You can try this:
Option Explicit
Sub AddReference()
Dim VBAEditor As VBIDE.VBE
Dim vbProj As VBIDE.VBProject
Dim chkRef As Reference
Dim BoolExists As Boolean
Set VBAEditor = Application.VBE
Set vbProj = ActiveWorkbook.VBProject
'~~> Check if reference is already added
For Each ref In vbProj.References
If ref.Name = "refname" Then
BoolExists = True
GoTo CleanUp
End If
Next
vbProj.References.AddFromFile "C:\WINDOWS\system32\refname.dll\3"
CleanUp:
If BoolExists = True Then
MsgBox "Reference already exists"
Else
MsgBox "Reference Added Successfully"
End If
Set vbProj = Nothing
Set VBAEditor = Nothing
End Sub
I got this code from: How to add a reference programmatically