I have the below code which works great, extracts attachments from all emails that are stored in a folder. I only want to extract the .xlsx files from the emails. I don't know how to modify the code to only select the .xlsx files.
Thanks,
Public Sub Extract_Attachments_From_Outlook_Msg_Files()
Dim outApp As Object
Dim outEmail As Object
Dim outAttachment As Object
Dim msgFiles As String
Dim sourceFolder As String
Dim saveInFolder As String
Dim fileName As String
'CHANGE - folder location and filespec of .msg files
msgFiles = ""
'CHANGE - folder where extracted attachments are saved
saveInFolder = ""
On Error Resume Next
Set outApp = GetObject(, "Outlook.Application")
If outApp Is Nothing Then
MsgBox "Outlook is not open"
Exit Sub
End If
On Error GoTo 0
fileName = Dir(msgFiles)
While fileName <> vbNullString
'Open .msg file in Outlook 2003
'Set outEmail = outApp.CreateItemFromTemplate(sourceFolder & fileName)
'Open .msg file in Outlook 2007+
Set outEmail = outApp.Session.OpenSharedItem(sourceFolder & fileName)
For Each outAttachment In outEmail.Attachments
outAttachment.SaveAsFile saveInFolder & outAttachment.fileName
Next
fileName = Dir
Wend
End Sub
Related
We have a macro that sends e-mails of documents in a certain directory. We want to exclude documents whose file names begin with "AUT_XXXXXX" ETA: the Xs can be a string of letters and numbers that vary.
Sub SendScannedDocstoWellsFargo()
Dim Filename As Variant
Dim olApp As Outlook.Application
Dim olNewEmail As Outlook.MailItem
Dim strDirectory As String
Dim strPath As String
Dim FSO As FileSystemObject
Set FSO = CreateObject("Scripting.FileSystemObject")
Set olApp = Outlook.Application
Filename = Dir("\\kwa-file01\ClientFiles\Wells Fargo III\_Scanned_Documents\Pending Uploads\")
strDirectory = "\\kwa-file01\ClientFiles\Wells Fargo III\_Scanned_Documents\Pending Uploads\"
While Filename <> ""
'Comment out when completed
'Debug.Print Filename
'Set the filename to the next file
Filename = Dir
'Create a path for the item
strPath = strDirectory & Filename
If strPath = strDirectory Then GoTo StopThisNow
'Create a mail item
Set olNewEmail = olApp.CreateItem(olMailItem)
With olNewEmail
.To = "ccslegaldocuments#wellsfargo.com"
.Subject = Filename
.Attachments.Add (strPath)
.Send
End With
FSO.DeleteFile strPath, True
Set olNewEmail = Nothing
StopThisNow:
Wend
Set olApp = Nothing
Set olNewEmail = Nothing
strDirectory = ""
Filename = ""
strPath = ""
End Sub
I've seen posts showing how to exclude PDFs.
Give this a try.
Read the code's comments and adjust it to fit your needs.
EDIT: Changed to Like statement with wildcards
Public Sub SendScannedDocstoWellsFargo()
' Define the folder path
Dim folderPath As String
folderPath = "C:\Temp\" ' "\\kwa-file01\ClientFiles\Wells Fargo III\_Scanned_Documents\Pending Uploads\"
' Define the file name string to exclude
Dim stringExclude As String
stringExclude = "AUT_??????"
' Set a referece to the FSO object
Dim FSO As FileSystemObject
Set FSO = CreateObject("Scripting.FileSystemObject")
' Set a reference to Outlook application
Dim outlookApp As Outlook.Application
Set outlookApp = Outlook.Application
' Get files in folder
Dim fileName As String
fileName = Dir(folderPath)
' Loop through files
Do While fileName <> ""
If Not Left(fileName, Len(stringExclude)) Like stringExclude Then
' Build the file path
Dim filePath As String
filePath = folderPath & fileName
' Send the email by calling a procedure
sendEmail outlookApp, filePath, fileName
' Delete the file
FSO.DeleteFile filePath, True
End If
' Call next file
fileName = Dir
Loop
' Clean up outlook reference
Set outlookApp = Nothing
End Sub
Private Sub sendEmail(ByVal outlookApp As Outlook.Application, ByVal filePath As String, ByVal fileName As String)
Dim olNewEmail As Outlook.MailItem
'Create a mail item
Set olNewEmail = outlookApp.CreateItem(olMailItem)
With olNewEmail
.To = "ccslegaldocuments#wellsfargo.com"
.Subject = fileName
.Attachments.Add filePath
.Send
End With
Set olNewEmail = Nothing
End Sub
Let me know if it works
New to VBA and initially my problem was to copy text in CSV file into string and then ultimately to a master workbook. I used the below code which works perfectly:
Sub Compiler()
Dim handle As Integer
Dim wbDst As Workbook
Dim wsDst As Worksheet
Dim lLastRow As Long
Dim MyPath As String
Dim strFilename As String
handle = FreeFile
Set wbDst = ThisWorkbook
Set wsDst = wbDst.Worksheets("First Sheet")
lLastRow = wsDst.UsedRange.Rows(wsDst.UsedRange.Rows.Count).Row + 1
Sheets("First Sheet").Columns(1).NumberFormat = "#"
Sheets("First Sheet").Columns(2).NumberFormat = "#"
Sheets("First Sheet").Columns(3).NumberFormat = "#"
MyPath = "W:\Test Folder\"
strFilename = Dir(MyPath, vbNormal)
Do While strFilename <> ""
Dim buffer As String
Open MyPath & strFilename For Input As #handle
buffer = Input(LOF(handle), handle) '<-- reads the entire contents of the file to "buffer"
Close #handle
With CreateObject("new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
.SetText buffer
.PutInClipboard
End With
wsDst.Paste wsDst.Range("A" & lLastRow)
'Application.CutCopyMode = False
strFilename = Dir()
Loop
End Sub
However, for some reason, it only copy pastes some of the files and not others (or maybe it overwrites it?, point is some of the files are not copied in). Not sure why this is the case? Is it because there are some blank cells in files? To rectify this, i replaced all blank cells with 0 - didn't work. Is it because of different copy paste area? Don't know how to rectify that if this is the case
So after long investigation, i found out an impractical approach where if you paste in files that you need to copy one by one, It does the trick but it is inefficient. So just for a temp solution, i did the following where vba code copies in a file from a temp folder to the source folder, does its job of copy pasting to the master work book and then deletes the file that was copied in. For some reason, the code stops at the first even though it's a Do while loop. Not sure what's the problem here and what is most efficient approach here?
Sub ISINCompiler()
'Declare Variables
Dim FSO
Dim MyPath As String
Dim strFilename As String
Dim sFile As String
Dim sSFolder As String
Dim sDFolder As String
Application.DisplayAlerts = False
MyPath = "C:\Users\Tomhardy\Desktop\ISIN-Compiler Temp\"
strFilename = Dir(MyPath, vbNormal)
'This is Your File Name which you want to Copy
'Change to match the destination folder path
sDFolder = "W:\Test Folder\"
'Create Object
Set FSO = CreateObject("Scripting.FileSystemObject")
'Checking If File Is Located in the Source Folder
Do While strFilename <> ""
If Not FSO.FileExists(MyPath & strFilename) Then
MsgBox "Specified File Not Found", vbInformation, "Not Found"
'Copying If the Same File is Not Located in the Destination Folder
ElseIf Not FSO.FileExists(sDFolder & strFilename) Then
FSO.CopyFile (MyPath & strFilename), sDFolder, True
ISINCompilerx2 '<-Copying and pasting in text
DeleteExample1 '<-Deleting the file after it has been copied in
Else
MsgBox "Specified File Already Exists In The Destination Folder",
vbExclamation, "File Already Exists"
End If
strFilename = Dir()
Loop
End Sub
Private Sub ISINCompilerx2()
Dim handle As Integer
Dim wbDst As Workbook
Dim wsDst As Worksheet
Dim lLastRow As Long
Dim someotherpath As String
Dim somestrFilename As String
handle = FreeFile
Set wbDst = ThisWorkbook
Set wsDst = wbDst.Worksheets("First Sheet")
lLastRow = wsDst.UsedRange.Rows(wsDst.UsedRange.Rows.Count).Row + 1
Sheets("First Sheet").Columns(1).NumberFormat = "#"
Sheets("First Sheet").Columns(2).NumberFormat = "#"
Sheets("First Sheet").Columns(3).NumberFormat = "#"
someotherpath = "W:\Test Folder\"
somestrFilename = Dir(someotherpath, vbNormal)
Do While somestrFilename <> ""
Dim buffer As String
Open someotherpath & somestrFilename For Input As #handle
buffer = Input(LOF(handle), handle) '<-- reads the entire
contents of the file to "buffer"
Close #handle
With CreateObject("new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
.SetText buffer
.PutInClipboard
End With
wsDst.Paste wsDst.Range("A" & lLastRow)
Application.CutCopyMode = False
somestrFilename = Dir()
Loop
End Sub
Private Sub DeleteExample1()
On Error Resume Next
Kill "W:\Test Folder\*.*"
On Error GoTo 0
End Sub
new Code:
Sub ISINCompiler()
'Declare Variables
Dim FSO As Object
Dim MyPath As String
Dim strFilename As String
Dim f As Object
Dim sDFolder As String
Application.DisplayAlerts = False
MyPath = "C:\Users\Tomhardy\Desktop\ISIN-Compiler Temp\"
strFilename = Dir(MyPath, vbNormal)
'This is Your File Name which you want to Copy
'Change to match the destination folder path
sDFolder = "W:\Destination folder\"
' Create Object
Set FSO = CreateObject("Scripting.FileSystemObject")
'Checking If File Is Located in the Source Folder
For Each f In FSO.GetFolder(MyPath).Files
If Not FSO.FileExists(MyPath & strFilename) Then
MsgBox "Specified File Not Found", vbInformation, "Not Found"
'Copying If the Same File is Not Located in the Destination Folder
ElseIf Not FSO.FileExists(sDFolder & strFilename) Then
FSO.CopyFile (MyPath & strFilename), sDFolder, True
'ISINCompilerx2
'DeleteExample1
MsgBox "Specified File Copied Successfully", vbInformation, "Done!"
Else
MsgBox "Specified File Already Exists In The Destination Folder",
vbExclamation, "File Already Exists"
End If
Next f
Set f = Nothing
Set FSO = Nothing
End Sub
You can simplify your code;
Dim Filename As String
Dim lLastRow As Long
Dim wsDst As Worksheet
Set wsDst = ThisWorkbook.Worksheets("First Sheet")
Filename = Dir("W:\Test Folder\*.csv")
Do While Filename <> ""
Set wbSrce = Workbooks.Open(Filename)
lLastRow = wsDst.UsedRange.Rows.Count + 1
wbSrce.Sheets(1).UsedRange.Copy wsDst.Range("A" & lLastRow)
wbSrce.Close savechanges:=False
Filename = Dir
Loop
So i found out that Dir was the problem so i just removed dir in my main macro
Option Explicit
Public wbDst As Workbook
Public wsDst As Worksheet
Sub ISINCompiler()
'Declare Variables
Set wbDst = ThisWorkbook
Set wsDst = wbDst.Worksheets("First Sheet")
Dim i As Long
Dim myFSO As FileSystemObject
Dim xFolder As Scripting.Folder
Dim FSO As Object
Dim f
Dim MyPath As String
Dim sDFolder As String
Application.DisplayAlerts = False
sDFolder = "W:\Destination\"
Set FSO = CreateObject("Scripting.FileSystemObject")
Set myFSO = New FileSystemObject
Set xFolder = myFSO.GetFolder("C:\Source")
'Checking If File Is Located in the Source Folder
For Each f In xFolder.Files
f.Copy sDFolder & f.Name
MsgBox "Specified File Copied Successfully", vbInformation, "Done!"
ISINCompilerx2
DeleteExample1
Next f
End Sub
Private Sub ISINCompilerx2()
Dim handle As Integer
Dim lLastRow As Long
Dim somePath As String
Dim someFilename As String
handle = FreeFile
lLastRow = wsDst.UsedRange.Rows(wsDst.UsedRange.Rows.Count).Row + 1
Sheets("First Sheet").Columns(1).NumberFormat = "#"
Sheets("First Sheet").Columns(2).NumberFormat = "#"
Sheets("First Sheet").Columns(3).NumberFormat = "#"
somePath = "W:\Destination\"
someFilename = Dir(somePath, vbNormal)
Dim buffer As String
Open somePath & someFilename For Input As #handle
buffer = Input(LOF(handle), handle) '<-- reads the entire contents of
the file to "buffer"
Close #handle
With CreateObject("new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
.SetText buffer
.PutInClipboard
End With
wsDst.Paste wsDst.Range("A" & lLastRow)
Application.CutCopyMode = False
End Sub
Private Sub DeleteExample1()
'You can use this to delete all the files in the folder Test
On Error Resume Next
Kill "W:\Destination\*.*"
On Error GoTo 0
End Sub
Set up a macro to open word documents through excel. It's been working fine, but after copying the code from the test environment into another file it's refusing to open word on every machine I test it on. Every other part of the macro is working fine, but for some reason word will no longer open via macro.
I've attached the code, but any help would be appreciated. It was working earlier today, and because of this i'm having trouble identifying the problem.
Public Function Method2(ByVal rngl As Range, ByVal strSearch As Variant, ByVal sPath As String)
Dim filePath As String
Dim directory As String
Dim fileName As String
Dim myPath As String
Dim myFile As File
Dim FSO As New FileSystemObject
Dim myFolder As Folder
Dim myExtension As String
Dim mySubFolder As Folder
Dim mySubFolder2 As Folder
Dim objWord
Dim objDoc
Dim rngRange
Dim rng1 As Range
Set myFolder = FSO.GetFolder(sPath)
directory = "S:\File Recipes\"
fileName = "Yaroze_Test"
myExtension = "*.docx*"
Set rng1 = Range("A:A").find(strSearch, , xlValues, xlWhole)
If strSearch = "" Then
MsgBox "Please Enter a Product Code!"
Exit Function
End If
If Not rng1 Is Nothing Then
MsgBox "Product Codes Found!"
For Each mySubFolder In myFolder.SubFolders
For Each mySubFolder2 In mySubFolder.SubFolders
For Each myFile In mySubFolder.Files
If InStr(myFile, strSearch) > 0 Then
fileName = Dir(myPath & myExtension)
MsgBox (myFile.Name)
Do While fileName <> ""
Set objWord = CreateObject("Word.Application")
objWord.Visible = True
ChDrive ("S")
ChDir ("S:\File Recipes\")
filePath = myFile.Path
MsgBox directory
objWord.Documents.Open fileName:=filePath
DoEvents
fileName = Dir
Loop
MsgBox "Task Complete!"
End If
Next
For Each myFile In mySubFolder2.Files
If InStr(myFile, strSearch) > 0 Then
fileName = Dir(myPath & myExtension)
' MsgBox (myFile.Name)
Do While fileName <> ""
Set objWord = CreateObject("Word.Application")
objWord.Visible = True
ChDrive ("S")
ChDir ("S:\File Recipes\")
filePath = myFile.Path
' MsgBox directory
objWord.Documents.Open fileName:=filePath
DoEvents
fileName = Dir
Loop
MsgBox "Task Complete!"
End If
Next
Next
Next
Else
MsgBox "Product Codes Not Found!"
End If
' Set rngRange = _
objWord.Range(objWord.Paragraphs(1).Start, objWord.Paragraphs(1).End - 1)
' rngRange.InsertAfter _
"This is now the last sentence in paragraph one."
I've attempted to test the Macro on other computers to see if it was just the copy of word I was using, and I've tested writing new Macros to open word. They worked initially but other macros are now no longer working. I've tried disabling office from references in VBA and testing with that, and I've made sure it's not an issue with instances of word being left open.
I've found a lot on importing folder of .txt files into excel, but not many on importing .txt files into word. I'm trying to get my macro to open all .txt files in a specific folder and import them into a single word document, with each .txt file having its own page. This is the code I have so far (that I found online):
Sub AllFilesInFolder()
Dim myFolder As String, myFile As String
myFolder = Application.FileDialog(msoFileDialogFolderPicker)
With Application.FileDialog(msoFileDialogFolderPicker)
.AllowMultiSelect = False
.Show
If .SelectedItems.Count > 0 Then
myFolder = .SelectedItems(1)
End If
End With
myFile = Dir(myFolder & "\*.txt") '
Do While myFile <> ""
Open myFolder & "\" & myFile For Input As #1
'Copy & Paste Macro?
myFile = Dir
Loop
End Sub
here is something to get you started
Word 2010
Edit this should allow you to open all txt files in one document and save it
Option Explicit
Sub AllFilesInFolder()
Dim myFolder As String
Dim myFile As String
Dim wdDoc As Document
Dim txtFiles As Document
Application.ScreenUpdating = False
myFolder = openFolder
If myFolder = "" Then Exit Sub
myFile = Dir(myFolder & "\*.txt", vbNormal)
Set wdDoc = ActiveDocument
While myFile <> ""
Set txtFiles = Documents.Open(FileName:=myFolder & "\" & myFile, AddToRecentFiles:=False, Visible:=False, ConfirmConversions:=False)
wdDoc.Range.InsertAfter txtFiles.Range.Text & vbCr
txtFiles.Close SaveChanges:=True
myFile = Dir()
Wend
Set txtFiles = Nothing
Set wdDoc = Nothing
Application.ScreenUpdating = True
End Sub
Function openFolder() As String
Dim oFolder As Object
openFolder = ""
Set oFolder = CreateObject("Shell.Application").BrowseForFolder(0, "Choose a folder", 0)
If (Not oFolder Is Nothing) Then openFolder = oFolder.Items.Item.Path
Set oFolder = Nothing
End Function
Copy all the text files into a single file using the Command Prompt (cmd.exe) and the following command:
copy *.txt NewFile.txt
Then open this file with word and modify the way you want to see the text.
I have code that saves attachments in message in a specific Outlook folder.
My script will work if the email has an attachment, but will not work if the email was sent as an attachment with an attachment.
In this case my emails contains other emails as attachments (from an auto-forward rule). The embedded email attachments then contain excel files.
Please see my current vba below:
Public Sub SaveOlAttachments()
Dim isAttachment As Boolean
Dim olFolder As Outlook.MAPIFolder
Dim msg As Outlook.MailItem
Dim att As Outlook.Attachment
Dim fsSaveFolder, sSavePathFS, ssender As String
On Error GoTo crash
fsSaveFolder = "C:\Documents and Settings\user\Desktop\"
isAttachment = False
Set olFolder = Outlook.GetNamespace("MAPI").Folders("...email server...")
Set olFolder = olFolder.Folders("Inbox")
If olFolder Is Nothing Then Exit Sub
For Each msg In olFolder.Items
If UCase(msg.Subject) = "TEST EMAIL WITH ATTACHMENT" Then
If msg.Attachments.Count > 0 Then
While msg.Attachments.Count > 0
sSavePathFS = fsSaveFolder & msg.Attachments(1).Filename
msg.Attachments(1).SaveAsFile sSavePathFS
msg.Attachments(1).Delete
isAttachment = True
Wend
msg.Delete
End If
End If
Next
crash:
If isAttachment = True Then Call findFiles(fsSaveFolder)
End Sub
Any help would be much appreciated.
The code below uses this approach to work on the email as an attachment
Tests whether the attachment is an email message or not (if the filename ends in msg)
If the attachment is a message, it is saved as "C:\temp\KillMe.msg".
CreateItemFromTemplate is used to access the saved file as a new message (msg2)
The code then processes this temporary message to strip the attachmnets to fsSaveFolder
If the attachment is not a message then it is extracted as per your current code
Note that as I didnt have your olFolder structure, Windoes version, Outlook variable etc I have had to add in my own file paths and Outlook folders to test. You will need to change these
Sub SaveOlAttachments()
Dim olFolder As Outlook.MAPIFolder
Dim msg As Outlook.MailItem
Dim msg2 As Outlook.MailItem
Dim att As Outlook.Attachment
Dim strFilePath As String
Dim strTmpMsg As String
Dim fsSaveFolder As String
fsSaveFolder = "C:\test\"
'path for creating attachment msg file for stripping
strFilePath = "C:\temp\"
strTmpMsg = "KillMe.msg"
'My testing done in Outlok using a "temp" folder underneath Inbox
Set olFolder = Application.GetNamespace("MAPI").GetDefaultFolder(olFolderInbox)
Set olFolder = olFolder.Folders("Temp")
If olFolder Is Nothing Then Exit Sub
For Each msg In olFolder.Items
If msg.Attachments.Count > 0 Then
While msg.Attachments.Count > 0
bflag = False
If Right$(msg.Attachments(1).FileName, 3) = "msg" Then
bflag = True
msg.Attachments(1).SaveAsFile strFilePath & strTmpMsg
Set msg2 = Application.CreateItemFromTemplate(strFilePath & strTmpMsg)
End If
If bflag Then
sSavePathFS = fsSaveFolder & msg2.Attachments(1).FileName
msg2.Attachments(1).SaveAsFile sSavePathFS
msg2.Delete
Else
sSavePathFS = fsSaveFolder & msg.Attachments(1).FileName
msg.Attachments(1).SaveAsFile sSavePathFS
End If
msg.Attachments(1).Delete
Wend
msg.Delete
End If
Next
End Sub