252 lines
No EOL
8.8 KiB
Text
252 lines
No EOL
8.8 KiB
Text
Option Explicit
|
|
|
|
' Toggle category logic:
|
|
' False = email must match ANY of the entered categories (OR)
|
|
' True = email must match ALL of the entered categories (AND)
|
|
Const USE_AND_LOGIC As Boolean = False
|
|
|
|
' ------------------- CLEAN CSV FUNCTION -------------------
|
|
Function CleanCSV(s As Variant) As String
|
|
If IsError(s) Or IsNull(s) Or Trim(s) = "" Then
|
|
CleanCSV = ""
|
|
Else
|
|
Dim tmp As String
|
|
tmp = Trim(CStr(s))
|
|
tmp = Replace(tmp, """", """""") ' escape internal quotes for proper CSV
|
|
tmp = Replace(tmp, vbCrLf, " ") ' remove new lines
|
|
tmp = Replace(tmp, vbLf, " ")
|
|
tmp = Replace(tmp, vbCr, " ")
|
|
CleanCSV = tmp
|
|
End If
|
|
End Function
|
|
|
|
' ------------------- UNIQUE FILE PATH HELPER -------------------
|
|
Function GetUniqueFilePath(basePath As String) As String
|
|
Dim counter As Long
|
|
Dim newPath As String
|
|
Dim dotPos As Long
|
|
|
|
' If no conflict, use basePath as-is
|
|
If Dir(basePath) = "" Then
|
|
GetUniqueFilePath = basePath
|
|
Exit Function
|
|
End If
|
|
|
|
dotPos = InStrRev(basePath, ".")
|
|
If dotPos = 0 Then
|
|
dotPos = Len(basePath) + 1
|
|
End If
|
|
|
|
counter = 2
|
|
Do
|
|
newPath = Left(basePath, dotPos - 1) & "_v" & counter & Mid(basePath, dotPos)
|
|
If Dir(newPath) = "" Then
|
|
GetUniqueFilePath = newPath
|
|
Exit Function
|
|
End If
|
|
counter = counter + 1
|
|
Loop
|
|
End Function
|
|
|
|
' ------------------- RECURSIVE EXPORT FUNCTION -------------------
|
|
Sub ExportFolder(folder As Outlook.Folder, fileNum As Long, startDate As Date, endDate As Date, allowedCats() As String)
|
|
Dim itm As Object
|
|
Dim mail As Outlook.MailItem
|
|
Dim line As String
|
|
Dim followUpText As String
|
|
Dim cats As String
|
|
Dim matchFound As Boolean
|
|
Dim subF As Outlook.Folder
|
|
Dim mailCats() As String
|
|
Dim mc As Variant, ac As Variant
|
|
Dim foundThis As Boolean
|
|
Dim acTrim As String
|
|
|
|
For Each itm In folder.Items
|
|
If TypeOf itm Is Outlook.MailItem Then
|
|
Set mail = itm
|
|
|
|
' --- Date filter ---
|
|
If mail.ReceivedTime < startDate Or mail.ReceivedTime > endDate Then GoTo SkipItem
|
|
|
|
' --- Category filter ---
|
|
cats = LCase(Trim(mail.Categories))
|
|
matchFound = False
|
|
|
|
If allowedCats(0) = "" Then
|
|
matchFound = True ' no filter
|
|
ElseIf cats <> "" Then
|
|
mailCats = Split(cats, ",")
|
|
|
|
If USE_AND_LOGIC Then
|
|
' ---------- AND LOGIC ----------
|
|
matchFound = True
|
|
For Each ac In allowedCats
|
|
acTrim = LCase(Trim(ac))
|
|
If acTrim <> "" Then
|
|
foundThis = False
|
|
For Each mc In mailCats
|
|
If Trim(mc) = acTrim Then
|
|
foundThis = True
|
|
Exit For
|
|
End If
|
|
Next mc
|
|
If Not foundThis Then
|
|
matchFound = False
|
|
Exit For
|
|
End If
|
|
End If
|
|
Next ac
|
|
Else
|
|
' ---------- OR LOGIC ----------
|
|
For Each mc In mailCats
|
|
mc = Trim(mc)
|
|
For Each ac In allowedCats
|
|
acTrim = LCase(Trim(ac))
|
|
If acTrim <> "" And mc = acTrim Then
|
|
matchFound = True
|
|
Exit For
|
|
End If
|
|
Next ac
|
|
If matchFound Then Exit For
|
|
Next mc
|
|
End If
|
|
End If
|
|
|
|
If Not matchFound Then GoTo SkipItem
|
|
|
|
' --- Follow-up status ---
|
|
Select Case mail.FlagStatus
|
|
Case olNoFlag: followUpText = "No Flag"
|
|
Case olFlagComplete: followUpText = "Complete"
|
|
Case olFlagMarked: followUpText = "Marked"
|
|
Case Else: followUpText = "Other"
|
|
End Select
|
|
|
|
' --- Build CSV line (folder name only) ---
|
|
line = """" & CleanCSV(mail.Subject) & """,""" & _
|
|
CleanCSV(mail.SenderName) & """,""" & _
|
|
Format(mail.ReceivedTime, "yyyy-mm-dd hh:nn") & """,""" & _
|
|
CleanCSV(folder.Name) & """,""" & _
|
|
CleanCSV(mail.Categories) & """,""" & _
|
|
followUpText & """,""" & _
|
|
CleanCSV(mail.ConversationTopic) & """"
|
|
|
|
Print #fileNum, line
|
|
End If
|
|
SkipItem:
|
|
Next itm
|
|
|
|
' --- Recurse subfolders ---
|
|
For Each subF In folder.Folders
|
|
ExportFolder subF, fileNum, startDate, endDate, allowedCats
|
|
Next subF
|
|
End Sub
|
|
|
|
' ------------------- MAIN MACRO -------------------
|
|
Sub ExportEmailsToCSV()
|
|
Dim selectedFolder As Outlook.Folder
|
|
Dim fileNum As Long
|
|
Dim filePath As String
|
|
Dim startDateStr As String, endDateStr As String
|
|
Dim startDate As Date, endDate As Date
|
|
Dim categoriesInput As String
|
|
Dim allowedCats() As String
|
|
Dim catSuffix As String
|
|
Dim fileDatePrefix As String
|
|
Dim dateRangePart As String
|
|
Dim basePath As String
|
|
|
|
' --- Pick folder ---
|
|
Set selectedFolder = Application.Session.PickFolder
|
|
If selectedFolder Is Nothing Then Exit Sub
|
|
|
|
' --- Date range input ---
|
|
startDateStr = InputBox("Enter START date (YYYY-MM-DD) or leave blank for no limit:", _
|
|
"Start Date", Format(Date - 1, "yyyy-mm-dd"))
|
|
If Trim(startDateStr) <> "" Then
|
|
If IsDate(startDateStr) Then
|
|
startDate = CDate(startDateStr)
|
|
Else
|
|
startDate = DateSerial(1900, 1, 1)
|
|
End If
|
|
Else
|
|
startDate = DateSerial(1900, 1, 1)
|
|
End If
|
|
|
|
endDateStr = InputBox("Enter END date (YYYY-MM-DD) or leave blank for today:", _
|
|
"End Date", Format(Date, "yyyy-mm-dd"))
|
|
If Trim(endDateStr) <> "" Then
|
|
If IsDate(endDateStr) Then
|
|
endDate = CDate(endDateStr)
|
|
Else
|
|
endDate = Now
|
|
End If
|
|
Else
|
|
endDate = Now
|
|
End If
|
|
|
|
' Make endDate inclusive if only a date was given
|
|
If endDate = Int(endDate) Then
|
|
endDate = endDate + TimeSerial(23, 59, 59)
|
|
End If
|
|
|
|
' --- Categories input ---
|
|
categoriesInput = InputBox("Enter category names separated by commas (e.g., Cat1,CatX):", _
|
|
"Categories Filter", "")
|
|
If Trim(categoriesInput) <> "" Then
|
|
allowedCats = Split(categoriesInput, ",")
|
|
Else
|
|
allowedCats = Split("", ",") ' no filter
|
|
End If
|
|
|
|
' --- File name components ---
|
|
fileDatePrefix = Format(Date, "yyyymmdd")
|
|
|
|
' Category suffix for filename (sanitized)
|
|
If Trim(categoriesInput) <> "" Then
|
|
catSuffix = Replace(categoriesInput, " ", "")
|
|
catSuffix = Replace(catSuffix, ",", "_")
|
|
catSuffix = Replace(catSuffix, "/", "-")
|
|
catSuffix = Replace(catSuffix, "\", "-")
|
|
catSuffix = Replace(catSuffix, ":", "-")
|
|
catSuffix = Replace(catSuffix, "*", "-")
|
|
catSuffix = Replace(catSuffix, "?", "")
|
|
catSuffix = Replace(catSuffix, """", "")
|
|
catSuffix = Replace(catSuffix, "<", "")
|
|
catSuffix = Replace(catSuffix, ">", "")
|
|
catSuffix = Replace(catSuffix, "|", "")
|
|
If Len(catSuffix) > 50 Then catSuffix = Left(catSuffix, 50)
|
|
catSuffix = "_" & catSuffix
|
|
Else
|
|
catSuffix = ""
|
|
End If
|
|
|
|
' Date range segment (use date-only for end)
|
|
dateRangePart = "_" & Format(startDate, "yyyy-mm-dd") & "-" & Format(Int(endDate), "yyyy-mm-dd")
|
|
|
|
' Base path according to your pattern:
|
|
' CurrentDate_Emails_folderName_dateRange_categories.csv
|
|
basePath = Environ("USERPROFILE") & "\Desktop\" & _
|
|
fileDatePrefix & "_Emails_" & Replace(selectedFolder.Name, " ", "_") & _
|
|
dateRangePart & catSuffix & ".csv"
|
|
|
|
' Always get a safe/unique path (no overwrite)
|
|
filePath = GetUniqueFilePath(basePath)
|
|
|
|
' --- Open file & header ---
|
|
fileNum = FreeFile
|
|
Open filePath For Output As #fileNum
|
|
Print #fileNum, "Subject,Sender,ReceivedTime,Folder,Categories,FollowUpStatus,ConversationTopic"
|
|
|
|
' --- Export ---
|
|
ExportFolder selectedFolder, fileNum, startDate, endDate, allowedCats
|
|
|
|
Close #fileNum
|
|
|
|
' --- Notify user ---
|
|
MsgBox "Export complete!" & vbCrLf & _
|
|
"File saved as: " & filePath & vbCrLf & vbCrLf & _
|
|
"Category logic: " & IIf(USE_AND_LOGIC, "AND (all categories must match)", "OR (any category may match)"), _
|
|
vbInformation, "Export Complete"
|
|
End Sub |