Upload files to "vba"

V0.1

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
+    If dotPos = 0 Then dotPos = Len(basePath) + 1
-        dotPos = Len(basePath) + 1
-    End If
 
     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 ---
+            ' --- Category filter with "include uncategorized" option ---
-            cats = LCase(Trim(mail.Categories))
+            cats = Trim(mail.Categories)
-            matchFound = False
+
-            
+            If cats = "" Then
-            If allowedCats(0) = "" Then
+                ' No categories on this mail
-                matchFound = True  ' no filter
+                If includeNoCategory Then
-            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 ----------
+                    matchFound = False
-                    For Each mc In mailCats
+                End If
-                        mc = Trim(mc)
+            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
+                            If acTrim <> "" Then
-                                matchFound = True
+                                foundThis = False
-                                Exit For
+                                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
+                    Else
-                    Next mc
+                        ' ---------- 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
+    If endDate = Int(endDate) Then endDate = endDate + TimeSerial(23, 59, 59)
-        endDate = endDate + TimeSerial(23, 59, 59)
-    End If
 
-    ' --- Categories input ---
+    ' --- Build default categories suggestion from most-used within date range ---
-    categoriesInput = InputBox("Enter category names separated by commas (e.g., Cat1,CatX):", _
+    defaultCats = GetTopCategoriesCSV(selectedFolder, startDate, endDate, TOP_CATEGORIES_SUGGESTION)
-                               "Categories Filter", "")
+
+    ' --- 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:
+    ' Base path: CurrentDate_Emails_folderName_dateRange_categories.csv
-    ' 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