I have a template in which I want to display the document path in the footer just before a save happends.
I have got the DocumentBeforeSave Sub all ready and functioning but the problem is I seem to have no way to get the destination path for the document, unless i'm missing something.
Private WithEvents App As Word.Application
Private Sub App_DocumentBeforeSave(ByVal Doc As Document, SaveAsUI As Boolean, Cancel As Boolean)
' UPDATE FOOTER HERE '
End Sub
I first thought that maybe the parameter Doc contained the destination, but I've only found the current directory.
The problem is only when doing a 'Save As', otherwise the footer don't need changing.
By now you know you need to save as a '.docm' if you have VBA code. Not that the following will do what you want, but it is an example of how to see the default save path, and the 'latest' save path for this document. I set it to display different messages (on close) if someone does a SaveAs.
Option Explicit
Dim strPath As String
Private Sub Document_Open()
MsgBox "On Open, default save path is: " & Options.DefaultFilePath(wdDocumentsPath)
strPath = ActiveDocument.Path
End Sub
Private Sub Document_Close()
If strPath <> ActiveDocument.Path Then
MsgBox "Document now in DIFFERENT path." & vbCrLf & _
"On Close, document was saved at: " & ActiveDocument.Path & vbCrLf & _
"Originally the document was in path: " & strPath
Else
MsgBox "Document still in same path." & vbCrLf & _
"On Close, document was saved at: " & ActiveDocument.Path & vbCrLf & _
"Full Path & Name: " & ActiveDocument.FullName
End If
End Sub
Related
I have .docm documents with VBA code located in
Project(Document1)
|_Microsoft Word Object
|_ThisDocument
The purpose of this code is to export the document as a PDF file when the user saves the file (NOTE : the file already exists in the remote directoy when the user opens it) :
Private WithEvents App As Word.Application
Private Sub Document_Open()
Set App = Word.Application
End Sub
Private Sub App_DocumentBeforeSave(ByVal Doc As Document, SaveAsUI As Boolean, Cancel As Boolean)
If Word.Documents.Count And ActiveDocument = ThisDocument Then
Dim strFilename As String
strFilename = ActiveDocument.Name
Dim positionPoint As Integer
positionPoint = InStr(strFilename, ".")
If positionPoint <> 0 Then
strFilename = Left(strFilename, positionPoint - 1)
strPath = ActiveDocument.Path & Application.PathSeparator
ActiveDocument.ExportAsFixedFormat outputFileName:= _
strPath & strFilename & ".pdf", _
ExportFormat:=wdExportFormatPDF, _
OpenAfterExport:=False, _
OptimizeFor:=wdExportOptimizeForOnScreen, _
Range:=wdExportAllDocument, _
IncludeDocProps:=False, _
CreateBookmarks:=wdExportCreateNoBookmarks, _
BitmapMissingFonts:=True
End If
End If
End Sub
Most of the times it works just fine but sometimes the user would have a popup say
Word Cannot Complete the Save Due to a File Permission Error
If the user retries saving it does not work. Also, the PDF export work, sometimes in under a minute and sometimes it takes a very long time to perform the export, it can take hours. The file is only 300 to 500Ko large. It is saved on a remote directory.
Is there anything I can do in my code to secure the file save ? Is it possible to find another event to trigger the PDF export ? I tried to trigger it before close but it would display a "Do you want to save your file" popup and it is not always relevant to export before close.
Thanks
Using Microsoft Access: there is a form. On the form is a textbox containing a name. There is a button on the form which, when clicked, runs vba code that looks at the name on the form then opens the like named folder. The database and folder reside in the same directory. Two users have reported that, instead of the folder opening, Internet Explorer opens for them (to their default webpage).
Code for the button:
Private Sub cmdNewOpenFolder_Click()
'Uses the OpenFolderMod module to open the folder for the active record in file explorer, and create
'one if it doesn't yet exist
On Error GoTo Err_Handler
If Me.chkComplete = True Then
MsgBox "This folder has been moved to the archive"
Exit Sub
Else:
Call OpenFolder(Me.FullName)
End If
Exit_Handler:
Exit Sub
Err_Handler:
If err.Number = 94 Then
MsgBox "Please add the name of the fugitive in the 'Name' text box in order" & vbCrLf & _
"for a folder to be created."
Else
MsgBox "Error " & err.Number & ": " & err.Description
End If
Resume Exit_Handler
End Sub
The Open Folder code:
Public Sub OpenFolder(fldName As String)
Dim strStartFilePath As String
Dim strEndFilePath As String
Dim Continue As String
On Error GoTo err
strStartFilePath = strBEPath & "\" & fldName
strEndFilePath = Dir(strStartFilePath & fldName & "*", vbDirectory)
Application.FollowHyperlink strStartFilePath & strEndFilePath
err:
If err.Number = 490 Then
Continue = MsgBox("There is no folder yet, do you want to create one?", _
vbYesNo, "Create Folder")
If Continue = vbYes Then
Call MakeFolder(strBEPath & "\" & fldName)
Application.FollowHyperlink strStartFilePath & strEndFilePath
Else: Exit Sub
End If
End If
End Sub
strBEPath is a constant that is the backend database location on a shared server. It looks like "\\{name of server}\{otherfoldername}\{otherfoldername with a space in the name}\etc." (there are five subfolders in all.)
Interestingly, there is a similar button which opens the "Project Folder" the folder with the database and subfolder and it works just fine:
Public Sub OpenProjFolder()
Application.FollowHyperlink strBEPath
'Debug.Print strBEPath
End Sub
I looked over the machines where this is happening and nothing looks out of the ordinary. Both users have all the right reference libraries and so on.
Any ideas as to why Internet Explorer is opening?
My goal is to extract the .png files of emails in the Outlook Inbox sub folder named Infuse Energy Daily Usage Reports.
The emails each contain six png files. The largest is the only one I need; it is exactly 37.6KB. The next largest file is 22.5KB. The third largest is 18.2KB.
The code mostly does what I need.
I want to add the full subject of the email to the beginning of the file name.
The file name should be:
"Email Subject, Creation Time ("yyyymmdd_hhnnss_"), Original File Name of PNG Image."
Sub SaveAttachmentsToFolder()
' This Outlook macro checks a named subfolder in the Outlook Inbox
' (here the "Infuse Eneregy Daily Usage Reports" folder) for messages with attached
' files of a specific type (here file with a "png" extension)
' and saves them to disk. Saved files are timestamped. The user
' can choose to view the saved files in Windows Explorer.
' NOTE: make sure the specified subfolder and save folder exist
' before running the macro.
On Error GoTo SaveAttachmentsToFolder_err
' Declare variables
Dim ns As NameSpace
Dim Inbox As MAPIFolder
Dim SubFolder As MAPIFolder
Dim Item As Object
Dim Atmt As Attachment
Dim FileName As String
Dim i As Integer
Dim varResponse As VbMsgBoxResult
Set ns = GetNamespace("MAPI")
Set Inbox = ns.GetDefaultFolder(olFolderInbox)
Set SubFolder = Inbox.Folders("Infuse Energy Daily Usage Reports") ' Enter correct subfolder name.
i = 0
' Check subfolder for messages and exit if none found
If SubFolder.Items.Count = 0 Then
MsgBox "There are no messages in the Infuse Energy Daily Usage folder.", vbInformation, _
"Nothing Found"
Exit Sub
End If
' Check each message for attachments
For Each Item In SubFolder.Items
For Each Atmt In Item.Attachments
' Check filename of each attachment and save if it has "png" extension
If Right(Atmt.FileName, 3) = "png" Then
' This path must exist! Change folder name as necessary.
FileName = "C:\Desktop\Energy Comparisons\Infuse Reports (from email)\" & _
Format(Item.CreationTime, "yyyymmdd_hhnnss_") & Atmt.FileName
Atmt.SaveAsFile FileName
i = i + 1
End If
Next Atmt
Next Item
' Show summary message
If i > 0 Then
varResponse = MsgBox("I found " & i & " attached files." _
& vbCrLf & "I have saved them into the Infuse Reports (from email)." _
& vbCrLf & vbCrLf & "Would you like to view the files now?" _
, vbQuestion + vbYesNo, "Finished!")
' Open Windows Explorer to display saved files if user chooses
If varResponse = vbYes Then
Shell "Explorer.exe /e,C:\Desktop\Energy Comparisons\Infuse Reports (from email)", vbNormalFocus
End If
Else
MsgBox "I didn't find any attached files in your mail.", vbInformation, "Finished!"
End If
' Clear memory
SaveAttachmentsToFolder_exit:
Set Atmt = Nothing
Set Item = Nothing
Set ns = Nothing
Exit Sub
' Handle Errors
SaveAttachmentsToFolder_err:
MsgBox "An unexpected error has occurred." _
& vbCrLf & "Please note and report the following information." _
& vbCrLf & "Macro Name: GetAttachments" _
& vbCrLf & "Error Number: " & Err.Number _
& vbCrLf & "Error Description: " & Err.Description _
, vbCritical, "Error!"
Resume SaveAttachmentsToFolder_exit
End Sub
First of all, there is no need to iterate over all items in a folder:
For Each Item In SubFolder.Items
For Each Atmt In Item.Attachments
This is not really a good idea because it can take a lot of time to iterate over all items in a folder. Instead, you need to use the Find/FindNext or Restrict methods of the Items class. Filter Example: [Attachment & Subject Like '%keyword%']
Filter = "#SQL=" & Chr(34) & "urn:schemas:httpmail:subject" & _
Chr(34) & " Like '%keyword%' AND " & _
Chr(34) & "urn:schemas:httpmail:hasattachment" & _
Chr(34) & "=1"
Read more about these methods in the following articles:
How To: Use Find and FindNext methods to retrieve Outlook mail items from a folder (C#, VB.NET)
How To: Use Restrict method to retrieve Outlook mail items from a folder
As for the filename of attachments saved to the disk, you need to make sure there are no forbidden symbols included to the filename before calling the SaveAsFile method.
If Right(Atmt.FileName, 3) = "png" Then
' This path must exist! Change folder name as necessary.
FileName = "C:\Desktop\Energy Comparisons\Infuse Reports (from email)\" & Item.Subject & _
Format(Item.CreationTime, "yyyymmdd_hhnnss_") & Atmt.FileName
Atmt.SaveAsFile FileName
i = i + 1
End If
Also be aware, an Outlook folder may contain different kind of items. I'd suggest checking the item's type at runtime to make sure you deal with mail items only. The Class property returns an OlObjectClass constant indicating the object's class. Or just use the following condition:
If TypeOf Item Is MailItem Then
' your code here
End If
I'm familiar with VBA but I am not a programmer so any help I can get in this matter is greatly appreciated. I have a report object that is mailed as a .pdf file. This portion of the code works fine but I would like to be able to save a copy of this file to a specific location with a unique name that includes the date and time the file was created. The first set of code is the SendObject that works the second set of code does not work, it is a separate procedure I have been testing to save the object. Once I can get it working I was going to integrate it into first. I would appreciate any help.
Private Sub Command21_Click()
DoCmd.SetWarnings (False)
Dim mailto As String
Dim ccto As String
Dim bccto As String
mailto = "Safety-RiskGroup#bargeacbl.com"
ccto = ""
bccto = ""
emailmsg = "The attached document is the updated Case Log." & vbNewLine
& "Please review the report, contact me and you find any discrepancies. "&vbNewLine & vbNewLine & "Thank You, " & vbNewLine & vbNewLine & vbNewLine & "Cary S. WInchester" & vbNewLine & "American Commercial Barge Line" & vbNewLine & "Safety Department"
mailsub = "Updated Case Log Report"
On Error Resume Next
DoCmd.SendObject acSendReport, "rpt_CaseLog-CurrentYear", acFormatPDF, mailto, ccto, bccto, mailsub, emailmsg, True
DoCmd.SetWarnings (True)
End Sub
This is the second set of code to attempt to save the object to a specific path with a unique name.
Private Sub Command23_Click()
On Error GoTo Command23_Click_Err
Dim filePath As String
filePath = "C:\Work\ACBL\Access Dbase\DayCount" & "CaseLog" _
& Format(Date, " yyyy/mm/dd") _
& Format(Time, " hh:MM:ss") & ".pdf"
DoCmd.OutputTo acOutputReport, "rpt_CaseLog-CurrentYear", _
"PDFFormat(*.pdf)", filePath, _
False, "", , acExportQualityPrint
Command23_Click_Exit:
Exit Sub
Command23_Click_Err:
MsgBox Error$
Resume Command23_Click_Exit
End Sub
Thanks Bit Accesser but that was not the problem, the code was laid out as it should be; however, the Date and Time formats were using characters that could be used for a file name, specifically, the colons and the backslashes were causing it to fail. Below is the corrected code. There are a few other spots I tweaked but this works great.
Private Sub Command25_Click()
On Error GoTo Command25_Click_Err
Dim filePath As String
filePath = "C:\Work\ACBL\Access Dbase\DayCount\Reports\"
DoCmd.OutputTo acOutputReport, "rpt_CaseLog-CurrentYear", acFormatPDF, _
filePath & " Case Log Update" & Format(Now(), " dd-mm-yyyy hhmmss") & ".pdf"
Command25_Click_Exit:
Exit Sub
Command25_Click_Err:
MsgBox Error$
Resume Command25_Click_Exit
End Sub
i need to save the excel attachement received inside outlook messages in a specific sub folder (daily final) located in the inbox and knowing that all the emails in that subflders will be including that excel attached file. i had below an example with excel VBA but it is not working so kindly advie me
Sub SaveAttachmentsToFolder()
' This Outlook macro checks a named subfolder in the Outlook Inbox
' (here the "daily final" folder) for messages with attached
' files of a specific type (here file with an "xls" extension)
' and saves them to disk. Saved files are timestamped. The user
' can choose to view the saved files in Windows Explorer.
' NOTE: make sure the specified subfolder and save folder exist
' before running the macro.
On Error GoTo SaveAttachmentsToFolder_err
' Declare variables
Dim ns As Namespace
Dim Inbox As MAPIFolder
Dim SubFolder As MAPIFolder
Dim Item As Object
Dim Atmt As Attachment
Dim FileName As String
Dim i As Integer
Dim varResponse As VbMsgBoxResult
Set ns = GetNamespace("MAPI")
Set Inbox = ns.GetDefaultFolder(olFolderInbox)
Set SubFolder = Inbox.Folders("daily final") ' Enter correct subfolder
name.
i = 0
' Check subfolder for messages and exit of none found
If SubFolder.Items.Count = 0 Then
MsgBox "There are no messages in the Sales Reports folder.",
vbInformation , _
"Nothing Found"
Exit Sub
End If
' Check each message for attachments
For Each Item In SubFolder.Items
For Each Atmt In Item.Attachments
' Check filename of each attachment and save if it has "xls" extension
If Right(Atmt.FileName, 3) = "xls" Then
' This path must exist! Change folder name as necessary.
FileName = "C:\Email Attachments\" & _
Format(Item.CreationTime, "yyyymmdd_hhnnss_") &
Atmt.FileName
Atmt.SaveAsFile FileName
i = i + 1
End If
Next Atmt
Next Item
' Show summary message
If i > 0 Then
varResponse = MsgBox("I found " & i & " attached files." _
& vbCrLf & "I have saved them into the C:\Email Attachments folder." _
& vbCrLf & vbCrLf & "Would you like to view the files now?" _
, vbQuestion + vbYesNo, "Finished!")
' Open Windows Explorer to display saved files if user chooses
If varResponse = vbYes Then
Shell "Explorer.exe /e,C:\Email Attachments", vbNormalFocus
End If
Else
MsgBox "I didn't find any attached files in your mail.",
vbInformation , "Finished!"
End If
' Clear memory
SaveAttachmentsToFolder_exit:
Set Atmt = Nothing
Set Item = Nothing
Set ns = Nothing
Exit Sub
' Handle Errors
SaveAttachmentsToFolder_err:
MsgBox "An unexpected error has occurred." _
& vbCrLf & "Please note and report the following information." _
& vbCrLf & "Macro Name: GetAttachments" _
& vbCrLf & "Error Number: " & Err.Number _
& vbCrLf & "Error Description: " & Err.Description _
, vbCritical, "Error!"
Resume SaveAttachmentsToFolder_exit
End Sub
It seems you have cut-and-pasted from a website but you are not familiar with VBA. When you paste code into the VBA Code wondow, it will highlight lines where there are problems. You then apply your knowledge to fix these problems. For example, this line from above should be one statement:
MsgBox "There are no messages in the Sales Reports folder.",
vbInformation , _
"Nothing Found"
Like so:
MsgBox "Message", buttons, "Title"
You can put a statement on three lines like you have it, but you must use the line continuation character (_), you only have one, you need two.
MsgBox "There are no messages in the Sales Reports folder.", _
vbInformation , _
"Nothing Found"
Here
FileName = "C:\Email Attachments\" & _
Format(Item.CreationTime, "yyyymmdd_hhnnss_") &
You have an extra &. A statement cannot end with &
The F1 key can be very helpful in these situations.