I want to find e-mails with attachment named "IE529" or 599 or ZC and extension of .xml and save them to a folder on sharedrive.
Outlook seems to process the code, but neither of the attachments is saved.
Once this code works, I will think how to add parameter ".xml" into criteria.
Public Sub Komunikaty(MItem As Outlook.MailItem)
Dim Zalacznik As Outlook.Attachment
Dim KatalogIE529 As String
Dim KatalogIE599 As String
Dim KatalogZC299 As String
KatalogIE529 -"xxxx"
KatalogIE599 -"zzzz"
KatalogZC299 -"yyyyy"
For Each Zalacznik In MItem.Attachments
If InStr(1, Zalacznik.DisplayName, "IE529", vbTextCompare) Then
Zalacznik.SaveAsFile KatalogIE529 & Zalacznik.DisplayName
ElseIf InStr(1, Zalacznik.DisplayName, "IE599", vbTextCompare) Then
Zalacznik.SaveAsFile KatalogIE599 & Zalacznik.DisplayName
ElseIf InStr(1, Zalacznik.DisplayName, "ZC299", vbTextCompare) Then
Zalacznik.SaveAsFile KatalogZC299 & Zalacznik.DisplayName
End If
Next
End Sub
After applying some corrections, my code is saving attachments into given folder, but I cannot figure out, how to save only the attachments with extension ".xml".
I tried "AND", but afterwards it doesn't work.
It can either save xml or IE529.
How can I update this code, so it will search through xml files?
Public Sub Komunikaty(MItem As Outlook.MailItem)
Dim Zalacznik As Outlook.Attachment
Dim KatalogIE529 As String
Dim KatalogIE599 As String
Dim KatalogZC299 As String
KatalogIE529 = "C:"
KatalogIE599 = "C:"
KatalogZC299 = "C:"
For Each Zalacznik In MItem.Attachments
If (InStr(1, Zalacznik.DisplayName, "IE529", vbTextCompare)) Then
Zalacznik.SaveAsFile KatalogIE529 & "\" & Zalacznik.DisplayName
ElseIf InStr(1, Zalacznik.DisplayName, "IE599", vbTextCompare) Then
Zalacznik.SaveAsFile KatalogIE599 & "\" & Zalacznik.DisplayName
ElseIf InStr(1, Zalacznik.DisplayName, "ZC299", vbTextCompare) Then
Zalacznik.SaveAsFile KatalogZC299 & "\" & Zalacznik.DisplayName
End If
Next
End Sub
The Attachment.SaveAsFile method accepts a string which specifies the location at which to save the attachment. Office applications are designed to deal with local disks only, so it makes sense to save the attached file to the local drive and then copy it where required (shared drive). Note, you need to specify the full file path (not relative) and make sure no forbidden symbols are presented in the string passed to the SaveAsFile method.
Also pay attention to the fact that attachments may not be presented on the item physically, only items with the Attachment.Type property value set to the olByValue can be retrieved and saved to the disk (files). So, it makes sense to check the attachment type before calling the SaveAsFile method.
Related
I am currently trying to put a macro together to sort files into folders based on a filename. I am locked into using VBA due to the system we are on.
For example sorting just the excel documents from below present in C:\ :
123DE.xls
124DE.xls
125DE.xls
124.doc
123.csv
into the following folder paths:
C:\Data\123\Data Extract
C:\Data\124\Data Extract
C:\Data\125\Data Extract
The folders are already created, and as in the example are named after the first x characters of the file. Batches of 5000+ files will need to be sorted into over 5000 folders so im trying to avoid coding for each filename
I am pretty new to VBA, so any guidance would be much appreciated. So far I have managed to move all the excel files into a single folder, but am unsure how to progress.
Sub MoveFile()
Dim strFolderA As String
Dim strFolderB As String
Dim strFile as String
strFolderA = "\\vs2-alpfc\omgusers7\58129\G Test\"
strFolderb = "\\vs2-alpfc\omgusers7\58129\G Test\1a\"
strFile = Dir(strFolderA & "*.xlsx*")
Do While Len(strFile) >0
Name StrFolderA & strFile As strFolderB & strFile
strFile = Dir
Loop
End Sub
Greg
EDIT
Sub MoveFile()
Dim strFolderA As String
Dim strFile As String
Dim AccNo As String
strFolderA = "\\vs2-alpfc7\omgUSERS7\58129\G Test\"
strFile = Dir(strFolderA & "*.xlsx*")
Do While Len(strFile) > 0
AccNo = Left(strFile, 2)
Name strFolderA & strFile As strFolderA & "\" & AccNo & "\Data Extract\" & strFile
strFile = Dir
Loop
End Sub
Thanks folks, are a few more bits and pieces i want to add, but functionality is there!
Sub DivideFiles()
Const SourceDir = "C:\" 'where your files are
Const topdir = "\\vs2-alpfc\omgusers7\58129\G Test\"
Dim s As String
Dim x As String
s = Dir(SourceDir & "\*.xls?")
Do
x = Left(s, 3) 'I assume we're splitting by first three chars
Name SourceDir & s As topdir & s & "\" & s
Loop Until s = ""
End Sub
If I understand you correctly, the problem is deriving the new fullpathname from the file name to use as the newpathname argument of the Name function.
If all of your files end with DE.XLS* you can do something like:
NewPathName = C:\Data\ & Split(strFile, "DE")(0) & "\Data Extract\" & strFile
You could use Filesystem object (tools > references > microsoft scripting runtime
This does a copy first then delete. You can comment out delete line and check copy is safely performed.
If on Mac replace "\" with Application.PathSeparator.
Based on assumption, as you stated, that folders already exist.
Option Explicit
Sub FileAway()
Dim fileNames As Collection
Set fileNames = New Collection
With fileNames
.Add "123DE.xls"
.Add "124DE.xls"
.Add "125DE.xls"
.Add "124.doc"
.Add "123.csv"
End With
Dim fso As FileSystemObject 'tools > references > scripting runtime
Set fso = New FileSystemObject
Dim i As Long
Dim sourcePath As String
sourcePath = "C:\Users\User\Desktop" 'where files currently are
For i = 1 To fileNames.Count
If Not fso.FileExists("C:\Data\" & Left$(fileNames(i), 3) & "\Data Extract\" & fileNames(i)) Then
fso.CopyFile (sourcePath & "\" & fileNames(i)), _
"C:\Data\" & Left$(fileNames(i), 3) & "\Data Extract\", True
fso.DeleteFile (sourcePath & "\" & fileNames(i))
End If
Next i
End Sub
I found this thread with the same issue as mine, but I've copied the code into my project, and it doesn't seem to work.
VBA macro: replace text in word file in all sub folders
I was stepping through the code, and it gets to line 32 (under the For Each varItem in colSubFolders) but then it skips right over the find/replace section to the end of the code. Is the problem in my file format?
EDIT: Additionally, when I get to varitem in ln 31, the value of "varitem" is the name of the folder, not the names of the word documents in the folder: I think this is where the issue is.
Sub DoLangesNow()
Dim file
Dim path As String
Dim strFolder As String
Dim strSubFolder As String
Dim strFile As String
Dim colSubFolders As New Collection
Dim varItem As Variant
' Parent folder including trailing backslash
'YOU MUST EDIT THIS.
strFolder = "L:\Admin\Corporate Books\2015\2014 Consents macro\company Annual Consents"
' Loop through the subfolders and fill Collection object
strSubFolder = Dir(strFolder & "*", vbDirectory)
Do While Not strSubFolder = ""
Select Case strSubFolder
Case ".", ".."
' Current folder or parent folder - ignore
Case Else
' Add to collection
colSubFolders.Add Item:=strSubFolder, Key:=strSubFolder
End Select
' On to the next one
strSubFolder = Dir
Loop
' Loop through the collection
For Each varItem In colSubFolders
' Loop through word docs in subfolder
'YOU MUST EDIT THIS if you want to change the files extension
strFile = Dir(strFolder & varItem & "\" & "*.doc")
Do While strFile <> ""
Set file = Documents.Open(FileName:=strFolder & _
varItem & "\" & strFile)
Use CMD to get all the files into an array and work with that instead - quicker and cleaner.
Sub S_O()
Dim fileArray As Variant
fileArray = Filter(Split(CreateObject("WScript.Shell").Exec("CMD /C DIR """ & strFolder & "\*.doc*"" /S /B /A:-D").StdOut.ReadAll, vbCrLf), ".")
For Each fil In fileArray
'//
'// Insert your code for doing the replacements here
'// e.g. Workbooks.Open(fil)
'// ...
Next
End Sub
I am trying to set up a macro to pull all excel files in a folder into a database in access. I have the below code, but when I run the macro, it errors out into "No Files Found," so intFile = 0. However, there are files in the chosen folder. Why is it not finding them? I think I messed up the linking piece too but one problem at a time. I am obviously pretty new to VBA, so any help would be appreciated!
Thanks,
Option Compare Database
Option Explicit
'code will link to excel and pull site survey files into access tables
'Setting the path for the directory
Const strPath As String = "S:\LOG\PURCHASI\Daniel Binkoski\Outlook Attachments\R7398Z Look Forward Daily Snapshot"
'FileName
Dim strFile As String
'Array
Dim strFileList() As String
'File Number
Dim intFile As Integer
Sub Sample()
strFile = Dir(strPath & "*.xlsx")
'Looping through the folder and building the file list
strFile = Dir(strPath & "*.xlsx")
While strFile <> ""
'adding files to the list
intFile = intFile + 1
ReDim Preserve strFileList(1 To intFile)
strFileList(intFile) = strFile
strFile = Dir()
Wend
'checking to see if files where found
If intFile = 0 Then
MsgBox "No Files Found"
Exit Sub
End If
'going through the files and linking them to access
For intFile = 1 To UBound(strFileList)
DoCmd.TransferSpreadsheet acLink, , _
strFileList(intFile), strPath & strFileList(intFile), True, "A1:M50"
Next
MsgBox UBound(strFileList) & "Files were linked"
End Sub
try:
strFile = Dir(strPath & "\*.xlsx", vbNormal)
or add a final "\" onto your strPath value
You need another path separator to show you're looking in a directory, not at one.
I often use something like:
Dir(strPath & IIf(Right(strPath, 1) = "\", vbNullString, "\"))
as a check to ensure that the path always ends in a trailing backslash.
I'm trying to crawl through a certain drive and grab data off of certain .xls files that are buried in sub-directories. The drive is over a TB, and the folders don't all have the same hierarchy, so I'm crawling through all of them. So far, the script works great.
The problem is, there are zipped files in the drive. At least half the files are in zipped format. How can I crawl through these files as well?
Here is the part of my code that crawls through the sub-directories. There is another function "TrailingSlash" which just appends a "\" to the string if it doesn't already have one. I give credit to the author in my comments.
Public Function recursiveDir(colFiles As Collection, strFolder As String, strFileSpec As String, bIncludeSubfolders As Boolean) as Collection
'From Ammara.com/access_image_faq/recursive_folder_search.html
'Recursive function to search document tree from specific file extension
Dim strTemp As String
Dim colFolders As New Collection
Dim vFolderName As Variant
Dim colFiles As New Collection
Dim counter As Integer
'Add files in strFolder matching strFileSpec to colFiles
strFolder = TrailingSlash(strFolder)
strTemp = Dir(strFolder & strFileSpec)
On Error Resume Next
Do While strTemp <> vbNullString
colFiles.Add (strFolder & strTemp)
counter = counter + 1
Debug.Print ("files found: " & counter)
strTemp = Dir
Loop
If bIncludeSubfolders Then
'Fill colFolders with list of subdirectories of strFolder
strTemp = Dir(strFolder, vbDirectory)
Do While strTemp <> vbNullString
If (strTemp <> ".") And (strTemp <> "..") Then
If (GetAttr(strFolder & strTemp) And vbDirectory) <> 0 Then
colFolders.Add strTemp
End If
End If
strTemp = Dir
Loop
'Call recursiveDir for each subfolder in colFolders
For Each vFolderName In colFolders
Call recursiveDir(colFiles, strFolder & vFolderName, strFileSpec, True)
Next vFolderName
End If
recursiveDir = colFiles
End Function
The function adds all the path strings to the collection "colFolders", which I then use to open and extract data from. I'm now thinking there may not be a simple way to return a string path to a file within a zipped folder. There may need to be a separate function that is called when this function encounters a zip, that in turn crawls through the zipped folder and extracts the specific file to a local destination (as long as I don't have to extract the whole folder, we should be good).
I'm kind of lost in what I should do. Googleing around points me towards using shell.Application. I know nothing of shells, is this the path I should take?
Thanks SO - you all are awesome!
Try this code instead to search through subfolders:
Sub SO()
Dim x, i
x = GetFiles("C:\Users\SO\Folder", "*.xls*", True) '// x becomes an array of files found
For Each i In x
Debug.Print i
Next i
End Sub
'-------------------------------------------------
Function GetFiles(StartPath As String, FileType As String, SubFolders As Boolean) As Variant
StartPath = StartPath & IIf(Right(StartPath, 1) = "\", vbNullString, "\") 'Sanity check
GetFiles = Split(Join(Filter(Split(CreateObject("WScript.Shell").Exec("CMD /C DIR """ & StartPath & FileType & """ " & _
IIf(SubFolders, "/S", vbNullString) & " /B /A:-D").StdOut.ReadAll, vbCrLf), ":"), "#"), "#")
End Function
But for zip files, there isn't really anything native to windows that will allow you to do this other than the CreateObject("Shell.Application").Namespace(zipName).Items method.
I prefer to use 7-zip which is free, open-source and has a great command line utility which means you can access it via VBA too using the CreateObject("WScript.Shell") method (like above)
Saving a file attachment in an Outlook mail item with the VBA method Attachment.SaveAsFile() call produces the expected result (file saved with same filename on the filesystem), even for file names with non-ASCII characters.
However, VBA apparently stores the file name in a 16-bit composite format String where accented letters are stored as a (letter, accent) pair. I can't find a way to output the string inside the message body with accented letters showing up as one glyph ("é") instead of two ("e´").
Concretely, the attachment is properly saved under the correct file name on disk when using the following code:
' Save the Outlook attachment
oAttachment.SaveAsFile (sTempFileLocation)
This results in a file being written to the folder specified in sTempFileLocation and the file name complies with the way it appears in the Outlook message (accents, non-ASCII characters etc).
However, when retrieving and manipulating the file name, it appears that a 16-bit composite internal representation of special characters is used. This means that the file name "à présent.txt" is displayed as "a` pre´sent.txt" (accented characters are represented with the character + the accent in 2 consecutive bytes).
For instance:
sAttachmentName = fso.getfilename(sTempFileLocation)
Debug.Print ("Attachment name = [" & sAttachmentName & "]")
will result in:
Attachment name = [a` pre´sent.txt]
There is little information available on this matter, all I found so far was this MSDN link describing the MultiByteToWideChar() function. From there it appears that the 16-bit internal VBA rendering happens implcitly and is even computer dependent (depending on code page and locale in use).
Here follows a self-contained minimalistic example that tries to save the email attachments of the first selected message to your My Documents folder unless it already exists:
Sub SaveMessageAttachments()
Dim objApp As Outlook.Application
Dim oSelection As Outlook.Selection
Dim aMail As Outlook.MailItem
Dim fso As Object
On Error Resume Next
' Instantiate an Outlook Application object.
Set objApp = CreateObject("Outlook.Application")
' Get the collection of selected objects.
Set oSelection = objApp.ActiveExplorer.Selection
If oSelection Is Nothing Then
Exit Sub
End If
' Select the 1st mail item in the current selection
Set aMail = oSelection.item(1)
Dim sAttachmentFolder As String
' Get the path to your "My Documents" folder
sAttachmentFolder = CreateObject("WScript.Shell").SpecialFolders(16)
Set fso = CreateObject("Scripting.FileSystemObject")
Dim oAttachments As Outlook.Attachments
Dim lItemAttachmentCount As Long
Set oAttachments = aMail.Attachments
lItemAttachmentCount = oAttachments.Count
If (lItemAttachmentCount > 0) Then
Dim lAttachmentIndex As Long
For lAttachmentIndex = 1 To lItemAttachmentCount
Dim oAttachment As Outlook.attachment
Set oAttachment = oAttachments.item(lAttachmentIndex)
Dim sFileName As String
sFileName = oAttachment.FileName
If LenB(sFileName) > 0 Then
Dim sFilePath As String
sFilePath = sAttachmentFolder & "\" & sFileName
If fso.fileexists(sFilePath) Then
MsgBox "Cannot save attachment " & lAttachmentIndex & vbCr _
& "File already exists: " & vbCr _
& sFilePath, vbExclamation + vbOKOnly
Else
If MsgBox("Saving atachment " & lAttachmentIndex & "?" & vbCr _
& "Save location: " & vbCr & sFilePath, _
vbQuestion + vbOKCancel) = vbOK Then
' Save the attachment to the temporary folder
oAttachment.SaveAsFile (sFilePath)
Dim sAttachmentName As String
sAttachmentName = fso.getfilename(sFilePath)
Dim lAttachmentLength As Long
lAttachmentLength = fso.getfile(sFilePath).size
Dim sURL As String
sURL = "file://" & Replace(sFilePath, "\", "/")
MsgBox "Attachment " & lAttachmentIndex _
& " saved as: " & sAttachmentName & vbCr _
& "Size: " & lAttachmentLength & vbCr _
& "URL = " & sURL, _
vbInformation + vbOKOnly
End If
End If
End If
Next lAttachmentIndex
End If
End Sub
As you will see, the SaveMessageAttachments() subroutine correctly saves the file to the filesystem, with the proper file name. However, Outlook dialogs (as well as when trying to write the attachment file name or URL to the message body in VBA) will always render the file names having accents differently. Please give it a try with an Outlook message having an attachment named e.g. "à présent.txt").
What is strange, however, is that if I try to paste sURL in the message body, although the URL is incorrectly written (2 character decomposition of accented letters) Outlook seems to find and open the file.
How can I transform this accented string (sAttachmentName) with VBA in order to correctly paste it ("à présent.txt" instead of "a` pre´sent.txt") into the message body?