I'm currently using the following to automatically save the output to a specified file.
ActiveWorkbook.SaveAs Filename:=FilePath & Range("E9") & " Perf Eval.xlsx", FileFormat:=xlOpenXMLWorkbook
I need to change it to show the Save As dialog box and pre-fill the filename and extension so the directory can be manually chosen. I'm trying to use Application.GetSaveAsFilename and it displays the dialog box with no filename or file format defined. How can I get it to pre-fill the filename and set the file format?
I've tried using the InitialFileName argument as shown below, but it just gives me "compile error expected: ="
Application.GetSaveAsFilename (InitialFileName:=Range("E9") & " Perf Eval.xlsx")
Sub fileDialog()
Dim fd As Office.fileDialog
Dim strFile As String
Set fd = Application.fileDialog(msoFileDialogSaveAs)
With fd
.InitialFileName = "File Name"
If .Show = True Then
strFile = .SelectedItems(1)
End If
End With
End Sub
Related
From the code below, I want to programmatically copy and rename the files I am adding into the table tblObjects to be same as the primary key which is ObjectID, i.e. /Images/1.jpeg etc and then return the relative filepath containing all the images to be in a folder called "Images" within the current project folder.
Currently, when i select a file through the file dialog to populate the table, i am getting
error 75 in cmdBrowse_Click procedure: path/file access error.
Private Sub cmdBrowse_Click()
On Error GoTo Err_Handler
Dim PathStrg As String
Dim relativePath As String
Dim dbPath As String
'Code compatible with both 32-bit & 64-bit Office
' Set options for the file dialog box.
Dim F As FileDialog
Set F = Application.FileDialog(msoFileDialogFilePicker)
F.Title = "Locate the image file folder and click on 'Open' to select it"
' Clear out any current filters, and add our own
F.Filters.Clear
F.Filters.Add "Image files", "*.jpg;*.jpeg"
' Set the start folder. Open in default file folder if blank
F.InitialFileName = Nz(Application.CurrentProject.Path & "\Images\", "C:\") 'modify this as appropriate
' Call the Open dialog procedure.
F.Show
' setup new file name and appropriate DB subfolder
relativePath = "\Images\" & Me.txtObjectID & ".jpg"
dbPath = Application.CurrentProject.Path
'copy selected file with new name and subfolder
FileCopy LCase(PathStrg), dbPath & relativePath
'update the table field with the new file name and relative location
Me!ImagePath.Value = relativePath
'display the image from the subfolder of the DB
Me.Requery
Exit_Handler:
Exit Sub
Err_Handler:
If Err <> 5 Then 'err=5 user cancelled
MsgBox "Error " & Err.Number & " in cmdBrowse_Click procedure: " & Err.Description
End If
Resume Exit_Handler
End Sub
I have a script that saves a backup database (with a date stamp) to a shared drive.
Private Sub Command0_Click()
Dim fs As Object Dim oldPath As String, newPath As String
Dim CurrentDate As String
CurrentDate = Format(Now, "MMDDYY")
oldPath = "\\xxx\xxx Database" 'Folder file is located in
'newPath = "\\xxx\xxx\FINANCE\USERS\xxx\xxx Operations\xxx\xxx\" 'Folder to copy file to
newPath = "C:\Users\xxx\Documents\xxx\xxx" 'Folder to copy file to
Set fs = CreateObject("Scripting.FileSystemObject")
fs.CopyFile oldPath & "\" & "xxx Database Update v.1.6_be.accdb", newPath & "\" _
& "xxx Database Update v.1.6_be_" & CurrentDate & ".accdb"
Set fs = Nothing
MsgBox "Database Backed up", , "Backup Complete"
End Sub
This worked fine.
However I have now been asked to also send the database to a shared inbox email address.
Private Sub btnbrowse_click()
Dim filediag As FileDialog
Dim file As Variant
Set filediag = FileDialog(msofiledialogfilepicker)
filediag.allowmultiselect = False
If filediag.show Then
For Each file In filediag.selecteditems
Me.txtattachment = file
Next
End If
End Sub
Private Sub btnSend_Click()
Dim oApp As New Outlook.Application
Dim oEmail As Outlook.MailItem
Set oEmail = oApp.CreateItem(olMailItem)
oEmail.To = Me.txtto
oEmail.Subject = Me.txtsubject
oEmail.Body = Me.txtbody
If Len(Me.txtattachment) > 0 Then
oEmail.Attachments.Add Me.txtattachment.Value
End If
With oEmail
If Not IsNull(.To) And Not IsNull(.Subject) And Not IsNull(.Body) Then
.Send
MsgBox "Email Sent!"
Else
MsgBox "Please fill out the required fields."
End If
End With
End Sub
Please can somebody help me link the two scripts so that instead of using the FileDialog to choose the email attachment, I can use the path in the first query to select the attachment and the script will run both the save file and the email file commands at the same time.
It's just the filename, so it could be just passing the value from your script:
oEmail.Attachments.Add newPath & "\xxx Database Update v.1.6_be_" & CurrentDate & ".accdb"
If you want to just automatically send after the backup, make the email code a Sub that can be called in Backup button click procedure.
Sub SendEmail(strFile As String)
...
oEmail.Attachments.Add strFile
...
End Sub
Then calling the sub at end of the Backup button click:
SendEmail(newPath & "\xxx Database Update v.1.6_be_" & CurrentDate & ".accdb")
Many email systems reject emails with Access file as an attachment because of malicious code risk. However, a zipped Access file should pass security. Example code:
Dim strZip As String
strZip = CurrentProject.Path & "\Construction.zip"
'create empty zip folder
'found this on web, no idea what the Print line does but if it isn't there, this won't work
Open strZip For Output As #1
Print #1, "PK" & Chr$(5) & Chr$(6) & String(18, 0)
Close #1
'copy file into zip folder
Dim objApp As Object
Set objApp = CreateObject("Shell.Application")
'variable for source file doesn't seem to work in this line
'also double parens not in original example code but won't work without
objApp.NameSpace((strZip)).CopyHere CurrentProject.Path & "\Construction.accdb"
As noted in code comment, issue is passing source file via variable. Sorry, I never needed to solve.
Creating zip file code could be in the email procedure and then attach the zip file:
oEmail.Attachments.Add strZip
Then at the end of email procedure, can delete the zip file:
Kill strZip
I've got a VBA macro that renames a file. I have the full path where this file exist but I want to rename this file independent from its location.
Private Sub Workbook_Open()
Dim sFileName As String, sNewFileName As String
sFileName = "C:\Users\me\Desktop\text.txt"
sNewFileName = "C:\Users\me\Desktop\test1.txt"
If Dir(sFileName, 16) = "" Then MsgBox "File not found", vbCritical, "Error": Exit Sub
Name sFileName As sNewFileName 'rename file
MsgBox "file has been renamed"
End Sub
I mean if you extract the archive with this Excel file and text.txt file and start it, it will find test.txt and rename it independent from its location.
You are looking for ThisWorkbook.Path which gives you the path of the workbook you are using. So if your txt file is in the same directory you can use something like this:
sFileName = ThisWorkbook.Path & "\text.txt"
sNewFileName = ThisWorkbook.Path & "\test1.txt"
When the excel file location is the same as the text file location, you don't have to write the direction path.
Just write the filename without its direction path:
sFileName = "test.txt"
sNewFileName = "test1.txt"
I was searching for macro that batch opens .doc documents and save them as .docx. I have already found one. Now I want to remove any highlight (keep the text; as well as to do more cleaning operations) in all the documents. When I add a line into it (to the best place I could guess), then it runs continuously without stopping after the last document. Any idea where and how to do amend it ?
Sub batch_cleaner()
Dim strFilename As String
Dim strDocName As String
Dim strPath As String
Dim oDoc As Document
Dim fDialog As FileDialog
Dim intPos As Integer
Set fDialog = Application.FileDialog(msoFileDialogFolderPicker)
With fDialog
.Title = "Select folder and click OK"
.AllowMultiSelect = False
.InitialView = msoFileDialogViewList
If .Show <> -1 Then
MsgBox "Cancelled By User", , "List Folder Contents"
Exit Sub
End If
strPath = fDialog.SelectedItems.Item(1)
If Right(strPath, 1) <> "\" Then strPath = strPath + "\"
End With
If Documents.Count > 0 Then
Documents.Close SaveChanges:=wdPromptToSaveChanges
End If
If Left(strPath, 1) = Chr(34) Then
strPath = Mid(strPath, 2, Len(strPath) - 2)
End If
strFilename = Dir$(strPath & "*.doc")
While Len(strFilename) <> 0
Set oDoc = Documents.Open(strPath & strFilename)
' here I was trying to add stuff
strDocName = ActiveDocument.FullName
intPos = InStrRev(strDocName, ".")
strDocName = Left(strDocName, intPos - 1)
strDocName = strDocName & ".docx"
oDoc.SaveAs FileName:=strDocName, _
FileFormat:=wdFormatDocumentDefault
oDoc.Close SaveChanges:=wdDoNotSaveChanges
strFilename = Dir$()
Wend
End Sub
And this code always ruins it:
Selection.WholeStory
Selection.Range.HighlightColorIndex = wdNoHighlight
The problem lies in the "short name" (8.3 name) for your .docx files. It'll still have a name ending in .doc so it also finds your new file in the dir$() call.
This can be demonstrated at a command prompt fairly easily (fake .doc file just to show the name issue):
C:\> echo x> 1.docx
C:\> if exist *.doc echo y
y
C:\> dir *.doc
09/03/2014 06:27 PM 3 1.docx
C:\> dir /x *.doc
09/03/2014 06:27 PM 3 100FD~1.DOC 1.docx
So you see the short name, although hidden from normal view, is actually a .DOC file so it matches. Likewise in your script it'll match.
A couple of options come to mind offhand:
name the files to something else that won't match like .xyz and then do a bulk rename later
use subdirectories to store the resulting files so it won't, again, match in the dir$() call
I have an email message with an image attachment that I want to save with a VBA macro. The file name and the display name show French accents in the attachment name (e.g. "Événement.jpg").
Saving the attachment with Outlook VBA works:
Dim fso As Object
Dim sFileName As String
Dim oAttachment As Outlook.attachment
set fso = CreateObject("Scripting.FileSystemObject")
' Edit the folder location accordingly:
sFileName = "C:\Users\YOUR_ACCOUNT_HERE\Desktop\" & oAttachment.getFileName
oAttachment.SaveAsFile sFileName
I can see the file correctly named on the file system.
Trying to access this file within VBA later on fails. The following code always returns FALSE:
' Returns False
MsgBox "File [" & sFileName & "] exists? " & sfo.fileexists(sFileName), vbInformation
Dim bFileExists as Boolean
If lenB (Dir(sFileName) > 0 Then
bFileExists = True
Else
bFileExists = True
EndIf
' Also returns False
MsgBox "File [" & sFileName & "] exists? " & bFileExists, vbInformation
What am I doing wrong?
I eventually came upon a workaround, thanks to the MS-DOS "8.3" file naming legacy of Windows. Converting the file name to its short file name makes Dir() and Open() happy:
Dim sFileShortName As String
sFileShortName = fso.Getfile(sTempFileLocation).shortpath
bFileExists = (Dir(sFileShortName) <> "") ' Now returns True at last!
Now fso.FileExists(sFileShortName) as well as bFileExists (based on Dir()) return True and Open sFileShortName For Binary Access Read As lFileNum works as well.
I hope that this will be beneficial to others.