Follow along with the video below to see how to install our site as a web app on your home screen.
Note: This feature may not be available in some browsers.
TextFileName = objFile.Name
Set Instream = fso.OpenTextFile(MinFilePath & TextFileName, ForReading)
aryHeaders = Split(Instream.ReadLine, vbTab)
Instream.Close
Set OutStream = fso.OpenTextFile(MinFilePath & "\schema.ini", ForWriting, True)
OutStream.WriteLine "[" & TextFileName & "]"
OutStream.WriteLine "ColNameHeader = True"
OutStream.WriteLine "Format = TabDelimited"
OutStream.WriteLine "MaxScanRows = 0"
For i = 0 To UBound(aryHeaders)
OutStream.WriteLine "Col" & i + 1 & "=" & aryHeaders(i) & " Memo"
Next
OutStream.Close
CSVSql = ""
For i = 0 To lstFields.ListCount - 1
CSVSql = CSVSql & "[" & lstFields.List(i) & "],"
Next
CSVSql = Left(CSVSql, (Len(CSVSql) - 1))
rstxt.Open "SELECT * INTO [Master] IN '" & App.Path & "\" & MDBFileName & "' FROM [" & TextFileName & "]", conn, adOpenStatic, adLockReadOnly, adCmdText
If rstxt.State = adStateOpen Then rstxt.Close
chr(34) + Replace(line, chr(9), chr(34)+chr(9)+chr(34)) + chr(34)
[CR3_17_AL1994_7bb79cd4-f3a3-4853-9572-cad1e4a7828b.csv]
ColNameHeader = True
Format = TabDelimited
TextDelimiter = "
MaxScanRows = 0
Col1="BatchID" Memo
Col2="BatchType" Memo
Col3="NotificationID" Memo
Col4="ExternalCompanyID" Memo
Col5="LoopCompanyId" Memo
Col6="DocumentID" Memo
Col7="DMSCustomerID" Memo
Col8="RequestedShipDate" Memo
Col9="FirstName" Memo
Col10="MiddleName" Memo
Col11="LastName" Memo
Col12="Suffix" Memo
Col13="Address1" Memo
Col14="Address2" Memo
Col15="City" Memo
Col16="State" Memo
Col17="Zip" Memo
Col18="VehicleMake" Memo
Col19="VehicleModel" Memo
Col20="VehicleYear" Memo
Col21="VIN" Memo
Col22="VehicleLastServiceDate" Memo
Col23="DealerName" Memo
Col24="DealerAddress" Memo
Col25="DealerCity" Memo
Col26="DealerState" Memo
Col27="DealerZip" Memo
Col28="DealerPhone" Memo
Col29="DealerContactName" Memo
Col30="DealerContactTitle" Memo
Col31="DealerContactPhone" Memo
Col32="DealerContactEmail" Memo
Col33="DealerHours" Memo
Col34="DealerURL" Memo
Col35="WillSendEmail" Memo
Col36="LoopServiceId" Memo
Col37="Level" Memo
Col38="Months" Memo
Col39="Category" Memo
Col40="Urgency" Memo
Col41="SIFriendlyName" Memo
Col42="IsVehicleMake" Memo
Col43="IsLoyalty" Memo
Col44="IsVehicleMileageGroup" Memo
Col45="AnniversaryYears" Memo
Col46="USP1" Memo
Col47="USP2" Memo
Col48="USP3" Memo
Col49="USP4" Memo
Col50="USP5" Memo
Col51="USP6" Memo
Col52="USP7" Memo
Col53="USP8" Memo
Col54="coupon1_Title" Memo
Col55="coupon1_Amount" Memo
Col56="coupon1_Subtitle" Memo
Col57="coupon1_Body" Memo
Col58="coupon1_BodyB" Memo
Col59="coupon1_Disclaimer" Memo
Col60="coupon1_Expiration_Date" Memo
Col61="coupon2_Title" Memo
Col62="coupon2_Amount" Memo
Col63="coupon2_Subtitle" Memo
Col64="coupon2_Body" Memo
Col65="coupon2_BodyB" Memo
Col66="coupon2_Disclaimer" Memo
Col67="coupon2_Expiration_Date" Memo
Col68="FirstClassUpgrade" Memo
Col69="PrintSamples" Memo
Col70="CustomerPin" Memo
Set Instream = fso.OpenTextFile(FilePath & TextFileName, ForReading)
Set OutStream = fso.OpenTextFile(FilePath & "minified\" & TextFileName, ForWriting, True)
Counter = 0
Do
aryHeaders = Split(Instream.ReadLine, vbTab)
InputData = ""
For i = 0 To lstHeaders.ListCount - 1
Counter = Counter + 1
If Len(aryHeaders(lstHeaders.List(i))) > 2 Then
InputData = InputData & Chr(34) & Replace(Left(aryHeaders(lstHeaders.List(i)), 1), Chr(34), "") & _
Mid(aryHeaders(lstHeaders.List(i)), 2, Len(aryHeaders(lstHeaders.List(i))) - 2) & _
Replace(Right(aryHeaders(lstHeaders.List(i)), 1), Chr(34), "") & Chr(34) & vbTab
ElseIf aryHeaders(lstHeaders.List(i)) = String(2, Chr(34)) Then
InputData = InputData & String(2, Chr(34)) & vbTab
Else
InputData = InputData & Chr(34) & aryHeaders(lstHeaders.List(i)) & Chr(34) & vbTab
End If
Next
OutStream.WriteLine Left(InputData, (Len(InputData) - 1))
Loop Until Instream.AtEndOfStream
Instream.Close
OutStream.Close
Set OutStream = fso.OpenTextFile(MinFilePath & "\schema.ini", ForWriting, True)
OutStream.WriteLine "[" & TextFileName & "]"
OutStream.WriteLine "ColNameHeader = True"
OutStream.WriteLine "Format = TabDelimited"
OutStream.WriteLine "TextDelimiter = none"
OutStream.WriteLine "MaxScanRows = 0"
For i = 0 To UBound(aryHeaders)
OutStream.WriteLine "Col" & i + 1 & "=" & aryHeaders(i) & " Memo"
Next
OutStream.Close
CSVSql = ""
For i = 0 To lstFields.ListCount - 1
CSVSql = CSVSql & "[" & lstFields.List(i) & "],"
Next
CSVSql = Left(CSVSql, (Len(CSVSql) - 1))
rstxt.Open "SELECT * INTO [Master] IN '" & App.Path & "\" & MDBFileName & "' FROM [" & TextFileName & "]", conn, adOpenStatic, adLockReadOnly, adCmdText
If rstxt.State = adStateOpen Then rstxt.Close
conn.Close
Set rstxt = Nothing
If fso.FileExists(MinFilePath & "\schema.ini") Then fso.DeleteFile MinFilePath & "\schema.ini"
conn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Data Source='" & App.Path & "\" & MDBFileName & "'"
conn.Execute "INSERT INTO [Final] (" & CSVSql & ") SELECT " & CSVSql & " FROM [Master]"
Set rstxt = New ADODB.Recordset
rstxt.Open "SELECT * FROM [Final]", conn
Set OutStream = fso.OpenTextFile(FilePath & "Test_" & Format(Date, "MM-DD-YYYY") & ".txt", ForWriting, True)
HeaderTxtFnl = ""
For z = 0 To rstxt.Fields.Count - 1
HeaderTxtFnl = HeaderTxtFnl & Chr(34) & rstxt.Fields(z).Name & Chr(34) & ","
Next
OutStream.WriteLine Left(HeaderTxtFnl, Len(HeaderTxtFnl) - 1)
OutStream.Write rstxt.GetString(adClipString, , ",", vbCrLf, "")
OutStream.Close
rstxt.Close
conn.Close
Set conn = Nothing
Set rstxt = Nothing
Set OutStream = Nothing
If Len(aryHeaders(lstHeaders.List(i))) > 2 Then ' Check for populated strings and any enclosed quotes
InputData = InputData & Chr(34) & Replace(Left(aryHeaders(lstHeaders.List(i)), 1), Chr(34), "") & _
Mid(aryHeaders(lstHeaders.List(i)), 2, Len(aryHeaders(lstHeaders.List(i))) - 2) & _
Replace(Right(aryHeaders(lstHeaders.List(i)), 1), Chr(34), "") & Chr(34) & vbTab
ElseIf aryHeaders(lstHeaders.List(i)) = String(2, Chr(34)) Then ' Check for blank strings with enclosed quotes
InputData = InputData & String(2, Chr(34)) & vbTab
Else ' Write out any other string adding enclosed quotes
InputData = InputData & Chr(34) & aryHeaders(lstHeaders.List(i)) & Chr(34) & vbTab
End If
[blue][green]' Note example is using DAO in Access (as that si what I had at hand), but should need very little work to turn into ADO
' Requires references to Microsoft VBScript Regular Expressions 5.5 and Microsoft Scripting Runtime[/green]
Public Sub test()
Dim m As String
Dim fso As New FileSystemObject
Dim header As String
Dim myfile As TextStream
Dim lp As Long
[green]' Grab source file text[/green]
With fso.OpenTextFile("F:\Michael\Documents\deletemesrc.txt")
header = .ReadLine
m = .ReadAll
End With
[green]' Delimit[/green]
With New RegExp
.Global = True
.Multiline = True
.Pattern = "(\t)"
m = .Replace(m, Chr$(34) & "$1" & Chr$(34))
.Pattern = "^(.+?)($)"
m = .Replace(m, Chr$(34) & "$1" & Chr$(34))
End With
[green]' Save delimited version[/green]
With fso.OpenTextFile("F:\Michael\Documents\deleteme.txt", ForWriting)
.WriteLine header
.Write m
End With
With CurrentDb
[green]' Import delimited text file. Example assumes existence of relevant schema.ini file[/green]
.Execute "SELECT * INTO deleteme FROM [Text;FMT=Delimited;HDR=Yes;DATABASE=F:\Michael\Documents;].[deleteme.txt];", False
[green]' Clean off text delimiters (chr$(34) for purposes of this example)[/green]
For lp = 0 To .TableDefs("DELETEME").fields.Count - 1
With .TableDefs("DELETEME").fields(lp)
CurrentDb.Execute "UPDATE deleteme SET [" & .Name & "] = REPLACE([" & .Name & "], chr$(34), '')"
End With
Next
.TableDefs.Refresh
End With
Application.RefreshDatabaseWindow [green]' Access ...[/green]
End Sub[/blue]