From d3b97041eb9950c7b3c5df771b17501dcb044181 Mon Sep 17 00:00:00 2001 From: hyperaktiveSloth Date: Wed, 12 Nov 2025 10:22:20 +0100 Subject: [PATCH 1/6] Upload files to "vba" A VBA macro to export a report from outlook --- vba/2025-11-12T11_20_05.044915.txt | 252 +++++++++++++++++++++++++++++ 1 file changed, 252 insertions(+) create mode 100644 vba/2025-11-12T11_20_05.044915.txt 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 From f405eeb248b2dc9c67186a367a3ffac518f8f3f5 Mon Sep 17 00:00:00 2001 From: hyperaktiveSloth Date: Wed, 12 Nov 2025 17:49:08 +0100 Subject: [PATCH 2/6] Upload files to "vba" V0.1 --- vba/2025-11-12T11_20_05.044915.txt | 250 ++++++++++++++++++++++------- 1 file changed, 191 insertions(+), 59 deletions(-) diff --git a/vba/2025-11-12T11_20_05.044915.txt b/vba/2025-11-12T11_20_05.044915.txt index 6cec89e..4fdefb7 100644 --- a/vba/2025-11-12T11_20_05.044915.txt +++ b/vba/2025-11-12T11_20_05.044915.txt @@ -5,6 +5,9 @@ Option Explicit ' True = email must match ALL of the entered categories (AND) Const USE_AND_LOGIC As Boolean = False +' How many top categories to suggest by default +Const TOP_CATEGORIES_SUGGESTION As Long = 5 + ' ------------------- CLEAN CSV FUNCTION ------------------- Function CleanCSV(s As Variant) As String If IsError(s) Or IsNull(s) Or Trim(s) = "" Then @@ -26,16 +29,13 @@ Function GetUniqueFilePath(basePath As String) As String 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 + If dotPos = 0 Then dotPos = Len(basePath) + 1 counter = 2 Do @@ -48,8 +48,99 @@ Function GetUniqueFilePath(basePath As String) As String Loop End Function +' ------------------- CATEGORY STATS (for default suggestions) ------------------- +Private Sub AccumulateCategoryCounts(folder As Outlook.Folder, _ + ByVal startDate As Date, ByVal endDate As Date, _ + ByRef dict As Object) + Dim itm As Object + Dim mail As Outlook.MailItem + Dim cats As String, parts() As String + Dim i As Long + Dim subF As Outlook.Folder + + For Each itm In folder.Items + If TypeOf itm Is Outlook.MailItem Then + Set mail = itm + If mail.ReceivedTime >= startDate And mail.ReceivedTime <= endDate Then + cats = Trim(mail.Categories) + If cats <> "" Then + parts = Split(cats, ",") + For i = LBound(parts) To UBound(parts) + Dim key As String + key = LCase(Trim(parts(i))) + If key <> "" Then + If Not dict.Exists(key) Then + dict.Add key, 1 + Else + dict(key) = CLng(dict(key)) + 1 + End If + End If + Next i + End If + End If + End If + Next itm + + ' Recurse subfolders + For Each subF In folder.Folders + AccumulateCategoryCounts subF, startDate, endDate, dict + Next subF +End Sub + +Private Function GetTopCategoriesCSV(folder As Outlook.Folder, _ + ByVal startDate As Date, ByVal endDate As Date, _ + ByVal topN As Long) As String + Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary") ' late-bound + Dim keys() As Variant, counts() As Long + Dim i As Long, j As Long + Dim tmpKey As Variant, tmpCount As Long + Dim result As String, shown As Long + + AccumulateCategoryCounts folder, startDate, endDate, dict + + If dict.Count = 0 Then + GetTopCategoriesCSV = "" + Exit Function + End If + + ' Copy to arrays for sorting + ReDim keys(0 To dict.Count - 1) + ReDim counts(0 To dict.Count - 1) + i = 0 + Dim k As Variant + For Each k In dict.Keys + keys(i) = k + counts(i) = CLng(dict(k)) + i = i + 1 + Next k + + ' Simple bubble sort by count DESC (dict is usually small) + For i = LBound(counts) To UBound(counts) + For j = i + 1 To UBound(counts) + If counts(j) > counts(i) Then + tmpCount = counts(i): counts(i) = counts(j): counts(j) = tmpCount + tmpKey = keys(i): keys(i) = keys(j): keys(j) = tmpKey + End If + Next j + Next i + + ' Build comma-separated list (restore original case by using keys as-is; they are lowercased) + result = "" + shown = 0 + For i = LBound(keys) To UBound(keys) + If shown >= topN Then Exit For + If result <> "" Then result = result & "," + ' Capitalize first letter (optional cosmetic) + result = result & UCase(Left(CStr(keys(i)), 1)) & Mid(CStr(keys(i)), 2) + shown = shown + 1 + Next i + + GetTopCategoriesCSV = result +End Function + ' ------------------- RECURSIVE EXPORT FUNCTION ------------------- -Sub ExportFolder(folder As Outlook.Folder, fileNum As Long, startDate As Date, endDate As Date, allowedCats() As String) +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 @@ -65,56 +156,69 @@ Sub ExportFolder(folder As Outlook.Folder, fileNum As Long, startDate As Date, e 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 ---------- + + ' --- Category filter with "include uncategorized" option --- + cats = Trim(mail.Categories) + + If cats = "" Then + ' No categories on this mail + If includeNoCategory Then 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) + matchFound = False + End If + 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 <> "" And mc = acTrim Then - matchFound = True - Exit For + 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 - If matchFound Then Exit For - Next mc + 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" @@ -122,7 +226,7 @@ Sub ExportFolder(folder As Outlook.Folder, fileNum As Long, startDate As Date, e Case olFlagMarked: followUpText = "Marked" Case Else: followUpText = "Other" End Select - + ' --- Build CSV line (folder name only) --- line = """" & CleanCSV(mail.Subject) & """,""" & _ CleanCSV(mail.SenderName) & """,""" & _ @@ -131,15 +235,15 @@ Sub ExportFolder(folder As Outlook.Folder, fileNum As Long, startDate As Date, e 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 + ExportFolder subF, fileNum, startDate, endDate, allowedCats, includeNoCategory Next subF End Sub @@ -156,6 +260,10 @@ Sub ExportEmailsToCSV() Dim fileDatePrefix As String Dim dateRangePart As String Dim basePath As String + Dim includeNoCategory As Boolean + Dim resp As VbMsgBoxResult + Dim defaultCats As String + Dim i As Long ' --- Pick folder --- Set selectedFolder = Application.Session.PickFolder @@ -187,21 +295,36 @@ Sub ExportEmailsToCSV() End If ' Make endDate inclusive if only a date was given - If endDate = Int(endDate) Then - endDate = endDate + TimeSerial(23, 59, 59) - End If + If endDate = Int(endDate) Then endDate = endDate + TimeSerial(23, 59, 59) - ' --- Categories input --- - categoriesInput = InputBox("Enter category names separated by commas (e.g., Cat1,CatX):", _ - "Categories Filter", "") + ' --- Build default categories suggestion from most-used within date range --- + defaultCats = GetTopCategoriesCSV(selectedFolder, startDate, endDate, TOP_CATEGORIES_SUGGESTION) + + ' --- Categories input (pre-populated with defaults if any) --- + 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") + Dim fileDatePrefixDate As Date + fileDatePrefixDate = Date + + fileDatePrefix = Format(fileDatePrefixDate, "yyyymmdd") ' Category suffix for filename (sanitized) If Trim(categoriesInput) <> "" Then @@ -222,11 +345,19 @@ Sub ExportEmailsToCSV() 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 + ' Base path: CurrentDate_Emails_folderName_dateRange_categories.csv basePath = Environ("USERPROFILE") & "\Desktop\" & _ fileDatePrefix & "_Emails_" & Replace(selectedFolder.Name, " ", "_") & _ dateRangePart & catSuffix & ".csv" @@ -240,13 +371,14 @@ Sub ExportEmailsToCSV() Print #fileNum, "Subject,Sender,ReceivedTime,Folder,Categories,FollowUpStatus,ConversationTopic" ' --- Export --- - ExportFolder selectedFolder, fileNum, startDate, endDate, allowedCats + 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)"), _ + "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 \ No newline at end of file From 1d45bf2af21a9576900163cf616b2422f8eaef07 Mon Sep 17 00:00:00 2001 From: hyperaktiveSloth Date: Wed, 12 Nov 2025 17:57:13 +0100 Subject: [PATCH 3/6] Add vba/outlookReportExport V0.2 --- vba/outlookReportExport | 292 ++++++++++++++++++++++++++++++++++++++++ 1 file changed, 292 insertions(+) create mode 100644 vba/outlookReportExport diff --git a/vba/outlookReportExport b/vba/outlookReportExport new file mode 100644 index 0000000..1f80dc0 --- /dev/null +++ b/vba/outlookReportExport @@ -0,0 +1,292 @@ +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 \ No newline at end of file From abb215e908739a4069c2a1e485ccf54936e866d3 Mon Sep 17 00:00:00 2001 From: hyperaktiveSloth Date: Wed, 12 Nov 2025 18:13:55 +0100 Subject: [PATCH 4/6] Add vba/readme.md --- vba/readme.md | 1 + 1 file changed, 1 insertion(+) create mode 100644 vba/readme.md diff --git a/vba/readme.md b/vba/readme.md new file mode 100644 index 0000000..ccbc59d --- /dev/null +++ b/vba/readme.md @@ -0,0 +1 @@ +generated by chatGPT \ No newline at end of file From 67f005d949670d746d9e74f5bcd57d71e9053bfe Mon Sep 17 00:00:00 2001 From: hyperaktiveSloth Date: Wed, 12 Nov 2025 18:14:23 +0100 Subject: [PATCH 5/6] Delete vba/2025-11-12T11_20_05.044915.txt --- vba/2025-11-12T11_20_05.044915.txt | 384 ----------------------------- 1 file changed, 384 deletions(-) delete mode 100644 vba/2025-11-12T11_20_05.044915.txt diff --git a/vba/2025-11-12T11_20_05.044915.txt b/vba/2025-11-12T11_20_05.044915.txt deleted file mode 100644 index 4fdefb7..0000000 --- a/vba/2025-11-12T11_20_05.044915.txt +++ /dev/null @@ -1,384 +0,0 @@ -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 - -' How many top categories to suggest by default -Const TOP_CATEGORIES_SUGGESTION As Long = 5 - -' ------------------- 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 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 - -' ------------------- CATEGORY STATS (for default suggestions) ------------------- -Private Sub AccumulateCategoryCounts(folder As Outlook.Folder, _ - ByVal startDate As Date, ByVal endDate As Date, _ - ByRef dict As Object) - Dim itm As Object - Dim mail As Outlook.MailItem - Dim cats As String, parts() As String - Dim i As Long - Dim subF As Outlook.Folder - - For Each itm In folder.Items - If TypeOf itm Is Outlook.MailItem Then - Set mail = itm - If mail.ReceivedTime >= startDate And mail.ReceivedTime <= endDate Then - cats = Trim(mail.Categories) - If cats <> "" Then - parts = Split(cats, ",") - For i = LBound(parts) To UBound(parts) - Dim key As String - key = LCase(Trim(parts(i))) - If key <> "" Then - If Not dict.Exists(key) Then - dict.Add key, 1 - Else - dict(key) = CLng(dict(key)) + 1 - End If - End If - Next i - End If - End If - End If - Next itm - - ' Recurse subfolders - For Each subF In folder.Folders - AccumulateCategoryCounts subF, startDate, endDate, dict - Next subF -End Sub - -Private Function GetTopCategoriesCSV(folder As Outlook.Folder, _ - ByVal startDate As Date, ByVal endDate As Date, _ - ByVal topN As Long) As String - Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary") ' late-bound - Dim keys() As Variant, counts() As Long - Dim i As Long, j As Long - Dim tmpKey As Variant, tmpCount As Long - Dim result As String, shown As Long - - AccumulateCategoryCounts folder, startDate, endDate, dict - - If dict.Count = 0 Then - GetTopCategoriesCSV = "" - Exit Function - End If - - ' Copy to arrays for sorting - ReDim keys(0 To dict.Count - 1) - ReDim counts(0 To dict.Count - 1) - i = 0 - Dim k As Variant - For Each k In dict.Keys - keys(i) = k - counts(i) = CLng(dict(k)) - i = i + 1 - Next k - - ' Simple bubble sort by count DESC (dict is usually small) - For i = LBound(counts) To UBound(counts) - For j = i + 1 To UBound(counts) - If counts(j) > counts(i) Then - tmpCount = counts(i): counts(i) = counts(j): counts(j) = tmpCount - tmpKey = keys(i): keys(i) = keys(j): keys(j) = tmpKey - End If - Next j - Next i - - ' Build comma-separated list (restore original case by using keys as-is; they are lowercased) - result = "" - shown = 0 - For i = LBound(keys) To UBound(keys) - If shown >= topN Then Exit For - If result <> "" Then result = result & "," - ' Capitalize first letter (optional cosmetic) - result = result & UCase(Left(CStr(keys(i)), 1)) & Mid(CStr(keys(i)), 2) - shown = shown + 1 - Next i - - GetTopCategoriesCSV = result -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 - If includeNoCategory Then - matchFound = True - Else - matchFound = False - End If - 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 defaultCats As String - Dim i As Long - - ' --- 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) - - ' --- Build default categories suggestion from most-used within date range --- - defaultCats = GetTopCategoriesCSV(selectedFolder, startDate, endDate, TOP_CATEGORIES_SUGGESTION) - - ' --- Categories input (pre-populated with defaults if any) --- - 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 --- - Dim fileDatePrefixDate As Date - fileDatePrefixDate = Date - - fileDatePrefix = Format(fileDatePrefixDate, "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: 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 \ No newline at end of file From 69edc8589e2e000c3580af2eb7b5ec62ff21a133 Mon Sep 17 00:00:00 2001 From: hyperaktiveSloth Date: Wed, 12 Nov 2025 18:15:11 +0100 Subject: [PATCH 6/6] Update vba/outlookReportExport.bas Correcred file extension --- vba/{outlookReportExport => outlookReportExport.bas} | 0 1 file changed, 0 insertions(+), 0 deletions(-) rename vba/{outlookReportExport => outlookReportExport.bas} (100%) diff --git a/vba/outlookReportExport b/vba/outlookReportExport.bas similarity index 100% rename from vba/outlookReportExport rename to vba/outlookReportExport.bas