Compare commits
No commits in common. "69edc8589e2e000c3580af2eb7b5ec62ff21a133" and "64ed28b53ab26ac718e57ebc20b193ec38e5df01" have entirely different histories.
69edc8589e
...
64ed28b53a
2 changed files with 0 additions and 293 deletions
|
|
@ -1,292 +0,0 @@
|
||||||
Option Explicit
|
|
||||||
|
|
||||||
' ---------- SETTINGS ----------
|
|
||||||
' 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
|
|
||||||
|
|
||||||
' Use a fixed, hardcoded default for the Categories input box
|
|
||||||
Const USE_SMART_DEFAULTS As Boolean = False ' keep for future; not used here
|
|
||||||
Const DEFAULT_CATEGORIES As String = "Finance, Clients, HR, Legal, Billing" ' <-- edit to your needs
|
|
||||||
|
|
||||||
' ------------------- 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
|
|
||||||
|
|
||||||
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, includeNoCategory As Boolean)
|
|
||||||
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 with "include uncategorized" option ---
|
|
||||||
cats = Trim(mail.Categories)
|
|
||||||
|
|
||||||
If cats = "" Then
|
|
||||||
' No categories on this mail
|
|
||||||
matchFound = includeNoCategory
|
|
||||||
Else
|
|
||||||
' Has categories -> apply normal logic (case-insensitive)
|
|
||||||
Dim catsLower As String
|
|
||||||
catsLower = LCase(cats)
|
|
||||||
matchFound = False
|
|
||||||
|
|
||||||
If allowedCats(0) = "" Then
|
|
||||||
matchFound = True ' no filter list -> include all categorized emails
|
|
||||||
Else
|
|
||||||
mailCats = Split(catsLower, ",")
|
|
||||||
|
|
||||||
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
|
|
||||||
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, includeNoCategory
|
|
||||||
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
|
|
||||||
Dim includeNoCategory As Boolean
|
|
||||||
Dim resp As VbMsgBoxResult
|
|
||||||
Dim i As Long
|
|
||||||
Dim defaultCats 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
|
|
||||||
|
|
||||||
' --- Pre-populated categories (hardcoded) ---
|
|
||||||
defaultCats = DEFAULT_CATEGORIES
|
|
||||||
|
|
||||||
' --- Categories input ---
|
|
||||||
categoriesInput = InputBox( _
|
|
||||||
"Enter category names separated by commas (e.g., Cat1,CatX)." & vbCrLf & _
|
|
||||||
"Leave blank for no filter.", _
|
|
||||||
"Categories Filter", defaultCats)
|
|
||||||
|
|
||||||
' Parse categories (trim each)
|
|
||||||
If Trim(categoriesInput) <> "" Then
|
|
||||||
allowedCats = Split(categoriesInput, ",")
|
|
||||||
For i = LBound(allowedCats) To UBound(allowedCats)
|
|
||||||
allowedCats(i) = Trim(allowedCats(i))
|
|
||||||
Next i
|
|
||||||
Else
|
|
||||||
allowedCats = Split("", ",") ' no filter
|
|
||||||
End If
|
|
||||||
|
|
||||||
' --- Include emails with NO category? (Yes/No) ---
|
|
||||||
resp = MsgBox("Include emails with NO category?", vbQuestion + vbYesNo, "Include Uncategorized")
|
|
||||||
includeNoCategory = (resp = vbYes)
|
|
||||||
|
|
||||||
' --- 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
|
|
||||||
|
|
||||||
' Add marker if including uncategorized (optional but handy)
|
|
||||||
If includeNoCategory Then
|
|
||||||
If catSuffix = "" Then
|
|
||||||
catSuffix = "_Uncategorized"
|
|
||||||
Else
|
|
||||||
catSuffix = catSuffix & "_Uncategorized"
|
|
||||||
End If
|
|
||||||
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, includeNoCategory
|
|
||||||
|
|
||||||
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)") & vbCrLf & _
|
|
||||||
"Included uncategorized: " & IIf(includeNoCategory, "Yes", "No"), _
|
|
||||||
vbInformation, "Export Complete"
|
|
||||||
End Sub
|
|
||||||
|
|
@ -1 +0,0 @@
|
||||||
generated by chatGPT
|
|
||||||
Loading…
Add table
Add a link
Reference in a new issue