Hi,
I currently use the following Macro to save my emails to the server. When the macro saves the email (for an email I recieve) it gives it a file name of <project number <YYMMDD> <RECIPIENT INITIAL><SUBJECT>
I would like to add to this so that when I recieve an email it saves it as <project number <YYMMDD> <SENDER NAME> <RECIPIENT INITIAL><SUBJECT>
The sender name can just be the first part of the email address i suppose. If anyone has any ideas that would be great!
Here's the email macro in full:
Thanks,
Sub SaveAsMsgNew()
'=====================================
' REVISION 6.11
'=====================================
'Archives all messages in selected mail folder (except inbox)to a chosen folder location.
'Chosen folder saved to registry and recalled
'Categories checked for presence of "Archived" category, created if not.
'Category "Archived" applied to each message once archived.
'Message items already marked as archived are skipped.
'Message saved with ADMMIN req'd filename. "<proj no.> YYMMDD <user initials> -"
'<proj. no.> taken from mail folder name. Ensure mail folder has project number in name.
'<YYMMDD> taken from mail received date.
'<user initials> from logon name.
' requires reference to Microsoft Scripting Runtime
' \Windows\System32\Scrrun.dll
' tools->references
Dim fso As FileSystemObject
Dim strSubject As String
Dim strSaveName, strFoldername As String
Dim strMsg As String
Dim intRes As Integer
Dim i, j, iPos As Integer
Dim strUsr, strCompDate, strFn As String
Dim bRes
Dim strProjNo, pN As String
Dim iNoArch, iNoSkip As Integer
Dim Inbox As MAPIFolder
Dim Item As Object
Dim strDate, iCat
Dim bInOrOut As String
Dim bolCancel As Boolean
bolCancel = False
On Error GoTo saveitems_err
iNoArch = 0
iNoSkip = 0
Set Inbox = Application.ActiveExplorer.CurrentFolder
If Inbox.Name = "Inbox" Then
MsgBox "Archive cannot be performed on the Inbox. Select a subfolder to archive.", vbCritical
bolCancel = True
GoTo saveitems_exit
End If
'**********************************************************
'To keep registry key clean from inactive store locations, check when routine was last run.
'If date was greater than 1 year ago, call cleanStoreLocns routine to clean registry.
If fnChkRegCleanDate(Date) = True Then
CleanStorelocns
End If
'**********************************************************
'Get Project Number from folder name
'Rev: Added tag for financial, confidential, etc in place of project number.
' Confidential - 99995 - "C"
' Financial - 99996 - "F"
' Marketing - 99997 - "M"
' Personnel - 99998 - "P"
' QA - 99999 - "Q"
'if one of these categories, skip save path to registry.
pN = altGetProjNo(Inbox.Name)
If pN = "err" Then GoTo saveitems_err
If Len(pN) > 1 Then
strProjNo = pN
Else
strProjNo = pN
End If
' Select Save Path ------------------------------------------------------------
' store save location to registry. Prompt if user wants to use same destination
bRes = vbNo
strFoldername = GetSetting("EArch", "StoreLocn", Inbox.Name, strFoldername)
If strFoldername <> "" Then
bRes = MsgBox("Click YES to save all items in this folder to: " & strFoldername & vbCr _
& vbCr & "Click NO to select a new save location.", vbYesNo, "Save To...")
End If
If bRes = vbNo Then 'if saveto folder is blank or user chosen to select new location, show folder browser
strFoldername = PickFolder(17)
End If
If strFoldername <> "" Then 'if folder name has been selected store in registry under project number
SaveSetting "EArch", "StoreLocn", Inbox.Name, strFoldername ' save setting to registry
End If
'----------------------------------------------------------------------------
'get user name-------------------------------------------
strUsr = Environ("USERNAME")
If IsNumeric(Right((strUsr), 1)) Then
strUsr = Left(strUsr, Len(strUsr) - 1)
End If
strUsr = UCase(Right(strUsr, Len(strUsr) - 2))
'-----------------------------------------------------------------------------
' Check for validity of chosen folder & ensure path ends with a backslash-----
If Len(strFoldername) > 0 Then
If Right(strFoldername, 1) <> "\" Then
strFoldername = strFoldername & "\"
End If
Else
'No folder chosen, or user cancelled
bolCancel = True
GoTo saveitems_exit
End If
strMsg = "Outlook will now save all items in this folder to " & vbCr & vbCr & strFoldername & vbCr & vbCr & _
" Click OK to continue." & vbCr & _
" Click CANCEL to abort."
intRes = MsgBox(strMsg, vbDefaultButton1 + vbQuestion + vbOKCancel, strProjNo & " yymmdd " & strUsr & " ")
'******************************************************************************************************************
If intRes = vbOK Then 'if user clicks yes, continue with save macro
'Add data to subject line
'Load progress form / listbox
Load frmEArch
frmEArch.Height = 350
frmEArch.lbSummary.Visible = True
fnInitLog 'Initiate Log file
fnAppendLog ("Archiving: " & strProjNo & " yymmdd " & strUsr & " to " & strFoldername & vbCrLf)
frmEArch.lbSummary.AddItem "Archiving: " & strProjNo & " yymmdd " & strUsr & "...."
frmEArch.lbSummary.AddItem " to " & strFoldername
frmEArch.lbSummary.AddItem " "
'=======Check for, and Add, Category======
CreateCat ("Archived")
'initialise counter for progress form
j = 1
frmEArch.Show vbModeless
'For each mail item in the current folder---------------
For Each Item In Inbox.Items
If Not Item Is Nothing Then
'check whether item has been marked as archived
If chkForArch(Item, "Archived") = False Then ' if not archived, perform archive
'check for valid folder name------------------------
'Clean the file name of invalid characters
strSubject = CleanFileName(Item.Subject)
strDate = Format(Item.ReceivedTime, "YYMMDD")
'********************
'Check if subject title already has project number in
'Check for FW and RE at beginning of subject
'MsgBox strProjNo
'++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
strSubject = Replace(strSubject, "-", " ", 1, 1, vbTextCompare) 'removes hyphen between "CIV" and proj. no.
iPos = InStr(1, strSubject, strProjNo, vbTextCompare)
If Len(strProjNo) > 1 And iPos > 0 Then
'project number already in subject heading
strSubject = Right(strSubject, Len(strSubject) - iPos + 1)
If strSubject <> strProjNo Then
strCompDate = Left(Right(strSubject, Len(strSubject) - Len(strProjNo) - 1), 6)
If strCompDate <> strDate Then
'dates do not match, replace date
strSubject = strProjNo & " " & strDate & " " & Right(strSubject, Len(strSubject) - Len(strProjNo) - Len(strDate) - 2)
End If
Else
strSubject = strProjNo & " " & strDate & " " & strUsr & " "
End If
strFn = strSubject
strSaveName = strSubject & ".msg"
Else
'*********************
'name file with projectnumber-date-person-subject
strFn = strProjNo & " " & strDate & " " & strUsr & " " & strSubject
strSaveName = strFn & ".msg"
End If '*end if iPos
'++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Set fso = CreateObject("Scripting.FileSystemObject")
i = 1
chk:
If fso.FileExists(strFoldername & strSaveName) Then
'Check if file exists, if so add an integer identifier to the filename
strSaveName = strFn & "-" & i & ".msg"
i = i + 1
GoTo chk ' go back to check if new filename exists and increment identifier
End If
'save file as .msg file to path
Item.SaveAs strFoldername & strSaveName, olMSG
iNoArch = iNoArch + 1
'Add Archive Category to email
iCat = AddCat(Item, "Archived")
fnAppendLog (strSaveName) 'add filename to log file
'update listbox
frmEArch.lbSummary.AddItem "Arch:" & strSaveName
frmEArch.lbSummary.Selected(frmEArch.lbSummary.ListCount - 1) = True
frmEArch.Repaint
Else 'skip item if already archived
iNoSkip = iNoSkip + 1
'update listbox
frmEArch.lbSummary.AddItem "Skip:" & Item.Subject & vbTab
frmEArch.Repaint
frmEArch.lbSummary.Selected(frmEArch.lbSummary.ListCount - 1) = True
End If 'end of check for archived
End If 'end of IF block for item is nothing
j = j + 1 'increment counter
Set fso = Nothing
Next Item
fnAppendLog (vbCrLf & "--------------------" & vbCrLf & _
j - 1 - iNoSkip & " items archived." & vbCrLf & _
iNoSkip & " items skipped." & vbCrLf & _
"--------------------" & vbCrLf & _
j - 1 & " total items.")
'update listbox
frmEArch.lbSummary.AddItem " "
frmEArch.lbSummary.AddItem "--------------------"
frmEArch.lbSummary.AddItem j - 1 - iNoSkip & " items archived."
frmEArch.lbSummary.AddItem iNoSkip & " items skipped."
frmEArch.lbSummary.AddItem "--------------------"
frmEArch.lbSummary.AddItem j - 1 & " total items."
frmEArch.lbSummary.Selected(frmEArch.lbSummary.ListCount - 1) = True
Else 'if user clicks cancel, jump to here!
bolCancel = True
End If
'******************************************************************************************************************
saveitems_exit:
Set Item = Nothing
Set ns = Nothing
'message box with summary of archive operation
'MsgBox "File archive complete." & vbCrLf & vbCrLf & "Total number of messages archived = " & iNoArch & vbCrLf _
& "Total number of messages skipped = " & iNoSkip & vbCrLf & vbCrLf & iNoArch & " messages were archived to " & strFoldername, vbOKOnly, "Email Archive"
If bolCancel = False Then
frmEArch.cmdClose.Enabled = True
frmEArch.hide
strSaveName = ""
frmEArch.Show vbModal
Unload frmEArch 'unload form
End If
Exit Sub
saveitems_err:
frmEArch.lbSummary.AddItem "ERROR: " & err.Number & ":" & err.Description
If strSaveName = "" Then
MsgBox "Folder name MUST contain the project number for the emails being archived.", vbCritical, "Error!"
Else
'Log error message
fnAppendLog ("Error Description: " & err.Description & vbCrLf & _
"Date: " & Date & " " & Time & vbCrLf & _
"Filename: " & strSaveName)
MsgBox "An unexpected error has occurred." _
& vbCrLf & "Please note and report the following information." _
& vbCrLf & "Macro Name: Save Folder Contents" _
& vbCrLf & "Error Number: " & err.Number _
& vbCrLf & "Error Description: " & err.Description _
& vbCrLf & "Filename: " & strSaveName _
, vbCritical, "Error!"
End If
Resume saveitems_exit
End Sub
Function CleanFileName(strText As String) As String
Dim strStripChars As String
Dim intLen As Integer
Dim i As Integer
strStripChars = "/\[]:=," & Chr(34) & Chr(63)
intLen = Len(strStripChars)
strText = Trim(strText)
For i = 1 To intLen
strText = Replace(strText, Mid(strStripChars, i, 1), "")
Next
If Len(strText) > 196 Then 'LIMIT LENGTH OF SUBJECT LINE TO 196 Characters.
strText = Left(strText, 196)
End If
CleanFileName = strText
End Function
Function AddCat(itm, catname)
Dim arr
Dim i As Integer
arr = Split(itm.Categories, ",")
If UBound(arr) >= 0 Then
' item has categories
For i = 0 To UBound(arr)
If Trim(arr(i)) = catname Then
' category already exists on item
' no need to add it
Exit Function
End If
Next
itm.Categories = itm.Categories & "," & catname
Else
' item has no categories
itm.Categories = catname
itm.Save
End If
End Function
Function chkForArch(itm, catname) As Boolean
Dim arr
Dim i As Integer
chkForArch = False
arr = Split(itm.Categories, ",")
If UBound(arr) >= 0 Then
' item has categories
For i = 0 To UBound(arr)
If Trim(arr(i)) = catname Then
' category already exists on item
chkForArch = True
End If
Next
End If
End Function
Sub CreateCat(catname As String)
Dim namespace As namespace
Set namespace = Application.GetNamespace("MAPI")
Dim found As Boolean
found = False
Dim category As category
Dim strTemp
strTemp = GetSetting("EArch", "Category", "Archived")
If strTemp = "Added" Then
found = True
Else
For Each category In namespace.Categories
If LCase(category.Name) = LCase(catname) Then
SaveSetting "Earch", "Category", "Archived", "Added"
found = True
category.Color = olCategoryColorDarkTeal
Exit For
End If
Next
End If
If Not found Then
namespace.Categories.Add catname, olCategoryColorDarkGreen
SaveSetting "Earch", "Category", "Archived", "Added"
End If
Set category = Nothing
Set namespace = Nothing
End Sub
Function altGetProjNo(Phrase As String)
Dim Length_of_String As Integer
Dim Current_Pos As Integer
Dim temp As String
Dim iStart, iStop As Integer
iStart = InStr(1, Phrase, "<", 0)
iStop = InStr(1, Phrase, ">", 0) - iStart
If iStart = 0 Or iStop = 0 Then
altGetProjNo = "err"
Exit Function
Else
altGetProjNo = Left((Right(Phrase, Len(Phrase) - iStart)), iStop - 1)
End If
Select Case altGetProjNo
Case Is = 99995
altGetProjNo = "C" 'Confidential
Case Is = 99996
altGetProjNo = "F" 'Financial
Case Is = 99997
altGetProjNo = "M" 'Marketing
Case Is = 99998
altGetProjNo = "P" 'Personnel
Case Is = 99999
altGetProjNo = "Q" 'QA
End Select
End Function
Function officeId(officeInitials As String)
Select Case LCase(officeInitials)
Case Is = "cf"
officeId = "CF"
Case Is = "bl"
officeId = "07"
'--------use following as template to add more office id's if required.----------
'case is = "xx"
'officeid = "xx"
'-------------------
Case Else
officeId = officeInitials
End Select
End Function
Function PickFolder(strStartDir As Variant) As String
Dim SA As Object, F As Object
Set SA = CreateObject("Shell.Application")
Set F = SA.BrowseForFolder(0, "Choose a folder", 0, strStartDir)
If (Not F Is Nothing) Then
PickFolder = F.Items.Item.Path
End If
Set F = Nothing
Set SA = Nothing
End Function
'*************************Log file functions*******************************************
Function fnInitLog()
'initiates log file.
'save log file for each month
Dim strLogFolder, sDate As String
strLogFolder = "C:\temp\earch"
fnChkDir (strLogFolder)
strLogFolder = strLogFolder & "\" & "earch" & DatePart("m", Date) & ".log"
On Error Resume Next
Open strLogFolder For Input As #1
Input #1, sDate
Close #1
If DatePart("yyyy", Date) > DatePart("yyyy", sDate) Then 'if log file was created last month, overwrite log
Open strLogFolder For Output As #1
Print #1, Date
Print #1, "*************" & Time & "*************"
Close #1
Else 'else append existing log file
Open strLogFolder For Append As #1
Print #1, "*************" & DatePart("d", Date) & "/" & DatePart("m", Date) & " - " & Time & "*************"
Close #1
End If
End Function
Function fnChkDir(strDirectory As String)
'Checks for presence of folder to store log file
'if not then create folder
Dim objFSO, objFolder
Set objFSO = CreateObject("Scripting.FileSystemObject")
If objFSO.FolderExists("C:\temp\") = False Then
Set objFolder = objFSO.CreateFolder("C:\temp\")
End If
If objFSO.FolderExists(strDirectory) = False Then
Set objFolder = objFSO.CreateFolder(strDirectory)
End If
Set objFSO = Nothing
End Function
Function fnAppendLog(sMsg As String)
'Append log file with text passed using sMsg variable
Dim strLogFolder As String
strLogFolder = "C:\temp\earch\earch" & DatePart("m", Date) & ".log"
On Error Resume Next
Open strLogFolder For Append As #1
Print #1, sMsg
Close #1
End Function
'*************************[END]Log file functions[END]*******************************************
'**************************Clean registry entries sub********************************************
Function fnChkRegCleanDate(sDate As Date) As Boolean
'Check earch.dat file for date when reg clean was last run
'if time is greater than 1 year then reset date and pass "true" back to calling function
Dim sDate2 As String
Dim strLogFolder As String
chk:
fnChkRegCleanDate = False
strLogFolder = "C:\temp\earch\earch.dat"
On Error GoTo createdatfile
Open strLogFolder For Input As #1
Input #1, sDate2
Close #1
If DatePart("yyyy", sDate) > DatePart("yyyy", sDate2) Then
Open strLogFolder For Output As #1
Print #1, Date
Close #1
fnChkRegCleanDate = True
End If
Exit Function
createdatfile: 'file does not exist, or is corrupt. Re-write earch.dat file
'Debug.Print err.Number & ":" & err.Description
If err.Number = 76 Then 'Folder does not exist, create folder & file
fnChkDir ("C:\temp\earch\")
Open strLogFolder For Output As #1
Print #1, Date
Close #1
err.Clear
End If
If err.Number = 53 Or err.Number = 13 Then
Open strLogFolder For Output As #1 'file does not exist, create
Print #1, Date
Close #1
End If
GoTo chk
End Function
Sub CleanStorelocns()
'enumerates through inbox subfolders to check for presence of a store location registry entry
'deletes entire key where store locations are held in registry
'resets all valid store location registry entries
Dim Inbox As MAPIFolder
Dim Item, subItem As Object
Dim storeLoc(256) As Variant
Dim sFldName(256) As Variant
Dim strFoldername
Set Inbox = Application.ActiveExplorer.CurrentFolder
chk_inbox:
If Inbox.Name <> "Inbox" Then
On Error GoTo err:
Set Inbox = Inbox.Parent
GoTo chk_inbox
End If
i = 1
For Each Item In Inbox.Folders 'for every sub folder in inbox
For Each subItem In Item.Folders 'for every subfolder in subfolder
strFoldername = GetSetting("EArch", "StoreLocn", subItem) 'get storelocation name if exists
If strFoldername <> "" Then
storeLoc(i) = strFoldername 'store in array for later use
sFldName(i) = subItem
i = i + 1
End If
Next
strFoldername = GetSetting("EArch", "StoreLocn", Item) 'get storelocation name if exists
If strFoldername <> "" Then
storeLoc(i) = strFoldername 'store in array for later use
sFldName(i) = Item
i = i + 1
End If
Next
DeleteSetting "EArch", "StoreLocn" 'delete registry key
For j = 1 To i - 1
SaveSetting "EArch", "StoreLocn", sFldName(j), storeLoc(j) 'for every location in array, re-create registry key
Next j
Exit Sub
err:
MsgBox "Ensure inbox is selected", vbOKOnly, "error"
End Sub
'**************************[END]Clean registry entries sub[END]********************************************
Sub lstSummary()
End Sub
I currently use the following Macro to save my emails to the server. When the macro saves the email (for an email I recieve) it gives it a file name of <project number <YYMMDD> <RECIPIENT INITIAL><SUBJECT>
I would like to add to this so that when I recieve an email it saves it as <project number <YYMMDD> <SENDER NAME> <RECIPIENT INITIAL><SUBJECT>
The sender name can just be the first part of the email address i suppose. If anyone has any ideas that would be great!
Here's the email macro in full:
Thanks,
Sub SaveAsMsgNew()
'=====================================
' REVISION 6.11
'=====================================
'Archives all messages in selected mail folder (except inbox)to a chosen folder location.
'Chosen folder saved to registry and recalled
'Categories checked for presence of "Archived" category, created if not.
'Category "Archived" applied to each message once archived.
'Message items already marked as archived are skipped.
'Message saved with ADMMIN req'd filename. "<proj no.> YYMMDD <user initials> -"
'<proj. no.> taken from mail folder name. Ensure mail folder has project number in name.
'<YYMMDD> taken from mail received date.
'<user initials> from logon name.
' requires reference to Microsoft Scripting Runtime
' \Windows\System32\Scrrun.dll
' tools->references
Dim fso As FileSystemObject
Dim strSubject As String
Dim strSaveName, strFoldername As String
Dim strMsg As String
Dim intRes As Integer
Dim i, j, iPos As Integer
Dim strUsr, strCompDate, strFn As String
Dim bRes
Dim strProjNo, pN As String
Dim iNoArch, iNoSkip As Integer
Dim Inbox As MAPIFolder
Dim Item As Object
Dim strDate, iCat
Dim bInOrOut As String
Dim bolCancel As Boolean
bolCancel = False
On Error GoTo saveitems_err
iNoArch = 0
iNoSkip = 0
Set Inbox = Application.ActiveExplorer.CurrentFolder
If Inbox.Name = "Inbox" Then
MsgBox "Archive cannot be performed on the Inbox. Select a subfolder to archive.", vbCritical
bolCancel = True
GoTo saveitems_exit
End If
'**********************************************************
'To keep registry key clean from inactive store locations, check when routine was last run.
'If date was greater than 1 year ago, call cleanStoreLocns routine to clean registry.
If fnChkRegCleanDate(Date) = True Then
CleanStorelocns
End If
'**********************************************************
'Get Project Number from folder name
'Rev: Added tag for financial, confidential, etc in place of project number.
' Confidential - 99995 - "C"
' Financial - 99996 - "F"
' Marketing - 99997 - "M"
' Personnel - 99998 - "P"
' QA - 99999 - "Q"
'if one of these categories, skip save path to registry.
pN = altGetProjNo(Inbox.Name)
If pN = "err" Then GoTo saveitems_err
If Len(pN) > 1 Then
strProjNo = pN
Else
strProjNo = pN
End If
' Select Save Path ------------------------------------------------------------
' store save location to registry. Prompt if user wants to use same destination
bRes = vbNo
strFoldername = GetSetting("EArch", "StoreLocn", Inbox.Name, strFoldername)
If strFoldername <> "" Then
bRes = MsgBox("Click YES to save all items in this folder to: " & strFoldername & vbCr _
& vbCr & "Click NO to select a new save location.", vbYesNo, "Save To...")
End If
If bRes = vbNo Then 'if saveto folder is blank or user chosen to select new location, show folder browser
strFoldername = PickFolder(17)
End If
If strFoldername <> "" Then 'if folder name has been selected store in registry under project number
SaveSetting "EArch", "StoreLocn", Inbox.Name, strFoldername ' save setting to registry
End If
'----------------------------------------------------------------------------
'get user name-------------------------------------------
strUsr = Environ("USERNAME")
If IsNumeric(Right((strUsr), 1)) Then
strUsr = Left(strUsr, Len(strUsr) - 1)
End If
strUsr = UCase(Right(strUsr, Len(strUsr) - 2))
'-----------------------------------------------------------------------------
' Check for validity of chosen folder & ensure path ends with a backslash-----
If Len(strFoldername) > 0 Then
If Right(strFoldername, 1) <> "\" Then
strFoldername = strFoldername & "\"
End If
Else
'No folder chosen, or user cancelled
bolCancel = True
GoTo saveitems_exit
End If
strMsg = "Outlook will now save all items in this folder to " & vbCr & vbCr & strFoldername & vbCr & vbCr & _
" Click OK to continue." & vbCr & _
" Click CANCEL to abort."
intRes = MsgBox(strMsg, vbDefaultButton1 + vbQuestion + vbOKCancel, strProjNo & " yymmdd " & strUsr & " ")
'******************************************************************************************************************
If intRes = vbOK Then 'if user clicks yes, continue with save macro
'Add data to subject line
'Load progress form / listbox
Load frmEArch
frmEArch.Height = 350
frmEArch.lbSummary.Visible = True
fnInitLog 'Initiate Log file
fnAppendLog ("Archiving: " & strProjNo & " yymmdd " & strUsr & " to " & strFoldername & vbCrLf)
frmEArch.lbSummary.AddItem "Archiving: " & strProjNo & " yymmdd " & strUsr & "...."
frmEArch.lbSummary.AddItem " to " & strFoldername
frmEArch.lbSummary.AddItem " "
'=======Check for, and Add, Category======
CreateCat ("Archived")
'initialise counter for progress form
j = 1
frmEArch.Show vbModeless
'For each mail item in the current folder---------------
For Each Item In Inbox.Items
If Not Item Is Nothing Then
'check whether item has been marked as archived
If chkForArch(Item, "Archived") = False Then ' if not archived, perform archive
'check for valid folder name------------------------
'Clean the file name of invalid characters
strSubject = CleanFileName(Item.Subject)
strDate = Format(Item.ReceivedTime, "YYMMDD")
'********************
'Check if subject title already has project number in
'Check for FW and RE at beginning of subject
'MsgBox strProjNo
'++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
strSubject = Replace(strSubject, "-", " ", 1, 1, vbTextCompare) 'removes hyphen between "CIV" and proj. no.
iPos = InStr(1, strSubject, strProjNo, vbTextCompare)
If Len(strProjNo) > 1 And iPos > 0 Then
'project number already in subject heading
strSubject = Right(strSubject, Len(strSubject) - iPos + 1)
If strSubject <> strProjNo Then
strCompDate = Left(Right(strSubject, Len(strSubject) - Len(strProjNo) - 1), 6)
If strCompDate <> strDate Then
'dates do not match, replace date
strSubject = strProjNo & " " & strDate & " " & Right(strSubject, Len(strSubject) - Len(strProjNo) - Len(strDate) - 2)
End If
Else
strSubject = strProjNo & " " & strDate & " " & strUsr & " "
End If
strFn = strSubject
strSaveName = strSubject & ".msg"
Else
'*********************
'name file with projectnumber-date-person-subject
strFn = strProjNo & " " & strDate & " " & strUsr & " " & strSubject
strSaveName = strFn & ".msg"
End If '*end if iPos
'++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Set fso = CreateObject("Scripting.FileSystemObject")
i = 1
chk:
If fso.FileExists(strFoldername & strSaveName) Then
'Check if file exists, if so add an integer identifier to the filename
strSaveName = strFn & "-" & i & ".msg"
i = i + 1
GoTo chk ' go back to check if new filename exists and increment identifier
End If
'save file as .msg file to path
Item.SaveAs strFoldername & strSaveName, olMSG
iNoArch = iNoArch + 1
'Add Archive Category to email
iCat = AddCat(Item, "Archived")
fnAppendLog (strSaveName) 'add filename to log file
'update listbox
frmEArch.lbSummary.AddItem "Arch:" & strSaveName
frmEArch.lbSummary.Selected(frmEArch.lbSummary.ListCount - 1) = True
frmEArch.Repaint
Else 'skip item if already archived
iNoSkip = iNoSkip + 1
'update listbox
frmEArch.lbSummary.AddItem "Skip:" & Item.Subject & vbTab
frmEArch.Repaint
frmEArch.lbSummary.Selected(frmEArch.lbSummary.ListCount - 1) = True
End If 'end of check for archived
End If 'end of IF block for item is nothing
j = j + 1 'increment counter
Set fso = Nothing
Next Item
fnAppendLog (vbCrLf & "--------------------" & vbCrLf & _
j - 1 - iNoSkip & " items archived." & vbCrLf & _
iNoSkip & " items skipped." & vbCrLf & _
"--------------------" & vbCrLf & _
j - 1 & " total items.")
'update listbox
frmEArch.lbSummary.AddItem " "
frmEArch.lbSummary.AddItem "--------------------"
frmEArch.lbSummary.AddItem j - 1 - iNoSkip & " items archived."
frmEArch.lbSummary.AddItem iNoSkip & " items skipped."
frmEArch.lbSummary.AddItem "--------------------"
frmEArch.lbSummary.AddItem j - 1 & " total items."
frmEArch.lbSummary.Selected(frmEArch.lbSummary.ListCount - 1) = True
Else 'if user clicks cancel, jump to here!
bolCancel = True
End If
'******************************************************************************************************************
saveitems_exit:
Set Item = Nothing
Set ns = Nothing
'message box with summary of archive operation
'MsgBox "File archive complete." & vbCrLf & vbCrLf & "Total number of messages archived = " & iNoArch & vbCrLf _
& "Total number of messages skipped = " & iNoSkip & vbCrLf & vbCrLf & iNoArch & " messages were archived to " & strFoldername, vbOKOnly, "Email Archive"
If bolCancel = False Then
frmEArch.cmdClose.Enabled = True
frmEArch.hide
strSaveName = ""
frmEArch.Show vbModal
Unload frmEArch 'unload form
End If
Exit Sub
saveitems_err:
frmEArch.lbSummary.AddItem "ERROR: " & err.Number & ":" & err.Description
If strSaveName = "" Then
MsgBox "Folder name MUST contain the project number for the emails being archived.", vbCritical, "Error!"
Else
'Log error message
fnAppendLog ("Error Description: " & err.Description & vbCrLf & _
"Date: " & Date & " " & Time & vbCrLf & _
"Filename: " & strSaveName)
MsgBox "An unexpected error has occurred." _
& vbCrLf & "Please note and report the following information." _
& vbCrLf & "Macro Name: Save Folder Contents" _
& vbCrLf & "Error Number: " & err.Number _
& vbCrLf & "Error Description: " & err.Description _
& vbCrLf & "Filename: " & strSaveName _
, vbCritical, "Error!"
End If
Resume saveitems_exit
End Sub
Function CleanFileName(strText As String) As String
Dim strStripChars As String
Dim intLen As Integer
Dim i As Integer
strStripChars = "/\[]:=," & Chr(34) & Chr(63)
intLen = Len(strStripChars)
strText = Trim(strText)
For i = 1 To intLen
strText = Replace(strText, Mid(strStripChars, i, 1), "")
Next
If Len(strText) > 196 Then 'LIMIT LENGTH OF SUBJECT LINE TO 196 Characters.
strText = Left(strText, 196)
End If
CleanFileName = strText
End Function
Function AddCat(itm, catname)
Dim arr
Dim i As Integer
arr = Split(itm.Categories, ",")
If UBound(arr) >= 0 Then
' item has categories
For i = 0 To UBound(arr)
If Trim(arr(i)) = catname Then
' category already exists on item
' no need to add it
Exit Function
End If
Next
itm.Categories = itm.Categories & "," & catname
Else
' item has no categories
itm.Categories = catname
itm.Save
End If
End Function
Function chkForArch(itm, catname) As Boolean
Dim arr
Dim i As Integer
chkForArch = False
arr = Split(itm.Categories, ",")
If UBound(arr) >= 0 Then
' item has categories
For i = 0 To UBound(arr)
If Trim(arr(i)) = catname Then
' category already exists on item
chkForArch = True
End If
Next
End If
End Function
Sub CreateCat(catname As String)
Dim namespace As namespace
Set namespace = Application.GetNamespace("MAPI")
Dim found As Boolean
found = False
Dim category As category
Dim strTemp
strTemp = GetSetting("EArch", "Category", "Archived")
If strTemp = "Added" Then
found = True
Else
For Each category In namespace.Categories
If LCase(category.Name) = LCase(catname) Then
SaveSetting "Earch", "Category", "Archived", "Added"
found = True
category.Color = olCategoryColorDarkTeal
Exit For
End If
Next
End If
If Not found Then
namespace.Categories.Add catname, olCategoryColorDarkGreen
SaveSetting "Earch", "Category", "Archived", "Added"
End If
Set category = Nothing
Set namespace = Nothing
End Sub
Function altGetProjNo(Phrase As String)
Dim Length_of_String As Integer
Dim Current_Pos As Integer
Dim temp As String
Dim iStart, iStop As Integer
iStart = InStr(1, Phrase, "<", 0)
iStop = InStr(1, Phrase, ">", 0) - iStart
If iStart = 0 Or iStop = 0 Then
altGetProjNo = "err"
Exit Function
Else
altGetProjNo = Left((Right(Phrase, Len(Phrase) - iStart)), iStop - 1)
End If
Select Case altGetProjNo
Case Is = 99995
altGetProjNo = "C" 'Confidential
Case Is = 99996
altGetProjNo = "F" 'Financial
Case Is = 99997
altGetProjNo = "M" 'Marketing
Case Is = 99998
altGetProjNo = "P" 'Personnel
Case Is = 99999
altGetProjNo = "Q" 'QA
End Select
End Function
Function officeId(officeInitials As String)
Select Case LCase(officeInitials)
Case Is = "cf"
officeId = "CF"
Case Is = "bl"
officeId = "07"
'--------use following as template to add more office id's if required.----------
'case is = "xx"
'officeid = "xx"
'-------------------
Case Else
officeId = officeInitials
End Select
End Function
Function PickFolder(strStartDir As Variant) As String
Dim SA As Object, F As Object
Set SA = CreateObject("Shell.Application")
Set F = SA.BrowseForFolder(0, "Choose a folder", 0, strStartDir)
If (Not F Is Nothing) Then
PickFolder = F.Items.Item.Path
End If
Set F = Nothing
Set SA = Nothing
End Function
'*************************Log file functions*******************************************
Function fnInitLog()
'initiates log file.
'save log file for each month
Dim strLogFolder, sDate As String
strLogFolder = "C:\temp\earch"
fnChkDir (strLogFolder)
strLogFolder = strLogFolder & "\" & "earch" & DatePart("m", Date) & ".log"
On Error Resume Next
Open strLogFolder For Input As #1
Input #1, sDate
Close #1
If DatePart("yyyy", Date) > DatePart("yyyy", sDate) Then 'if log file was created last month, overwrite log
Open strLogFolder For Output As #1
Print #1, Date
Print #1, "*************" & Time & "*************"
Close #1
Else 'else append existing log file
Open strLogFolder For Append As #1
Print #1, "*************" & DatePart("d", Date) & "/" & DatePart("m", Date) & " - " & Time & "*************"
Close #1
End If
End Function
Function fnChkDir(strDirectory As String)
'Checks for presence of folder to store log file
'if not then create folder
Dim objFSO, objFolder
Set objFSO = CreateObject("Scripting.FileSystemObject")
If objFSO.FolderExists("C:\temp\") = False Then
Set objFolder = objFSO.CreateFolder("C:\temp\")
End If
If objFSO.FolderExists(strDirectory) = False Then
Set objFolder = objFSO.CreateFolder(strDirectory)
End If
Set objFSO = Nothing
End Function
Function fnAppendLog(sMsg As String)
'Append log file with text passed using sMsg variable
Dim strLogFolder As String
strLogFolder = "C:\temp\earch\earch" & DatePart("m", Date) & ".log"
On Error Resume Next
Open strLogFolder For Append As #1
Print #1, sMsg
Close #1
End Function
'*************************[END]Log file functions[END]*******************************************
'**************************Clean registry entries sub********************************************
Function fnChkRegCleanDate(sDate As Date) As Boolean
'Check earch.dat file for date when reg clean was last run
'if time is greater than 1 year then reset date and pass "true" back to calling function
Dim sDate2 As String
Dim strLogFolder As String
chk:
fnChkRegCleanDate = False
strLogFolder = "C:\temp\earch\earch.dat"
On Error GoTo createdatfile
Open strLogFolder For Input As #1
Input #1, sDate2
Close #1
If DatePart("yyyy", sDate) > DatePart("yyyy", sDate2) Then
Open strLogFolder For Output As #1
Print #1, Date
Close #1
fnChkRegCleanDate = True
End If
Exit Function
createdatfile: 'file does not exist, or is corrupt. Re-write earch.dat file
'Debug.Print err.Number & ":" & err.Description
If err.Number = 76 Then 'Folder does not exist, create folder & file
fnChkDir ("C:\temp\earch\")
Open strLogFolder For Output As #1
Print #1, Date
Close #1
err.Clear
End If
If err.Number = 53 Or err.Number = 13 Then
Open strLogFolder For Output As #1 'file does not exist, create
Print #1, Date
Close #1
End If
GoTo chk
End Function
Sub CleanStorelocns()
'enumerates through inbox subfolders to check for presence of a store location registry entry
'deletes entire key where store locations are held in registry
'resets all valid store location registry entries
Dim Inbox As MAPIFolder
Dim Item, subItem As Object
Dim storeLoc(256) As Variant
Dim sFldName(256) As Variant
Dim strFoldername
Set Inbox = Application.ActiveExplorer.CurrentFolder
chk_inbox:
If Inbox.Name <> "Inbox" Then
On Error GoTo err:
Set Inbox = Inbox.Parent
GoTo chk_inbox
End If
i = 1
For Each Item In Inbox.Folders 'for every sub folder in inbox
For Each subItem In Item.Folders 'for every subfolder in subfolder
strFoldername = GetSetting("EArch", "StoreLocn", subItem) 'get storelocation name if exists
If strFoldername <> "" Then
storeLoc(i) = strFoldername 'store in array for later use
sFldName(i) = subItem
i = i + 1
End If
Next
strFoldername = GetSetting("EArch", "StoreLocn", Item) 'get storelocation name if exists
If strFoldername <> "" Then
storeLoc(i) = strFoldername 'store in array for later use
sFldName(i) = Item
i = i + 1
End If
Next
DeleteSetting "EArch", "StoreLocn" 'delete registry key
For j = 1 To i - 1
SaveSetting "EArch", "StoreLocn", sFldName(j), storeLoc(j) 'for every location in array, re-create registry key
Next j
Exit Sub
err:
MsgBox "Ensure inbox is selected", vbOKOnly, "error"
End Sub
'**************************[END]Clean registry entries sub[END]********************************************
Sub lstSummary()
End Sub
