sindhu gollapudi
New Member
- Joined
- Nov 23, 2020
- Messages
- 2
- Office Version
- 2019
- Platform
- Windows
I have below code where the Macro fetches mail from the source folder "Testing". But i want to add another logic where it picks only unread mails
plz help
plz help
VBA Code:
Sub Save_Attachments_From_Emails_to_word()
Dim folderPath1, folderpath2 As String
'Check and create folder for the word files that would have the copy of images
folderPath1 = "C:\OutlookImagesCopy" & Format(Now, "ddMMMyyyyHHMM")
'Check if the folder exists
If Dir(folderPath1, vbDirectory) = "" Then
'Folder does not exist, so create it
MkDir folderPath1
Else
MsgBox ("OutlookImagesCopy folder already exists in the path. Please rename or delete it for the application to work")
Exit Sub
End If
'check and create the folder to temporarily save the image copies
folderpath2 = "C:\OutlookImagesTemp" & Format(Now, "ddMMMyyyyHHMM")
'Check if the folder exists
If Dir(folderpath2, vbDirectory) = "" Then
'Folder does not exist, so create it
MkDir folderpath2
Else
MsgBox ("OutlookImagesTemp folder already exists in the path. Please rename or delete it for the application to work")
Exit Sub
End If
'Declare Objects to Refer the Outlook Mailbox
Dim SourceFolderRef As Outlook.MAPIFolder, SourceMailBoxName As String, Source_Pst_Folder_Name As String
Dim MailItem As MailItem, MailsCount As Double, atch As Attachment, File_Path As String
'Source Mailbox or PST name
File_Path = folderpath2 & "\"
SourceMailBoxName = "mailid"
Source_Pst_Folder_Name = "testing"
Set SourceFolder = Outlook.Session.Folders(SourceMailBoxName).Folders(Source_Pst_Folder_Name)
'Loop through Each Email Item in the Folder
For Each MailItem In SourceFolder.Items
If TypeName(MailItem) = "MailItem" Then
'Extract & Save Attachments in Email to Folder
For Each atch In MailItem.Attachments
If atch.Type = olByValue Then
atch.SaveAsFile File_Path & atch.Filename
End If
Next atch
End If
Next MailItem
'All attachments in the Folder are processed
MsgBox "Mailes in " & Source_Pst_Folder_Name & " are Processed"
'Declare objects for word file
Dim objWord, objDoc, objSelection, pic, picShape As Object
'Loop through all files in a folder
Dim fileName1 As Variant
Dim filename2 As String
Dim i As Integer
i = 1
fileName1 = Dir(folderpath2 & "\")
While fileName1 <> ""
filename2 = folderpath2 & "\" & fileName1
'open word and copy the images into word files and save them
Set objWord = CreateObject("Word.Application")
Set objDoc = objWord.Documents.Add
objWord.Visible = True
Set pic = objDoc.InlineShapes.AddPicture( _
Filename:=filename2, _
LinkToFile:=False, _
SaveWithDocument:=True _
)
Set picShape = pic.ConvertToShape
objDoc.SaveAs ("C:\OutlookImagesCopy" & "\" & "Doc" & i)
objWord.Quit
Set objWord = Nothing
i = i + 1
'Set the fileName to the next file
fileName1 = Dir
Wend
folderpath2 = folderpath2 & "\"
Kill folderpath2 & "*.*"
RmDir folderpath2
MsgBox ("All images saved into different word files")
End Sub
Last edited by a moderator: