I can move emails to my file system. Is it possible to do the reverse? This is what I have tried:
Sub GetMSG()
Dim StrFolder As String
StrFolder = "G:\CP-Purchasing\Completed Projects"
ListFilesInFolder StrFolder, True 'True includes subfolders, false check only this folder
End Sub
Sub ListFilesInFolder(SourceFolderName As String, IncludeSubfolders As Boolean)
Dim FileItem As Scripting.File
Dim strFile, strFileType
Dim MyMsg As MailItem
Dim FolderPick As Folder
Set FSO = New Scripting.FileSystemObject
Set SourceFolder = FSO.GetFolder(SourceFolderName)
Set FolderPick = Application.GetNamespace("MAPI").PickFolder
For Each FileItem In SourceFolder.Files
strFile = FileItem.Name
' This code looks at the last 4 characters in a filename
strFileType = LCase$(Right$(strFile, 4))
If strFileType = ".msg" Then
Debug.Print FileItem.Path
Set MyMsg = Application.CreateItemFromTemplate(FileItem.Path)
MyMsg.SaveAs (FolderPick)'This does not error, but also does not seem to work
MyMsg.Move (FolderPick)'This errors
Set objAttachments = Nothing
Set MyMsg = Nothing
End If
Next FileItem
If IncludeSubfolders Then
For Each SubFolder In SourceFolder.SubFolders
ListFilesInFolder SubFolder.Path, True
Next SubFolder
End If
Set FileItem = Nothing
Set SourceFolder = Nothing
Set FSO = Nothing
End Sub
On MyMsg.SaveAs (FolderPick) I get no error message, but it also does not save the msg in the specified folder.
MyMsg.Move (FolderPick) errors with
run-time error 424 "Object required".
For further processing after the move, you need another object since the reference to myMsg is lost.
Set myCopiedMsg = myMsg.Move(folderPick)
Debug.Print myCopiedMsg.Parent.FolderPath
In your code for moving only:
' no brackets
myMsg.Move folderPick
Related
I found this code to change .doc files to .docx files. I would like to modify it so I can specify a top level folder and have it work through it AND every sub-folder. Appreciate any assistance.
Sub TranslateDocIntoDocx()
Dim objWordApplication As New Word.Application
Dim objWordDocument As Word.Document
Dim strFile As String
Dim strFolder As String
strFolder = "C:\Temp\doc\"
strFile = Dir(strFolder & "*.doc", vbNormal)
While strFile <> ""
With objWordApplication
Set objWordDocument = .Documents.Open(FileName:=strFolder & strFile, AddToRecentFiles:=False, ReadOnly:=True, Visible:=False)
With objWordDocument
.SaveAs FileName:=strFolder & Replace(strFile, "doc", "docx"), FileFormat:=16
.Close
End With
End With
strFile = Dir()
Wend
Set objWordDocument = Nothing
Set objWordApplication = Nothing
End Sub
I suggest switching from Dir to FileSystemObject. With FSO, you can get a folder as an object with GetFolder and then access the Folder Object's files and folders as collections. This enables For Each loops like For Each File In Folder. and then you can do the recursion For Each SubFolder In Folder where you can re-call the macro as if each subfolder was the top level folder.
Sub TranslateDocIntoDocx()
Dim objWordApplication As New Word.Application
Dim strFolder As String
strFolder = "C:\Temp\doc\"
Dim StartingFolder As Object
Set StartingFolder = CreateObject("Scripting.FileSystemObject").GetFolder(strFolder)
FolderToDocx StartingFolder, objWordApplication
Set objWordApplication = Nothing
End Sub
Sub FolderToDocx(Folder As Object, wdApp As Word.Application)
Dim File As Object
For Each File In Folder.Files
If LCase(Split(File.Name, ".")(1)) = "doc" Then SaveToDocx File, wdApp
Next
Dim SubFolder As Object
For Each SubFolder In Folder.Subfolders
FolderToDocx SubFolder, wdApp
Next
End Sub
Sub SaveToDocx(File As Object, wdApp As Word.Application)
With wdApp.Documents.Open(File.Path, AddToRecentFiles:=False, ReadOnly:=True, Visible:=False)
.SaveAs Filename:=File.Path & "x"), FileFormat:=16
.Close
End With
End Sub
The file matching expression I did in this answer is just an example. You may want to improve that expression to prevent errors. One error that may come up is with Microsoft Office temp files. They are usually hidden and prefixed with ~$ like ~$Word Document.docx. So to avoid accidentally matching one of those, it would be good to exclude anything with that prefix.
I would recommend splitting out the file searching into a separate function: it's easier to tweak your logic and the main method doesn't get overloaded by the code for finding the files.
Sub TranslateDocIntoDocx()
Dim objWordApplication As New Word.Application
Dim objWordDocument As Word.Document
Dim colFiles As Collection
Dim strFile
Set colFiles = GetMatchingFiles("C:\Temp\doc\", "*.doc")
For Each strFile In colFiles
With objWordApplication
Set objWordDocument = .Documents.Open(Filename:=strFile, _
AddToRecentFiles:=False, ReadOnly:=True, Visible:=False)
With objWordDocument
.SaveAs Filename:=strFile & "x", FileFormat:=16
.Close
End With
End With
Next strFile
End Sub
'Search beginning at supplied folder root, including subfolders, for
' files matching the supplied pattern. Return all matches in a Collection
Function GetMatchingFiles(startPath As String, filePattern As String) As Collection 'of paths
Dim colFolders As New Collection, colFiles As New Collection
Dim fso As Object, fldr, subfldr, fl
Set fso = CreateObject("scripting.filesystemobject")
colFolders.Add startPath 'queue up root folder for processing
Do While colFolders.Count > 0 'loop until the queue is empty
fldr = colFolders(1) 'get next folder from queue
colFolders.Remove 1 'remove current folder from queue
With fso.getfolder(fldr)
For Each fl In .Files
If UCase(fl.Name) Like UCase(filePattern) Then 'check pattern
colFiles.Add fl.Path 'collect the full path
End If
Next fl
For Each subfldr In .subFolders
colFolders.Add subfldr.Path 'queue any subfolders
Next subfldr
End With
Loop
Set GetMatchingFiles = colFiles
End Function
I need to extract attachments from Emails received in a user preferred time frame.
Say like extract for Emails received between 2PM to 4PM.
Please find the below code I've that extract files perfectly - but it did for all the Emails in the folder.
Please help me to resolve it.
Sub Unzip()
Dim ns As NameSpace 'variables for the main functionality
Dim Inbox As MAPIFolder
Dim SubFolder As MAPIFolder
Dim Atchmt As Attachment
Dim FileName As Variant
Dim msg As Outlook.MailItem
Dim FSO As Object 'variables for unzipping
Dim oApp As Object
Dim FileNameFolder As Variant
Dim Totalmsg As Object
Dim oFrom
Dim oEnd
Set ns = GetNamespace("MAPI")
Set Inbox = ns.GetDefaultFolder(olFolderInbox)
Set SubFolder = Inbox.Folders("TEST")
Set Totalmsg = msg.ReceivedTime
oFrom = InputBox("Please give start time", ("Shadowserver report"))
oEnd = InputBox("Please give End time", ("Shadowserver report"))
If Totalmsg <= oFrom And Totalmsg >= oEnd Then
For Each msg In SubFolder.Items
For Each Atchmt In msg.Attachments
If (Right(Atchmt.FileName, 3) = "zip") Then
MsgBox "1"
FileNameFolder = "C:\Users\xxxx\Documents\test\"
FileName = FileNameFolder & Atchmt.FileName
Atchmt.SaveAsFile FileName
Set oApp = CreateObject("Shell.Application")
oApp.NameSpace(FileNameFolder).CopyHere oApp.NameSpace(FileName).Items
Kill (FileName)
On Error Resume Next
Set FSO = CreateObject("scripting.filesystemobject")
FSO.deletefolder Environ("Temp") & "\Temporary Directory*", True
End If
Next
Next
End If
End Sub
Made a few improvements to improve performance and clarity :
Test received time inside the loop on the messages
Defined related variables as Date (like MsG.ReceivedTime) and improved input messages
Added Option Explicit to avoid mishaps in future coding (VERY GOOD PRACTICE)
Use Environ$("USERPROFILE") to get User directory's path
Reorganize variables and initialisation outside of the loops
Added LCase to be sure to get all zips (including .ZIP)
Code :
Option Explicit
Sub Unzip()
'''Variables for the main functionality
Dim NS As NameSpace
Dim InboX As MAPIFolder
Dim SubFolder As MAPIFolder
Dim MsG As Outlook.MailItem
Dim AtcHmt As Attachment
Dim ReceivedHour As Date
Dim oFrom As Date
Dim oEnd As Date
'''Variables for unzipping
Dim FSO As Object
Dim ShellApp As Object
Set FSO = CreateObject("Scripting.FileSystemObject")
Set ShellApp = CreateObject("Shell.Application")
Dim FileNameFolder As Variant
Dim FileName As Variant
'''Define the Outlook folder you want to scan
Set NS = GetNamespace("MAPI")
Set InboX = NS.GetDefaultFolder(olFolderInbox)
Set SubFolder = InboX.Folders("TEST")
'''Define the folder where you want to save attachments
FileNameFolder = Environ$("USERPROFILE") & "\Documents\test\"
'''Define the hours in between which you want to apply the extraction
oFrom = CDate(InputBox("Please give Start time" & vbCrLf & _
"Example: 9AM", ("Shadowserver report"), "9AM"))
oEnd = CDate(InputBox("Please give End time" & vbCrLf & _
"Example: 6PM", ("Shadowserver report"), "6PM"))
For Each MsG In SubFolder.items
ReceivedHour = MsG.ReceivedTime
If oFrom <= TimeValue(ReceivedHour) And _
TimeValue(ReceivedHour) <= oEnd Then
For Each AtcHmt In MsG.Attachments
FileName = AtcHmt.FileName
If LCase(Right(FileName, 3)) <> "zip" Then
Else
FileName = FileNameFolder & FileName
AtcHmt.SaveAsFile FileName
ShellApp.NameSpace(FileNameFolder).CopyHere _
ShellApp.NameSpace(FileName).items
Kill (FileName)
On Error Resume Next
FSO.deletefolder Environ$("Temp") & "\Temporary Directory*", True
End If
Next AtcHmt
End If
Next MsG
End Sub
I am just going to include the part that you need to change. Other lines will be the same. Basically, what you need to do is to set the Totalmsg inside your loop for each msg;
Sub Unzip()
'... copy your code till here
Set SubFolder = Inbox.Folders("TEST")
oFrom = InputBox("Please give start time", ("Shadowserver report"))
oEnd = InputBox("Please give End time", ("Shadowserver report"))
For Each msg In SubFolder.Items
Set Totalmsg = msg.ReceivedTime
If Totalmsg <= oFrom And Totalmsg >= oEnd Then 'You check it for each msg
'rest will be the same until ...
FSO.deletefolder Environ("Temp") & "\Temporary Directory*", True
End If
Next
End If
Next
End Sub
I'm trying to extract an zip file from my Outlook mail.
Below is my script but its throwing an error object variable or with block variable not set.
On
oApp.NameSpace((FileNameFolder)).CopyHere oApp.NameSpace((Atchmt.FileName)).Items
How I fix it.
Sub Unzip()
Dim ns As NameSpace
Dim Inbox As MAPIFolder
Dim SubFolder As MAPIFolder
Dim Atchmt As Attachment
Dim FileName As String
Dim msg As Outlook.MailItem
Dim FileNameFolder As String
Dim FSO As Object 'variables for unzipping
Dim oApp As Object
Set ns = GetNamespace("MAPI")
Set Inbox = ns.GetDefaultFolder(olFolderInbox)
Set SubFolder = Inbox.Folders("TEST")
For Each msg In SubFolder.Items
If msg.UnRead = True Then
If LCase(msg.Subject) Like "*motor*" Then
For Each Atchmt In msg.Attachments
If (Right(Atchmt.FileName, 3) = "zip") Then
MsgBox "1"
FileNameFolder = "C:\Users\xxxx\Documents\test\"
Set oApp = CreateObject("Shell.Application")
oApp.NameSpace((FileNameFolder)).CopyHere oApp.NameSpace((Atchmt.FileName)).Items
End If
Next
End If
End If
Next
End Sub
Try saving the zip file first then extract it, if you want to delete the zip file then try Kill (zippath & zipname )
Dim TempFile As String
For Each msg In SubFolder.Items
If msg.UnRead = True Then
If LCase(msg.Subject) Like "*motor*" Then
For Each Atchmt In msg.Attachments
If (Right(Atchmt.FileName, 3) = "zip") Then
' MsgBox "1"
FileNameFolder = "C:\Temp\Folders\"
Debug.Print FileNameFolder ' Immediate Window
Debug.Print Atchmt.FileName ' Immediate Window
TempFile = FileNameFolder & Atchmt.FileName
Atchmt.SaveAsFile TempFile
Set oApp = CreateObject("Shell.Application")
oApp.NameSpace((FileNameFolder)).CopyHere oApp.NameSpace((Atchmt.FileName)).Items
Kill (TempFile)
End If
Next
End If
End If
Next
Declare msg as a generic Object - you can have objects other than MailItem in the Inbox, such as ReportItem or MeetingItem.
Working on a macro for Outlook 2007 which selects messages in a folder.
In example 1 and 2 below the customers folder is selected, then a specific customer folder is selected. The method to define the location seems clumsy. Is there a cleaner way to do this?
Right clicking on the sub-folder and selecting properties, the path shown is: "\mailbox-name\customers\customer-xyz". Referencing the path this way in a macro doesn't work. Is it possible to reference the folder location in a more direct manner?
Set olNamespace = olApp.GetNamespace("MAPI")
' Example-1, Select folder by name from default PST inbox
Set FolderKeep = _
olNamespace.GetDefaultFolder(olFolderInbox).Folders("customers").Folders("customer-XYZ")
' Example-2, Select folder by mailbox name/folder/subfolder
Set FolderKeep = _
olNamespace.Folders("mailbox-name").Folders("customers").Folders("customer-XYZ")
A method of pulling the folder out of a path is described here.
http://www.outlookcode.com/d/code/getfolder.htm
Private Function GetFolder(strFolderpath As String) As Folder
' The path argument needs to be in quotation marks and
' exactly match the folder hierarchy that the user sees in the Folder List.
'
' NOTE: If any folder name in the path string contains a "\" character,
' this routine will not work,
'
' As the developer do not use this. It hides errors.
'On Error GoTo GetFolder_Error
Dim objNS As Namespace
Dim objFolder As Folder
Dim arrFolders() As String
Dim colFolders As Folders
Dim i As Long
Dim uErrorMsg As String
' Remove leading slashes, if any
Do While Left(strFolderpath, 1) = "\"
'Debug.Print strFolderpath
strFolderpath = Right(strFolderpath, Len(strFolderpath) - 1)
Loop
Debug.Print strFolderpath
arrFolders() = Split(strFolderpath, "\")
Set objNS = GetNamespace("MAPI")
Set objFolder = objNS.Folders.Item(arrFolders(0))
If Not objFolder Is Nothing Then
For i = 1 To UBound(arrFolders)
Set colFolders = objFolder.Folders
Set objFolder = Nothing
Set objFolder = colFolders.Item(arrFolders(i))
If objFolder Is Nothing Then Exit For
Next
End If
Set GetFolder = objFolder
ExitRoutine:
Set colFolders = Nothing
Set objNS = Nothing
Set objFolder = Nothing
Exit Function
GetFolder_Error:
uErrorMsg = "Err.Number: " & Err.Number & vbCr & "Err.Description: " & Err.Description
MsgBox uErrorMsg
Set GetFolder = Nothing
Resume ExitRoutine
End Function
Private Sub GetFolder_Test()
Dim testFolder As Folder
Set testFolder = GetFolder("\mailbox-name\customers\customer-xyz")
If Not (testFolder Is Nothing) Then testFolder.Display
End Sub
I dragged an outlook msg to a specific folder named "email temp folder" and would like to reply on that msg automatically.
The title name of the msg which I saved in "email temp folder" could be anything. It is not possible for me to get the file's title name. So I try to loop through the file in "email temp folder" and Set FileItemToUse = objFile
However, there is an error: object doesn't support this property or method on this line. .ReplyAll
How am I able to turn FileItemToUse into an outlook item?
Sub outlookActivate1()
Dim OutApp As Outlook.Application
Dim OutMail As Outlook.MailItem
Dim fso As New FileSystemObject
Dim objFolder As Object
Dim objFile As Object
Dim FileItemToUse As Object
Dim i As Long
Set OutApp = CreateObject("Outlook.Application")
strPath = "C:\Users\admin\Desktop\email temp folder" & "\"
strFiles = Dir(strPath & "*.*")
Set objFolder = fso.GetFolder(strPath)
For Each objFile In objFolder.Files
If i = 0 Then
Set FileItemToUse = objFile
End If
Next objFile
With FileItemToUse
.ReplyAll
.BCC = ""
.Subject = "Hi"
.HTMLBody = "testing"
.BodyFormat = olFormatHTML
.display
End With
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
Your code should look similar to the following:
Sub ReplyToFilesInFolder(SourceFolderName As String)
Dim FSO As Scripting.FileSystemObject
Dim SourceFolder As Scripting.Folder
Dim FileItem As Scripting.File
Dim strFile
Dim strFileType
Dim openMsg As MailItem
Dim strFolderpath As String
Set FSO = New Scripting.FileSystemObject
Set SourceFolder = FSO.GetFolder(SourceFolderName)
For Each FileItem In SourceFolder.Files
strFile = FileItem.name
' This code looks at the last 4 characters in a filename
' If we wanted more than .msg, we'd use Case Select statement
strFileType = LCase$(Right$(strFile, 4))
If strFileType = ".msg" Then
Debug.Print FileItem.Path
Set openMsg = Application.CreateItemFromTemplate(FileItem.Path)
' do whatever is needed to reply
openMsg.Close olDiscard
Set openMsg = Nothing
' end do whatever
End If
Next FileItem
Set FileItem = Nothing
Set SourceFolder = Nothing
Set FSO = Nothing
End Sub
This (untested) snipped was inspired by this article. Microsoft Scripting Runtime has to be included as project reference.
So I try to loop through the file in "email temp folder" and Set FileItemToUse = objFile
It is not possible to get the job done that way.
When you drag a message file (.msg) file to a specific folder the ItemAdd event is fired. So, you need to handle the event to get a MailItem object which corresponds a dropped file. Then you can use the Reply or ReplyAll methods.