15 KiB
15 KiB
MainModule
Analysis generated on: 4/1/2025 5:16:51 PM
VBA Code
Attribute VB_Name = "MainModule"
Option Compare Database
Option Explicit
' Global queue for API requests
Public Type ApiRequest
code As String
filePath As String
ItemType As String ' To track the type of item (Form, Query, Table, Module)
ItemName As String ' To track the name of the item for progress display
End Type
' Declare Sleep for both 32-bit and 64-bit Office
#If VBA7 Then
Public Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
#Else
Public Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
#End If
' Main subroutine to generate the Obsidian vault
Public Sub GenerateObsidianVault()
On Error GoTo ErrorHandler
' Create the overview file
Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")
Dim vaultPath As String
vaultPath = CurrentProject.Path & "\ObsidianVault"
Dim overviewPath As String
overviewPath = vaultPath & "\Overview.md"
Dim overviewFile As Object
Set overviewFile = fso.CreateTextFile(overviewPath, True)
If overviewFile Is Nothing Then
MsgBox "Failed to create Overview.md. Error: " & Err.Description, vbCritical
Exit Sub
End If
overviewFile.WriteLine "# Overview"
overviewFile.WriteLine "Generated on: " & Now
' Run each analysis section
FormsModule.AnalyzeFormsForObsidianVault overviewFile, fso, vaultPath
QueriesModule.AnalyzeQueriesForObsidianVault overviewFile, fso, vaultPath
TablesModule.AnalyzeTablesForObsidianVault overviewFile, fso, vaultPath
ModulesModule.AnalyzeModulesForObsidianVault overviewFile, fso, vaultPath
' Finalize and clean up
overviewFile.WriteLine "---"
overviewFile.WriteLine "## Analysis Complete"
overviewFile.Close
Set overviewFile = Nothing
Set fso = Nothing
MsgBox "Analysis complete. Files saved to: " & vaultPath, vbInformation
Exit Sub
ErrorHandler:
Debug.Print "Error in GenerateObsidianVault: " & Err.Number & ": " & Err.Description & " at " & Now
MsgBox "Error " & Err.Number & ": " & Err.Description, vbCritical
If Not overviewFile Is Nothing Then overviewFile.Close
Set overviewFile = Nothing
Set fso = Nothing
Exit Sub
End Sub
' Helper function to sanitize filenames
Public Function SanitizeFileName(fileName As String) As String
Dim invalidChars As String
Dim i As Integer
invalidChars = "\/:*?""<>|#" ' Added # to the list of invalid characters
SanitizeFileName = fileName
For i = 1 To Len(invalidChars)
SanitizeFileName = Replace(SanitizeFileName, Mid(invalidChars, i, 1), "_")
Next i
End Function
' Helper function to parse JSON (basic implementation)
Public Function ParseJson(jsonStr As String) As Object
On Error GoTo JsonError
Dim scriptControl As Object
Set scriptControl = CreateObject("ScriptControl")
If scriptControl Is Nothing Then
Set ParseJson = Nothing
Exit Function
End If
scriptControl.Language = "JScript"
Set ParseJson = scriptControl.Eval("(" & jsonStr & ")")
Exit Function
JsonError:
Set ParseJson = Nothing
End Function
Public Function SplitVBACode(code As Variant) As Collection
Dim chunks As New Collection
Dim lines() As String
Dim currentChunk As String
Dim i As Long
Dim chunkSize As Long
Const MAX_CHUNK_SIZE As Long = 12000 ' Approx 3000 tokens (assuming 1 token = 4 chars)
' Handle invalid or empty input
If IsNull(code) Or IsEmpty(code) Or TypeName(code) <> "String" Then
Debug.Print "SplitVBACode: Invalid input, code is " & TypeName(code)
chunks.Add "*No VBA code to document*"
Set SplitVBACode = chunks
Exit Function
End If
' Handle empty or whitespace-only code
If Trim(code) = "" Then
Debug.Print "SplitVBACode: Code is empty or whitespace-only"
chunks.Add "*No VBA code to document*"
Set SplitVBACode = chunks
Exit Function
End If
' Split the code into lines
On Error Resume Next
lines = Split(code, vbCrLf)
If Err.Number <> 0 Then
Debug.Print "SplitVBACode: Error splitting code: " & Err.Description
chunks.Add "*Error splitting VBA code: " & Err.Description & "*"
Err.Clear
Set SplitVBACode = chunks
Exit Function
End If
On Error GoTo 0
' Check if the lines array is valid
Dim linesLowerBound As Long
Dim linesUpperBound As Long
On Error Resume Next
linesLowerBound = LBound(lines)
linesUpperBound = UBound(lines)
If Err.Number <> 0 Then
Debug.Print "SplitVBACode: Error accessing lines array bounds: " & Err.Description
chunks.Add "*Error accessing lines array: " & Err.Description & "*"
Err.Clear
Set SplitVBACode = chunks
Exit Function
End If
On Error GoTo 0
' Check if the lines array is empty
If linesUpperBound < linesLowerBound Then
Debug.Print "SplitVBACode: Lines array is empty"
chunks.Add "*No VBA code to document*"
Set SplitVBACode = chunks
Exit Function
End If
currentChunk = ""
chunkSize = 0
For i = linesLowerBound To linesUpperBound
Dim line As String
On Error Resume Next
line = lines(i)
If Err.Number <> 0 Then
Debug.Print "SplitVBACode: Error accessing lines(" & i & "): " & Err.Description
chunks.Add "*Error accessing line " & i & ": " & Err.Description & "*"
Err.Clear
Set SplitVBACode = chunks
Exit Function
End If
On Error GoTo 0
' Add the line to the current chunk
currentChunk = currentChunk & IIf(currentChunk = "", "", vbCrLf) & line
chunkSize = chunkSize + Len(line) + 2 ' +2 for vbCrLf
' Check if the current chunk is too large or if we've reached a logical boundary
If chunkSize > MAX_CHUNK_SIZE Or (i < linesUpperBound And IsLogicalBoundary(lines(i), lines(i + 1))) Then
If currentChunk <> "" Then
chunks.Add currentChunk
currentChunk = ""
chunkSize = 0
End If
End If
Next i
' Add the last chunk if it exists
If currentChunk <> "" Then
chunks.Add currentChunk
End If
' Ensure at least one chunk is added
If chunks.Count = 0 Then
Debug.Print "SplitVBACode: No chunks created"
chunks.Add "*No VBA code to document*"
End If
Set SplitVBACode = chunks
End Function
' Helper function to determine if we're at a logical boundary (e.g., between subroutines)
Public Function IsLogicalBoundary(currentLine As String, nextLine As String) As Boolean
currentLine = Trim(currentLine)
nextLine = Trim(nextLine)
' Check if the current line ends a subroutine/function and the next line starts a new one
If (UCase(Right(currentLine, 7)) = "END SUB" Or UCase(Right(currentLine, 12)) = "END FUNCTION") And _
(UCase(Left(nextLine, 3)) = "SUB" Or UCase(Left(nextLine, 8)) = "FUNCTION") Then
IsLogicalBoundary = True
Else
IsLogicalBoundary = False
End If
End Function
' Helper function to process API requests to Ollama
Public Sub ProcessApiQueue(ApiQueue() As ApiRequest, QueueSize As Long, fso As Object)
Dim i As Long
Dim http As Object
Dim requestBody As String
Dim response As String
Dim txtFile As Object
' Open the progress form
On Error Resume Next
DoCmd.OpenForm "frmOllamaProgress", acNormal
If Err.Number <> 0 Then
Debug.Print "Failed to open progress form: " & Err.Description
Err.Clear
' Continue without the progress form
GoTo SkipProgressForm
End If
On Error GoTo 0
Dim frm As Form
Set frm = Forms("frmOllamaProgress")
' Set the maximum width of the progress bar (in twips; 1 inch = 1440 twips)
Const PROGRESS_BAR_MAX_WIDTH As Long = 5760 ' 4 inches
' Check if the queue is empty
If QueueSize = 0 Then
Debug.Print "ApiQueue is empty, no items to process for Ollama"
frm.Controls("lblProgress").Caption = "Processing complete (0 of 0 requests)"
frm.Controls("rectProgressBar").Width = PROGRESS_BAR_MAX_WIDTH
frm.Controls("lblCurrentTask").Caption = "Finished"
DoEvents
DoCmd.Close acForm, "frmOllamaProgress"
GoTo SkipProgressForm
End If
' Verify array bounds
On Error Resume Next
Dim upperBound As Long
upperBound = UBound(ApiQueue)
On Error GoTo 0
Debug.Print "ApiQueue UBound: " & upperBound & ", QueueSize: " & QueueSize
If upperBound + 1 < QueueSize Then
Debug.Print "QueueSize (" & QueueSize & ") exceeds ApiQueue bounds (" & (upperBound + 1) & "). Adjusting QueueSize."
QueueSize = upperBound + 1
End If
For i = 0 To QueueSize - 1
' Debug: Log the current item being processed
Debug.Print "Processing ApiQueue(" & i & "): ItemType=" & ApiQueue(i).ItemType & ", ItemName=" & ApiQueue(i).ItemName & ", FilePath=" & ApiQueue(i).filePath
' Validate ApiQueue(i).Code
Debug.Print "Validating ApiQueue(" & i & ").Code"
If IsNull(ApiQueue(i).code) Or ApiQueue(i).code = "" Then
Debug.Print "ApiQueue(" & i & ").Code is empty or null for " & ApiQueue(i).ItemName
GoTo NextRequest
End If
Debug.Print "ApiQueue(" & i & ").Code length: " & Len(ApiQueue(i).code)
' Update overall progress
Debug.Print "Updating progress for item " & i
Dim progressPercent As Double
progressPercent = (i / QueueSize) * 100
frm.Controls("lblProgress").Caption = "Processing " & (i + 1) & " of " & QueueSize & " requests (" & Format(progressPercent, "0.0") & "%)"
frm.Controls("rectProgressBar").Width = (progressPercent / 100) * PROGRESS_BAR_MAX_WIDTH
frm.Controls("lblCurrentTask").Caption = "Processing " & LCase(ApiQueue(i).ItemType) & ": " & ApiQueue(i).ItemName
DoEvents ' Allow the form to refresh
' Split the code into chunks if necessary
Debug.Print "Splitting code into chunks for item " & i
Dim codeChunks As Collection
Set codeChunks = SplitVBACode(ApiQueue(i).code)
' Debug: Log the number of chunks
Debug.Print "Number of chunks for " & ApiQueue(i).ItemName & ": " & codeChunks.Count
' Open the file for appending
Debug.Print "Opening file for appending: " & ApiQueue(i).filePath
Set txtFile = fso.OpenTextFile(ApiQueue(i).filePath, 8, True)
If txtFile Is Nothing Then
Debug.Print "Failed to open file for appending: " & ApiQueue(i).filePath
GoTo NextRequest
End If
txtFile.WriteLine "## VBA Documentation (Generated by Ollama)"
' Process each chunk
Dim chunkIndex As Long
For chunkIndex = 1 To codeChunks.Count
Debug.Print "Processing chunk " & chunkIndex & " for " & ApiQueue(i).ItemName
Dim chunk As String
chunk = codeChunks(chunkIndex)
' Debug: Log the chunk being processed
Debug.Print "Processing chunk " & chunkIndex & " for " & ApiQueue(i).ItemName & ": " & Left(chunk, 100) & "..."
' Prepare the request to Ollama
Set http = CreateObject("WinHttp.WinHttpRequest.5.1")
If http Is Nothing Then
Debug.Print "Failed to create WinHttpRequest object for chunk " & chunkIndex & " of " & ApiQueue(i).ItemName
txtFile.WriteLine "#### Chunk " & chunkIndex
txtFile.WriteLine "*Error: Failed to create WinHttpRequest object.*"
GoTo NextChunk
End If
http.Open "POST", "http://localhost:11434/api/generate", False
http.SetRequestHeader "Content-Type", "application/json"
' Build the JSON payload with the chunk
requestBody = "{""model"": ""llama3.2:3b"", ""prompt"": ""Generate detailed Markdown documentation for the following VBA code. Include a high-level overview section titled \""What it does\"" that summarizes the overall purpose of the code, followed by detailed documentation of each subroutine or function, including descriptions, parameters, details, and dependencies:\n\n" & Replace(chunk, """", "\""") & """" & ", ""stream"": false}"
Debug.Print "Sending request to Ollama for chunk " & chunkIndex & " of " & ApiQueue(i).ItemName
http.Send requestBody
' Get the response
If http.Status = 200 Then
response = http.ResponseText
Debug.Print "Received response from Ollama for chunk " & chunkIndex & " of " & ApiQueue(i).ItemName & ": " & Left(response, 100) & "..."
' Parse the response (Ollama returns JSON with a "response" field)
Dim json As Object
Set json = ParseJson(response)
If Not json Is Nothing Then
Dim doc As String
On Error Resume Next
doc = json("response")
If Err.Number <> 0 Then
doc = "*Error parsing JSON response: " & Err.Description & "*"
Debug.Print "Error parsing JSON response for chunk " & chunkIndex & " of " & ApiQueue(i).ItemName & ": " & Err.Description
Err.Clear
End If
On Error GoTo 0
' Append the documentation for this chunk
Debug.Print "Writing documentation for chunk " & chunkIndex & " of " & ApiQueue(i).ItemName & ": " & Left(doc, 100) & "..."
txtFile.WriteLine "#### Chunk " & chunkIndex
txtFile.WriteLine doc
Else
Debug.Print "Failed to parse Ollama response for chunk " & chunkIndex & " of " & ApiQueue(i).ItemName
txtFile.WriteLine "#### Chunk " & chunkIndex
txtFile.WriteLine "*Failed to parse Ollama response*"
End If
Else
Debug.Print "Ollama API call failed for chunk " & chunkIndex & " of " & ApiQueue(i).ItemName & ": Status " & http.Status & " - " & http.StatusText
txtFile.WriteLine "#### Chunk " & chunkIndex
txtFile.WriteLine "*Error calling Ollama API: " & http.Status & " - " & http.StatusText & "*"
End If
NextChunk:
' Clean up
Set http = Nothing
' Add a delay to avoid overwhelming the API (e.g., 1 second)
Sleep 1000
Next chunkIndex
txtFile.Close
NextRequest:
' Clean up
Set txtFile = Nothing
Next i
' Update the form to show completion
frm.Controls("lblProgress").Caption = "Processing complete (" & QueueSize & " of " & QueueSize & " requests)"
frm.Controls("rectProgressBar").Width = PROGRESS_BAR_MAX_WIDTH
frm.Controls("lblCurrentTask").Caption = "Finished"
DoEvents
' Close the progress form
DoCmd.Close acForm, "frmOllamaProgress"
SkipProgressForm:
Set fso = Nothing
End Sub
What it does
No VBA code to document due to export failure