In my Excel workbook, I can attach an Access database as an OLE object.
I now want to save a copy of this object (Access database) in another folder.
Here is my code:
If nameEnd = "ccdb" Then
'Access Type
Dim AccessApp As Object
Dim obja As OLEObject
Application.ScreenUpdating = False
Set obja = ActiveSheet.OLEObjects(i)
obja.Activate
obja.Visible = True
Set AccessApp = GetObject(, "Access.Application")
AccessApp.CurrentDatabase.SaveAs FileName:=fpath & "AttachmentAccess"
AccessApp.CurrentDb.ExportAsFixedFormat outputfilename:=saveFile & "Attachment DB", _
ExportFormat:=accdbExportFormatPDF
Set AccessApp = Nothing
Range("K2:Z300").Select
Application.ScreenUpdating = True
End If
I get the error "Object doesn't support this property or method" probably because "CurrentDatabase.SaveAs" does not exist as a property.
I think you used wrong property names.
As you write in the next line, it's not CurrentDatabase but CurrentDb. Moreover, the function isn't called SaveAs but MakeReplica. So, try this:
AccessApp.CurrentDb.MakeReplica PathName:=fpath & "AttachmentAccess"
Related
I used the following Access VBA code to open four different excel workbooks in a loop while I need to edit the excel data and then update the Access table through recordset.
xl.Application.DisplayAlerts = False
Set wb = xl.Workbooks.Open(fileName, ReadOnly = True, editable = True, notify = False)
Set ws = wb.Sheets("Sheet1")
Set ws2 = wb.Worksheets.Add
cn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & fileName & ";Extended Properties=""Excel 8.0;HDR=YES;IMEX=1;"";"
*****Other Codes******
wb.Close savechanges:=False
Set wb = Nothing
Set xlc = Nothing
Set ws = Nothing
Set ws2 = Nothing
Set xl = Nothing
rs.Close
Set rs = Nothing
cn.Close
Set cn = Nothing
However, even though I close the excel file without saving for all the four files, I still receive the following notice after the full loop.
with Set wb = xl.Workbooks.Open(fileName, ReadOnly = True, editable = True, notify = False), I was still not able to turn off the notice.
PS. I did not receive the read-write notification for all the four files, normally one or two, which really confused me.
Any recommendations for solving the issue?
Thanks in advance for all the help!
You can't manually control garbage collection in VBA but you can structure your data so that garbage collection is more predictable. The first thing I recommend is to place the Excel inter-op code in to it's own procedure that is called from your main loop. The reason is that when the procedure ends, the garbage collection will occur. Next time the loop calls the open procedure you will be working with a fresh set of object handles, instead of recycling the objects as you are currently doing. If you do it this way you never have to set your objects to nothing because they are destroyed as they go out of scope at the end of the procedure. Just be sure to always use local variables.
In order to do this without closing and opening Excel repetitively you need to get a handle on the currently running Excel instance. That is provided by the GetExcelApp procedure below.
EXAMPLE:
Private Sub YourMainLoop()
For Each fileName in fileNames
ProcessExcelData fileName
Next fileName
End Sub
Private Sub ProcessExcelData(ByVal fileName as String)
Dim xl As Object
Set xl = GetExcelApp
xl.Application.DisplayAlerts = False
Set wb = xl.Workbooks.Open(fileName, ReadOnly = True, editable = True, notify = False)
Set ws = wb.Sheets("Sheet1")
Set ws2 = wb.Worksheets.Add
cn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & fileName & ";Extended Properties=""Excel 8.0;HDR=YES;IMEX=1;"";"
' Process the data, blah blah blah
wb.Close savechanges:=False
rs.Close
cn.Close
End Sub
Public Function GetExcelApp() As Object
' Returns open excel instance.
' If it doesn't exist, creates one to return
On Error GoTo ErrHandler
Const ERR_APP_NOTRUNNING As Long = 429
Set GetExcelApp = GetObject(, "Excel.Application")
CleanExit:
Exit Function
ErrHandler:
If Err.number = ERR_APP_NOTRUNNING Then
Set GetExcelApp = CreateObject("Excel.Application")
Resume CleanExit
Else
ShowErrorMessageBox
End If
End Function
I am getting an Automation error, when Catia is trying to write values in a selected Excel sheet. It's a bit confusing because on the first try of the code there was no error and the values were in the Excel sheet.
I didn't change the code, but on the second try I get:
Run-time error '-2147417846 (8001010a)': Automation error
"The Message filter indicated that the application is busy."
on the line: Set MyXL = GetObject(FPath)
Sub CATMain()
FPath = CATIA.FileSelectionBox("Select the Excel file you wish to put the value in", "*.xlsx", CatFileSelectionModeOpen)
If FPath = "" Then
Exit Sub
End If
Set xlApp = CreateObject("Excel.Application")
Set MyXL = GetObject(, "Excel.Application")
Set MyXL = GetObject(FPath)
MyXL.Application.Visible = True
MyXL.Parent.Windows(1).Visible = True
Dim oSelection As Selection
Set oSelection = CATIA.ActiveDocument.Selection
Dim oProduct As AnyObject
On Error Resume Next
Set oProduct = oSelection.FindObject("CATIAProduct")
If (Err.Number <> 0) Then
MsgBox "No selected product"
Else
On Error GoTo 0
Dim oInertia As AnyObject
Set oInertia = oProduct.GetTechnologicalObject("Inertia")
Dim dMass As Double
dMass = oInertia.Mass
Dim dDen As Double
dDen = oInertia.Density
MsgBox oProduct.Name & ": Masse = " & CStr(dMass) & " KG" & ": Dichte = " & (CStr(dDen) / 1000) & " "
MyXL.Application.Cells(1, 1).Value = "Masse"
MyXL.Application.Cells(2, 1).Value = dMass
MyXL.Application.Cells(1, 2).Value = "Dichte"
MyXL.Application.Cells(2, 2).Value = "dDen"
MsgBox "Werte wurden in Excel eingetragen"
End If
End Sub
It appears you did not set Option Explicit - put it on the first line and it will help you avoid errors. (With it, the compiler will force you to declare all your variables. This will also mean that when you put it in, your code will not work unless you declare all variables.)
The first problem:
Set xlApp = CreateObject("Excel.Application")
Set MyXL = GetObject(, "Excel.Application")
You first create a new instance of Excel with CreateObject and store a reference to it in xlApp (which you subsequently do not use). Then you try to get a reference to an existing Excel instance with GetObject and store its reference in MyXL. This only works reliably because you first create a new instance. Otherwise you could not guarantee that there always is an Excel instance available.
A related problem is, that you don't release/close these instances. If you create an Excel instance, you need to close it with xlApp.Quit after you're done using it, otherwise it will linger around.
Be careful though with instances you took over with GetObject - calling MyXL.Quit will close the instance regardless of what other workbooks are open at that time.
Similarly, if you open a file this way, you need to make sure to close it afterwards. Otherwise you'll run into the problem you experience: Write protected files.
So, to mend your problem: Close all open instances of Excel (best done via Task Manager, as some of them might be invisible). Then adjust your code to only use one reference to an Excel.Application. And finally make sure to .Close the workbook after you've saved it and .Quit your Excel instance. This should hopefully prevent the error from reappearing.
'Dim xlApp As Excel.Application ' early-bound declaration
'Set xlApp = New Excel.Application ' early-bound assignment
Dim xlApp As Object ' late-bound declaration
Set xlApp = CreateObject("Excel.Application") ' late-bound assignment
'Dim wb As Workbook ' early-bound declaration
Dim wb as Object
Set wb = xlApp.Workbooks.Open(FPath)
' stuff you want to do with the workbook
wb.Close SaveChanges:=True
xlApp.Quit
If you can add a reference to the Excel object model in you Catia VBA project (not sure about that), you can comment out the late-bound lines and use the early-bound lines instead. That way you gain the very useful IntelliSense for the Excel objects. Which makes it so much easier to code.
Thank you guys! I've solved the Problem with simply adding the code:
Workbook.Close SaveChanges:=True
I want to generate and format an excel workbook out of access. The creation of the file is done easy, but I struggle with the format.
file creation
Dim strCurrentDBName As String
strCurrentDBName = CurrentDb.Name
For i = Len(strCurrentDBName) To 1 Step -1
If Mid(strCurrentDBName, i, 1) = "\" Then
strPath = Left(strCurrentDBName, i)
Exit For
End If
Next
xlsxPath = strPath & "Report.xlsx"
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12Xml, "Report", xlsxPath, True
MsgBox ("Report generated. " & xlsxPath)
format
Dim xl As Object
'This deals with Excel already being open or not
On Error Resume Next
Set xl = GetObject(, "Excel.Application")
On Error GoTo 0
If xl Is Nothing Then
Set xl = CreateObject("Excel.Application")
End If
Set XlBook = GetObject(xlsxPath)
'filename is the string with the link to the file ("C:/....blahblah.xls")
'Make sure excel is visible on the screen
xl.Visible = True
XlBook.Windows(1).Visible = True
'xl.ActiveWindow.Zoom = 75
'Define the sheet in the Workbook as XlSheet
Set xlsheet1 = XlBook.Worksheets(1)
'Format
With xlsheet1
xlsheet1.Rows("1:1").Select
and here is my error (Run-time error '1004': Application-defined or object-defined error)
xlsheet1.Range(xl.Selection, xl.Selection.End(xlDown)).Select
xlsheet1.Selection.EntireRow.AutoFit
End With
You're using the xlDown enum value, which requires a reference to the Microsoft Excel Object Library. Since you're using late bindings, that reference probably isn't set.
Work around it by using the value of xlDown, -4121:
xlsheet1.Range(xl.Selection, xl.Selection.End(-4121)).Select
Note that this error would've been more easy to spot if you had put Option Explicit at the top of your module.
Prelude
I am starting a new project, and basically I am using Excel as a log for another program I am using. With this being said, this is a mixture of VBA (Only when using Excel's object) and VB6 (the main "host" programming language). This is why both languages are tagged as I anticipate hateful comments from the use of tags; I am looking for a solution in either/mixture of both programming languages!!
Also, I am aware some VBA activists will say to never use ActiveSheet. I am not concerned about this and I would like to say thank you ahead of time. I have one sheet in this workbook as it's primary function is to serve as a log. The ActiveSheet will always be the one and only sheet.
I have the following code, and I am not too familiar with Setting a workbook as an object, which is likely the reason I receive the Bad Index error.
Sub Test()
' Checking if Excel is open, if not, open it.
Dim xL As Object, wBook As Object, iCloseThings As Byte
On Error Resume Next
Set xL = GetObject(, "Excel.Application")
On Error GoTo 0
If xL Is Nothing Then
iCloseThings = 1 ' Set Excel to close only if it was never open
Set xL = CreateObject("Excel.Application")
End If
Set wBook = xL.Workbooks("C:\Users\<UserName>\Documents\<WorkBook>.xlsx").ActiveSheet
If iCloseThings = 1 Then xL.Quit
End sub
What I need assistance with is how would I properly set this object to point to the exact workbook I have in the above example? All I have ever known to do was something such as Set wBook = XL.Workbooks("<WorkBook>.xlsx").ActiveSheet because I knew such workbook would already be open. But with the possibility of it not being open, I need something a little more flexible.
Thanks for your assistance!
you need some different cases handling, mainly depending if the wanted workbook is already open or not should a running Excel session be "caught"
you may want to use some dedicated Functions not to clutter your main code and be more effective in both debugging and maintaining your code, like follows
Option Explicit
Sub Test()
' Checking if Excel is open, if not, open it.
Dim xL As Object, wBook As Object, wSheet As Object, iCloseThings As Byte
Set xL = GetExcel(iCloseThings)
Set wBook = GetExcelWorkbook(xL, "C:\Users\<UserName>\Documents\<WorkBook>.xlsx")
If wBook Is Nothing Then Exit Sub
Set wSheet = wBook.ActiveSheet
If iCloseThings = 1 Then xL.Quit
End Sub
Function GetExcel(iCloseThings As Byte) As Object
On Error Resume Next
Set GetExcel = GetObject(, "Excel.Application")
On Error GoTo 0
If GetExcel Is Nothing Then
iCloseThings = 1 ' Set Excel to close only if it was never open
Set GetExcel = CreateObject("Excel.Application")
End If
End Function
Function GetExcelWorkbook(xL As Object, wbFullName As String) As Object
Dim wbName As String
wbName = Right(wbFullName, Len(wbFullName) - InStrRev(wbFullName, "\"))
On Error Resume Next
Set GetExcelWorkbook = xL.Workbooks(wbName)
On Error GoTo 0
If GetExcelWorkbook Is Nothing Then
Set GetExcelWorkbook = xL.Workbooks.Open(wbFullName)
Else
If GetExcelWorkbook.Path & "\" & wbName <> wbFullName Then
MsgBox "A workbook with the wanted name '" & wbName & "' is already open but its path doesn't match the required one" _
& vbCrLf & vbCrLf & "Close the already open workbook and run this macro again", vbCritical + vbInformation
Set GetExcelWorkbook = Nothing
Else
MsgBox "Wanted workbook is already open", vbInformation
End If
End If
End Function
Am trying to Open the Word application, Edit, Saveas in the specified location and Need to check whether user has entered the correct Filename.
Here's my code
Dim Doc
Dim DocPath
Dim DocObj
Dim VarResult
DocPath = "C:\MyFolder\MyDocument.doc"
Set DocObj = CreateObject("word.Application")
Doc = DocObj.Documents.Open(DocPath)
DocObj.Visible = True
After opening the document I am doing some changes
With Doc.ActiveDocument
Set myRange = .Content
With myRange.Find
.Execute FindText:="FindText", ReplaceWith:="ReplaceText", Replace:=2
End With
End With
Now, I have an issue in saveas the file. I used both the alternative methods,
1: GetSaveAsFilename, 2: SaveAs. I need the saveas dialog box to appear(with all DefaultLocation, InitialFilename, DocumentType, Title properties). User needs to select and the same needed to be validated, whether user has not given Cancel button.
varResult = Doc.GetSaveAsFilename( _
FileFilter:="DP Document (*.doc), *.doc, DP Document (*.docx), *.docx", Title:="Save DP", initialvalue:="InitialDocument")
If varResult <> False Then
MsgBox "File choosen = " & varResult
Else
MsgBox "Please select the file"
End If
Am getting Run-time error. Thanks in advance.
According to this Microsoft Article, "If you use the CreateObject function with an object of type Word.Application or Word.Basic, the function fails if Word is already running." The failure is indicated by a Run-Time error. Microsoft suggests that you "check to see whether Word is already running. If it is not, start a new instance of Word." For example, you could use "the GetObject function to create a Word.Application object. If the GetObject function fails, Word is not running, so the CreateObject function is then used to set the Word.Application object." The code provided in the linked article is as follows:
Sub RunWord()
Dim wObj As Word.Application
On Error Resume Next
' Get existing instance of Word if it exists.
Set wObj = GetObject(, "Word.Application")
If Err <> 0 Then
' If GetObject fails, then use CreateObject instead.
Set wObj = CreateObject("Word.Application")
End If
' Add a new document.
wObj.Documents.Add
' Exit Word.
wObj.Quit
' Clear object memory.
Set wObj = Nothing
End Sub