I've been trying to find a way to modify the SaveAs code to include Me.EvalID_T1.Text userform information into the title of the message.
I know I am missing something, but not sure what it is. Any help would be great!
Thanks!
Dim strPrompt As String, strname As String
Dim sreplace As String, mychar As Variant, strdate As String
Dim M As String ' variable used to store userform info
M = Me.EvalID_T1.Text ' userform info
For Each mychar In Array("/", "\", ":", "?", Chr(34), "<", ">", "¦")
strname = Replace(strname, mychar, sreplace)
strdate = Replace(strdate, mychar, sreplace)
Next mychar
myPath = "C:\Users\cam\Desktop\Test\ & " - path to save file
If myPath = False Then
MsgBox "No directory chosen !", vbExclamation
Else
On Error Resume Next
olmail.SaveAs myPath & M & ".msg", olMsg ' unknown how to modify
Related
i am trying to save a selected mail from outlook to a folder dynamically created with mail's subject name. The code ran successfully for one mail. if i select different mail and try to run the macro it is showing path not found error. My code is below:
Public Sub OpslaanMails()
Dim OlApp As Outlook.Application
Set OlApp = New Outlook.Application
Set OlApp = CreateObject("Outlook.Application")
Dim fName, sName As String
Dim oMail As Outlook.MailItem
fName = "F:\Test\inwards\"
Set oMail = OlApp.ActiveExplorer.Selection.Item(1)
sName = oMail.Subject
makeSelectionDir (sName)
sPath = fName & "\" & sName & "\"
oMail.SaveAs sPath & sName & ".msg", olMsg
For Each oAttach In oMail.Attachments
oAttach.SaveAsFile sPath & oAttach.FileName
Set oAttach = Nothing
Next
End Sub
Sub makeSelectionDir(sName As String)
Dim fName, sPath As String
fName = "F:\Test\inwards\"
sPath = fName & sName
With CreateObject("Scripting.FileSystemObject")
If Not .FolderExists(sName) Then .CreateFolder sPath 'error is in this line
End With
End Sub
Make sure sName does not contain any characters illegal in a file name, such as ":".
I used your idea and changed two or three things to make it more robust.
Put this in a module in Outlook VBA Editor and run, having selected an email.
I also added the time and date at the beginning of the folder and email file names.
I left the part about saving file attachements but know that they are already embedded in the .msg file.
Const ILLEGAL_CHARACTERS = Array("*", "/", "\", "?", """", "<", ">", ":", "|")
Sub SaveEmailToFile()
Dim oMail As MailItem
Dim sPath As String
Dim sObj As String
Dim oAttach As Attachment
'Select email and process subject
If ActiveExplorer.Selection.Count = 0 Then
MsgBox "No emails are selected."
Exit Sub
End If
Set oMail = ActiveExplorer.Selection.Item(1)
With oMail
sObj = oMail.Subject
'Remove illegal characters from email subject
If sObj = "" Then
sObj = "No Object"
Else
For Each s In ILLEGAL_CHARACTERS
sObj = Replace(sObj, s, "")
Next s
End If
'Get date and time string from email received timestamp
dateStr = Year(.ReceivedTime) & "_" & _
Month(.ReceivedTime) & "_" & _
Day(.ReceivedTime) & " " & _
Hour(.ReceivedTime) & " " & _
Minute(.ReceivedTime) & " " & _
Second(.ReceivedTime) & " "
End With
sPath = "C:\Someplace\" & dateStr & sObj & "\"
'Create folder
With CreateObject("Scripting.FileSystemObject")
If Not .FolderExists(sPath) Then .CreateFolder sPath
End With
'Save email and attachements
oMail.SaveAs sPath & oMail.Subject & ".msg", olMSG
For Each oAttach In oMail.Attachments
oAttach.SaveAsFile sPath & oAttach.FileName
Next oAttach
End Sub
I could only recreate the error
path not found
if fName was not valid.
Option Explicit ' Consider this mandatory
' Tools | Options | Editor tab
' Require Variable Declaration
' If desperate declare as Variant
Public Sub OpslaanMails()
Dim fName As String
Dim sName As String
Dim sPath As String
Dim oMail As MailItem
Dim oAttach As Attachment
fName = "F:\Test\inwards\"
Debug.Print "fName: " & fName
Set oMail = ActiveExplorer.Selection.Item(1)
sName = oMail.subject
Debug.Print "sName: " & sName
' Double slash accepted by Windows but not by some programmers
'If Right(fName, 1) = "\" Then
' fName = Left(fName, Len(fName) - 1)
' Debug.Print
' Debug.Print "fName: " & fName
'End If
' Double slash after fName preferable to no slash
sPath = fName & "\" & sName & "\"
Debug.Print "sPath: " & sPath
makeSelectionDir fName, sPath
' Possible illegal characters in sName not addressed.
' Do not test with replies nor forwards,
' the : in the subject is not a legal character.
oMail.SaveAs sPath & sName & ".msg", olMsg
For Each oAttach In oMail.Attachments
oAttach.SaveAsFile sPath & oAttach.FileName
Set oAttach = Nothing
Next
End Sub
Sub makeSelectionDir(fName As String, sPath As String)
With CreateObject("Scripting.FileSystemObject")
' Test for fName
' Otherwise there is file not found error in the create
If .FolderExists(fName) Then
' if subfolder does not exist create it
If Not .FolderExists(sPath) Then
.createFolder sPath
End If
Else
Debug.Print
Debug.Print "Folder " & fName & " does not exist."
'MsgBox "Folder " & fName & " does not exist."
End
End If
End With
End Sub
Inconsistency of sName vs sPath has been addressed in
If Not .FolderExists(sName) Then .CreateFolder sPath
I'm trying to create a list of files in a specific directory folder where I am renaming the files, but because there is a chance some files should not be renamed, I only need to rename the PDF files that begin with the letters "AB".
The renaming works fine, I just need to make sure it only renames specific files.
Private Sub CMD_RENAME_FILES_Click()
On Error GoTo CMD_RENAME_FILES_ERR
Dim varDir As String
varDir = Me.TXT_BILLING_STATEMENT_PATH
If MsgBox("Are you sure you want to rename all of the files in the directory " & "'" & varDir & "'", vbYesNo, "Confirm") = vbNo Then
Exit Sub
Else
Dim strFileName, varDateString As String
Dim strFolder As String: strFolder = Nz(Me.TXT_BILLING_STATEMENT_PATH, "Z:\")
Dim strFileSpec As String: strFileSpec = strFolder & "*.pdf"
Dim FileList() As String
Dim intFoundFiles As Integer
DoCmd.RunSQL ("UPDATE tblDirFileList SET tblDirFileList.RenameSelection = -1 WHERE FileName LIKE 'AB*'")
strFileName = Dir(strFileSpec, "AB*.PDF") 'THIS AB* DOESN'T WORK"
varDateString = Format(Date, "mmddyy")
Do While Len(strFileName) > 0
ReDim Preserve FileList(intFoundFiles)
FileList(intFoundFiles) = strFileName
intFoundFiles = intFoundFiles + 1
varLoanNumString = Mid(strFileName, 4, 9)
varNewStrFile = varLoanNumString & " - BILL STMT - " & varDateString & ".pdf"
On Error Resume Next
Name strFolder & strFileName As strFolder & varNewStrFile
strFileName = Dir
Loop
Call CMD_GET_FILE_NAMES_Click
End If
CMD_RENAME_FILES_ERR_EXIT:
Exit Sub
CMD_RENAME_FILES_ERR:
Call LogError(Err.Number, Err.Description, "CMD_RENAME_FILES_Click()")
MsgBox "Error: (" & Err.Number & ") " & Err.Description, vbCritical
Resume CMD_RENAME_FILES_ERR_EXIT
End Sub
I have a macro in excel which loops over the tabs and saves the tabs as PDFs in a given folder.
The macro partially works, it creates a few PDFs but then stops and throws this error:
Run Time Error 5 - Invalid Procedure Call or Argument
Here is my code:
Option Explicit
Sub WorksheetLoop()
Dim wsA As Worksheet
Dim wbA As Workbook
Dim strTime As String
Dim strName As String
Dim strPath As String
Dim strFile As String
Dim strPathFile As String
Dim myFile As Variant
Dim rng As Range
' Prevents screen refreshing.
Application.ScreenUpdating = False
Set wbA = ActiveWorkbook
strPath = wbA.Path
strTime = Format(Now(), "yyyymmdd")
'get active workbook folder, if saved
strPath = wbA.Path
If strPath = "" Then
strPath = Application.DefaultFilePath
End If
strPath = strPath & "\"
' Begin the loop.
For Each wsA In ActiveWorkbook.Worksheets
'replace spaces and periods in sheet name
strName = Replace(wsA.Name, " ", "")
strName = Replace(strName, ".", "_")
If strName = "Macro" Then
MsgBox "That's all folks! :)"
Exit Sub
End If
If strName = "TOUCHPOINTS" Then
strName = "Touchpoints by markets"
End If
If strName = "VIDEOHOURS" Then
strName = "Viewing Hours by markets"
End If
If strName = "TARGETS" Then
strName = "Shares by markets"
End If
If strName = "SHARESCHANNELS" Then
strName = "IGNORE ME"
End If
If strName = "TOP10PREMIERES" Then
strName = "Top 10 Premieres by markets"
End If
If strName = "SHARETREND" Then
strName = "Share trends last 13 months"
End If
If strName = "COMPETITION" Then
strName = "Share overview international media companies"
End If
If strName = "COMPETITIONSHARETREND" Then
strName = "Share trends factual competitors last 13 months"
End If
If strName = "PUT" Then
strName = "PUT level"
End If
If strName = "CHANNELRANKER" Then
strName = "Top 20 Channels by Market"
End If
'create default name for savng file
strFile = strName & "_" & strTime & ".pdf"
myFile = strPath & strFile
Debug.Print myFile
'export to PDF if a folder was selected
If myFile <> "False" Then
wsA.ExportAsFixedFormat _
Type:=xlTypePDF, _
Filename:=myFile, _
Quality:=xlQualityStandard, _
IncludeDocProperties:=True, _
IgnorePrintAreas:=False, _
OpenAfterPublish:=False
End If
Next wsA
' Enables screen refreshing.
Application.ScreenUpdating = True
End Sub
Probably the error is here:
If myFile <> "False" Then
I guess that it should be simply like this -> If myFile Then or If len(myFile) >8 Then
However, the code looks working. Just try to rebuild it with Select Case, it looks way better and slightly faster:
Select Case strName
Case "Macro"
MsgBox "That's all"
Exit Sub
Case "TOUCHPOINTS"
strName = "Touchpoints by markets"
Case Else
Debug.Print "I don't know -> "; strName
End Select
Probably you will find the error then.
Good morning all,
I am hoping someone can help me here with a piece of coding.
I am looking to save the selected email to a specific directory, with the name of the email, and of course as a .msg file.
This is what i have today, and it is not working. It saves a file but the name only has the first 2 characters (looks like it errors after the semi colon file name eg: FW or RE)... the content of the file is blank and the filetype has not been applied.
'code to save selected email
Dim selectedEmail As MailItem
Set selectedEmail = ActiveExplorer.Selection.Item(1)
Dim emailsub As String
emailsub = ActiveExplorer.Selection.Item(1).Subject
With selectedEmail
.SaveAs "C:\direcotry\folder\" & emailsub & ".msg", olMSG
End With
Thank you in anticipation.
Dom
The reason is very simple. You email subject contains and Invalid Character. For example : This usually happens when the email is a RE: or FWD:
Try this
Sub Sample()
Dim selectedEmail As MailItem
Dim emailsub As String
Set selectedEmail = ActiveExplorer.Selection.Item(1)
emailsub = GetValidName(selectedEmail.subject)
'Debug.Print emailsub
With selectedEmail
.SaveAs "C:\direcotry\folder\" & emailsub & ".msg", OlSaveAsType.olMSG
End With
End Sub
Function GetValidName(sSub As String) As String
'~~> File Name cannot have these \ / : * ? " < > |
Dim sTemp As String
sTemp = sSub
sTemp = Replace(sTemp, "\", "")
sTemp = Replace(sTemp, "/", "")
sTemp = Replace(sTemp, ":", "")
sTemp = Replace(sTemp, "*", "")
sTemp = Replace(sTemp, """", "")
sTemp = Replace(sTemp, "<", "")
sTemp = Replace(sTemp, ">", "")
sTemp = Replace(sTemp, "|", "")
GetValidName = sTemp
End Function
I’m trying to create a VBA macro that saves an email attachment to folder depending on the email address. For example if I receive and email with an attachment from joey#me.com I want to save that attachment to the directory
\server\home\joey
or if I receive it from steve#me.com the attachment should be saved in
\server\home\steve .
And finally I want send a reply email with the name of the file that has been saved. I found some code that almost does what I want but I having a difficult time modifying it. This is all being done in Outlook 2010. This is what I have so far. Any help would be greatly appreciated
Const mypath = "\\server\Home\joe\"
Sub save_to_v()
Dim objItem As Outlook.MailItem
Dim strPrompt As String, strname As String
Dim sreplace As String, mychar As Variant, strdate As String
Set objItem = Outlook.ActiveExplorer.Selection.item(1)
If objItem.Class = olMail Then
If objItem.Subject <> vbNullString Then
strname = objItem.Subject
Else
strname = "No_Subject"
End If
strdate = objItem.ReceivedTime
sreplace = "_"
For Each mychar In Array("/", "\", ":", "?", Chr(34), "<", ">", "|")
strname = Replace(strname, mychar, sreplace)
strdate = Replace(strdate, mychar, sreplace)
Next mychar
strPrompt = "Are you sure you want to save the item?"
If MsgBox(strPrompt, vbYesNo + vbQuestion) = vbYes Then
objItem.SaveAs mypath & strname & "--" & strdate & ".msg", olMSG
Else
MsgBox "You chose not to save."
End If
End If
End Sub
Is this what you are trying? (UNTESTED)
Option Explicit
Const mypath = "\\server\Home\"
Sub save_to_v()
Dim objItem As Outlook.MailItem
Dim strPrompt As String, strname As String, strSubj As String, strdate As String
Dim SaveAsName As String, sreplace As String
Dim mychar As Variant
Set objItem = Outlook.ActiveExplorer.Selection.Item(1)
If objItem.Class = olMail Then
If objItem.Subject <> vbNullString Then
strSubj = objItem.Subject
Else
strSubj = "No_Subject"
End If
strdate = objItem.ReceivedTime
sreplace = "_"
For Each mychar In Array("/", "\", ":", "?", Chr(34), "<", ">", "|")
strSubj = Replace(strSubj, mychar, sreplace)
strdate = Replace(strdate, mychar, sreplace)
Next mychar
strname = objItem.SenderEmailAddress
strPrompt = "Are you sure you want to save the item?"
If MsgBox(strPrompt, vbYesNo + vbQuestion) = vbYes Then
Select Case strname
Case "joey#me.com"
SaveAsName = mypath & "joey\" & strSubj & "--" & strdate & ".msg"
Case "steve#me.com"
SaveAsName = mypath & "steve\" & strSubj & "--" & strdate & ".msg"
End Select
objItem.SaveAs SaveAsName, olMSG
Else
MsgBox "You chose not to save."
End If
End If
End Sub
It will never work. As Outlook 2010 is not saving any msg file to a network drive only local drive is working !!
As described in the documentation of M$ and tested by me.
Simple test with fixed path and filename.
Local c:\ works. Network drive in UNC or L: does not work !!!!