Skip to content

Instantly share code, notes, and snippets.

@joeinnes

joeinnes/FileDownloader

Last active August 31, 2016 16:54
Show Gist options
  • Save joeinnes/c1cea1efff9864e1f2b5226401b25167 to your computer and use it in GitHub Desktop.
Save joeinnes/c1cea1efff9864e1f2b5226401b25167 to your computer and use it in GitHub Desktop.
Download ZIP
Collection of macros to download a file using Internet Explorer, collate a bunch of emails from yesterday, assess whether they're 'new' or 'updated', and then send the whole thing to a particular email address.This macro can be deployed in Outlook 2013.Why the hell do I need to do that? Well, because without authenticating into our proxy at work…
Raw
FileDownloader
Public Sub DownloadFile()
' Requires 'Sleep' function
Dim IE As Object
Dim timeout As Date
Set IE = CreateObject("InternetExplorer.Application")
IE.Visible = False
'Navigate to a page to trigger Zscaler authentication
IE.Navigate "http://any.old.site" 'CHANGE
While IE.Busy
DoEvents
Wend
'Address to fetch file from
IE.Navigate "http://any.old.site/path/to/file.xlsx" 'CHANGE
Sleep (5)
SendKeys ("{DOWN}{DOWN}{ENTER}")
Sleep (1)
'Location to save to
SendKeys ("{%}USERPROFILE{%}\file.xls {ENTER}") 'CHANGE
'Note that this is only required in case you need to overwrite
SendKeys ("y")
IE.Quit
Set IE = Nothing
Sleep (1)
'Close the IE Download dialogue
SendKeys ("%C")
End Sub
Raw
SendCriticals
Public Sub SendCriticals()
On Error GoTo On_Error
Dim olApp As Outlook.Application
Dim olMsg As Outlook.MailItem
Dim Report As String
Dim Folder As Outlook.Folder
Dim oPA As Outlook.PropertyAccessor
Dim YdaysDate
Dim CurrentItem
Dim State
Call DownloadChats
Set Folder = GetFolder("\\Mailbox\Folder") 'CHANGE
Set olApp = Outlook.Application
Set olMsg = Outlook.CreateItem(0)
YdaysDate = GetDate(Now, 1)
Report = "<table>"
State = ""
For Each CurrentItem In Folder.Items
If GetDate(CurrentItem.ReceivedTime, 0) = YdaysDate And InStr(CurrentItem.Subject, "Critical Incident Ops Call Report") = 0 Then
If InStr(CurrentItem.Subject, "Update") > 0 Or InStr(CurrentItem.Subject, "Resolved") > 0 Then
State = "Updated"
ElseIf InStr(CurrentItem.Subject, "Initial") > 0 Then
State = "New"
Else
State = ""
End If
Report = Report & "<tr><td>" & YdaysDate & "</td><td>" & State & "</td><td>" & CurrentItem.Subject & "</td></tr>"
State = ""
End If
Next
Report = Report & "</table>"
olMsg.Subject = "Criticals for " & GetDate(Now, 1)
olMsg.To = "target.email@domain.com" 'CHANGE
olMsg.BodyFormat = olFormatHTML
olMsg.HTMLBody = Report
olMsg.Attachments.Add "{%}USERPROFILE{%}\file.xls" 'CHANGE
olMsg.Send
Exiting:
Set olApp = Nothing
Set olMsg = Nothing
Set Folder = Nothing
Set oPA = Nothing
Exit Sub
On_Error:
MsgBox "error=" & Err.Number & " " & Err.Description
Resume Exiting
End Sub
Function GetFolder(ByVal FolderPath As String) As Outlook.Folder
Dim TestFolder As Outlook.Folder
Dim FoldersArray As Variant
Dim i As Integer
On Error GoTo GetFolder_Error
If Left(FolderPath, 2) = "\\" Then
FolderPath = Right(FolderPath, Len(FolderPath) - 2)
End If
'Convert folderpath to array
FoldersArray = Split(FolderPath, "\")
Set TestFolder = Application.Session.Folders.Item(FoldersArray(0))
If Not TestFolder Is Nothing Then
For i = 1 To UBound(FoldersArray, 1)
Dim SubFolders As Outlook.Folders
Set SubFolders = TestFolder.Folders
Set TestFolder = SubFolders.Item(FoldersArray(i))
If TestFolder Is Nothing Then
Set GetFolder = Nothing
End If
Next
End If
'Return the TestFolder
Set GetFolder = TestFolder
Exit Function
GetFolder_Error:
Set GetFolder = Nothing
Exit Function
End Function
Function GetDate(dt As Date, o As Integer) As String
GetDate = Month(dt) & "/" & Day(dt) - o & "/" & Year(dt)
End Function
Raw
Sleep
Public Sub Sleep(Seconds As Integer)
Dim timeout As Date
timeout = Now + TimeSerial(0, 0, Seconds)
Do
DoEvents
Loop Until Now > timeout
End Sub
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment