1. Click Tools
2. Click Options
3. In this view, click the tab Other
4. Click Advanced Options
5. Click Browse (right of from Startup in this folder)
6. Choose which folder you want view and click OK
7. Click OK
6. Choose which folder you want view and click OK
7. Click OK
5. Uncheck 'Mark item as read when selection changes' (see picture below)
4. Here in this step is the window for you to point where you want this file to be created or where you have your existing one. Just decide where and click OK (see picture below)
6. The new file will be presented in the left tree view. Just copy/create items there as you like.
3. On this next window (see picture below), choose option "View or change existing e-mail accounts" and then click Next
7. Click Add button and type in the name of the mailbox. Then Click OK
8. Click Next
9. Click Finish
Sub StripAttachments(Item As Outlook.MailItem)
On Error GoTo EarlyBath
Const BASE_PATH = "H:\\MailAttachments\\"
If Item.Class = olMail Then
If Item.Attachments.Count > 0 Then
Dim objAtt As Outlook.Attachments
Set objAtt = Item.Attachments
For Each objattach In objAtt
Dim i, lngCounter As Long
Dim strLogger, strFile, strLocalFileLink, strLocalPath, strUser, strFolder As String
lngCounter = Item.Attachments.Count
'Debug.Print lngcounter
strLogger = "-------------------------------------------------------------------------------------------------"
'organise folders by sender
strFolder = BASE_PATH & Item.SenderName & "\\"
If Dir(strFolder, vbDirectory) = "" Then
MkDir (strFolder)
End If
'organise subfolder by received date
strFolder = strFolder & Strings.Format(Item.ReceivedTime, "ddmmyyyy") & "\\"
If Dir(strFolder, vbDirectory) = "" Then
MkDir (strFolder)
End If
'create and display link to dest folder
strLocalPath = "file://" & Replace(strFolder, " ", "%20")
strLocalPath = Replace(strLocalPath, "\\", "\")
strLogger = strLogger & vbCrLf & "Attachment Path: " & strLocalPath & vbCrLf
strLogger = strLogger & vbCrLf & "The following attachments have been stripped from this message:"
'move through the attachments, saving the file, deleting from msg body and inserting links
For i = lngCounter To 1 Step -1
strFile = objAtt.Item(i).FileName
If Len(strFile) > 0 Then
Dim trimLen: trimLen = Len(strFile) - InStrRev(strFile, ".")
Dim time As String
time = Format(Now(), "hhmm")
strFile = strFolder & "\\" & time & "_" & strFile
objAtt.Item(i).SaveAsFile strFile
objAtt.Item(i).Delete
strLocalFileLink = Replace(strFile, "\\", "\")
strLocalFileLink = "file://" & Replace(strLocalFileLink, " ", "%20")
strLogger = strLogger & vbCrLf & vbCrLf & "Attachment " & lngCounter & ": " & strLocalFileLink
Else
End If
'strLogger = ""
SkipAtt:
Next i
strLogger = strLogger & vbCrLf & "-------------------------------------------------------------------------------------------------" & vbCrLf
Item.Body = strLogger & Item.Body
Item.Save
Next
Set objAtt = Nothing
End If
End If
EarlyBath:
Exit Sub
End Sub
Public WithEvents olkFolder As Outlook.Items
Private Sub Application_MAPILogonComplete()
'Change the folder path on the following line to that of the fodler you want to monitor
Set olkFolder = OpenOutlookFolder("Mailbox - name\Inbox").Items
End Sub
Private Sub olkFolder_ItemChange(ByVal Item As Object)
'If the item is marked as read
If Item.UnRead = False Then
If TypeName(Application.ActiveInspector) <> "Nothing" Then
If Item.Subject = Application.ActiveInspector.CurrentItem.Subject Then
'If no category is set already
If Item.Categories = "" Then
'Set the category and save the change
Item.Categories = Replace(Session.CurrentUser, ",", "")
Item.Save
End If
End If
End If
End If
End Sub
Function IsNothing(obj)
If TypeName(obj) = "Nothing" Then
IsNothing = True
Else
IsNothing = False
End If
End Function
Function OpenOutlookFolder(strFolderPath As String) As Outlook.MAPIFolder
Dim arrFolders As Variant, _
varFolder As Variant, _
olkFolder As Outlook.MAPIFolder
On Error GoTo ehOpenOutlookFolder
If strFolderPath = "" Then
Set OpenOutlookFolder = Nothing
Else
If Left(strFolderPath, 1) = "\" Then
strFolderPath = Right(strFolderPath, Len(strFolderPath) - 1)
End If
arrFolders = Split(strFolderPath, "\")
For Each varFolder In arrFolders
If IsNothing(olkFolder) Then
Set olkFolder = Session.Folders(varFolder)
Else
Set olkFolder = olkFolder.Folders(varFolder)
End If
Next
Set OpenOutlookFolder = olkFolder
End If
On Error GoTo 0
Exit Function
ehOpenOutlookFolder:
Set OpenOutlookFolder = Nothing
On Error GoTo 0
End Function