From f405eeb248b2dc9c67186a367a3ffac518f8f3f5 Mon Sep 17 00:00:00 2001 From: hyperaktiveSloth Date: Wed, 12 Nov 2025 17:49:08 +0100 Subject: [PATCH] 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