I want to create a backup file when sending an email. The following code works fine if I do a step by step debug it works fine. Without it a manually need to kill the Excel task otherwise the whole thing hangs:
Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
Call SaveACopy(Item)
End Sub
Sub SaveACopy(Item As Object)
Const olMsg As Long = 3
Dim m As MailItem
Dim savePath As String
If TypeName(Item) <> "MailItem" Then Exit Sub
Set m = Item
Dim xlApp As Object
Set xlApp = CreateObject("Excel.Application")
xlApp.Visible = False
Dim fd As Office.FileDialog
Set fd = xlApp.Application.FileDialog(msoFileDialogFolderPicker)
Dim selectedItem As Variant
If fd.Show = -1 Then
For Each selectedItem In fd.SelectedItems
savePath = selectedItem & "\"
savePath = savePath & Format(Now(), "yyyy-mm-dd - hhNNss")
savePath = savePath & ".msg"
m.SaveAs savePath, olMsg
Next
End If
Set fd = Nothing
xlApp.Quit
Set xlApp = Nothing
End Sub
Any ideas?
Using a liberal application of DoEvents to solve a problem is not unlike fixing a hole in your car's oil pan by adding more oil.
Whatever was causing that bind is still there and your program will run faster if you can get it straightened out.
Related
I have made some progress and hence editing my description
I have a .xls file with signature that user save.
User clicks a custom button which opens a FileDialog from where he searches and selects the signature file. The code extracts the signature from the xls file and creates an HTML file in "AppData/Roaming/Microsoft/Signatures". My code works uptill this part--it opens the file and extracts the signature portion, creates HTML, the signature option is visible in the Signature Menu in Outlook. But when i click the mode-generated signature option, it is not displayed in the mail body.
I compared it with a manually created Signature in Outlook and after comparing the 2 HTML files, I feel this portion is causing the problem.
The marked portion is in the manually created signature but not in my code generated one. My inference is I am not creating a signature type HTML file as such. Can anyone help me with this? And my initial question still remains how do I make my code generated signature the default one?
My Code is as follows:
Option Explicit
Public Sub MailSignatur2()
Dim SigFolder2 As String
Dim fd As Office.FileDialog
Dim selectedItem As Variant
Dim SigFolder As String
Dim ExcelFileName As String
Dim FileName As String
Dim objExcel As New Excel.Application
Dim exWb As Excel.Workbook
Dim Signature As String
Dim oMsg As MailItem
Dim c As Variant
Dim fso As New FileSystemObject
Dim saveFolder As String
Dim DateFormat As String
Dim objSign As MailItem
SigFolder2 = "C:\Users\" & Environ("UserName") & "\Downloads\"
Debug.Print SigFolder2
Set fd = objExcel.FileDialog(msoFileDialogFilePicker)
With fd
.Filters.Clear
.InitialFileName = SigFolder2
.AllowMultiSelect = False
.Title = "Select Signature File"
End With
If fd.Show = -1 Then
For Each selectedItem In fd.SelectedItems
SigFolder = selectedItem
Next
Else
Exit Sub
End If
ExcelFileName = SigFolder
FileName = Left(fso.GetFileName(ExcelFileName), InStr(fso.GetFileName(ExcelFileName), ".") - 1)
Debug.Print ExcelFileName
Debug.Print FileName
Set exWb = objExcel.Workbooks.Open(ExcelFileName)
Signature = vbNullString
For Each c In exWb.Sheets(FileName).Range("A1:A30")
If c.Value = "$" Then
Exit For
Else
If c.Value = "%" Then
Signature = Signature & "<hr align='left' width='20%'><br>"
Else
Signature = Signature & c.Value & "<br>"
End If
End If
Next c
On Error Resume Next
Set oMsg = ActiveInspector.CurrentItem
On Error GoTo 0
Set objSign = Application.CreateItem(olMailItem)
With objSign
.HTMLBody = "<html><body><div><p>" & Signature & "</p></div></body></html>"
End With
saveFolder = "C:\Users\" & Environ("UserName") & "\AppData\Roaming\Microsoft\Signatures\"
objSign.SaveAs saveFolder & "Official_Sign.html", olHTML
Debug.Print saveFolder
ExitRoutine:
Set oMsg = Nothing
Set exWb = Nothing
Set objExcel = Nothing
End Sub
Got it. Very small mistake.It should be .htm instead of .html
objSign.SaveAs saveFolder & "Official_Sign.htm", olHTML
Ever day at 12 am there is an automatic email with an excel attachment from a vendor service with a specific subject. I am using rules and code to attempt to save the attachment and insert the information into a database I have created upon being received in the inbox.
I have tried code that I have found online however I don't know if doesn't work because of some network/ security setting my company has or if its he code it self.
Rule:
CODE:
Public Sub CribMaster2Database(itm As Outlook.MailItem)
Dim objAtt As Outlook.Attachment
Dim saveFolder As String
saveFolder = "c:\temp\"
If olItem.Subject = "Test" Then
For Each objAtt In itm.Attachments
objAtt.SaveAsFile saveFolder & "\" & objAtt.DisplayName
Set objAtt = Nothing
Next
End If
End Sub
Add code to the ThisOutlookSession to watch your folder for arrivals.
CribMaster_ItemAdd fires whenever something arrives in your watched folder.
At the very top of the module:
Dim WithEvents CribMaster As Items
Const SAVE_PATH As String = "c:\temp\"
Private Sub Application_Startup()
Dim ns As Outlook.NameSpace
Set ns = GetNamespace("MAPI")
'Change `holi4683` to the name of your account
'(should be visible just above your inbox).
Set CribMaster = ns.Folders.Item("holi4683") _
.Folders.Item("Inbox").Items
End Sub
Sub CribMaster_ItemAdd(ByVal Item As Object)
Dim olAtt As Attachment
Dim i As Integer
With Item
For i = 1 To .Attachments.Count
Set olAtt = .Attachments(i)
olAtt.SaveAsFile SAVE_PATH & olAtt.DisplayName
.UnRead = False
DoEvents
Next i
End With
Set olAtt = Nothing
End Sub
I'd usually use a rule to move the emails to a subfolder and watch that folder - means I don't have to worry about meeting invites, etc.
To do this you'd change your watched folder like this:
Set CribMaster = ns.Folders.Item("holi4683") _
.Folders.Item("Inbox") _
.Folders.Item("SubFolder").Items
Restart Outlook for the code to work, or manually run the Application_Startup() procedure.
I've got a code from here and I'm tweaking it for my need. My need is quite simple: I need it to download if it has the name of the Daily Tracker I'm keeping track of (as it changes daily with the Format(Now)). The problem is that it is not finding the attachment.
The code can find the email if I substitute the ElseIf to Next part for oOlItm.Display, but won't download the attachment.
Sub AttachmentDownload()
Const olFolderInbox As Integer = 6
'~~> Path for the attachment
Const AttachmentPath As String = "C:\TEMP\TestExcel"
Dim oOlAp As Object
Dim oOlns As Object
Dim oOlInb As Object
Dim oOlItm As Object
Dim oOlAtch As Object
Dim NewFileName As String
NewFileName = "Daily Tracker " & Format(Now, "dd/MM/yyyy")
Set oOlAp = GetObject(, "Outlook.application")
Set oOlns = oOlAp.GetNamespace("MAPI")
Set oOlInb = oOlns.GetDefaultFolder(olFolderInbox)
For Each oOlItm In oOlInb.Items
If InStr(oOlItm.Subject, NewFilename)) <> 0 Then
ElseIf oOlItm.Attachments.Count <> 0 Then
For Each oOlAtch In oOlItm.Attachments
oOlAtch.SaveAsFile (AttachmentPath)
Exit For
Next
Else
MsgBox "No attachments found"
End If
Exit For
Next
End Sub
The email:
This should work for you:
Sub AttachmentDownload()
Const olFolderInbox As Integer = 6
'~~> Path for the attachment
Const AttachmentPath As String = "C:\TEMP\TestExcel"
Dim oOlAp As Object
Dim oOlns As Object
Dim oOlInb As Object
Dim oOlItm As Object
Dim oOlAtch As Object
Dim oOlResults As Object
Dim x As Long
Dim NewFileName As String
NewFileName = "Daily Tracker " & Format(Now, "dd-MM-yyyy")
'You can only have a single instance of Outlook, so if it's already open
'this will be the same as GetObject, otherwise it will open Outlook.
Set oOlAp = CreateObject("Outlook.Application")
Set oOlns = oOlAp.GetNamespace("MAPI")
Set oOlInb = oOlns.GetDefaultFolder(olFolderInbox)
'No point searching the whole Inbox - just since yesterday.
Set oOlResults = oOlInb.Items.Restrict("[ReceivedTime]>'" & Format(Date - 1, "DDDDD HH:NN") & "'")
'If you have more than a single attachment they'll all overwrite each other.
'x will update the filename.
x = 1
For Each oOlItm In oOlResults
If oOlItm.attachments.Count > 0 Then
For Each oOlAtch In oOlItm.attachments
If GetExt(oOlAtch.FileName) = "xlsx" Then
oOlAtch.SaveAsFile AttachmentPath & "\" & NewFileName & "-" & x & ".xlsx"
End If
x = x + 1
Next oOlAtch
End If
Next oOlItm
End Sub
'----------------------------------------------------------------------
' GetExt
'
' Returns the extension of a file.
'----------------------------------------------------------------------
Public Function GetExt(FileName As String) As String
Dim mFSO As Object
Set mFSO = CreateObject("Scripting.FileSystemObject")
GetExt = mFSO.GetExtensionName(FileName)
End Function
Another way of doing it is from within Outlook:
Create a new folder in your Outlook Inbox and set a rule to move the email to this folder when it arrives. You can then write code to watch this folder and save the file as soon as it arrives.
Place this code within the ThisOutlookSession module in Outlook.
Dim WithEvents TargetFolderItems As Items
Const FILE_PATH As String = "C:\TEMP\TestExcel\"
Private Sub Application_Startup()
Dim ns As Outlook.NameSpace
Set ns = Application.GetNamespace("MAPI")
Set TargetFolderItems = ns.Folders.Item("Mailbox - Darren Bartrup-Cook") _
.Folders.Item("Inbox") _
.Folders.Item("My Email For Processing").Items
End Sub
Sub TargetFolderItems_ItemAdd(ByVal Item As Object)
'when a new item is added to our "watched folder" we can process it
Dim olAtt As Attachment
Dim i As Integer
Dim sTmpFileName As String
Dim objFSO As Object
Dim sExt As String
If Item.Attachments.Count > 0 Then
Set objFSO = CreateObject("Scripting.FileSystemObject")
For i = 1 To Item.Attachments.Count
Set olAtt = Item.Attachments(i)
sExt = objFSO.GetExtensionName(olAtt.FileName)
If sExt = "xlsx" Then
sTmpFileName = "Daily Tracker " & Format(Now, "dd-mm-yyyy") & ".xlsx"
End If
Item.UnRead = False
olAtt.SaveAsFile FILE_PATH & sTmpFileName
DoEvents
Next
End If
Set olAtt = Nothing
MsgPopup "A new attachment has been saved.", vbOKOnly, "New Daily Tracker"
End Sub
Private Sub Application_Quit()
Dim ns As Outlook.NameSpace
Set TargetFolderItems = Nothing
Set ns = Nothing
End Sub
Create a new module in Outlook and put this code in there. This will create a messagebox that won't stop whatever you're doing.
Public Function MsgPopup(Optional Prompt As String, _
Optional Buttons As VbMsgBoxStyle = vbOKOnly, _
Optional Title As String, _
Optional SecondsToWait As Long = 0) As VbMsgBoxResult
' Replicates the VBA MsgBox() function, with an added parameter
' to automatically dismiss the message box after n seconds
' If dismissed automatically, this will return -1: NOT ‘cancel’ or the default button choice.
' Nigel Heffernan, 2006. This code is in the public domain.
' Uses late-binding: bad for performance and stability, useful for code portability
' The correct declaration is: Dim objWshell As IWshRuntimeLibrary.WshShell
Dim objWshell As Object
Set objWshell = CreateObject("WScript.Shell")
MsgPopup = objWshell.Popup(Prompt, SecondsToWait, Title, Buttons)
Set objWshell = Nothing
End Function
I'm having trouble with automatically exporting the body of an email into a text file using a script.
I've managed a script that will save the text into a file on a macro but that won't work on a rule which is what I need.
My current code is as follows:
Sub SaveAsTXT()
Dim myItem As Outlook.Inspector
Dim objItem As Object
Dim myFolder As Folder
Set myItem = Application.ActiveInspector
If Not TypeName(myItem) = "Nothing" Then
Set myNamespace = Application.GetNamespace("MAPI")
Set myFolder = myNamespace.GetDefaultFolder(olFolderInbox)
Set objItem = myItem.CurrentItem
strname = objItem.Subject
strdate = Format(objItem.ReceivedTime, " yyyy mm dd")
objItem.SaveAs "c:\users\philip\documents\" & strname & strdate & ".txt", olTXT
End If
End Sub
Apologies if it looks a bit messy, I've edited it countless times trying to get it to work.
That's the code that will correctly run when I'm in the open email and run it as a macro but it won't work correctly when run as a rule
I have tried amending to Sub SaveAsTXT(Item as Outlook.Mailitem) but this also doesn't seem to work
So basically the question is how to I ensure the code will select the email (which will always be entitled "Rotas" without quotes) when it is run as a rule?
Info: Using office 2010 and I'm not a very good coder to start with.
Actually I managed to sort it out myself.
I didn't consider that the item as Outlook.Mailitem element was actually the thing that was selected by the rule. So I applied item as the object rather than objItem
Find the successful (and cleaned up) code below:
Sub SaveAsTXT(myMail As Outlook.MailItem)
Dim objItem As Object
Dim myFolder As Folder
If Not TypeName(myitem) = "Nothing" Then
If myMail.Subject = "Rotas" Then
strname = myMail.Subject
strdate = Format(myMail.ReceivedTime, " yyyy mm dd")
myMail.SaveAs "c:\users\philip\documents\" & strname & ".txt", olTXT
End If
End If
End Sub
got a little problem, I hope someone can help me.
(Outlook 2010 VBA)
this is my current code, what i need is when i click on a mail (only the mail i clicked on, not every mail in the folder/same place)
it has to check if the Sender of the mail is already in my contacts or in the
Addressbook 'All Users',
and if it's not a one of those yet, open the AddContact window and fill in his/her information
what doesn't work yet is:
most important of all, it doesn't run the script when i click on a mail
the current check if the contact already exsist doesn't work
and goes with a vbMsgBox (yes or no and response stuff) wich is not what i want/need
if the contact already exsist then nothing has to happen.
I hope i gave enough information and someone can help me out here :)
Sub AddAddressesToContacts(objMail As Outlook.MailItem)
Dim folContacts As Outlook.MAPIFolder
Dim colItems As Outlook.Items
Dim oContact As Outlook.ContactItem
Dim oMail As Outlook.MailItem
Dim obj As Object
Dim oNS As Outlook.NameSpace
''don't want or need a vbBox/ask box, this is a part of the current contactcheck
''wich doesn't work and is totaly wrong :P
Dim response As VbMsgBoxResult
Dim bContinue As Boolean
Dim sSenderName As String
On Error Resume Next
Set oNS = Application.GetNamespace("MAPI")
Set folContacts = oNS.GetDefaultFolder(olFolderContacts)
Set colItems = folContacts.Items
''this selects the mail that is currently selected.
''what i want is that the sender of the new incoming mail gets added to contacts
''(ofcourse, if that contact doesn't exsist yet)
''so the new incoming mail gotta be selected.
For Each obj In Application.ActiveExplorer.Selection
If obj.Class = olMail Then
Set oContact = Nothing
bContinue = True
sSenderName = ""
Set oMail = obj
sSenderName = oMail.SentOnBehalfOfName
If sSenderName = ";" Then
sSenderName = oMail.SenderName
End If
Set oContact = colItems.Find("[FullName] = '" & sSenderName & "'")
''this part till the --- is wrong, i need someting to check if the contact (the sender)
''already exsists. Any ideas?
If Not (oContact Is Nothing) Then
response = vbAbort
If response = vbAbort Then
bContinue = False
End If
End If
''---------
If bContinue Then
Set oContact = colItems.Add(olContactItem)
With oContact
.Email1Address = oMail.SenderEmailAddress
.Email1DisplayName = sSenderName
.Email1AddressType = oMail.SenderEmailType
.FullName = oMail.SenderName
'.Save
oContact.Display
End With
End If
End If
Next
Set folContacts = Nothing
Set colItems = Nothing
Set oContact = Nothing
Set oMail = Nothing
Set obj = Nothing
Set oNS = Nothing
End Sub
hey, i still have a last question,
'sets the name of the contact
Set oContact = colItems.Find("[FullName] = '" & sSenderName & "'")
'checks if the contact exsist, if it does exit the for loop
If Not oContact Is Nothing Then
Exit For
End If
End If
this checks if the name is already in contacts,
i need it that it checks if the E-mailaddress is in contacts or not,
can you help me with that?
i had someting like this in mind
set oSendermail = ?the e-mailaddress?
If Not oSendermail Is Nothing Then
Exit For
End If
End If
A solution (including test routine) could look as follows:
(assuming that we only consider external SMTP mails. Adjust the path to your contact folder and add some more error checking!)
Option Explicit
Private Declare Function GetTickCount Lib "kernel32.dll" () As Long
Sub AutoContactMessageRule(newMail As Outlook.mailItem)
' "script" routine to be called for each incoming Mail message
' This subroutine has to be linked to this mail type using
' Outlook's rule assistant
Dim EntryID As String
Dim StoreID As Variant
Dim mi As Outlook.mailItem
Dim contactFolder As Outlook.Folder
Dim contact As Outlook.ContactItem
On Error GoTo ErrorHandler
' we have to access the new mail via an application reference
' to avoid security warnings
EntryID = newMail.EntryID
StoreID = newMail.Parent.StoreID
Set mi = Application.Session.GetItemFromID(EntryID, StoreID)
With mi
If .SenderEmailType = "SMTP" Then
Set contactFolder = FindFolder("Kemper\_local\TestContacts")
Set contact = contactFolder.items.Find("[Email1Address]=" & Chr(34) & .SenderEmailAddress & Chr(34))
If Not TypeName(contact) <> "Nothing" Then
Set contact = contactFolder.items.Add(olContactItem)
contact.Email1Address = .SenderEmailAddress
contact.Email1AddressType = .SenderEmailType
contact.FullName = .SenderName
contact.Save
End If
End If
End With
Exit Sub
ErrorHandler:
MsgBox Err.Description, vbCritical, "Ooops!"
Err.Clear
On Error GoTo 0
End Sub
Private Function FindFolder(path As String) As Outlook.Folder
' Locate MAPI Folder.
' Separate sub-folder using '/' . Example: "My/2012/Letters"
Dim fd As Outlook.Folder
Dim subPath() As String
Dim I As Integer
Dim ns As NameSpace
Dim s As String
On Error GoTo ErrorHandler
s = Replace(path, "\", "/")
If InStr(s, "//") = 1 Then
s = Mid(s, 3)
End If
subPath = Split(s, "/", -1, 1)
Set ns = Application.GetNamespace("MAPI")
For I = 0 To UBound(subPath)
If I = 0 Then
Set fd = ns.Folders(subPath(0))
Else
Set fd = fd.Folders(subPath(I))
End If
If fd Is Nothing Then
Exit For
End If
Next
Set FindFolder = fd
Exit Function
ErrorHandler:
Set FindFolder = Nothing
End Function
Public Sub TestAutoContactMessageRule()
' Routine to test Mail Handlers AutoContactMessageRule()'
' without incoming mail messages
' select an existing mail before executing this routine
Dim objItem As Object
Dim objMail As Outlook.mailItem
Dim started As Long
For Each objItem In Application.ActiveExplorer.Selection
If TypeName(objItem) = "MailItem" Then
Set objMail = objItem
started = GetTickCount()
AutoContactMessageRule objMail
Debug.Print "elapsed " & (GetTickCount() - started) / 1000# & "s"
End If
Next
End Sub