diff --git a/vba/2025-11-12T11_20_05.044915.txt b/vba/2025-11-12T11_20_05.044915.txt new file mode 100644 index 0000000..6cec89e --- /dev/null +++ b/vba/2025-11-12T11_20_05.044915.txt @@ -0,0 +1,252 @@ +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 \ No newline at end of file