Delete vba/2025-11-12T11_20_05.044915.txt
This commit is contained in:
hyperaktiveSloth
parent
abb215e908
commit
67f005d949
1 changed files with 0 additions and 384 deletions
|
|
@ -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
|
||||
Loading…
Add table
Add a link
Reference in a new issue