Can anyone point to what I'm doing wrong. I'm trying to output an Access 2007 report to Word (using .rtf!) but I can't seem to then point my code at the file. I keep getting Type Mismatch errors.
Here is my code:
Private Sub CatalogTitle_Click()
Dim AppWord As Object
Dim Doc As Object
Dim FileName As String
Dim DateTime As Date
Dim DTString As String
Dim x As Integer
Set AppWord = CreateObject(Class:="Word.Application") ' create an instance of Word
DateTime = Now() ' build a date string which is compatible with the Windows File structure
DTString = CStr(DateTime)
For x = 1 To Len(DTString) ' changes dd/mm/yy hh:mm:ss into dd_mm_yy hh_mm_ss
If (Mid(DTString, x, 1) = "/" Or Mid(DTString, x, 1) = ":") Then
Mid(DTString, x, 1) = "_"
End If
Next x
' build the full .rtf filename
FileName = "Titles " & DTString & ".rtf"
' and output the rtf file to it
DoCmd.OutputTo acReport, "ItemsReportByTitle", acFormatRTF, FileName
' then open the Word instance with the file just created
Set Doc = "AppWord.Documents.Open(FileName)"
' and make the instance visible
AppWord.Visible = True
End Sub
I keep failing on the 'Set Doc...' line.
Remove the double quotes around the object/method...
Set Doc = AppWord.Documents.Open(FileName)
Related
Is there a way, setting, macro, or otherwise, that can automatically create backups of the current document in a series? Such as, working on a Writer document, pressing a macro button, and creating a backup at that time, so that there is another backup added to the previous backups in a folder?
Well, try this
Sub createBackUp()
Dim sURL As String
Dim aURL As Variant
Dim saveTime As String
sURL = ThisComponent.getURL()
If Trim(sURL) = "" Then Exit Sub ' No name - cannot store
saveTime = "_" & FORMAT(Now,"YYYYMMDD\_HHmmSS")
aURL = Split(sURL, ".")
If UBound(aURL) < 1 Then ' No extention?
sURL = sURL & saveTime
Else
aURL(UBound(aURL)-1) = aURL(UBound(aURL)-1) & saveTime
sURL = Join(aURL,".")
EndIf
On Error Resume Next
ThisComponent.storeToURL(sURL,Array())
On Error GOTO 0
End Sub
Also you can try Timestamp Backup
I have 2 files that I want to merge to one report. Both files are in different folders and they are alone in their folder.
My problem is that when I dim each workbook as a variable I need to put a path with the name of the file.
I want that the path will stay and every time I run the Macro it will dim the current workbook in the file as "x"
Name of file for example - Clean room GSS parts - tracking file 17.05.2017
Here is my code:
Set x = Workbooks.Open("C:\Users\rosipov\Desktop\eliran\MFG - GSS\GSS\Clean room GSS parts - tracking file 17.05.2017.xlsx")
Thanks for helping.
You can convert the date of a cell, input or NOW to a string with the format you use in the filename:
FORMAT(NOW(),"dd.mm.yyyy")
Now you can use this when opening the file:
Set x = Workbooks.Open("C:\Users\rosipov\Desktop\eliran\MFG - GSS\GSS\Clean room GSS parts - tracking file " & FORMAT(NOW(),"dd.mm.yyyy") & ".xlsx")
Remember that you can use other values than the current date NOW().
You could perhaps, ask the user to select the file that you are wanting to select using the File Dialog Box.
Option Explicit
Public Enum FileDialogType
msoFileDialogOpen = 1
msoFileDialogSaveAs = 2
msoFileDialogFilePicker = 3
msoFileDialogFolderPicker = 4
End Enum
Public Function OpenTargetWBExample()
Dim FilePath As String: FilePath = FileDialog(msoFileDialogFilePicker, "Select workbook to open")
If Len(FilePath) = 0 Then Exit Function
Dim TargetWB As Workbook: Set TargetWB = Workbooks.Open(FilePath)
'Extra code goes here
Set TargetWB = Nothing
End Function
Public Function FileDialog(ByVal DialogType As FileDialogType, Optional ByVal DialogTitle As String, _
Optional MultiSelect As Boolean, Optional ByVal FileFilter As String) As String
'If MultiSelect then outputs files in the following format: "File1;File2;File3"
'Custom File Extension Filter Format: "File Description 1~File Extension Filter 1|File Description 2~File Extension Filter 2"
Dim FileDialogObject As FileDialog: Set FileDialogObject = Application.FileDialog(DialogType)
Dim Index As Long, Filters() As String, Element() As String
Dim SelectedFile As Variant
With FileDialogObject
If Len(DialogTitle) > 0 Then .Title = DialogTitle
.AllowMultiSelect = MultiSelect
If Len(FileFilter) > 0 Then
Filters = Split(FileFilter, "|")
For Index = 0 To UBound(Filters)
Element = Split(Filters(Index), "~")
.Filters.Add Element(0), Element(1), (.Filters.Count + 1)
Next Index
End If
.FilterIndex = 0
.Show
.Filters.Clear
For Each SelectedFile In .SelectedItems
FileDialog = FileDialog & CStr(SelectedFile) & ";"
Next SelectedFile
If Len(FileDialog) > 0 Then FileDialog = Left(FileDialog, Len(FileDialog) - 1)
End With
Set FileDialogObject = Nothing
End Function
since there is only one file in the directory
dim aaa as String
aaa = ""C:\Users\rosipov\Desktop\eliran\MFG - GSS\GSS\"
Set x = Workbooks.Open(aaa & Dir(aaa))
I'm trying to pull text from a bunch of XML files into Word. I'm working from a list of files and have found that some of them don't actually exist in the folder. So, I'm using this function to check whether the files actually exist before opening them. But I'm still getting error 52 (Bad file name or number).
This is the function:
Function FileThere(FileName As String) As Boolean
FileThere = (Dir(FileName) > "")
End Function
And this is the code I'm calling it from:
Sub PullContent()
Dim docList As Document
Dim docCombinedFile As Document
Dim objFileListTable As Table
Dim objRow As Row
Dim strContent As String
Dim strFileCode As String
'Code # for the current file. (Pulled in temporarily, output to the Word doc.)
Dim strFilename As String
'Name of XML file. Created based on strFileCode
Set docCombinedFile = Documents.Add
'The new doc which will list all warnings
Dim strXml As String
'String variable that holds the entire content of the data module
Dim strInvalidCodes
'String listing any invalid file codes. Displayed at the end.
Dim FSO As Object: Set FSO = CreateObject("Scripting.FileSystemObject")
Documents.Open FileName:="C:\Users\kelly.keck\Documents\Triton MTS\IETMs - Test\IETMList.docx"
Set docList = Documents("IETMList.docx")
Set objFileListTable = docList.Tables(1)
For Each objRow In objFileListTable.Rows
strFileCode = objRow.Cells(4).Range.Text
strFileCode = Left(strFileCode, Len(strFileCode) - 2)
strFilename = strFileCode & ".xml"
strPath = "C:\Applications\xml\"
If FileThere(strPath & strFileCode) = True Then
'MsgBox (strPath & strFilename)
strXml = FSO.OpenTextFile(strPath & strFilename).ReadAll
Else
strInvalidCodes = strInvalidCodes & vbCr & strFileCode
End If
Next
MsgBox ("The following filenames were invalid: " & vbCr & strInvalidCodes)
End Sub
Getting this error seems to defeat the purpose of having a function to check if a file exists, but I'm not sure what's wrong with the function.
A bit late to the party, but this hasn't had an accepted answer yet.
I generally use this method to test if a file exists, and your code uses FileSystemObject already so could use that reference.
Public Function FileExists(ByVal FileName As String) As Boolean
Dim oFSO As Object
Set oFSO = CreateObject("Scripting.FileSystemObject")
FileExists = oFSO.FileExists(FileName)
End Function
I believe that you need to be sure that FileThere is actually returning the Boolean value you intend. It would be more reliable if you checked the Len property (the number of characters) or checked whether it actually returns the empty string.
The following is more verbose than absolutely necessary in order to make the logic clear. If you were to use Len, instead, then you'd check Len(Dir(FileName)) > 0
Function FileThere(FileName as String) as Boolean
Dim bFileExists as Boolean
If Dir(FileName) = "" Then
bFileExists = False
Else
bFileExists = True
End If
FileThere = bFileExists
End Function
In LibreOffice 4.2 I am trying to open the file picker and select multiple files (which I succeeded), and then to transfer the names (and path) of those files to a variable (or array, does not matter).
Although I can open the file picker and select multiple files, I can get the file name and path of only one file (the first one). And I couldn't find any way to get the others.
I am using the following code:
Sub TakeFile()
Dim FileNames(0 to 100) as String
FileNames() = fImportLocalFile()
Msgbox FileNames
End Sub
Function fImportLocalFile() 'as String
' FJCC: Can't define the function as returning a String because now it returns an array
'this function opens a system file open dialog box and allows the
' user to pick a file from thier computer to open into the
' document for processing
'stores the filedialog object
Dim oFileDialog as Object
'stores the returned result of the activation of the dialog box
Dim iAccept as Integer
'stores the returned file name/path from the file dialog box
Dim sPath as String
'stores the set default path for the dialog box
Dim InitPath as String
'stores the types of files allowed in the filedialog
Dim sFilterNames as String
'setup the filters for the types of files to allow in the dialog
sFilterNames = "*.csv; *.txt; *.odt; *.ods; *.xls; *.xlt; *.xlsx"
'create the dialog box as a Windows File Dialog
oFileDialog = CreateUnoService("com.sun.star.ui.dialogs.FilePicker")
'set the filters for the dialog
oFileDialog.AppendFilter("Supported files", sFilterNames)
'set the path as blank
InitPath = ""
'add the default path to the dialog
oFileDialog.setDisplayDirectory(InitPath)
'setup the dialog to allow multiple files to be selected
oFileDialog.setMultiSelectionMode(True)
'set iAccept as the execution of the dialog
iAccept = oFileDialog.Execute()
'execute and test if dialog works
If iAccept = 1 Then
'set sPath as the chosen file from the dialog
'sPath = oFileDialog.Files(0)
FileArray = oFileDialog.getFiles() 'added by FJCC
'set the function as sPath for returning to the previous sub
fImportLocalFile = FileArray 'modified by FJCC
'end current if statement
End If
End Function
Your error is you are assigning the array of selected files to the funtion name itself! Choose a different name.
This works with me on LO 5.0.0.5
SUB TakeFile()
' Dim FileNames(0 to 100) as String
' Dont limit yourself!
FileNames = fImportLocalFile()
path = FileNames(0)
FOR i = 1 TO Ubound(FileNames)
print path + FileNames(i)
Next
End Sub
and within the function:
path = FileArray(0)
FOR i = 1 TO Ubound(FileArray)
print path + FileArray(i)
Next
fImportLocalFile = FileArray
There is a Interface XFilePicker2 which "extends file picker interface to workaround some design problems." This Interface has a Method getSelectedFiles.
See https://www.openoffice.org/api/docs/common/ref/com/sun/star/ui/dialogs/XFilePicker2.html.
Use this Method instead of XFilePicker.getFiles.
The following should work:
Sub TakeFile()
Dim FileNames() as String
FileNames = fImportLocalFile()
Msgbox Join(FileNames, Chr(10))
End Sub
Function fImportLocalFile() as Variant
Dim oFileDialog as Object
Dim iAccept as Integer
Dim sPath as String
Dim InitPath as String
Dim sFilterNames as String
sFilterNames = "*.csv; *.txt; *.odt; *.ods; *.xls; *.xlt; *.xlsx"
oFileDialog = CreateUnoService("com.sun.star.ui.dialogs.FilePicker")
oFileDialog.AppendFilter("Supported files", sFilterNames)
InitPath = ""
oFileDialog.setDisplayDirectory(InitPath)
oFileDialog.setMultiSelectionMode(True)
iAccept = oFileDialog.Execute()
If iAccept = 1 Then
fImportLocalFile = oFileDialog.getSelectedFiles()
Else
fImportLocalFile = Array()
End If
End Function
I am running MS Access 2010. Using VBA I am trying to pull attachments out of MS Exchange 2013 and insert them into the Access table "TBL_APPT_ATTACHMENT".
The table "TBL_APPT_ATTACHMENT" looks like this:
Attachment_title Memo
Attachment_filename Memo
Attachment_blob OLE Object
Everything seems to work correctly except I can not figure out how to save the actual file into the column ATTACHMENT_BLOB. Here is my VBA function that I am calling (See question marks below).
Private Function createRecord(fItem As Outlook.AppointmentItem)
Set rsAtt = CurrentDb.OpenRecordset("TBL_APPT_ATTACHMENT")
rsAtt.OpenRecordset
For Each Attachment In fItem.Attachments
Call MsgBox("FileName: " & Attachment.FileName, vbOKOnly, "Error")
Call MsgBox("DisplayName: " & Attachment.DisplayName, vbOKOnly, "Error")
Call MsgBox("Index: " & Attachment.Index, vbOKOnly, "Error")
rsAtt.AddNew
rsAtt!APPT_ITEM_ID = aID
rsAtt!APPT_FIELD_id = rsOl!ID
rsAtt!ATTACHMENT_TITLE = Attachment.DisplayName
rsAtt!ATTACHMENT_FILENAME = Attachment.FileName
rsAttID = rsAtt!ID
rsAtt.Update
'Save file to harddrive.
filePath = "c:\temp\" + Attachment.FileName
Attachment.SaveAsFile (filePath)
Set rsParent = CurrentDb.OpenRecordset("SELECT ID, ATTACHMENT_BLOB FROM TBL_APPT_ATTACHMENT WHERE ID = " & rsAttID)
rsParent.OpenRecordset
Do While Not rsParent.EOF
rsParent.Edit
'Load file into Database.
'??? This next statement gives me a "Type Mismatch" error. Why?????
Set rsChild = rsParent.Fields("ATTACHMENT_BLOB").Value
rsChild.AddNew
rsChild.Fields("FileData").LoadFromFile (filePath)
rsChild.Update
rsParent.Update
rsParent.MoveNext
Loop
Next
End Function
Thanks!!
Remember that the attachment is really a file (whether its an OLE object or not). While it may be possible to perform a copy-paste of the object from Outlook into Access, my recommendation is to save the attachment as a file:
dim filepath as String
dim filename as String
filepath = "C:\appropriatefolder\"
filename = Attachment.FileName
Attachment.SaveAsFile filepath & filename
Now you're in a position to save the attachment in Access, but I seriously don't recommend using the Attachment field type. It can be rather tricky to use. So my solution to the same problem was to create a field of type Hyperlink. Then your statement in your macro will simply be:
rsAtt!ATTACHMENT_LINK = filename & "#" & filepath & filename
The hyperlink definition is important and uses the format:
displayString # fullPathToFile [ # optionalPositionInsideFile ]
EDIT: Using the Attachment Field Type in Access
The Attachment field type in an Access table can be understood if you consider it an embedded recordset within that single record. Therefore, every time you add a new record (or read an existing record), you have to handle the Attachment field a bit differently. In fact, the .Value of the Attachment field is the recordset itself.
Option Compare Database
Option Explicit
Sub test()
AddAttachment "C:\Temp\DepTree.txt"
End Sub
Sub AddAttachment(filename As String)
Dim tblAppointments As DAO.Recordset
Dim attachmentField As DAO.Recordset
Dim tblField As Field
Set tblAppointments = CurrentDb.OpenRecordset("TBL_APPT_ATTACHMENT", dbOpenDynaset)
tblAppointments.AddNew
tblAppointments![APPT_ITEM_ID] = "new item id"
tblAppointments![APPT_FIELD_ID] = "new field id"
tblAppointments![ATTACHMENT_TITLE] = "new attachment"
tblAppointments![ATTACHMENT_FILENAME] = filename
'--- the attachment field itself is a recordset, because you can add multiple
' attachments to this single record. so connect to the recordset using the
' .Value of the parent record field, then use it like a recordset
Set attachmentField = tblAppointments![ATTACHMENT_BLOB].Value
attachmentField.AddNew
attachmentField.Fields("FileData").LoadFromFile filename
attachmentField.Update
tblAppointments.Update
tblAppointments.Close
Set tblAppointments = Nothing
End Sub
Here is what I ended up doing.
Private Function createRecord(fItem As Outlook.AppointmentItem)
Set rsAtt = CurrentDb.OpenRecordset("TBL_APPT_ATTACHMENT")
rsAtt.OpenRecordset
For Each Attachment In fItem.Attachments
'Save file to harddrive.
filePath = "c:\temp\" + Attachment.FileName
Attachment.SaveAsFile (filePath)
rsAtt.AddNew
rsAtt!APPT_ITEM_ID = aID
rsAtt!APPT_FIELD_id = rsOl!ID
rsAtt!ATTACHMENT_TITLE = Attachment.DisplayName
rsAtt!ATTACHMENT_FILENAME = Attachment.FileName
Call FileToBlob(filePath, rsAtt!ATTACHMENT_BLOB)
rsAttID = rsAtt!ID
rsAtt.Update
Next
End Function
Public Function FileToBlob(strFile As String, ByRef Field As Object)
On Error GoTo FileToBlobError
If Len(Dir(strFile)) > 0 Then
Dim nFileNum As Integer
Dim byteData() As Byte
nFileNum = FreeFile()
Open strFile For Binary Access Read As nFileNum
If LOF(nFileNum) > 0 Then
ReDim byteData(1 To LOF(nFileNum))
Get #nFileNum, , byteData
Field = byteData
End If
Else
MsgBox "Error: File not found", vbCritical, _
"Error reading file in FileToBlob"
End If
FileToBlobExit:
If nFileNum > 0 Then Close nFileNum
Exit Function
FileToBlobError:
MsgBox "Error " & Err.Number & ": " & Err.Description, vbCritical, _
"Error reading file in FileToBlob"
Resume FileToBlobExit
End Function