Attribute VB_Name = "modIdExport"
Option Explicit

' AutoCAD VBA exporter for the future ID acts application.
' The source file is ASCII-only so it can be imported by the VBA editor
' regardless of the Windows system code page.
'
' Output workbook schema:
'   Pipes  - one row per diameter found in a leader
'   Issues - leaders that require manual review
'   Meta   - schema and source drawing information
'
' The application should ask the user for road-crossing flags after import.

Private Const EXPORT_SCHEMA As String = "id-acts-pipes/1"
Private Const XLSX_FORMAT As Long = 51

Public Sub ExportPipesForIdActs()

    Dim ss As AcadSelectionSet
    Dim ent As AcadEntity
    Dim ssName As String

    Dim rawText As String
    Dim cleanText As String
    Dim segmentLength As Double
    Dim hasLength As Boolean
    Dim methodName As String
    Dim isExisting As Boolean
    Dim drawingRef As String

    Dim diameters As Collection
    Dim quantities As Collection
    Dim parseNote As String

    Dim xlApp As Object
    Dim wb As Object
    Dim wsPipes As Object
    Dim wsIssues As Object
    Dim wsMeta As Object

    Dim pipeRow As Long
    Dim issueRow As Long
    Dim recordNumber As Long
    Dim textObjectCount As Long
    Dim exportedCount As Long
    Dim issueCount As Long
    Dim i As Long

    Dim diameterMm As Long
    Dim pipeCount As Long
    Dim totalPipeMeters As Double
    Dim statusText As String
    Dim savePath As Variant
    Dim selectedHandles As Object

    ssName = "TEMP_ID_ACTS_EXPORT"

    On Error Resume Next
    ThisDrawing.SelectionSets.Item(ssName).Delete
    On Error GoTo ErrHandler

    Set ss = ThisDrawing.SelectionSets.Add(ssName)
    Set selectedHandles = CreateObject("Scripting.Dictionary")

    ThisDrawing.Utility.Prompt vbCrLf & _
        "Select pipe leaders for the ID acts export..." & vbCrLf

    On Error Resume Next
    ss.SelectOnScreen

    If Err.Number <> 0 Then
        Err.Clear
        MsgBox "Selection was cancelled.", vbInformation, "ID acts export"
        GoTo CleanExit
    End If

    On Error GoTo ErrHandler

    If ss.Count = 0 Then
        MsgBox "No objects were selected.", vbExclamation, "ID acts export"
        GoTo CleanExit
    End If

    Set xlApp = CreateObject("Excel.Application")
    xlApp.Visible = True
    xlApp.DisplayAlerts = False

    Set wb = xlApp.Workbooks.Add
    Set wsPipes = wb.Worksheets(1)
    wsPipes.Name = "Pipes"

    Set wsIssues = wb.Worksheets.Add(, wsPipes)
    wsIssues.Name = "Issues"

    Set wsMeta = wb.Worksheets.Add(, wsIssues)
    wsMeta.Name = "Meta"

    PreparePipesSheet wsPipes
    PrepareIssuesSheet wsIssues
    PrepareMetaSheet wsMeta

    pipeRow = 2
    issueRow = 2
    recordNumber = 1

    For Each ent In ss

        If IsSupportedTextEntity(ent) Then

            textObjectCount = textObjectCount + 1

            If SafeEntityHandle(ent) <> "" Then
                selectedHandles(SafeEntityHandle(ent)) = True
            End If

            rawText = GetEntityText(ent)
            cleanText = CleanMTextFormatting(rawText)

            hasLength = TryGetLengthValue(cleanText, segmentLength)
            methodName = DetectMethod(cleanText)
            isExisting = DetectExisting(cleanText)
            drawingRef = ExtractDrawingReference(cleanText)

            Set diameters = New Collection
            Set quantities = New Collection
            parseNote = ""

            ParsePipeSpecifications cleanText, diameters, quantities, parseNote

            statusText = ""

            If Not hasLength Then
                statusText = AddNote(statusText, "L_NOT_FOUND")
            End If

            If diameters.Count = 0 Then
                statusText = AddNote(statusText, "PIPE_SPEC_NOT_FOUND")
            End If

            If parseNote <> "" Then
                statusText = AddNote(statusText, parseNote)
            End If

            If statusText = "" Then

                For i = 1 To diameters.Count

                    diameterMm = CLng(diameters.Item(i))
                    pipeCount = CLng(quantities.Item(i))
                    totalPipeMeters = segmentLength * pipeCount

                    wsPipes.Cells(pipeRow, 1).Value = _
                        "P-" & Format$(recordNumber, "0000")
                    wsPipes.Cells(pipeRow, 2).Value = cleanText
                    wsPipes.Cells(pipeRow, 3).Value = SafeEntityHandle(ent)
                    wsPipes.Cells(pipeRow, 4).Value = SafeEntityLayer(ent)
                    wsPipes.Cells(pipeRow, 5).Value = segmentLength
                    wsPipes.Cells(pipeRow, 6).Value = diameterMm
                    wsPipes.Cells(pipeRow, 7).Value = pipeCount
                    wsPipes.Cells(pipeRow, 8).Value = totalPipeMeters
                    wsPipes.Cells(pipeRow, 9).Value = methodName
                    wsPipes.Cells(pipeRow, 10).Value = BoolForExport(isExisting)

                    ' Deliberately blank. This is a manual checkbox in the app.
                    wsPipes.Cells(pipeRow, 11).Value = ""

                    wsPipes.Cells(pipeRow, 12).Value = drawingRef
                    wsPipes.Cells(pipeRow, 13).Value = "OK"

                    pipeRow = pipeRow + 1
                    recordNumber = recordNumber + 1
                    exportedCount = exportedCount + 1

                Next i

            Else

                wsIssues.Cells(issueRow, 1).Value = _
                    "I-" & Format$(issueCount + 1, "0000")
                wsIssues.Cells(issueRow, 2).Value = cleanText
                wsIssues.Cells(issueRow, 3).Value = SafeEntityHandle(ent)
                wsIssues.Cells(issueRow, 4).Value = SafeEntityLayer(ent)
                wsIssues.Cells(issueRow, 5).Value = statusText

                issueRow = issueRow + 1
                issueCount = issueCount + 1

            End If

        End If

    Next ent

    ' Catch valid pipe leaders that were accidentally missed during selection.
    ' They are listed for review and are not silently added to the import.
    FindUnselectedPipeLeaders selectedHandles, wsIssues, issueRow, issueCount

    WriteMeta wsMeta, textObjectCount, exportedCount, issueCount
    FormatPipesSheet wsPipes, pipeRow - 1
    FormatIssuesSheet wsIssues, issueRow - 1
    FormatMetaSheet wsMeta

    wsPipes.Activate

    savePath = xlApp.GetSaveAsFilename( _
        DefaultExportPath(), _
        "Excel Workbook (*.xlsx), *.xlsx", _
        1, _
        "Save ID acts import file")

    If VarType(savePath) = vbBoolean Then

        xlApp.DisplayAlerts = True

        MsgBox "The workbook is ready but has not been saved." & vbCrLf & _
               "Use File > Save As in Excel when ready.", _
               vbInformation, "ID acts export"

    Else

        wb.SaveAs CStr(savePath), XLSX_FORMAT
        xlApp.DisplayAlerts = True

        MsgBox "Export completed." & vbCrLf & vbCrLf & _
               "Imported rows: " & CStr(exportedCount) & vbCrLf & _
               "Rows requiring review: " & CStr(issueCount) & vbCrLf & vbCrLf & _
               CStr(savePath), _
               vbInformation, "ID acts export"

    End If

CleanExit:
    On Error Resume Next
    If Not ss Is Nothing Then ss.Delete
    On Error GoTo 0
    Exit Sub

ErrHandler:
    MsgBox "Export error: " & Err.Description, vbCritical, "ID acts export"

    On Error Resume Next
    If Not xlApp Is Nothing Then xlApp.DisplayAlerts = True
    If Not ss Is Nothing Then ss.Delete
    On Error GoTo 0

End Sub

Private Function IsSupportedTextEntity(ByVal ent As AcadEntity) As Boolean

    IsSupportedTextEntity = False

    Select Case ent.ObjectName
        Case "AcDbText", "AcDbMText", "AcDbMLeader"
            IsSupportedTextEntity = True
    End Select

End Function

Private Function GetEntityText(ByVal ent As AcadEntity) As String

    On Error GoTo ReadFailed

    Select Case ent.ObjectName
        Case "AcDbText", "AcDbMText", "AcDbMLeader"
            GetEntityText = ent.TextString
        Case Else
            GetEntityText = ""
    End Select

    Exit Function

ReadFailed:
    GetEntityText = ""

End Function

Private Function SafeEntityHandle(ByVal ent As AcadEntity) As String

    On Error GoTo ReadFailed
    SafeEntityHandle = CStr(ent.Handle)
    Exit Function

ReadFailed:
    SafeEntityHandle = ""

End Function

Private Function SafeEntityLayer(ByVal ent As AcadEntity) As String

    On Error GoTo ReadFailed
    SafeEntityLayer = CStr(ent.Layer)
    Exit Function

ReadFailed:
    SafeEntityLayer = ""

End Function

Private Function CleanMTextFormatting(ByVal value As String) As String

    If value = "" Then
        CleanMTextFormatting = ""
        Exit Function
    End If

    value = Replace(value, vbCr, " ")
    value = Replace(value, vbLf, " ")
    value = Replace(value, Chr(160), " ")

    ' Remove formatting controls before handling the paragraph marker.
    ' Otherwise a lowercase control such as \pxsm1; leaves "xsm1;" behind.
    value = RemoveRegex(value, "\\[fF][^;]*;")
    value = RemoveRegex(value, "\\[cC][0-9]+;")
    value = RemoveRegex(value, "\\[pP][^;]*;")
    value = RemoveRegex(value, "\\[aAhHwWtTqQ][^;]*;")

    value = Replace(value, "\P", " ", 1, -1, vbBinaryCompare)
    value = Replace(value, "\~", " ", 1, -1, vbBinaryCompare)

    value = Replace(value, "%%c", ChrW(&HD8), 1, -1, vbTextCompare)
    value = Replace(value, "\U+00D8", ChrW(&HD8), 1, -1, vbTextCompare)
    value = Replace(value, "\U+2205", ChrW(&HD8), 1, -1, vbTextCompare)

    value = Replace(value, "{", "")
    value = Replace(value, "}", "")

    value = Replace(value, "\L", "", 1, -1, vbTextCompare)
    value = Replace(value, "\O", "", 1, -1, vbTextCompare)
    value = Replace(value, "\l", "", 1, -1, vbTextCompare)
    value = Replace(value, "\o", "", 1, -1, vbTextCompare)

    Do While InStr(value, "  ") > 0
        value = Replace(value, "  ", " ")
    Loop

    CleanMTextFormatting = Trim$(value)

End Function

Private Function RemoveRegex(ByVal value As String, _
                             ByVal pattern As String) As String

    Dim re As Object
    Set re = CreateObject("VBScript.RegExp")

    With re
        .Global = True
        .IgnoreCase = True
        .pattern = pattern
    End With

    RemoveRegex = re.Replace(value, "")

End Function

Private Function TryGetLengthValue(ByVal value As String, _
                                   ByRef resultValue As Double) As Boolean

    Dim re As Object
    Dim matches As Object
    Dim numberText As String
    Dim ruLetterL As String

    resultValue = 0
    TryGetLengthValue = False

    ruLetterL = ChrW(&H41B) & ChrW(&H43B)

    Set re = CreateObject("VBScript.RegExp")

    With re
        .Global = False
        .IgnoreCase = True
        .pattern = "[Ll" & ruLetterL & "]\s*=\s*([0-9]+([.,][0-9]+)?)"
    End With

    If re.Test(value) Then
        Set matches = re.Execute(value)
        numberText = matches(0).SubMatches(0)
        numberText = Replace(numberText, ",", ".")
        resultValue = Val(numberText)
        TryGetLengthValue = True
    End If

End Function

Private Sub ParsePipeSpecifications(ByVal value As String, _
                                    ByRef diameters As Collection, _
                                    ByRef quantities As Collection, _
                                    ByRef note As String)

    Dim re As Object
    Dim matches As Object
    Dim matchItem As Object
    Dim qty As Long
    Dim diameterMm As Long
    Dim ruTr As String
    Dim ruTrub As String
    Dim ruA As String
    Dim ruY As String

    note = ""

    ' Russian tokens are built with Unicode code points to keep this .bas file
    ' safe to import on systems with different ANSI code pages.
    ruTr = ChrW(&H442) & ChrW(&H440)
    ruTrub = ruTr & ChrW(&H443) & ChrW(&H431)
    ruA = ChrW(&H430)
    ruY = ChrW(&H44B)

    Set re = CreateObject("VBScript.RegExp")

    With re
        .Global = True
        .IgnoreCase = True
        .pattern = "([0-9]+)\s*(" & _
                   ruTr & "\.?|" & _
                   ruTrub & "\.?|" & _
                   ruTrub & "[" & ruA & ruY & "]?)" & _
                   "\s*[^0-9]{0,80}?([0-9]{2,3})\b"
    End With

    If Not re.Test(value) Then Exit Sub

    Set matches = re.Execute(value)

    For Each matchItem In matches

        qty = CLng(matchItem.SubMatches(0))
        diameterMm = CLng(matchItem.SubMatches(2))

        If qty <= 0 Then
            note = AddNote(note, "INVALID_PIPE_COUNT")
        ElseIf diameterMm <= 0 Then
            note = AddNote(note, "INVALID_DIAMETER")
        Else
            quantities.Add qty
            diameters.Add diameterMm
        End If

    Next matchItem

End Sub

Private Sub FindUnselectedPipeLeaders(ByVal selectedHandles As Object, _
                                      ByVal wsIssues As Object, _
                                      ByRef issueRow As Long, _
                                      ByRef issueCount As Long)

    Dim candidate As AcadEntity
    Dim candidateHandle As String
    Dim cleanText As String
    Dim segmentLength As Double
    Dim diameters As Collection
    Dim quantities As Collection
    Dim parseNote As String

    For Each candidate In ThisDrawing.ModelSpace

        If IsSupportedTextEntity(candidate) Then

            candidateHandle = SafeEntityHandle(candidate)

            If candidateHandle <> "" Then

                If Not selectedHandles.Exists(candidateHandle) Then

                    cleanText = CleanMTextFormatting(GetEntityText(candidate))
                    Set diameters = New Collection
                    Set quantities = New Collection
                    parseNote = ""

                    ParsePipeSpecifications _
                        cleanText, diameters, quantities, parseNote

                    If TryGetLengthValue(cleanText, segmentLength) And _
                       diameters.Count > 0 Then

                        wsIssues.Cells(issueRow, 1).Value = _
                            "I-" & Format$(issueCount + 1, "0000")
                        wsIssues.Cells(issueRow, 2).Value = cleanText
                        wsIssues.Cells(issueRow, 3).Value = candidateHandle
                        wsIssues.Cells(issueRow, 4).Value = _
                            SafeEntityLayer(candidate)
                        wsIssues.Cells(issueRow, 5).Value = _
                            "PIPE_LEADER_NOT_SELECTED"

                        issueRow = issueRow + 1
                        issueCount = issueCount + 1

                    End If

                End If

            End If

        End If

    Next candidate

End Sub

Private Function DetectMethod(ByVal value As String) As String

    Dim ruGnb As String

    ruGnb = ChrW(&H413) & ChrW(&H41D) & ChrW(&H411)

    If InStr(1, value, "GNB", vbTextCompare) > 0 Or _
       InStr(1, value, ruGnb, vbTextCompare) > 0 Then
        DetectMethod = "GNB"
    Else
        DetectMethod = "OPEN"
    End If

End Function

Private Function DetectExisting(ByVal value As String) As Boolean

    Dim ruSusch As String

    ruSusch = ChrW(&H441) & ChrW(&H443) & ChrW(&H449)

    DetectExisting = (InStr(1, value, ruSusch, vbTextCompare) > 0)

End Function

Private Function ExtractDrawingReference(ByVal value As String) As String

    Dim re As Object
    Dim matches As Object

    ExtractDrawingReference = ""

    Set re = CreateObject("VBScript.RegExp")

    With re
        .Global = False
        .IgnoreCase = True
        .pattern = "\[([^\]]+)\]"
    End With

    If re.Test(value) Then
        Set matches = re.Execute(value)
        ExtractDrawingReference = Trim$(matches(0).SubMatches(0))
    End If

End Function

Private Function BoolForExport(ByVal value As Boolean) As String

    If value Then
        BoolForExport = "TRUE"
    Else
        BoolForExport = "FALSE"
    End If

End Function

Private Function AddNote(ByVal oldNote As String, _
                         ByVal newNote As String) As String

    oldNote = Trim$(oldNote)
    newNote = Trim$(newNote)

    If newNote = "" Then
        AddNote = oldNote
    ElseIf oldNote = "" Then
        AddNote = newNote
    Else
        AddNote = oldNote & ";" & newNote
    End If

End Function

Private Function DefaultExportPath() As String

    Dim folderPath As String
    Dim drawingName As String
    Dim dotPosition As Long

    folderPath = ThisDrawing.Path
    drawingName = ThisDrawing.Name

    dotPosition = InStrRev(drawingName, ".")
    If dotPosition > 1 Then
        drawingName = Left$(drawingName, dotPosition - 1)
    End If

    If folderPath = "" Then
        folderPath = Environ$("USERPROFILE") & "\Desktop"
    End If

    DefaultExportPath = folderPath & "\" & drawingName & "_ID_import.xlsx"

End Function

Private Sub PreparePipesSheet(ByVal ws As Object)

    Dim headers As Variant
    Dim i As Long

    headers = Array( _
        "record_id", _
        "source_text", _
        "source_handle", _
        "source_layer", _
        "segment_length_m", _
        "diameter_mm", _
        "pipe_count", _
        "total_pipe_m", _
        "method", _
        "is_existing", _
        "road_crossing", _
        "drawing_ref", _
        "status")

    For i = LBound(headers) To UBound(headers)
        ws.Cells(1, i + 1).Value = headers(i)
    Next i

    ws.Rows(1).Font.Bold = True
    ws.Rows(1).AutoFilter

End Sub

Private Sub PrepareIssuesSheet(ByVal ws As Object)

    ws.Cells(1, 1).Value = "issue_id"
    ws.Cells(1, 2).Value = "source_text"
    ws.Cells(1, 3).Value = "source_handle"
    ws.Cells(1, 4).Value = "source_layer"
    ws.Cells(1, 5).Value = "reason"

    ws.Rows(1).Font.Bold = True
    ws.Rows(1).AutoFilter

End Sub

Private Sub PrepareMetaSheet(ByVal ws As Object)

    ws.Cells(1, 1).Value = "key"
    ws.Cells(1, 2).Value = "value"
    ws.Rows(1).Font.Bold = True

End Sub

Private Sub WriteMeta(ByVal ws As Object, _
                      ByVal selectedTextObjects As Long, _
                      ByVal exportedRows As Long, _
                      ByVal issueRows As Long)

    ws.Cells(2, 1).Value = "schema"
    ws.Cells(2, 2).Value = EXPORT_SCHEMA

    ws.Cells(3, 1).Value = "source_drawing"
    ws.Cells(3, 2).Value = ThisDrawing.FullName

    ws.Cells(4, 1).Value = "selected_text_objects"
    ws.Cells(4, 2).Value = selectedTextObjects

    ws.Cells(5, 1).Value = "exported_pipe_rows"
    ws.Cells(5, 2).Value = exportedRows

    ws.Cells(6, 1).Value = "issue_rows"
    ws.Cells(6, 2).Value = issueRows

End Sub

Private Sub FormatPipesSheet(ByVal ws As Object, ByVal lastRow As Long)

    If lastRow < 1 Then lastRow = 1

    With ws
        .Columns("A:M").AutoFit
        .Columns("B:B").ColumnWidth = 65
        .Columns("B:B").WrapText = True
        .Columns("D:D").ColumnWidth = 22

        .Range("E:E").NumberFormat = "0.00"
        .Range("H:H").NumberFormat = "0.00"

        .Range(.Cells(1, 1), .Cells(lastRow, 13)).Borders.LineStyle = 1
        .Range(.Cells(1, 1), .Cells(lastRow, 13)).VerticalAlignment = -4108
    End With

End Sub

Private Sub FormatIssuesSheet(ByVal ws As Object, ByVal lastRow As Long)

    If lastRow < 1 Then lastRow = 1

    With ws
        .Columns("A:E").AutoFit
        .Columns("B:B").ColumnWidth = 65
        .Columns("B:B").WrapText = True
        .Range(.Cells(1, 1), .Cells(lastRow, 5)).Borders.LineStyle = 1
        .Range(.Cells(1, 1), .Cells(lastRow, 5)).VerticalAlignment = -4108
    End With

End Sub

Private Sub FormatMetaSheet(ByVal ws As Object)

    ws.Columns("A:B").AutoFit
    ws.Columns("B:B").ColumnWidth = 70
    ws.Columns("B:B").WrapText = True

End Sub