tradon/notes/accounting/excel_api/GLAccountsExcelApi.bas

Attribute VB_Name = "GLAccountsExcelApi"
Option Explicit

' Excel API POC for GL ACCOUNTS FUNCTIONS.
'
' Setup:
'   1. Install PostgreSQL ODBC driver.
'   2. Apply notes/accounting/excel_api/gl_accounts_sql_poc.sql.
'   3. Open Excel in safe mode: double-clic sur Ouvrir_Excel_SafeMode.bat
'   4. Developer > Visual Basic > File > Import File > importe ce .bas.
'   5. Run SetManualCalculation once (sets xlCalculationManual).
'
' Usage (2 modes au choix):
'   Mode formule : tape =GetAccountAmount("ICT TRADING","20011","USD","2026-05-13")
'                  dans n'importe quelle cellule, puis F9 pour recalculer.
'   Mode macro   : remplis Setup!B6:B9, lance RefreshGLApi.

Private Const GL_API_CONNECTION_STRING As String = _
    "Driver={PostgreSQL Unicode(x64)};" & _
    "Server=vps107.geneva.hosting;" & _
    "Port=5432;" & _
    "Database=tradon;" & _
    "Uid=postgres;" & _
    "Pwd=dsproject;"

Private gConnection As Object
Private gCache As Object

' ---- Connection helpers ----

Private Function ApiCache() As Object
    If gCache Is Nothing Then
        Set gCache = CreateObject("Scripting.Dictionary")
    End If
    Set ApiCache = gCache
End Function

Private Function DbConnection() As Object
    If gConnection Is Nothing Then
        Set gConnection = CreateObject("ADODB.Connection")
        gConnection.ConnectionString = GL_API_CONNECTION_STRING
        gConnection.ConnectionTimeout = 5
        gConnection.CommandTimeout = 30
        gConnection.Open
    ElseIf gConnection.State = 0 Then
        gConnection.Open
    End If
    Set DbConnection = gConnection
End Function

Private Sub ResetDbConnection()
    On Error Resume Next
    If Not gConnection Is Nothing Then
        If gConnection.State <> 0 Then gConnection.Close
    End If
    Set gConnection = Nothing
    On Error GoTo 0
End Sub

Public Sub ClearGLApiCache()
    If Not gCache Is Nothing Then gCache.RemoveAll
End Sub

Public Sub CloseGLApiConnection()
    If Not gConnection Is Nothing Then
        If gConnection.State <> 0 Then gConnection.Close
    End If
    Set gConnection = Nothing
End Sub

' ---- Setup ----

' Vide le cache pour forcer un rafraichissement DB au prochain recalcul.
' Utile si les donnees ont change cote serveur.
Public Sub ForceRefresh()
    ClearGLApiCache
    Application.Calculate
End Sub

' ---- Mode macro : RefreshGLApi ----

' Lit Setup!B6:B9, interroge la DB, ecrit les valeurs dans Functions!C6:C13.
Public Sub RefreshGLApi()
    Dim wsSetup As Worksheet
    Dim wsFunctions As Worksheet

    On Error Resume Next
    Set wsSetup = ThisWorkbook.Worksheets("Setup")
    Set wsFunctions = ThisWorkbook.Worksheets("Functions")
    On Error GoTo 0

    If wsSetup Is Nothing Then
        MsgBox "Feuille 'Setup' introuvable.", vbExclamation
        Exit Sub
    End If
    If wsFunctions Is Nothing Then
        MsgBox "Feuille 'Functions' introuvable.", vbExclamation
        Exit Sub
    End If

    Application.EnableEvents = False
    Application.ScreenUpdating = False

    Dim company As String
    Dim account As String
    Dim currencyIso As String
    Dim valueDate As Variant

    company = CStr(wsSetup.Range("B6").Value)
    account = CStr(wsSetup.Range("B7").Value)
    currencyIso = CStr(wsSetup.Range("B8").Value)
    valueDate = wsSetup.Range("B9").Value

    ClearGLApiCache

    On Error GoTo RefreshError

    wsFunctions.Range("C6").Value = RunQuery("get_account_base_amount", company, account, currencyIso, valueDate)
    wsFunctions.Range("C7").Value = RunQuery("get_account_real_base_amount", company, account, currencyIso, valueDate)
    wsFunctions.Range("C8").Value = RunQuery("get_account_amount", company, account, currencyIso, valueDate)
    wsFunctions.Range("C9").Value = RunQuery("get_account_abbr", company, account, currencyIso, valueDate)
    wsFunctions.Range("C10").Value = RunQuery("get_account_name", company, account, currencyIso, valueDate)
    wsFunctions.Range("C11").Value = RunQuery("get_account_contact", company, account, currencyIso, valueDate)
    wsFunctions.Range("C12").Value = RunQuery("get_account_contact_code", company, account, currencyIso, valueDate)
    wsFunctions.Range("C13").Value = RunQuery("get_account_contact_name", company, account, currencyIso, valueDate)

    CloseGLApiConnection
    GoTo RefreshDone

RefreshError:
    MsgBox "RefreshGLApi error: " & Err.Description, vbExclamation

RefreshDone:
    Application.ScreenUpdating = True
    Application.EnableEvents = True
End Sub

' ---- Core SQL runner ----

Private Function RunQuery( _
        ByVal functionName As String, _
        ByVal companyKey As Variant, _
        ByVal accountCode As Variant, _
        ByVal currencyIso As Variant, _
        ByVal valueDate As Variant) As Variant

    On Error GoTo ErrorHandler

    Dim key As String
    key = functionName & "|" & CStr(companyKey) & "|" & CStr(accountCode) _
        & "|" & CStr(currencyIso) & "|" & SqlDate(valueDate)

    If ApiCache.Exists(key) Then
        RunQuery = ApiCache(key)
        Exit Function
    End If

    Dim sql As String
    sql = "select excel_api." & functionName & "('" _
        & SqlText(companyKey) & "','" _
        & SqlText(accountCode) & "','" _
        & SqlText(currencyIso) & "','" _
        & SqlDate(valueDate) & "'::date)"

    Dim rs As Object
    Dim attempt As Integer
RetryQuery:
    Set rs = CreateObject("ADODB.Recordset")
    rs.Open sql, DbConnection, 0, 1

    If rs.EOF Or IsNull(rs.Fields(0).Value) Then
        RunQuery = Empty
    Else
        RunQuery = rs.Fields(0).Value
    End If
    rs.Close

    ApiCache.Add key, RunQuery
    Exit Function

ErrorHandler:
    If attempt = 0 Then
        attempt = 1
        If Not rs Is Nothing Then
            If rs.State <> 0 Then rs.Close
        End If
        ResetDbConnection
        Resume RetryQuery
    End If
    RunQuery = "#ERR " & Err.Number & ": " & Err.Description
End Function

Private Function SqlDate(ByVal valueDate As Variant) As String
    SqlDate = Format$(CDate(valueDate), "yyyy-mm-dd")
End Function

Private Function SqlText(ByVal value As Variant) As String
    SqlText = Replace(CStr(value), "'", "''")
End Function

' ---- UDF formulas (mode formule) ----
' Utilisation : =GetAccountAmount("ICT TRADING", B7, B8, B9)
' Puis F9 pour recalculer. Le cache evite les appels DB redondants.

Public Function GetAccountBaseAmount( _
        ByVal companyKey As Variant, _
        ByVal accountCode As Variant, _
        ByVal currencyIso As Variant, _
        ByVal valueDate As Variant) As Variant
    GetAccountBaseAmount = RunQuery("get_account_base_amount", companyKey, accountCode, currencyIso, valueDate)
End Function

Public Function GetAccountRealBaseAmount( _
        ByVal companyKey As Variant, _
        ByVal accountCode As Variant, _
        ByVal currencyIso As Variant, _
        ByVal valueDate As Variant) As Variant
    GetAccountRealBaseAmount = RunQuery("get_account_real_base_amount", companyKey, accountCode, currencyIso, valueDate)
End Function

Public Function GetAccountAmount( _
        ByVal companyKey As Variant, _
        ByVal accountCode As Variant, _
        ByVal currencyIso As Variant, _
        ByVal valueDate As Variant) As Variant
    GetAccountAmount = RunQuery("get_account_amount", companyKey, accountCode, currencyIso, valueDate)
End Function

Public Function GetAccountAbbr( _
        ByVal companyKey As Variant, _
        ByVal accountCode As Variant, _
        ByVal currencyIso As Variant, _
        ByVal valueDate As Variant) As Variant
    GetAccountAbbr = RunQuery("get_account_abbr", companyKey, accountCode, currencyIso, valueDate)
End Function

Public Function GetAccountName( _
        ByVal companyKey As Variant, _
        ByVal accountCode As Variant, _
        ByVal currencyIso As Variant, _
        ByVal valueDate As Variant) As Variant
    GetAccountName = RunQuery("get_account_name", companyKey, accountCode, currencyIso, valueDate)
End Function

Public Function GetAccountContact( _
        ByVal companyKey As Variant, _
        ByVal accountCode As Variant, _
        ByVal currencyIso As Variant, _
        ByVal valueDate As Variant) As Variant
    GetAccountContact = RunQuery("get_account_contact", companyKey, accountCode, currencyIso, valueDate)
End Function

Public Function GetAccountContactCode( _
        ByVal companyKey As Variant, _
        ByVal accountCode As Variant, _
        ByVal currencyIso As Variant, _
        ByVal valueDate As Variant) As Variant
    GetAccountContactCode = RunQuery("get_account_contact_code", companyKey, accountCode, currencyIso, valueDate)
End Function

Public Function GetAccountContactName( _
        ByVal companyKey As Variant, _
        ByVal accountCode As Variant, _
        ByVal currencyIso As Variant, _
        ByVal valueDate As Variant) As Variant
    GetAccountContactName = RunQuery("get_account_contact_name", companyKey, accountCode, currencyIso, valueDate)
End Function