I am trying to write some macros in both Excel and Outlook that in the end will automatically unzip and open a CSV, process the data, and sends it where it needs to go when a new email arrives in a specific folder. I have everything worked out on the Excel side but I am having difficulties with Outlook. The below code unzips the file. How would i go about opening the unzipped file and triggering an Excel macro (which is always open in another workbook)?
Another issue I am running into: this code only seems to work when i actually open the target email in it's own window.
Public Sub OpenZippedSheet()
Dim objMail As Outlook.MailItem
Dim objAttachments As Outlook.Attachments
Dim objAttachment As Outlook.Attachment
Dim objShell As Object
Dim objFileSystem As Object
Dim strTempFolder As String
Dim strFilePath As String
Dim strFileName As String
Set objMail = Outlook.Application.ActiveInspector.CurrentItem
Set objAttachments = objMail.Attachments
'Save & Unzip the zip file in local drive
Set objShell = CreateObject("Shell.Application")
Set objFileSystem = CreateObject("Scripting.FileSystemObject")
strTempFolder = objFileSystem.GetSpecialFolder(2).Path & "\Temp" & Format(Now, "yyyy-mm-dd-hh-mm-ss")
MkDir (strTempFolder)
For Each objAttachment In objAttachments
If Right(objAttachment.FileName, 3) = "zip" Then
strFilePath = strTempFolder & "\" & objAttachment.FileName
objAttachment.SaveAsFile (strFilePath)
objShell.NameSpace((strTempFolder)).CopyHere objShell.NameSpace((strFilePath)).Items
End If
Next
End Sub
I'm assuming I would do some sort of object.open but I don't know what the syntax would be to get it to actually open in Excel. And then is there a way to trigger an Excel macro from Outlook?
Thanks so much in advance!
this code only seems to work when i actually open the target email in it's own window.
That is because you rely on the ActiveInspector window. If you want to handle items selected in the Explorer windows you need to check the Selection object (see the corresponding property).
To open an Excel file you can:
Use the Shell.ShellExecute method. This method is equivalent to launching one of the commands associated with a file's shortcut menu. Each command is represented by a verb string. The set of supported verbs varies from file to file. The most commonly supported verb is "open", which is also usually the default verb. Other verbs might be supported by only certain types of files.
Automate Excel from your VBA macro to do the required actions. See How to automate Microsoft Excel from Visual Basic for more information.
To run your VBA macro code from other applications you can use the Application.Run method. Read more about that in the How do I use Application.Run in Excel article.
Application.Run "'" & TestWkbk.Name & "'!MacroNameHere", "parm1", "parm2"
Something like this (untested so may need some fixes):
'Note - any paths passed to objShell should be
' passed as *Variants*, not Strings
Dim oXL As Object, wbCSV As Object, fileNameInZip As Variant
Set objShell = CreateObject("Shell.Application")
For Each objAttachment In objAttachments
If Right(objAttachment.Filename, 3) = "zip" Then
strFilePath = strTempFolder & "\" & objAttachment.Filename
objAttachment.SaveAsFile strFilePath
Set oNS = oApp.Namespace(strFilePath)
For Each fileNameInZip In oNS.items 'loop over the files in the zip
Debug.Print fileNameInZip
If LCase(fileNameInZip) Like "*.csv" Then 'csv file?
'extract the file
objShell.Namespace(strTempFolder).copyhere oNS.items.Item(CStr(fileNameInZip))
If oXL Is Nothing Then Set oXL = GetObject(, "Excel.Application") 'assumes excel is running
Set wbCSV = oXL.Workbooks.Open(strTempFolder & "\" & fileNameInZip)
oXL.Run "'YourMacroFile.xlsm'!YourMacroName" 'run the macro
'clean up stuff...
End If 'is a csv file
Next 'file in zip
End If 'attachment is a zip file
Next 'attachment
Related
I have an excel file that when opened needs to download and open the latest version of an add in that is stored in Sharepoint. I have this code that downloads the add in, saves it in a specific location (strSavePath) and tries to open it.
Function funLoadRomeFiles(strURL As String, strSavePath As String)
Dim objConnection As Object
Dim objStream As Object
Set objConnection = CreateObject("MSXML2.ServerXMLHTTP.6.0")
On Error GoTo ExitConnect
objConnection.Open "GET", strURL, False
objConnection.send
strURL = objConnection.responseBody
If objConnection.Status = 200 Then
Set objStream = CreateObject("ADODB.Stream")
objStream.Open
objStream.Type = 1
objStream.Write objConnection.responseBody
objStream.SaveToFile strSavePath, 2
objStream.Close
End If
ExitConnect:
On Error GoTo 0
Shell "C:\WINDOWS\explorer.exe """ & strSavePath & "", vbHide
End Function
However I get an error on the second to last row. The error is: Excel cannot open the file "Filename" because the file format or file extension is not valid [...]". The file downloaded is corrupted and cannot be opened manually either. When I download it and open it manually , it works.
The file size is 30.9 kb, but executing the code will download it as a 51 kb file. I've tried downloading other files using this code, and they have also become corrupted and 51 kb no matter the actual file size. Is there any way to change the code so the file will not be corrupted or any other ways of doing this?
Update: The file downloaded seems to be a html file even though its name still ends with .xlam
Also, I,ve tried using a link that ends with "filename.xlam" and one that ends with "filename.xlam?csf=1&e=b5f7991021ab45c1833229210f3ce810", both gives the same result, and when you copy the links into chrome both immediately downloads the correct file
I had a once a similar Problem.
The Problem by me was, that sharepoint did not allow a certain kind of file Type. So i had to do a workaround. So what you can try is to Zip your *.xlam File and Put that on the Sharepoint. Then you download it with the Code you already have. And then you just unzipped with the Following Code.
Sub Unzip1()
Dim FSO As Object
Dim oApp As Object
Dim Fname As Variant
Dim FileNameFolder As Variant
Dim DefPath As String
Dim strDate As String
Fname = strSavePath' I assume that this is the Path to the File you Downloaded
If Fname = False Then
'Do nothing
Else
'Root folder for the new folder.
DefPath = Application.DefaultFilePath 'Or Change it to the Path you want to unzip the Files
If Right(DefPath, 1) <> "\" Then
DefPath = DefPath & "\"
End If
'Create the folder name
strDate = Format(Now, " dd-mm-yy h-mm-ss")
FileNameFolder = DefPath & "MyUnzipFolder " & strDate & "\"
'Make the normal folder in DefPath
MkDir FileNameFolder
'Extract the files into the newly created folder
Set oApp = CreateObject("Shell.Application")
oApp.Namespace(FileNameFolder).CopyHere oApp.Namespace(Fname).items
'If you want to extract only one file you can use this:
'oApp.Namespace(FileNameFolder).CopyHere _
'oApp.Namespace(Fname).items.Item("test.txt")
MsgBox "You find the files here: " & FileNameFolder
On Error Resume Next
Set FSO = CreateObject("scripting.filesystemobject")
FSO.deletefolder Environ("Temp") & "\Temporary Directory*", True
End If
End Sub
And after that you just executed the Extension.
I Hope this can help you.
I could not find a way to download to add-ins, tried multiple different way and concluded that there was som authorization error or something else caused by the version of SharePoint I was using. The solution I found that suited my needs was to open the add-ins directly from SharePoint using this code:
On Error Resume Next
ActiveWorkbook.FollowHyperlink Address:="strUrl"
On Error GoTo 0
The VBA macro stops running on opening certain workbooks. When I run the code in break mode, it seems like control goes over to the newly opened workbook and there it has no instructions to follow.
I am trying to open a lot of workbooks, take a printout and close them.
I have also tried opening them in Read only mode, setting the calculation mode to manual but nothing has worked so far.
The following will work if you have a folder with all the workbooks.
This code will iterate through a series of excel files in a given folder:
Dim objFSO As Object
Dim objFolder As Object
Dim objFile As Object
Dim strPath As String
Dim intLen As Integer
Dim strName As String
Dim wsSheet As Worksheet
Set objFSO = CreateObject("Scripting.FileSystemObject")
strPath = "C:\Users\username\Desktop\FolderName" 'Set path of folder with excel files
Set objFolder = objFSO.GetFolder(strPath) 'Get the folder object associated with the directory
For Each objFile In objFolder.Files 'Loop through the files in the folder
Workbooks.Open (strPath & "\" & objFile.Name)
Set wsSheet = Worksheets("Sheet1") 'Name of sheet in excel file
ActiveWorkbook.CheckCompatibility = False 'Skip compatibility check
This code will printout a pdf of the specified range on each sheet to a given path:
intLen = Len(objFile.Name) - 5 'Remove .xlsx characters from name
strName = Left(objFile.Name, intLen)
wsSheet.Range("A1:P58").ExportAsFixedFormat xlTypePDF, "C:\Users\username\Desktop\" & strName & ".pdf", , , , , , False
This code will close each file without saving and continue the loop through the folder:
Workbooks(strName).Close SaveChanges:=False 'Close excel file without saving
Next
Team, I am working upon extract the zip file from VBA code but getting error, here is my code:
Sub Un_Zip_File()
Dim flname As String
Call PathCall
flname = Dir(impathn & "Transactions*.zip")
Call PathCall
Call UnZip_File(impathn, flname)
End Sub
Sub UnZip_File(strTargetPath As String, fname As Variant)
Dim oApp As Object, FSOobj As Object
Dim FileNameFolder As Variant
If Right(strTargetPath, 1) <> Application.PathSeparator Then
strTargetPath = strTargetPath & Application.PathSeparator
End If
FileNameFolder = strTargetPath
'destination folder if it does not exist
Set FSOobj = CreateObject("Scripting.FilesystemObject")
If FSOobj.FolderExists(FileNameFolder) = False Then
FSOobj.CreateFolder FileNameFolder
End If
Set oApp = CreateObject("Shell.Application")
oApp.Namespace(FileNameFolder).CopyHere oApp.Namespace(fname).Items
Set oApp = Nothing
Set FSOobj = Nothing
Set FileNameFolder = Nothing
End Sub
When I am running Un_zip_file macro, I am getting error:
Object variables or with block variable not set
after debug moving on
oApp.Namespace(FileNameFolder).CopyHere oApp.Namespace(fname).Items
Here is another example how to unzip a file. the macro unzip the zip file in a fixed folder"C:\test\"
Sub Unzip()
Dim FSO As Object
Dim oApp As Object
Dim Fname As Variant
Dim FileNameFolder As Variant
Dim DefPath As String
Fname = Application.GetOpenFilename(filefilter:="Zip Files (*.zip), *.zip", _
MultiSelect:=False)
If Fname = False Then
'Do nothing
Else
'Destination folder
DefPath = "C:\test\" ' Change to your path / variable
If Right(DefPath, 1) <> "\" Then
DefPath = DefPath & "\"
End If
FileNameFolder = DefPath
' 'Delete all the files in the folder DefPath first if you want
' On Error Resume Next
' Kill DefPath & "*.*"
' On Error GoTo 0
'Extract the files into the Destination folder
Set oApp = CreateObject("Shell.Application")
oApp.Namespace(FileNameFolder).CopyHere oApp.Namespace(Fname).items
MsgBox "You find the files here: " & FileNameFolder
On Error Resume Next
Set FSO = CreateObject("scripting.filesystemobject")
FSO.deletefolder Environ("Temp") & "\Temporary Directory*", True
End If
End Sub
Found elsewhere on the web and thought it might help here...
Sub UnzipAFile(zippedFileFullName As Variant, unzipToPath As Variant)
Dim ShellApp As Object
'Copy the files & folders from the zip into a folder
Set ShellApp = CreateObject("Shell.Application")
On Error Resume Next
ShellApp.Namespace(unzipToPath).CopyHere ShellApp.Namespace(zippedFileFullName).Items
On Error GoTo 0
End Sub
I had same error "Object variables or with block variable not set".
Solved it by adding reference to "Microsoft Shell Controls & Automation" - Shell32.dll. Then define & use the Shell object in this order.
Do not skip any of these steps. I have also posted full code in this page.
Dim wShApp As Shell
Set wShApp = CreateObject("Shell.Application")
Set objZipItems = wShApp.Namespace(zipFileName).items
wShApp.Namespace(unZipFolderName).CopyHere objZipItems
To avoid the message error:
1 - change "/" per "\"
unzipToPath= Replace(unzipToPath, "/", "\\")
zippedFileFullName= Replace(zippedFileFullName, "/", "\\")
2 - Use double (( to the parameters as below:
ShellApp.Namespace((unzipToPath)).CopyHere
ShellApp.Namespace((zippedFileFullName)).Items
I had exactly the same problem, but in MS Word, trying to extract files from a .zip folder. After a lot of experimentation and testing I discovered that the late-binding objects were not initializing correctly, and when i tested them with the TypeName function were typically "nothing".
I tested my code in both Windows 10 and on an old Windows XP machine, with the same results. All my testing was in Excel 2007 and Excel 2016.
Changing the code from late-binding to early-binding resolved the problem.
Late-binding uses the CreateObject function to initialize the objects in the Shell.Application library. Early-binding requires setting a reference to the "Microsoft Shell Controls and Automation" library in your project.
To set the reference, do this:
In the VBA IDE, use the Tools menu to open the References dialog. Scroll through the list of available references until you find the "Microsoft Shell Controls and Automation" entry, and then click the checkbox to select that library, thus:
The VBA References dialog, showing the "Microsoft Shell Controls and Automation" library after adding it to your project.
I receive emails each day which give me a report of my site's performance for the previous day. The reports are given a generic name and I am not able to change this at source. I run the below script via an Outlook rule for whenever a message with certain criteria is received and the report is saved to a given location with yesterday's date in the file name:
Public Sub Save Reports (itm As Outlook.MailItem)
Dim ObjAtt As Outlook.Attachment
Dim SaveFolder As String
For Each ObjAtt In itm.Attachments
If InStr(ObjAtt.DisplayName, ".csv") Then
FileName = (ObjAtt.FileName)
NewName = "System Performance " & Format(Date - 1, "DD-MM-YYYY") & Right(FileName, 4)
SaveFolder = "C:\Users\Me\Documents\"
ObjAtt.SaveAsFile SaveFolder & NewName
End If
Set ObjAtt = Nothing
Next
End Sub
The problem is that if we have any problems anywhere within the process, I might get an email today which actually relates to last week rather than yesterday. If this happens the above script does not work and it requires me to save it manually.
One way I could work round this is if I can work out a way to extract data from a cell in the attached CSV file I am saving and then use that as the file name. For every file I want to save, cell B1 has the date that I need to use in the file name.
I have look through Stackoverflow and other internet resources to try and find something that will allow me to do this but have been unable to work it out.
Thanks to a comment below I have tried to edit my script so saves the files, then opens the files and takes the data needed and then renames the file but to no avail:
Public Sub Save Reports (itm As Outlook.MailItem)
Dim ObjAtt As Outlook.Attachment
Dim SaveFolder As String
Dim xlApp As Object
Dim sourceWB As Excel.Workbook
Dim sourceSH As Excel.Worksheet
Dim strFile As String
For Each ObjAtt In itm.Attachments
If InStr(ObjAtt.DisplayName, ".csv") Then
FileName = (ObjAtt.FileName)
NewName = "System Performance " & Format(Date - 1, "DD-MM-YYYY") & Right(FileName, 4)
SaveFolder = "C:\Users\Me\Documents\"
ObjAtt.SaveAsFile SaveFolder & NewName
Set xlApp = CreateObject("Excel.Application")
With xlApp
.Visible = True
.EnableEvents = False
End With
strFile = SaveFolder & NewName
Set sourceWB = Workbooks.Open(strFile, , False, , , , , , , True)
Set sourceSH = sourceWB.Worksheets("Sheet2")
sourceWB.Activate
Range("B1").Select
newdate = ActiveCell.Value
Set sourceWB = Nothing
Set sourceSH = Nothing
xlApp.Quit
Set xlApp = Nothing
Name SaveFolder & NewName As SaveFolder & newdate
End If
Set ObjAtt = Nothing
Next
End Sub
The Outlook object model doesn't provide any property or method for that. You need to save the attached file on the disk first and then open it for reading the cells. The SaveAsFile method of the Attachment class saves the attachment to the specified path.
Also you can try to read the binary content of the attached file using the low-level API - Extended MAPI. The property name is PR_ATTACH_DATA_BIN which contains binary attachment data typically accessed through the OLE IStream interface. See Opening an Attachment for more information. Also you may consider using any third-party wrappers around that API (for example, Redemption).
Is there any way that one can open a workbook attached to an email template, edit, and save it prior to sending the message? I've created the mailitem object using Set Mesg = OutlookAp.CreateItemFromTemplate("C:\Template.oft") and I can see the attachment, but I can't see a way to open it thus far. If anyone has suggestions, or knows that this simply can't be done, I'm all ears.
Looks like I may have to save and edit the file prior to sending... Still open to ideas, but it looks like it simply isn't possible to open the attachment through VBA
I assume you are automating Outlook from Excel. This solution may work for you, but as you note it does rely on saving the attachment and re-attaching the manipulated version of the file. Assuming you can write the code which will "edit" the Workbook attachment, this should work for you.
Sub TestOutlookTemplate()
Dim MyOutlook As Outlook.Application
Dim MyMail As Outlook.MailItem
Dim att As Outlook.Attachment
Dim templatePath As String
Dim tempFileName As String
Dim attWorkbook As Workbook
templatePath = "C:\users\david_zemens\desktop\Untitled.oft"
tempFileName = "C:\users\david_zemens\desktop\tempexcelfile.xlsx"
Set MyOutlook = CreateObject("Outlook.Application")
Set MyMail = MyOutlook.CreateItemFromTemplate(templatePath)
MyMail.Display
For Each att In MyMail.Attachments
If att.DisplayName Like "*.xls*" Then
att.SaveAsFile tempFileName
'Now that you have saved the file, delete the attachment
att.Delete
'Open the file
Set attWorkbook = Workbooks.Open(tempFileName)
'Perform manipulation on the file
attWorkbook.Sheets(1).Name = "Sheet ONE"
'Save fhe file
attWorkbook.Save
'Close the file
attWorkbook.Close
MyMail.Attachments.Add tempFileName
End If
Next
'Send your mail (make sure you have added a recipient
MyMail.Send
Set attWorkbook = Nothing
Set MyMail = Nothing
Set MyOutlook = Nothing
End Sub