MisterTootor M.S., B.S., A.S., A.S.B
This Code archives files in a folder that have reached a certain age and sends them to another folder
Public Sub ArchivItems()
Dim SrcFolder As Outlook.MAPIFolder
Dim DestFolder As Outlook.MAPIFolder
Dim Items As Outlook.Items
Dim obj As Object
Dim Appt As Outlook.AppointmentItem
Dim Ns As Outlook.NameSpace
Dim DueDate As Date
Dim i& Dim Counter&
Set Ns = Application.GetNamespace("MAPI")
'Select Archive folder
Set DestFolder = Ns.PickFolder
If DestFolder Is Nothing Then Exit Sub
'Set the age, archive if older than 7 days
DueDate = DateAdd("d", -7, Now)
'Archive from default calendar
Set SrcFolder = Ns.GetDefaultFolder(olFolderCalendar)
Set Items = SrcFolder.Items
For i = Items.Count To 1 Step -1
Set obj = Items(i)
If TypeOf obj Is Outlook.AppointmentItem Then
Set Appt = obj
If DateDiff("s", Appt.End, DueDate, vbUseSystemDayOfWeek, vbUseSystem) > 0 Then
Appt.Move DestFolder
Counter = Counter + 1
End If
End If
Next
MsgBox Counter & " items have been moved", vbInformation End Sub
Code to find a sent message by prompting the user for keywords
Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
On Error Resume Next
Dim Msg$ If Len(Item.Categories) = 0 Then
Msg = "Do you want to add a category?"
If MsgBox(Msg, vbYesNo Or vbQuestion) = vbYes Then
Cancel = True
End If
End If
End Sub
Code to delete an email when clicking the reply button (email goes to the deleted folder)
Private WithEvents ReplyButton As Office.CommandBarButton
Private WithEvents m_Inspectors As Outlook.Inspectors
Private m_Mail As Outlook.MailItem
Private Sub Application_Startup()
Set ReplyButton = Application.ActiveExplorer.CommandBars.FindControl(, 354)
Set m_Inspectors = Application.Inspectors
End Sub
Private Sub m_Inspectors_NewInspector(ByVal Inspector As Outlook.Inspector)
On Error Resume Next
If Not m_Mail Is Nothing Then
m_Mail.Delete
Set m_Mail = Nothing
End If
End Sub
Private Sub ReplyButton_Click(ByVal Ctrl As Office.CommandBarButton, _
CancelDefault As Boolean _
)
On Error Resume Next
If TypeOf Application.ActiveWindow Is Outlook.Explorer Then
Set m_Mail = Application.ActiveExplorer.Selection(1)
Else
Set m_Mail = Application.ActiveInspector.CurrentItem
End If
End Sub
Code to edit the subject off an email without opening it up
Public Sub EditSubject()
Dim obj As Object
Dim Sel As Outlook.Selection
Dim DoSave As Boolean
Dim NewSubject As String
If TypeOf Application.ActiveWindow Is Outlook.Inspector Then
Set obj = Application.ActiveInspector.CurrentItem
Else
Set Sel = Application.ActiveExplorer.Selection
If Sel.Count Then
Set obj = Sel(1)
DoSave = True
End If
End If
If Not obj Is Nothing Then
NewSubject = InputBox("New subject:", , obj.Subject)
If NewSubject <> "" Then
obj.Subject = NewSubject
If DoSave Then
obj.Save
End If
End If
End If
End Sub
Code to export email address off a sender to a text file
Private Const SenderFile As String = "c:\email addresses\senders.txt"
Private Declare Function ShellExecute Lib "shell32.dll" Alias _
"ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, _
ByVal lpFile As String, ByVal lpParameters As String, _
ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
Public Sub ExportSenderAddresses()
On Error GoTo ERR_HANDLER
Dim Sel As Outlook.Selection
Dim Addresses As String
Dim File As String
Dim Hnd As Long
Set Sel = Application.ActiveExplorer.Selection
Addresses = GetSenderAddresses(Sel)
If Len(Addresses) Then
Hnd = FreeFile
Open SenderFile For Append As #Hnd
Print #Hnd, Addresses;
Close #Hnd
ShellExecute 0, "open", SenderFile, "", "", 1
End If
Exit Sub
ERR_HANDLER:
If Hnd Then Close #Hnd
MsgBox Err.Description
End Sub
Private Function GetSenderAddresses(Sel As Outlook.Selection) As String
Dim b As String
Dim obj As Object
Dim i As Long
For i = 1 To Sel.Count
Set obj = Sel(i)
If TypeOf obj Is Outlook.MailItem Or _
TypeOf obj Is Outlook.MeetingItem Then
b = b & obj.SenderEmailAddress & vbCrLf
End If
Next
GetSenderAddresses = b
End Function
Code to export the email address of a receiver to a text file
Private Const SenderFile As String = "c:\email addresses\senders.txt"
Private Declare Function ShellExecute Lib "shell32.dll" Alias _
"ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, _
ByVal lpFile As String, ByVal lpParameters As String, _
ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
Public Sub ExportSenderAddresses()
On Error GoTo ERR_HANDLER
Dim Sel As Outlook.Selection
Dim Addresses As String
Dim File As String
Dim Hnd As Long
Set Sel = Application.ActiveExplorer.Selection
Addresses = GetSenderAddresses(Sel)
If Len(Addresses) Then
Hnd = FreeFile
Open SenderFile For Append As #Hnd
Print #Hnd, Addresses;
Close #Hnd
ShellExecute 0, "open", SenderFile, "", "", 1
End If
Exit Sub
ERR_HANDLER:
If Hnd Then Close #Hnd
MsgBox Err.Description
End Sub
Private Function GetSenderAddresses(Sel As Outlook.Selection) As String
Dim b As String
Dim obj As Object
Dim i As Long
For i = 1 To Sel.Count
Set obj = Sel(i)
If TypeOf obj Is Outlook.MailItem Or _
TypeOf obj Is Outlook.MeetingItem Then
b = b & obj.SenderEmailAddress & vbCrLf
End If
Next
GetSenderAddresses = b
End Function
Code to hide text in an email
Public Sub CollapseExpandText()
Dim Ins As Outlook.Inspector
Dim Document As Object 'Word.Document
Dim Bm As Object 'Word.Bookmark
Dim Fn As Object 'Word.Font
Set Ins = Application.ActiveInspector
Set Document = Ins.WordEditor
'Here enter the name of the bookmark
Set Bm = Document.Bookmarks("HideText")
Set Fn = Bm.Range.Font
Fn.Hidden = Not Fn.Hidden
End Sub
Code to insert a formatted excel table into an email
Sub PasteFormattedTable()
Dim Doc As Word.Document
Dim wdRn As Word.Range
Dim Xl As Excel.Application
Dim Ws As Excel.Worksheet
Dim xlRn As Excel.Range
Set Doc = Application.ActiveInspector.WordEditor
Set wdRn = Doc.Range
Set Xl = GetObject(, "Excel.Application")
Set Ws = Xl.Workbooks("Mappe1.xls").Worksheets(1)
Set xlRn = Ws.Range("b2", "c6")
xlRn.Copy
wdRn.Paste
End Sub
Code to mark emails as being read
Private WithEvents Items As Outlook.Items
Private Sub Application_Startup()
Dim Ns As Outlook.NameSpace
Dim F As Outlook.MAPIFolder
Set Ns = Application.GetNamespace("MAPI")
Set F = Ns.GetDefaultFolder(olFolderInbox)
Set F = F.Folders("test")
Set Items = F.Items
End Sub
Private Sub Items_ItemAdd(ByVal Item As Object)
Item.UnRead = False
Item.Save
End Sub
Code to open excel from within outlook
Public Sub OpenMyExcelFile()
Dim File$
Dim Xl As Object ' Excel.Application
Dim Wb As Object ' Excel.Workbook
Dim Ws As Object ' Excel.Worksheet
Dim Rn as Object ' Excel.Range
File = "c:\file.xls"
On Error Resume Next
Set Xl = GetObject(, "excel.application")
On Error GoTo 0
If Xl Is Nothing Then Set Xl = New Excel.Application
Set Wb = Xl.Workbooks.Open(File)
Set Ws = Wb.Sheets(1)
Ws.Activate
Set Rn = Ws.Range("a1")
Rn.Activate
Xl.Visible = True
End Sub
Code to auto print attachments
Private Declare Function ShellExecute Lib "shell32.dll" Alias _
"ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, _
ByVal lpFile As String, ByVal lpParameters As String, _
ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
Private WithEvents Items As Outlook.Items
Private Sub Application_Startup()
Dim Ns As Outlook.NameSpace
Dim Folder As Outlook.MAPIFolder
Set Ns = Application.GetNamespace("MAPI")
Set Folder = Ns.GetDefaultFolder(olFolderInbox)
Set Items = Folder.Items
End Sub
Private Sub Items_ItemAdd(ByVal Item As Object)
If TypeOf Item Is Outlook.MailItem Then
PrintAttachments Item
End If
End Sub
Private Sub PrintAttachments(oMail As Outlook.MailItem)
On Error Resume Next
Dim colAtts As Outlook.Attachments
Dim oAtt As Outlook.Attachment
Dim sFile As String
Dim sDirectory As String
Dim sFileType As String
sDirectory = "D:Attachments"
Set colAtts = oMail.Attachments
If colAtts.Count Then
For Each oAtt In colAtts
sFileType = LCase$(right$(oAtt.FileName, 4))
Select Case sFileType
Case ".xls", ".doc", ".pdf"
sFile = ATTACHMENT_DIRECTORY & oAtt.FileName
oAtt.SaveAsFile sFile
ShellExecute 0, "print", sFile, vbNullString, vbNullString, 0
End Select
Next
End If
End Sub
Code to reply to an email with a template
Public Sub Reply_1()
Dim Subject As String, Msg As String
Subject = "Re: "
Msg = "Sample Message 1"
ReplyMail Subject, Msg
End Sub
Code to request a receipt
Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
If TypeOf Item Is Outlook.MailItem Then
SetReadReceipt Item
End If
End Sub
Private Sub SetReadReceipt(Mail As Outlook.MailItem)
Dim i&, y&
Dim Adr$
Dim Recipients As Outlook.Recipients
Dim Addresses As Variant
Dim Request As Boolean
' customize
Request = True
Addresses = Array("abc@domain.de", "@domain.com")
Set Recipients = Mail.Recipients
For i = 1 To Recipients.Count
Adr = Recipients.Item(i).Address
For y = 0 To UBound(Addresses)
If InStr(1, Adr, Addresses(y), vbTextCompare) Then
Mail.ReadReceiptRequested = Request
Exit Sub
End If
Next y
Next i
End Sub
Code to send a copy of every email to yourself
Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
Dim R As Outlook.Recipient
Dim Address$
Address = "abc@domain.com"
Set R = Item.Recipients.Add(Address)
R.Type = olBCC
R.Resolve
End Sub
Code to send all files with one email
Private m_Send as String
Private m_Done as String
Private m_To as String
Public Sub SendSingleFiles()
Dim Files As VBA.Collection
Dim File As Scripting.File
Dim Mail As Outlook.MailItem
Dim Atts As Outlook.Attachments
'Send the files of this directory
m_Send = "C:/Sample/"
'Move send files here
m_Done = "C:/Sample/Sent/"
'Recipient
m_To = ""
Set Files = GetFiles
If Files.Count Then
Set Mail = Application.CreateItem(olMailItem)
Set Atts = Mail.Attachments
For Each File In Files
Atts.Add File.Path
File.Move m_Done & File.Name
Next
Mail.To = m_To
Mail.Subject = "xxx"
Mail.Display
End If
End Sub
Private Function GetFiles() As VBA.Collection
Dim Folder As Scripting.Folder
Dim Fso As Scripting.FileSystemObject
Dim Files As Scripting.Files
Dim File As Scripting.File
Dim List As VBA.Collection
Set List = New VBA.Collection
Set Fso = New Scripting.FileSystemObject
Set Folder = Fso.GetFolder(m_Send)
Set Files = Folder.Files
For Each File In Files
'return only those files that are not hidden
If (File.Attributes Or Hidden) <> File.Attributes Then
List.Add File
End If
Next
Set GetFiles = List
End Function
Code to send files separately
Public Sub SendAllFiles()
Dim Files As VBA.Collection
Dim File As Scripting.File
Dim Mail As Outlook.MailItem
Dim Atts As Outlook.Attachments
'Send the files of this directory
m_Send = "C:/Sample/"
'Move send files here
m_Done = "C:/Sample/Sent/"
'Recipient
m_To = ""
Set Files = GetFiles
If Files.Count Then
For Each File In Files
Set Mail = Application.CreateItem(olMailItem)
Mail.Attachments.Add File.Path
File.Move m_Done & File.Name
Mail.To = m_To
Mail.Subject = "Datei: " & File.Name
Mail.Display
Next
End If
End Sub
Private Function GetFiles() As VBA.Collection
Dim Folder As Scripting.Folder
Dim Fso As Scripting.FileSystemObject
Dim Files As Scripting.Files
Dim File As Scripting.File
Dim List As VBA.Collection
Set List = New VBA.Collection
Set Fso = New Scripting.FileSystemObject
Set Folder = Fso.GetFolder(m_Send)
Set Files = Folder.Files
For Each File In Files
'return only those files that are not hidden
If (File.Attributes Or Hidden) <> File.Attributes Then
List.Add File
End If
Next
Set GetFiles = List
End Function