Imports System.IO

Module modFormatSQL

  '
  '*  SQL "Select" statement formatter/checker
  '
  '*  Author:  Si_the_geek of VBForums.com
  '
  '
  '* Example usage:
  '
  'Dim sSQL as String
  '  sSQL = "SELECT field1 FROM table1"
  '  sSQL = FormatSelect(sSQL)
  '  MsgBox sSQL


  Public Function FormatSelect(ByVal sInput As String, _
                               Optional ByVal bShowSpacerLines As Boolean = True, _
                               Optional ByVal lIndentSize As Integer = 10, _
                               Optional ByVal lIndentSubquerySize As Integer = 13) _
                               As String
    'Format an SQL "select" statement for easier reading

    'Also lists a few obvious errors if found, eg:
    '  - Sections (eg: FROM, WHERE) in the wrong order;
    '  - Wrong number of quotes, ie: a string/date is not closed properly;
    '  - Wrong number of brackets, ie: more ( than ) , or vice versa.

    'Current known omissions:
    '  does not start a new line for CASE WHEN (or other DBMS specific code)

    Dim sError As String = ""

    FormatSelect = FormatSelect_Worker(sInput, _
                                       sError, _
                                       bShowSpacerLines, _
                                       lIndentSize, _
                                       lIndentSubquerySize)

    If sError <> "" Then
      MsgBox("The following problems were found:" & vbCrLf & vbCrLf & sError, vbExclamation)
    End If

  End Function


  '* the following are helper functions for FormatSelect *


  Private Function FormatSelect_Worker(ByVal sInput As String, _
                                       ByRef ret_sWarnings As String, _
                                       Optional ByVal bSpacerLines As Boolean = True, _
                                       Optional ByVal lIndentSize As Integer = 10, _
                                       Optional ByVal lIndentSubquerySize As Integer = 13) _
                                       As String
    '(helper function for FormatSelect)

    'Format an SQL "select" statement for easier reading (also lists a few obvious errors)


    'Create keyword list array
    'Dim aKeywords As Object
    'aKeywords = Array("SELECT", "FROM", "WHERE", "GROUP BY", "HAVING", "ORDER BY")

    Dim aKeywords() As String = {"SELECT", "FROM", "WHERE", "GROUP BY", "HAVING", "ORDER BY"}

    'Setup variables
    Dim sRetString As String        'Text to return
    Dim sWarning As String          'Warning messages
    Dim sTempWarning As String = ""      'Potential warning messages froom sub queries
    Dim sText As String             '"Clean" text to work with
    Dim sIndent As String           'Space to indent 'normal' text by
    Dim sIndentSub As String        'Space to indent subqueries by
    Dim sTemp As String = ""            'Temporary text
    Dim aStrings(,) As String        'Strings within the SQL (temporarily removed, in case keywords found)
    Dim bGotStrings As Boolean      'Have we got any strings?
    Dim aSubQueries() As String     'Sub-queries within the SQL (temp. removed to aid formatting & simplify code)
    Dim bGotSubqueries As Boolean   'Have we got any sub-queries?
    Dim lCurrPos As Integer            'The current position within sText
    Dim lTempPos As Integer            'Position of text we just searched for
    Dim lTempPos2 As Integer           'Position of text we just searched for
    Dim lThisSectionType As Integer    'The type of section (from aKeywords) we are working with
    Dim lLastSectionType As Integer    'The type of the previous section (to show warnings)
    Dim lThisSectionStart As Integer   'The start position of this section
    Dim lNextSectionStart As Integer   'The start position of the next section (so we stop before it)
    Dim lCount As Integer              'Loop counter
    Dim bInQuotes As Boolean        'Are we currently inside single quotes? (for removing strings)
    sWarning = ""
    sRetString = ""
    sText = sInput
    sIndent = Space(lIndentSize)
    sIndentSub = Space(lIndentSubquerySize)

    'move all strings to array (so we dont find keywords in them)
    lCount = (Len(sText) - Len(Replace(Replace(Replace(sText, "'", ""), """", ""), "#", "")))
    'ReDim aStrings(1, lCount \ 2 + 1) As String
    ReDim aStrings(1, 0 To lCount \ 2 + 1)

    lCount = 0
    lCurrPos = 0
    bInQuotes = False
    lTempPos = InStr(1, sText, "'")
    lTempPos2 = InStr(1, sText, """")
    If (lTempPos = 0) Or (lTempPos2 > 0 And lTempPos2 < lTempPos) Then lTempPos = lTempPos2
    lTempPos2 = InStr(1, sText, "#")
    If (lTempPos = 0) Or (lTempPos2 > 0 And lTempPos2 < lTempPos) Then lTempPos = lTempPos2
    Do While (lTempPos > 0)
      sTemp = Mid$(sText, lTempPos, 1)
      aStrings(0, lCount) = sTemp
      If bInQuotes And (sTemp <> "#") Then
        Do While Mid$(sText, lTempPos, 2) = New String(sTemp, 2) 'String(2, sTemp)
          lTempPos = InStr(lTempPos + 2, sText, sTemp)
          If lTempPos = 0 Then Exit Do
        Loop
      End If
      If lTempPos = 0 Then Exit Do
      If bInQuotes Then
        aStrings(1, lCount) = Mid$(sText, lCurrPos, lTempPos - lCurrPos)
        sText = Left$(sText, lCurrPos - 1) & Mid$(sText, lTempPos)
        lCount = lCount + 1
        lTempPos = InStr(lCurrPos + 2, sText, "'")
        lTempPos2 = InStr(lCurrPos + 2, sText, """")
        If (lTempPos = 0) Or (lTempPos2 > 0 And lTempPos2 < lTempPos) Then lTempPos = lTempPos2
        lTempPos2 = InStr(lCurrPos + 2, sText, "#")
        If (lTempPos = 0) Or (lTempPos2 > 0 And lTempPos2 < lTempPos) Then lTempPos = lTempPos2
      Else
        lCurrPos = lTempPos + 1
        lTempPos = InStr(lTempPos + 1, sText, sTemp)
      End If
      bInQuotes = Not (bInQuotes)
    Loop
    If bInQuotes Then
      sWarning = sWarning _
               & "Incorrect number of quote (" & sTemp & " characters), a string/date is not closed!" _
               & vbCrLf & vbCrLf
    End If
    If lCount = 0 Then
      Erase aStrings
    Else
      ' ReDim Preserve aStrings(1, lCount - 1) As String
      ReDim Preserve aStrings(1, 0 To lCount - 1)

      bGotStrings = True
    End If

    'tidy input text
    sText = Trim$(Replace(Replace(sText, vbCr, " "), vbLf, " "))
    sText = Replace(sText, vbTab, " ")
    sTemp = "=<>+-/*"
    For lCount = 1 To Len(sTemp)
      sText = Replace(sText, Mid$(sTemp, lCount, 1), " " & Mid$(sTemp, lCount, 1) & " ")
    Next lCount
    sText = Replace(sText, ",", ", ")
    sText = Replace(Replace(sText, "(", " ( "), ")", " ) ")
    Do While InStr(sText, "  ")
      sText = Replace(sText, "  ", " ")
    Loop
    sText = Trim$(Replace(sText, " ,", ","))

    'move all subqueries to array (better formatting, and so we dont split on the wrong keywords)
    ' ReDim aSubQueries((Len(sText) - Len(Replace(sText, "( SELECT ", "", compare:=vbTextCompare))) \ 8 + 1) As String
    ReDim aSubQueries((Len(sText) - Len(Replace(sText, "( SELECT ", "", Compare:=vbTextCompare))) \ 8 + 1)

    lCount = 0
    lCurrPos = InStr(1, sText, "( SELECT ", vbTextCompare)
    Do While (lCurrPos > 0)
      lTempPos = FindCloseBracket(sText, lCurrPos)
      sTemp = FormatSelect_Worker(Mid$(sText, lCurrPos + 1, lTempPos - lCurrPos - 1), _
                                  sTempWarning, _
                                  bSpacerLines, _
                                  lIndentSize, _
                                  lIndentSubquerySize)
      If sTempWarning <> "" Then
        sWarning = sWarning _
                 & "(in sub-query: " _
                 & vbCrLf _
                 & "  " & Replace(sTempWarning, vbCrLf, vbCrLf & "  ") _
                 & ")" _
                 & vbCrLf & vbCrLf
      End If
      sTemp = vbCrLf _
            & sIndentSub _
            & Replace(sTemp, vbCrLf, vbCrLf & sIndentSub)
      aSubQueries(lCount) = sTemp
      sText = Left$(sText, lCurrPos) _
            & vbCrLf _
            & sIndentSub _
            & Mid$(sText, lTempPos)
      lCount = lCount + 1
      lCurrPos = InStr(lCurrPos + 1, sText, "( SELECT ", vbTextCompare)
    Loop
    If lCount = 0 Then
      Erase aSubQueries
    Else
      ' ReDim Preserve aSubQueries(lCount - 1) As String
      ReDim Preserve aSubQueries(lCount - 1)

      bGotSubqueries = True
    End If

    'count brackets to ensure a match
    lCount = (Len(sText) - Len(Replace(sText, "(", "")))
    lCount = lCount - (Len(sText) - Len(Replace(sText, ")", "")))
    Select Case Math.Sign(lCount)
      Case 1
        sWarning = sWarning _
                 & "You have " & lCount & " more open brackets: ( than close brackets: )  This may make any subqueries be invalid!" _
                 & vbCrLf & vbCrLf
      Case -1
        sWarning = sWarning _
                 & "You have " & Math.Abs(lCount) & " more close brackets: ) than open brackets: (  This may make any subqueries be invalid!" _
                 & vbCrLf & vbCrLf
    End Select


    'work with text...
    lCurrPos = 1
    lThisSectionType = -1
    Do While lCurrPos < Len(sInput)
      'find current section type & position
      lLastSectionType = lThisSectionType
      lThisSectionStart = FindFirstByArray(sText, aKeywords, lCurrPos, lThisSectionType)
      'if any "incorrect" text, add it to a new line
      If lThisSectionStart > lCurrPos Then
        sRetString = sRetString _
                   & Mid$(sText, lCurrPos, lThisSectionStart - lCurrPos - 1) _
                   & vbCrLf
        sWarning = sWarning _
                 & "Unexpected text: " _
                 & Mid$(sText, lCurrPos, lThisSectionStart - lCurrPos - 1) _
                 & vbCrLf & vbCrLf
      End If
      'if reached end of text, exit!
      If lThisSectionStart >= Len(sText) Then Exit Do
      'if sections ordered wrong, add to warning
      If lLastSectionType > lThisSectionType Then
        sWarning = sWarning _
                 & "Incorrect section ordering: " _
                 & aKeywords(lThisSectionType) _
                 & " should be before " _
                 & aKeywords(lLastSectionType) _
                 & vbCrLf & vbCrLf
      End If

      If bSpacerLines Then
        'add blank lines between sections
        If (lCurrPos > 1) Then
          sRetString = sRetString _
                     & vbCrLf
        End If
      End If

      'add keyword (Ucase), and spaces to indent
      If Len(aKeywords(lThisSectionType)) >= lIndentSize Then
        sRetString = sRetString & aKeywords(lThisSectionType) & " "
      Else
        sRetString = sRetString & aKeywords(lThisSectionType) & Space(Len(sIndent) - Len(aKeywords(lThisSectionType)))
      End If
      lCurrPos = lCurrPos + Len(aKeywords(lThisSectionType)) + 1
      lThisSectionStart = lThisSectionStart + Len(aKeywords(lThisSectionType)) + 1
      'find end of current section
      lNextSectionStart = FindFirstByArray(sText, aKeywords, lCurrPos)

      'work on each section...
      Dim lBracketStart As Integer
      Dim lBracketEnd As Integer
      'Dim aTempArray As Object
      Dim aTempArray() As String
      Dim lTempIndex As Integer
      Dim lTempLen As Integer
      Dim lTempInc As Integer
      Select Case aKeywords(lThisSectionType)

        Case "SELECT", "GROUP BY", "ORDER BY"
          lTempPos = lCurrPos
          Do
            Do
              lBracketStart = InStr(lTempPos, sText, "(")
              lTempPos = InStr(lTempPos, sText, ",")
              If (lBracketStart > 0) And (lBracketStart < lTempPos) And (lBracketStart < lNextSectionStart) Then
                lBracketEnd = FindCloseBracket(sText, lBracketStart)
                If lBracketEnd < lNextSectionStart Then
                  lTempPos = lBracketEnd - 1
                Else
                  lBracketStart = 0
                End If
              Else
                lBracketStart = 0
              End If
            Loop While (lBracketStart > 0) And (lTempPos > 0)
            If (lTempPos = 0) Or (lTempPos >= lNextSectionStart) Then lTempPos = lNextSectionStart - 1
            If (lTempPos > lCurrPos) Then
              sRetString = sRetString _
                         & Trim$(Mid$(sText, lCurrPos, lTempPos - lCurrPos + 1)) _
                         & vbCrLf
              If (lTempPos < lNextSectionStart - 1) Then
                sRetString = sRetString _
                           & sIndent
              End If
            End If
            lCurrPos = lTempPos + 1
            lTempPos = lCurrPos
          Loop While (lTempPos < lNextSectionStart) And (lCurrPos < lNextSectionStart)

        Case "FROM"
          'aTempArray = Array("INNER JOIN", "LEFT OUTER JOIN", "RIGHT OUTER JOIN", _
          '                   "LEFT JOIN", "RIGHT JOIN", "OUTER JOIN", "OUTER", _
          '                   "CROSS JOIN", "JOIN")


          aTempArray = {"INNER JOIN", "LEFT OUTER JOIN", "RIGHT OUTER JOIN", _
                             "LEFT JOIN", "RIGHT JOIN", "OUTER JOIN", "OUTER", _
                             "CROSS JOIN", "JOIN"}
          Do
            lTempPos = FindFirstByArray(sText, aTempArray, lCurrPos, lTempIndex)
            If (lTempPos < Len(sText)) And (lTempPos < lNextSectionStart) Then
              lTempLen = Len(aTempArray(lTempIndex))
              sRetString = sRetString _
                         & Trim$(Mid$(sText, lCurrPos, lTempPos - lCurrPos - 1)) _
                         & vbCrLf _
                         & sIndent _
                         & aTempArray(lTempIndex) _
                         & " "
              lCurrPos = lTempPos + lTempLen
            End If
          Loop While (lTempPos < Len(sText)) And (lTempPos < lNextSectionStart)
          If (lCurrPos < lNextSectionStart) Then
            sRetString = sRetString _
                       & Trim$(Mid$(sText, lCurrPos, lNextSectionStart - lCurrPos)) _
                       & vbCrLf
          End If

        Case "WHERE", "HAVING"
          aTempArray = {"AND", "OR", "BETWEEN"}
          Do
            lTempInc = 0
            Do
              lTempPos = FindFirstByArray(sText, aTempArray, lCurrPos + lTempInc, lTempIndex)
              'need to skip the 'And' in a Between clause
              If (lTempIndex = 2) Then
                lTempInc = InStr(lTempPos, sText, "AND", vbTextCompare) + 1 - lCurrPos
                If lTempInc < 0 Then lTempInc = 7
              End If
            Loop While (lTempIndex = 2)
            If (lTempPos < Len(sText)) And (lTempPos < lNextSectionStart) Then
              lTempLen = Len(aTempArray(lTempIndex))
              sRetString = sRetString _
                         & Trim$(Mid$(sText, lCurrPos, lTempPos - lCurrPos)) _
                         & vbCrLf _
                         & sIndent _
                         & aTempArray(lTempIndex) _
                         & " "
              lCurrPos = lTempPos + lTempLen
            End If
          Loop While (lTempPos < Len(sText)) And (lTempPos < lNextSectionStart)
          If (lCurrPos < lNextSectionStart) Then
            sRetString = sRetString _
                       & Trim$(Mid$(sText, lCurrPos, lNextSectionStart - lCurrPos)) _
                       & vbCrLf
          End If

        Case Else     'a section not coded for - just paste the text!
          sRetString = sRetString _
                     & sIndent _
                     & Trim$(Mid$(sText, lCurrPos, lNextSectionStart - lCurrPos)) _
                     & vbCrLf
      End Select

      lCurrPos = lNextSectionStart
    Loop

    '(main statement finished)

    're-insert the sub-queries we removed at the start
    If bGotSubqueries Then
      If bSpacerLines Then
        For lCount = 0 To UBound(aSubQueries)
          sRetString = Replace(sRetString, _
                               "(" & vbCrLf & sIndentSub & ")", _
                               "(" & vbCrLf & aSubQueries(lCount) & vbCrLf & vbCrLf & sIndentSub & ")", _
                               1, _
                               1)
        Next lCount
      Else
        For lCount = 0 To UBound(aSubQueries)
          sRetString = Replace(sRetString, _
                               "(" & vbCrLf & sIndentSub & ")", _
                               "(" & aSubQueries(lCount) & vbCrLf & sIndentSub & ")", _
                               1, _
                               1)
        Next lCount
      End If
    End If

    're-insert the strings we removed at the start
    If bGotStrings Then
      For lCount = 0 To UBound(aStrings, 2)
        'sRetString = Replace(sRetString, _
        '                     String(2, aStrings(0, lCount)), _
        '                     aStrings(0, lCount) & aStrings(1, lCount) & aStrings(0, lCount), _
        '                     1, _
        '                     1)

        sRetString = Replace(sRetString, _
                             New String(aStrings(0, lCount), 2), _
                             aStrings(0, lCount) & aStrings(1, lCount) & aStrings(0, lCount), _
                             1, _
                             1)


      Next lCount
    End If

    'return any warning messages
    If sWarning <> "" Then
      ret_sWarnings = sWarning
    End If

    'return formatted text
    FormatSelect_Worker = Left$(sRetString, Len(sRetString) - Len(vbCrLf))

  End Function


  Private Function FindCloseBracket(sText As String, _
                                    Optional lStartPos As Integer = 1) _
                                    As Integer
    '(helper function for FormatSelect)

    'Returns the position of the closing bracket to match the opening bracket at the position 'lStartPos',
    '(or length of string+1 if not found)

    Dim lCurrPos As Integer
    Dim lOpenPos As Integer
    Dim lClosePos As Integer
    Dim lOpenCount As Integer

    lOpenCount = 1
    lCurrPos = lStartPos + 1
    FindCloseBracket = Len(sText) + 1

    lOpenPos = InStr(lCurrPos, sText, "(")
    lClosePos = InStr(lCurrPos, sText, ")")
    Do While (lOpenPos > 0) Or (lClosePos > 0)
      If (lOpenPos > 0 And lOpenPos < lClosePos) Or (lClosePos = 0) Then
        lOpenCount = lOpenCount + 1
        lCurrPos = lOpenPos + 1
        lOpenPos = InStr(lCurrPos, sText, "(")
      Else
        lOpenCount = lOpenCount - 1
        If lOpenCount = 0 Then
          FindCloseBracket = lClosePos
          Exit Do
        End If
        lCurrPos = lClosePos + 1
        lClosePos = InStr(lCurrPos, sText, ")")
      End If
    Loop

  End Function

  '                                  vArray() As string, _

  Private Function FindFirstByArray(sText As String, _
                                    vArray() As String, _
                                    Optional lStartPos As Integer = 1, _
                                    Optional ByRef retArrayIndex As Integer = -1) _
                                    As Integer
    '(helper function for FormatSelect)

    'Returns the position of first instance in the string of any array item (or length of string+1 if none found)
    'nb: must be after some kind of punctuation as listed below

    Const csPunctuation = " '""#()=<>[]+-/*"

    Dim lFirstPos As Integer
    Dim lArrayIndex As Integer
    Dim lTempPos As Integer
    Dim lCount As Integer
    Dim bOK As Boolean

    lFirstPos = Len(sText) + 1
    lArrayIndex = 0

    For lCount = 0 To UBound(vArray)
      lTempPos = InStr(lStartPos, sText, vArray(lCount), vbTextCompare)
      Do While (lTempPos >= lStartPos)
        bOK = False    'check prev char is punctuation/start
        If (lTempPos = lStartPos) Then
          bOK = True
        Else
          If InStr(csPunctuation, Mid$(sText, lTempPos - 1, 1)) Then
            bOK = True
          End If
        End If
        If bOK Then    'check next char is punctuation/end
          If lTempPos + Len(vArray(lCount)) > Len(sText) Then Exit Do
          If InStr(csPunctuation, Mid$(sText, lTempPos + Len(vArray(lCount)), 1)) Then Exit Do
        End If
        lTempPos = InStr(lTempPos + 1, sText, vArray(lCount), vbTextCompare)
      Loop
      If (lTempPos > 0) And (lTempPos < lFirstPos) Then
        lFirstPos = lTempPos
        lArrayIndex = lCount
      End If
    Next lCount

    retArrayIndex = IIf(lFirstPos = Len(sText), -1, lArrayIndex)
    FindFirstByArray = lFirstPos

  End Function
End Module