Prospecting/app/lib/lib.ImportFile.asp

<%
'=======================================================================================================================
' IMPORT FILE HELPERS
' Reads CSV / XLSX / XLS uploads into a header array + rows dictionary, and normalizes values for the businesses table.
'
' ImportFile_Read(path, maxRows) returns a Scripting.Dictionary:
'   "headers" -> Array of column names
'   "rows"    -> Scripting.Dictionary (0-based index -> Array of string values), at most maxRows rows (0 = all)
'=======================================================================================================================

Function ImportFile_UploadDir()
    Dim fso : Set fso = CreateObject("Scripting.FileSystemObject")
    Dim dir : dir = fso.GetAbsolutePathName(Server.MapPath("/") & "\..\uploads")
    If Not fso.FolderExists(dir) Then fso.CreateFolder dir
    ImportFile_UploadDir = dir
End Function

' Returns the full path of the stored upload for a token, or "" when the token is malformed or the file is missing.
Function ImportFile_PathForToken(token)
    Dim re : Set re = New RegExp
    re.Pattern = "^[0-9A-Fa-f]{32}$"
    ImportFile_PathForToken = ""
    If Not re.Test(token) Then Exit Function

    Dim fso, ext, p
    Set fso = CreateObject("Scripting.FileSystemObject")
    For Each ext In Array("csv", "xlsx", "xls")
        p = ImportFile_UploadDir() & "\" & token & "." & ext
        If fso.FileExists(p) Then
            ImportFile_PathForToken = p
            Exit Function
        End If
    Next
End Function

Function ImportFile_NewToken()
    Dim tl : Set tl = CreateObject("Scriptlet.TypeLib")
    ImportFile_NewToken = Replace(Replace(Replace(Left(CStr(tl.Guid), 38), "{", ""), "}", ""), "-", "")
    Set tl = Nothing
End Function

Function ImportFile_Read(path, maxRows)
    Dim ext : ext = LCase(Mid(path, InStrRev(path, ".") + 1))
    If ext = "csv" Then
        Set ImportFile_Read = ImportFile_ReadCsv(path, maxRows)
    Else
        Set ImportFile_Read = ImportFile_ReadExcel(path, ext, maxRows)
    End If
End Function

'---------------------------------------------------------------------------------------------------------------------
' CSV
'---------------------------------------------------------------------------------------------------------------------
Function ImportFile_ReadCsv(path, maxRows)
    Dim stm, text
    Set stm = Server.CreateObject("ADODB.Stream")
    stm.Type = 2
    stm.Charset = "utf-8"
    stm.Open
    stm.LoadFromFile path
    text = stm.ReadText
    stm.Close
    ' Not valid UTF-8 (replacement character present): re-read as Windows-1252, which is what Excel "CSV" exports use.
    If InStr(text, ChrW(65533)) > 0 Then
        stm.Charset = "windows-1252"
        stm.Open
        stm.LoadFromFile path
        text = stm.ReadText
        stm.Close
    End If
    Set stm = Nothing

    text = Replace(text, vbCrLf, vbLf)
    text = Replace(text, vbCr, vbLf)

    ' Pick the delimiter that appears most in the first line.
    Dim firstLine, delim, best, cand, c
    firstLine = Left(text, InStr(text & vbLf, vbLf) - 1)
    delim = ","
    best = 0
    For Each cand In Array(",", ";", vbTab, "|")
        c = Len(firstLine) - Len(Replace(firstLine, cand, ""))
        If c > best Then best = c : delim = cand
    Next

    Dim lines, i, line, pending, all, rec
    lines = Split(text, vbLf)
    Set all = CreateObject("Scripting.Dictionary")
    pending = ""
    For i = 0 To UBound(lines)
        line = lines(i)
        If Len(pending) > 0 Then
            line = pending & vbLf & line
            pending = ""
        End If
        ' An odd number of quotes means a quoted field continues onto the next physical line.
        If ((Len(line) - Len(Replace(line, """", ""))) Mod 2) = 1 And i < UBound(lines) Then
            pending = line
        ElseIf Len(Trim(line)) > 0 Then
            all.Add all.Count, ImportFile_SplitCsvLine(line, delim)
            If maxRows > 0 And all.Count > maxRows Then Exit For
        End If
    Next

    Set ImportFile_ReadCsv = ImportFile_Pack(all)
End Function

Function ImportFile_SplitCsvLine(line, delim)
    If InStr(line, """") = 0 Then
        ImportFile_SplitCsvLine = Split(line, delim)
        Exit Function
    End If

    Dim fields(), n, i, ch, cur, inQ
    ReDim fields(Len(line))
    n = 0 : cur = "" : inQ = False : i = 1
    Do While i <= Len(line)
        ch = Mid(line, i, 1)
        If inQ Then
            If ch = """" Then
                If Mid(line, i + 1, 1) = """" Then
                    cur = cur & """"
                    i = i + 1
                Else
                    inQ = False
                End If
            Else
                cur = cur & ch
            End If
        ElseIf ch = """" Then
            inQ = True
        ElseIf ch = delim Then
            fields(n) = cur : n = n + 1 : cur = ""
        Else
            cur = cur & ch
        End If
        i = i + 1
    Loop
    fields(n) = cur
    ReDim Preserve fields(n)
    ImportFile_SplitCsvLine = fields
End Function

'---------------------------------------------------------------------------------------------------------------------
' Excel (via ACE OLEDB; 32-bit provider, so this only works in a 32-bit app pool / IIS Express x86)
'---------------------------------------------------------------------------------------------------------------------
Function ImportFile_ReadExcel(path, ext, maxRows)
    Dim conn, rs, schema, sheet, props, i, n, all, rec, v, ncols
    If ext = "xls" Then props = "Excel 8.0" Else props = "Excel 12.0 Xml"

    Set conn = Server.CreateObject("ADODB.Connection")
    conn.Open "Provider=Microsoft.ACE.OLEDB.16.0;Data Source=" & path & ";Extended Properties=""" & props & ";HDR=YES;IMEX=1"";"

    Set schema = conn.OpenSchema(20) ' adSchemaTables
    sheet = ""
    Do While Not schema.EOF
        If schema("TABLE_TYPE") = "TABLE" Or schema("TABLE_TYPE") = "SYSTEM TABLE" Then
            If InStr(schema("TABLE_NAME"), "_xlnm") = 0 And InStr(schema("TABLE_NAME"), "FilterDatabase") = 0 Then
                sheet = schema("TABLE_NAME")
                Exit Do
            End If
        End If
        schema.MoveNext
    Loop
    schema.Close

    Set all = CreateObject("Scripting.Dictionary")
    If Len(sheet) > 0 Then
        Set rs = Server.CreateObject("ADODB.Recordset")
        rs.Open "SELECT * FROM [" & sheet & "]", conn, 0, 1
        ncols = rs.Fields.Count

        ReDim rec(ncols - 1)
        For i = 0 To ncols - 1
            rec(i) = rs.Fields(i).Name
        Next
        all.Add 0, rec

        Do While Not rs.EOF
            ReDim rec(ncols - 1)
            For i = 0 To ncols - 1
                v = rs.Fields(i).Value
                If IsNull(v) Then rec(i) = "" Else rec(i) = Trim(CStr(v))
            Next
            all.Add all.Count, rec
            If maxRows > 0 And all.Count > maxRows Then Exit Do
            rs.MoveNext
        Loop
        rs.Close
    End If
    conn.Close
    Set ImportFile_ReadExcel = ImportFile_Pack(all)
End Function

' Splits the raw row dictionary (row 0 = header) into headers + data rows.
Function ImportFile_Pack(all)
    Dim result, rows, i
    Set result = CreateObject("Scripting.Dictionary")
    Set rows = CreateObject("Scripting.Dictionary")
    If all.Count = 0 Then
        result.Add "headers", Array()
    Else
        Dim hdr : hdr = all(0)
        For i = 0 To UBound(hdr)
            hdr(i) = Trim(Replace(hdr(i), ChrW(65279), ""))
        Next
        result.Add "headers", hdr
        For i = 1 To all.Count - 1
            rows.Add rows.Count, all(i)
        Next
    End If
    result.Add "rows", rows
    Set ImportFile_Pack = result
End Function

Function ImportFile_Cell(rec, idx)
    ImportFile_Cell = ""
    If idx >= 0 Then
        If idx <= UBound(rec) Then ImportFile_Cell = Trim(rec(idx))
    End If
End Function

'=======================================================================================================================
' FIELD DEFINITIONS AND NORMALIZATION
'=======================================================================================================================

' Importable fields: Array(key, label)
Function ImportFile_Fields()
    ImportFile_Fields = Array( _
        Array("name", "Business name"), _
        Array("contact_name", "Contact name"), _
        Array("industry", "Industry / type of business"), _
        Array("phone", "Phone"), _
        Array("email", "Email"), _
        Array("website", "Website"), _
        Array("address1", "Address"), _
        Array("city", "City"), _
        Array("state", "State"), _
        Array("zip", "Zip"), _
        Array("notes", "Notes") _
    )
End Function

' Guesses which field a column header represents ("" = ignore).
Function ImportFile_GuessField(header)
    Dim h : h = LCase(Trim(header))
    Dim rules, r
    rules = Array( _
        Array("contact_name", "contact|owner|person|first.?name|full.?name"), _
        Array("email", "e-?mail"), _
        Array("phone", "phone|tel|mobile|cell"), _
        Array("website", "web|url|site"), _
        Array("industry", "industry|category|categories|business.?type|type|niche|sic|naics"), _
        Array("zip", "zip|postal|post.?code"), _
        Array("state", "^st$|state|province|region"), _
        Array("city", "city|town"), _
        Array("address1", "address|street"), _
        Array("notes", "note|comment|description"), _
        Array("name", "business|company|org|^name$|name") _
    )
    Dim re : Set re = New RegExp
    re.IgnoreCase = True
    For Each r In rules
        re.Pattern = r(1)
        If re.Test(h) Then
            ImportFile_GuessField = r(0)
            Exit Function
        End If
    Next
    ImportFile_GuessField = ""
End Function

' Phone as digits only (leading US country code dropped); "" when fewer than 7 digits.
Function ImportFile_PhoneDigits(phone)
    Dim re, d
    Set re = New RegExp
    re.Global = True
    re.Pattern = "[^0-9]"
    d = re.Replace(phone, "")
    If Len(d) = 11 And Left(d, 1) = "1" Then d = Mid(d, 2)
    If Len(d) < 7 Then d = ""
    ImportFile_PhoneDigits = Left(d, 20)
End Function

' Digits of a search term, without the 7-digit minimum used for stored phone numbers.
Function ImportFile_PhoneDigitsLoose(s)
    Dim re : Set re = New RegExp
    re.Global = True
    re.Pattern = "[^0-9]"
    ImportFile_PhoneDigitsLoose = re.Replace(s, "")
End Function

' Zip codes that lost their leading zero in Excel (4 digits) get it back.
Function ImportFile_NormalizeZip(zip)
    Dim z : z = Trim(zip)
    If Len(z) > 2 Then
        If Right(z, 2) = ".0" Then
            If IsNumeric(Left(z, Len(z) - 2)) Then z = Left(z, Len(z) - 2)
        End If
    End If
    If Len(z) = 4 And IsNumeric(z) Then z = "0" & z
    ImportFile_NormalizeZip = z
End Function
%>