Option Explicit

' ========= ADIF Validator for WSJT-X logs =========
' Creates a sheet "ADIF_Report" with one row per detected issue.
' Author: ChatGPT
' ================================================

Public Sub ValidateADIF()
    Dim fpath As String
    Dim content As String
    Dim headerPos As Long
    Dim issues As Collection
    Dim dupMap As Object ' Scripting.Dictionary
    Dim i As Long, rec As String
    Dim records As Collection
    Dim hasNul As Boolean
    
    On Error GoTo FailSoft
    
    ' Pick .adi file
    With Application.FileDialog(msoFileDialogFilePicker)
        .AllowMultiSelect = False
        .Title = "Choisissez votre fichier ADIF (.adi)"
        .Filters.Clear
        .Filters.Add "Fichiers ADIF", "*.adi"
        If .Show <> -1 Then Exit Sub
        fpath = .SelectedItems(1)
    End With
    
    content = ReadAllText(fpath, hasNul)
    Set issues = New Collection
    Set dupMap = CreateObject("Scripting.Dictionary")
    
    ' Normalize line endings (not required by ADIF but helps human reading)
    content = Replace(Replace(content, vbCrLf, vbLf), vbCr, vbLf)
    
    If InStr(1, UCase$(content), "<EOH>") > 0 Then
        headerPos = InStrRev(UCase$(content), "<EOH>")
    Else
        headerPos = 0
        AddIssue issues, 0, "Header", "", "Balise <EOH> absente : le fichier pourrait être mal formé.", Left$(content, 120)
    End If
    
    ' After header, we should have one or more records ending by <EOR>
    Dim body As String
    If headerPos > 0 Then
        body = Mid$(content, headerPos + 5)
    Else
        body = content
    End If
    
    ' If there are NUL chars, warn (often encoding/UTF-16)
    If hasNul Then
        AddIssue issues, 0, "Encodage", "", "Caractères NUL détectés : le fichier semble encodé en UTF-16/UTF-16LE. Enregistre-le en UTF-8/ANSI avant import.", ""
    End If
    
    ' Split by <EOR> but keep last fragment if missing
    Set records = SplitRecordsByEOR(body)
    
    Dim recIdx As Long
    Dim tagMap As Object
    Dim key As String
    
    For recIdx = 1 To records.Count
        rec = records(recIdx)
        rec = Trim$(rec)
        If Len(rec) = 0 Then
            AddIssue issues, recIdx, "Structure", "", "Enregistrement vide (avant/entre <EOR>).", ""
            GoTo NextRecord
        End If
        
        ' Parse tags with ADIF length semantics
        Set tagMap = ParseAdifRecord(rec, issues, recIdx)
        
        ' Required fields checks
        CheckRequired tagMap, issues, recIdx, rec
        
        ' Date/time validation
        ValidateDateField tagMap, issues, recIdx
        ValidateTimeField tagMap, issues, recIdx
        
        ' Band / Freq validation
        ValidateBandFreq tagMap, issues, recIdx
        
        ' Mode (presence already checked)
        ' (Optional) Could normalize modes, but we just check presence above.
        
        ' Duplicate detection
        key = MakeDupKey(tagMap)
        If Len(key) > 0 Then
            If dupMap.Exists(key) Then
                AddIssue issues, recIdx, "Doublon", "KEY", "QSO probable en double (même CALL/DATE/TIME/BAND(or FREQ)/MODE).", ""
            Else
                dupMap.Add key, True
            End If
        End If
        
NextRecord:
        ' continue
    Next recIdx
    
    RenderIssuesToSheet issues, records.Count
    
    MsgBox "Validation terminée." & vbCrLf & _
           "Enregistrements scannés : " & records.Count & vbCrLf & _
           "Problèmes détectés : " & issues.Count, vbInformation, "ADIF Validator"
    Exit Sub
    
FailSoft:
    MsgBox "Erreur : " & Err.Number & " - " & Err.Description, vbExclamation, "ADIF Validator"
End Sub

' ---------- Helpers ----------

Private Function ReadAllText(ByVal path As String, ByRef hasNul As Boolean) As String
    Dim stm As Object ' ADODB.Stream for robust text reading without mangling bytes
    Dim txt As String
    On Error GoTo FallbackFSO
    
    ' Try ADODB.Stream to auto-detect encoding better than TextStream
    Set stm = CreateObject("ADODB.Stream")
    stm.Type = 2 ' text
    stm.Charset = "_autodetect_all"
    stm.Open
    stm.LoadFromFile path
    txt = stm.ReadText(-1)
    stm.Close
    hasNul = (InStr(1, txt, Chr$(0)) > 0)
    ReadAllText = txt
    Exit Function
    
FallbackFSO:
    Dim fso As Object, ts As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set ts = fso.OpenTextFile(path, 1, False)
    txt = ts.ReadAll
    ts.Close
    hasNul = (InStr(1, txt, Chr$(0)) > 0)
    ReadAllText = txt
End Function

Private Function SplitRecordsByEOR(ByVal body As String) As Collection
    Dim parts() As String
    Dim col As New Collection
    Dim i As Long
    
    parts = Split(UCase$(body), "<EOR>")
    ' Rebuild original-cased segments by using positions
    Dim pos As Long, lastPos As Long, up As String
    up = UCase$(body)
    lastPos = 1
    
    For i = 0 To UBound(parts)
        If i = UBound(parts) Then
            ' Last fragment may be leftover without <EOR>
            If lastPos <= Len(body) Then
                col.Add Mid$(body, lastPos)
            End If
        Else
            pos = InStr(lastPos, up, "<EOR>")
            If pos = 0 Then Exit For
            col.Add Mid$(body, lastPos, pos - lastPos)
            lastPos = pos + 5
        End If
    Next i
    
    Set SplitRecordsByEOR = col
End Function

Private Function ParseAdifRecord(ByVal rec As String, ByRef issues As Collection, ByVal recIdx As Long) As Object
    Dim i As Long, n As Long, j As Long
    Dim header As String, name As String, lstr As String, typ As String
    Dim colon1 As Long, colon2 As Long
    Dim value As String, declen As Long
    Dim map As Object
    Set map = CreateObject("Scripting.Dictionary")
    
    i = 1: n = Len(rec)
    Do While i <= n
        ' Find next tag start
        Do While i <= n And Mid$(rec, i, 1) <> "<"
            i = i + 1
        Loop
        If i > n Then Exit Do
        
        ' Find closing ">"
        j = InStr(i + 1, rec, ">")
        If j = 0 Then
            AddIssue issues, recIdx, "Structure", "", "Balise ouvrante sans '>' de fermeture.", Mid$(rec, i, 120)
            Exit Do
        End If
        
        header = Mid$(rec, i + 1, j - i - 1) ' NAME:len[:type]
        header = Trim$(header)
        If InStr(1, header, ":") = 0 Then
            AddIssue issues, recIdx, "Structure", "", "Balise sans longueur : '" & header & "'", ""
            i = j + 1
            GoTo ContinueLoop
        End If
        
        colon1 = InStr(1, header, ":")
        name = UCase$(Left$(header, colon1 - 1))
        lstr = Mid$(header, colon1 + 1)
        typ = ""
        colon2 = InStr(1, lstr, ":")
        If colon2 > 0 Then
            typ = Mid$(lstr, colon2 + 1)
            lstr = Left$(lstr, colon2 - 1)
        End If
        
        If Not IsNumeric(lstr) Then
            AddIssue issues, recIdx, "Structure", name, "Longueur ADIF non numérique : '" & lstr & "'", ""
            i = j + 1
            GoTo ContinueLoop
        End If
        
        declen = CLng(lstr)
        ' Extract value of declared length right after ">"
        If j + declen > n Then
            value = Mid$(rec, j + 1)
            AddIssue issues, recIdx, "Longueur", name, "Valeur plus courte que la longueur déclarée (" & declen & ").", value
            i = n + 1
            GoTo StoreValue
        Else
            value = Mid$(rec, j + 1, declen)
        End If
        
StoreValue:
        If Not map.Exists(name) Then map.Add name, value
        ' Soft check: if extra characters exist before next "<", ensure declared len matches
        Dim nextLt As Long
        nextLt = InStr(j + 1 + declen, rec, "<")
        If nextLt > 0 Then
            Dim gap As Long
            gap = nextLt - (j + 1 + declen)
            If gap > 0 And Trim$(Mid$(rec, j + 1 + declen, gap)) <> "" Then
                AddIssue issues, recIdx, "Longueur", name, "Des caractères suivent la valeur alors qu'une nouvelle balise est attendue. Longueur déclarée possiblement incorrecte.", _
                    Mid$(rec, j + 1, Application.Min(120, n - j))
            End If
        End If
        
        i = j + 1 + declen
        
ContinueLoop:
        ' continue scanning
    Loop
    
    Set ParseAdifRecord = map
End Function

Private Sub CheckRequired(ByVal tagMap As Object, ByRef issues As Collection, ByVal recIdx As Long, ByVal recRaw As String)
    Dim missing As String
    Dim needBand As Boolean
    
    missing = ""
    If Not tagMap.Exists("CALL") Or Len(Trim$(tagMap("CALL"))) = 0 Then missing = missing & "CALL,"
    If Not tagMap.Exists("QSO_DATE") Or Len(Trim$(tagMap("QSO_DATE"))) = 0 Then missing = missing & "QSO_DATE,"
    If Not tagMap.Exists("TIME_ON") Or Len(Trim$(tagMap("TIME_ON"))) = 0 Then missing = missing & "TIME_ON,"
    If Not tagMap.Exists("MODE") Or Len(Trim$(tagMap("MODE"))) = 0 Then missing = missing & "MODE,"
    
    needBand = Not tagMap.Exists("BAND") And Not tagMap.Exists("FREQ")
    If needBand Then missing = missing & "BAND/FREQ,"
    
    If Len(missing) > 0 Then
        missing = Left$(missing, Len(missing) - 1)
        AddIssue issues, recIdx, "Champs manquants", "", "Champs requis absents : " & missing, Left$(recRaw, 140)
    End If
End Sub

Private Sub ValidateDateField(ByVal tagMap As Object, ByRef issues As Collection, ByVal recIdx As Long)
    If Not tagMap.Exists("QSO_DATE") Then Exit Sub
    Dim d As String: d = Trim$(tagMap("QSO_DATE"))
    If Not d Like String(8, "#") Then
        AddIssue issues, recIdx, "Date", "QSO_DATE", "Format attendu YYYYMMDD (8 chiffres).", d
        Exit Sub
    End If
    
    Dim yyyy As Integer, mm As Integer, dd As Integer
    yyyy = CInt(Mid$(d, 1, 4)): mm = CInt(Mid$(d, 5, 2)): dd = CInt(Mid$(d, 7, 2))
    On Error GoTo BadDate
    Dim dt As Date
    dt = DateSerial(yyyy, mm, dd) ' will error if invalid
    If yyyy < 1900 Or yyyy > 2100 Then
        AddIssue issues, recIdx, "Date", "QSO_DATE", "Année hors plage raisonnable (1900–2100).", d
    End If
    Exit Sub
BadDate:
    AddIssue issues, recIdx, "Date", "QSO_DATE", "Date invalide (jour/mois incorrect).", d
End Sub

Private Sub ValidateTimeField(ByVal tagMap As Object, ByRef issues As Collection, ByVal recIdx As Long)
    If Not tagMap.Exists("TIME_ON") Then Exit Sub
    Dim t As String: t = Trim$(tagMap("TIME_ON"))
    If Not (Len(t) = 4 Or Len(t) = 6) Or Not t Like String(Len(t), "#") Then
        AddIssue issues, recIdx, "Heure", "TIME_ON", "Format attendu HHMM ou HHMMSS (UTC, chiffres uniquement).", t
        Exit Sub
    End If
    Dim hh As Integer, mn As Integer, ss As Integer
    hh = CInt(Mid$(t, 1, 2))
    mn = CInt(Mid$(t, 3, 2))
    ss = IIf(Len(t) = 6, CInt(Mid$(t, 5, 2)), 0)
    If hh < 0 Or hh > 23 Or mn < 0 Or mn > 59 Or ss < 0 Or ss > 59 Then
        AddIssue issues, recIdx, "Heure", "TIME_ON", "Heure hors plage (00:00[:00]–23:59[:59]).", t
    ElseIf Len(t) = 4 Then
        AddIssue issues, recIdx, "Avertissement", "TIME_ON", "Heure sans secondes (HHMM). Certains sites préfèrent HHMMSS.", t
    End If
End Sub

Private Sub ValidateBandFreq(ByVal tagMap As Object, ByRef issues As Collection, ByVal recIdx As Long)
    Dim band As String, freq As String
    band = ""
    freq = ""
    If tagMap.Exists("BAND") Then band = LCase$(Trim$(tagMap("BAND")))
    If tagMap.Exists("FREQ") Then freq = Trim$(tagMap("FREQ"))
    
    If band = "" And freq = "" Then Exit Sub ' Already flagged as missing
    
    If band <> "" Then
        If Not IsKnownBand(band) Then
            AddIssue issues, recIdx, "Bande", "BAND", "Bande inconnue/non standard.", band
        End If
    End If
    
    If freq <> "" Then
        If Not IsNumericDot(freq) Then
            AddIssue issues, recIdx, "Fréquence", "FREQ", "Fréquence non numérique (attendu décimal en MHz).", freq
        ElseIf CDbl(Replace(freq, ",", ".")) <= 0# Then
            AddIssue issues, recIdx, "Fréquence", "FREQ", "Fréquence doit être > 0.", freq
        End If
    End If
End Sub

Private Function IsKnownBand(ByVal b As String) As Boolean
    Dim known As Variant
    known = Array( _
        "2190m", "630m", "560m", "160m", "80m", "60m", "40m", "30m", "20m", "17m", "15m", "12m", "10m", _
        "8m", "6m", "5m", "4m", "2m", "1.25m", "70cm", "33cm", "23cm", "13cm", "9cm", "6cm", "3cm", "1.25cm", _
        "1cm", "6mm", "4mm", "2.5mm", "2mm", "1mm")
    Dim i As Long
    For i = LBound(known) To UBound(known)
        If b = CStr(known(i)) Then IsKnownBand = True: Exit Function
    Next i
    IsKnownBand = False
End Function

Private Function IsNumericDot(ByVal s As String) As Boolean
    Dim c As String, i As Long
    If Len(s) = 0 Then IsNumericDot = False: Exit Function
    For i = 1 To Len(s)
        c = Mid$(s, i, 1)
        If Not ((c >= "0" And c <= "9") Or c = "." Or c = ",") Then
            IsNumericDot = False: Exit Function
        End If
    Next i
    IsNumericDot = True
End Function

Private Function MakeDupKey(ByVal tagMap As Object) As String
    Dim callv As String, datev As String, timev As String, modev As String, bfreq As String
    If Not tagMap.Exists("CALL") Then Exit Function
    If Not tagMap.Exists("QSO_DATE") Then Exit Function
    If Not tagMap.Exists("TIME_ON") Then Exit Function
    If Not tagMap.Exists("MODE") Then Exit Function
    callv = UCase$(Trim$(tagMap("CALL")))
    datev = Trim$(tagMap("QSO_DATE"))
    timev = Trim$(tagMap("TIME_ON"))
    modev = UCase$(Trim$(tagMap("MODE")))
    If tagMap.Exists("BAND") Then
        bfreq = UCase$(Trim$(tagMap("BAND")))
    ElseIf tagMap.Exists("FREQ") Then
        bfreq = Trim$(tagMap("FREQ"))
    Else
        bfreq = ""
    End If
    MakeDupKey = callv & "|" & datev & "|" & timev & "|" & bfreq & "|" & modev
End Function

Private Sub AddIssue(ByRef issues As Collection, ByVal recIdx As Long, _
                     ByVal issueType As String, ByVal fieldName As String, _
                     ByVal message As String, ByVal context As String)
    Dim it As Variant
    it = Array(recIdx, issueType, fieldName, message, context)
    issues.Add it
End Sub

Private Sub RenderIssuesToSheet(ByVal issues As Collection, ByVal totalRecs As Long)
    Dim ws As Worksheet
    On Error Resume Next
    Set ws = ThisWorkbook.Worksheets("ADIF_Report")
    On Error GoTo 0
    If ws Is Nothing Then
        Set ws = ThisWorkbook.Worksheets.Add
        ws.Name = "ADIF_Report"
    Else
        ws.Cells.Clear
    End If
    
    ws.Range("A1:E1").Value = Array("Record #", "Type", "Champ", "Message", "Contexte")
    
    Dim r As Long, i As Long
    r = 2
    For i = 1 To issues.Count
        ws.Cells(r, 1).Value = issues(i)(0)
        ws.Cells(r, 2).Value = issues(i)(1)
        ws.Cells(r, 3).Value = issues(i)(2)
        ws.Cells(r, 4).Value = issues(i)(3)
        ws.Cells(r, 5).Value = issues(i)(4)
        r = r + 1
    Next i
    
    ' Summary top-left
    ws.Range("G1").Value = "Résumé"
    ws.Range("G2").Value = "Enregistrements scannés:"
    ws.Range("H2").Value = totalRecs
    ws.Range("G3").Value = "Problèmes détectés:"
    ws.Range("H3").Value = issues.Count
    
    ws.Columns("A:E").AutoFit
    ws.Rows("1:1").Font.Bold = True
End Sub