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