I want the following html page to submit the embedded image rather than using file input offered by
<input type= file name="file1" name="file1"> to an asp uploader following the code below?!
<form name="Mine" id="Mine" enctype="multipart/form-data" action="upload1.asp" method="post">
which will post image data to the following asp uploader ( upload1.asp) which originally submit the file input but not an embedded image
<%
option explicit
Response.Write "<BR>Execution ended: " & now
' used to track various positions
dim PosB, PosBBound, PosEBound, PosEHead, PosBFld, PosEFld
' these handle the data
dim Boundary, BBoundary, PartBHeader, PartAHeader, PartContent, PartContent2, Binary
' for writing and converting
dim fso, fle, rst, DataString, FileName
' various other
dim I, Length, ContType, PartName, LastPart, BCrlf, PartContentLength
' ado constants
const adLongVarBinary = 205
const adLongVarchar = 201
' must be submitted using POST
If Request.ServerVariables("REQUEST_METHOD") = "POST" Then
ContType = Request.ServerVariables("HTTP_Content_Type")
' must be "multipart/form-data"
If LCase(Left(ContType, 19)) = "multipart/form-data" Then
PosB = InStr(LCase(ContType), "boundary=") 'get boundary
If PosB > 0 Then Boundary = Mid(ContType, PosB + 9) 'we have one
'bugfix IE5.01 - double header
PosB = InStr(LCase(ContType), "boundary=")
If PosB > 0 then
PosB = InStr(Boundary, ",")
If PosB > 0 Then Boundary = Left(Boundary, PosB - 1)
end if
Length = CLng(Request.ServerVariables("HTTP_Content_Length")) 'Get Content-Length header
End If
If Length > 0 And Boundary <> "" Then
Boundary = "--" & Boundary
' get request, binary
Binary = Request.BinaryRead(Length)
' convert boundry to binary
For I=1 to len(Boundary)
BBoundary = BBoundary & ChrB(Asc(Mid(Boundary,I,1)))
Next
' binary crlf
BCrlf = ChrB(Asc(vbCr)) & ChrB(Asc(vbLf))
' get begin and end of first boundary
PosBBound = InStrB(Binary, BBoundary)
PosEBound = InStrB(PosBBound + LenB(BBoundary), Binary, BBoundary, 0)
' keep doing until we had them all
Do While (PosBBound > 0 And PosEBound > 0)
' get position of the end of the header
PosEHead = InStrB(PosBBound + LenB(BBoundary), Binary, BCrlf & BCrlf)
' get content of header and convert to string
PartBHeader = MidB(Binary, PosBBound + LenB(BBoundary) + 2, PosEHead - PosBBound - LenB(BBoundary) - 2)
PartAHeader = ""
For I=1 to lenb(PartBHeader)
PartAHeader = PartAHeader & Chr(AscB(MidB(PartBHeader,I,1)))
Next
' make sure we end it with ;
If Right(PartAHeader,1) <> ";" Then PartAHeader = PartAHeader & ";"
' get content of this part
PartContent = MidB(Binary, PosEHead + 4, PosEBound - (PosEHead + 4) - 2)
' get name of part
PosBFld = Instr(lcase(PartAHeader),"name=")
If PosBFld > 0 Then
' name found
PosEFld = Instr(PosBFld,lcase(PartAHeader),";")
If PosEFld > 0 Then
' well-formed name header
PartName = Mid(PartAHeader,PosBFld+5,PosEFld-PosBFld-5)
end if
' chop of leading and trailing "'s
Do Until Left(PartName,1) <> """"
PartName = Mid(PartName,2)
Loop
Do Until Right(PartName,1) <> """"
PartName = Left(PartName,Len(PartName)-1)
Loop
end if
' get file name of part (if any)
PosBFld = Instr(lcase(PartAHeader),"filename=""")
If PosBFld > 0 Then
' content header found
PosEFld = Instr(PosBFld + 10,lcase(PartAHeader),"""")
If PosEFld > 0 Then
' well-formed content header
FileName = Mid(PartAHeader,PosBFld+10,PosEFld-PosBFld-10)
end if
' chop of leading and trailing "'s
Do Until Left(FileName,1) <> """"
FileName = Mid(FileName,2)
Loop
Do Until Right(FileName,1) <> """"
FileName = Left(FileName,Len(FileName)-1)
Loop
Else
FileName = ""
end if
' do conversion of binary to regular data
' at the end, datastring will contain 'readable' data
' is this wide-byte binary data?
if vartype(PartContent) = 8 then
' need to do some conversion
Set rst = CreateObject("ADODB.Recordset")
PartContentLength = LenB(PartContent)
if PartContentLength > 0 then
' data, so add to recordset to speed up conversion
rst.Fields.Append "data", adLongVarBinary, PartContentLength
rst.Open
rst.AddNew
rst("data").AppendChunk PartContent & ChrB(0)
rst.Update
PartContent2 = rst("data").GetChunk(PartContentLength)
rst.close
set rst = nothing
else
' no data?
PartContent2 = ChrB(0)
End If
else
' no need for conversion
PartContent2 = PartContent
end if
PartContentLength = LenB(PartContent2)
if PartContentLength > 0 then
' we have data to convert
Set rst = CreateObject("ADODB.Recordset")
rst.Fields.Append "data", adLongVarChar, PartContentLength
rst.Open
rst.AddNew
rst("data").AppendChunk PartContent2
rst.Update
DataString = rst("data")
rst.close
set rst = nothing
Else
' nothing to convert
dataString = ""
End If
' conversion has been done, now what to do with it
If FileName <> "" Then
' we have a file, let's save it to disk
FileName = Mid(Filename,InstrRev(FileName,"\")+1)
' open a file (textstream)
set fso = Server.CreateObject("Scripting.Filesystemobject")
set fle = fso.CreateTextFile(server.MapPath(FileName))
' write the data
fle.write DataString
fle.close
' cleanup
set fle = nothing
set fso = nothing
' give notification
Response.Write "<BR>Uploaded file " & Partname & " - " & FileName & "(" & Len(Datastring) & " bytes)"
else
' some other type of field, let's just output this
Response.Write "<BR>Form field: " & Partname & " - " & Datastring
End If
LastPart = MidB(Binary, PosEBound + LenB(BBoundary), 2)
If LastPart = ChrB(Asc("-")) & ChrB(Asc("-")) Then
' don't look for others
PosBBound = 0
PosEBound = 0
else
' look for others
PosBBound = PosEBound
PosEBound = InStrB(PosBBound + LenB(BBoundary), Binary, BBoundary)
End If
loop
Response.Write "<P>End of form input, all fields processed"
else
Response.Write "<P>Invalid or empty request, no fields processed. Make sure that the content type is multipart/form-data"
end if
else
Response.Write "<P>Form must be submitted using the POST method"
end if
Response.Write "<BR>Execution ended: " & now
%>
Related
I have this json array and the data I need is in the array that starts data_id which I cannot extract. I am able to extract keys,value before the array but not in the array. I believe I need to request data in a specific way with a number in () after the fieldname nest but I cannot find a beginners explanation to see what number goes in the brackets and why you chose that number.
{"api":{"results":37,"data":[{"data_id":643951,"location_id":3005,"person":{"name":"Bob","country":"Turkey",
Any tips appreciated here is some code
'Print a few object variables before parse
Dim WrkSht As Worksheet
Set WrkSht = ThisWorkbook.Worksheets("jsonoutput")
WrkSht.Cells(1, 1).Value = xml_obj.responseText
' Displays data fine in one string as shown above
'Parse the response
Set jp = JsonConverter.ParseJson(xml_obj.responseText)
For Each dict In jp
Debug.Print dict
If Not IsObject(jp(dict)) Then
Debug.Print jp(dict)
Else
For Each subDict In jp(dict)
Debug.Print subDict
'Debug.Print jp(dict)(subDict)
Next subDict
End If
Next dict
' I need to drill down into further levels but ?
End Sub
Here's a simple example
JSON used:
{"api":{"results":37,
"data":[{"data_id":643951,
"location_id":3005,
"person":{"name":"Bob","country":"Turkey"}
} ]
}}
Code:
Sub Test36()
Dim jso As Object, arr, data, obj
'loading from a cell for testing...
Set jso = JsonConverter.ParseJson(Sheet2.Range("A17").Value)
'jso is a Dictionary
Debug.Print jso("api")("results") '>> 37
Set data = jso("api")("data") 'data is a Collection
Debug.Print data.Count ' >> 1
For Each obj In data
Debug.Print obj("data_id") '>> 643951
Debug.Print obj("person")("country") '>> Turkey
Next obj
End Sub
I thought I would just share the code I ended up with. It can be improved on and some is over coded simply to make it easier to see where amendments can be made. Currently this will:
Access an API - just put as many header lines in as you need
Collect the JSON data and flatten it to one level - this code will only work with Json where
blank values are recorded as "null" rather than just "". You may
have to manually correct the columns (or update the code) for
blank values
Ask you which key you want to start with - it will
then mark that keys values to start a new row each time it comes
across this
Make replacements in the data to create delimiters
to mark which data is keys and which is values
Pastes your keys
in row 1 that have values - dictionary keys are ignored but
you can change that if needed
Remove all keys from the string to
just leave values and paste those in the rows below.
You need to have the RunScriptime XMl HTTP 6.0 and Object library ticked in Tools reference in VBA as well
Sub FlattenJsonGetDataFromKeysWithValues()
ActiveWorkbook.Worksheets("yourworksheet").Range("a1:ZZ10000").ClearContents
Dim i As Long
'Declare variables
Dim xml_obj As MSXML2.XMLHTTP60
Dim base_url As String
Dim Json1 As String, Json2, Json3, Json4, Json5, Json6, json7, Json8, Json9, Json10, Json11, Json12, Json13, Json14, Json15, Json16, Json17, Json18
Dim Json0 As String
Dim keys As String, keys2
'Create a new Request Object make sure in Tools-> reference the xml6.0, scripting runtime and object library are ticked
Set xml_obj = New MSXML2.XMLHTTP60
'Define URL Components two headers are shown but you cana dd as many as required
base_url = "https://yoururl.com"
xml_obj.Open "GET", base_url
xml_obj.SetRequestHeader "key", "55555"
xml_obj.SetRequestHeader "host", "valuefor2ndheaderkeyifneeded"
xml_obj.Send
'Print the status code in case something went wrong
MsgBox("The Request was " + CStr(xml_obj.Status))
strJson0 = xml_obj.responseText
MsgBox (Len(strJson0)) ' tells how long string is
'Look for Json current delimiters and change all to a comma
Json1 = strJson0
Const SpecialCharacters As String = "!,#,#,$,%,^,&,*,(,),{,[,],},?,:"
Dim char As Variant
For Each char In Split(SpecialCharacters, ",")
Json1 = Replace(Json1, char, " ")
Next
' Place # before all field names, I have shown in this way so if needed you can vary to suit your needs
Json2 = Replace(Json1, "," & Chr(34), "#") ' Replaces ," - Chr(34) is a "
Json3 = Replace(Json2, ", " & Chr(34), "#") ' replaces , "
Json4 = Replace(Json3, Chr(34) & " " & Chr(34), Chr(34) & "#") ' Replaces " "
Json5 = Replace(Json4, Chr(34) & " " & Chr(34), Chr(34) & "#") ' Replaces " "
'Place : after fieldname and before value
Json6 = Replace(Json5, Chr(34) & " " & Chr(34), ":") 'Replaces " "
json7 = Replace(Json6, Chr(34) & " ", ":") 'Replaces "(blankspace)
Json8 = Replace(json7, Chr(34), ":") 'Replaces "
Json9 = Replace(Json8, ":#", "#") 'Replaces :# with #
Json10 = Replace(Json9, "/", "") 'Removes /
Json11 = Replace(Json10, " ", "") 'Removes blankspace
If Left(Json11, 1) = ":" Then Json11 = "#" & Right(Json11, (Len(Json11) - 1)) ' Replace : with # if first character
' Now you just have field names (keys) marked by # and values marked by :
' Find Field Names - which field should we start with? How many times is that key in the data
Dim firstkey As String
MsgBox (Json11) 'View this to see your key/header row options
firstkey = InputBox("Enter First Field/Key to locate") 'This will mark where all new rows start
keys = Json11
' Now take text between #*# as dictionary keys and ignore and text between #*: as headers for field names until repeat text is found in string by finding the firstkey you input above and putting a # marker in all heading that = firstkey
Dim openPos As Long
Dim closePos As Long
Dim k As Integer
Dim jsonFields As Collection
Set jsonFields = New Collection
Dim jsonValues As Collection
Set jsonValues = New Collection
' Find wanted starting key, skip over keys without value
k = 1
openPos = InStr(keys, firstkey)
closePos = InStr(openPos, keys, ":")
If InStr(1, Mid(keys, openPos, closePos - openPos), "#") > 0 Then openPos = openPos + InStr(1, Mid(keys, openPos, closePos - openPos), "#")
jsonFields.Add Mid(keys, openPos, closePos - openPos)
keys = Replace(keys, firstkey & ":", ":#")
k = k + 1
' Find other keys with values, find dict keys
Do Until Mid(keys, openPos, closePos - openPos) = ""
openPos = InStr(closePos, keys, "#") + 1
If k = 2 Then openPos = InStr(1, keys, "#")
closePos = InStr(openPos, keys, ":")
If InStr(1, Mid(keys, openPos, closePos - openPos), "#") > 0 Then openPos = openPos + InStr(1, Mid(keys, openPos, closePos - openPos), "#")
jsonFields.Add Mid(keys, openPos, closePos - openPos)
k = k + 1
Loop
' Find values and remove delimiters, keys and replace : in https values that are removed with other delimiters
y = 2 ' use to start populate rows
currentcolumn = 1
Dim r&
p = Split(keys, "#")
For r = 0 To UBound(p)
If InStr(1, p(r), ":") Then p(r) = Right(p(r), Len(p(r)) - InStr(1, p(r), ":") + 1) ' remove keys
If InStr(1, p(r), ":") = 0 Then p(r) = "" ' remove :
If InStr(1, p(r), ":") Then p(r) = Right(p(r), Len(p(r)) - InStr(1, p(r), ":")) ' set value for collection to print later
If InStr(1, p(r), "https") Then p(r) = Replace(p(r), "https", "https:") ' fix https value by readding :
jsonValues.Add p(r) ' add to collection
Next r
' Print Values to worksheet
currentcolumn = 1
'Now Output your parsed key data, turn screen updating off
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
For Each Item In jsonFields
ActiveWorkbook.Worksheets("yourworksheet").Cells(1, currentcolumn).Value = Item
currentcolumn = currentcolumn + 1
Next Item
y = 2
currentcolumn = 1
Dim ws As Worksheet
Set ws = Worksheets("yourworksheet")
For Each Item In jsonValues
If Len(Item) > 0 Then
If InStr(1, Item, "#") = 1 Then
y = y + 1
currentcolumn = 1
End If
ws.Cells(y, currentcolumn).Value = Item
currentcolumn = currentcolumn + 1
End If
Next Item
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
I have a ms access table that is tracking 50 products with their daily sold volumes. I would like to export using vba 1 csv file (including headers) for each product showing the daily volumes from a recordset without saving the recordset to a permanent query. I am using the below code but I am stuck at the point of the actual export highlighted below in code.
Any assistance in fixing this is appreciated.
Dim rst As Recordset
Dim rstId As Recordset
SQLExportIds = "SELECT DISTINCT tblDailyVols.SecId FROM tblDailyVols WHERE tblDailyVols.IsDeleted=False"
Set rstId = CurrentDb.OpenRecordset(SQLExportIds)
If rstId.EOF = True Then
MsgBox "No Products Found"
Exit Sub
End If
Do While rstId.EOF = False
SecId = rstId.Fields("SecId")
SQLExportQuotes = " SELECT tblDailyVols.ID , tblDailyVols.TradedVolume, tblDailyVols.EffectiveDate FROM tblDailyVols "
SQLExportQuotes = SQLExportQuotes & " WHERE tblDailyVols.IsDeleted=False and tblDailyVols.ID = " & SecId
SQLExportQuotes = SQLExportQuotes & " ORDER BY tblDailyVols.EffectiveDate "
Set rst = CurrentDb.OpenRecordset(SQLExportQuotes)
If rst.EOF = True Then
MsgBox "No Quotes Found"
Exit Sub
End If
IDFound = rst.Fields("ID")
OutputPlace = “C:\Output” & IDFound & ".csv"
Set qdfTemp = CurrentDb.CreateQueryDef("", SQLExportQuotes)
**DoCmd.TransferText acExportDelim, , 1, OutputPlace, True** <--This Here Line Fails
Set rst = Nothing
rstId.MoveNext
Loop
Set rstId = Nothing
You will have to create an actual named QueryDef object for TransferText to work with, but then you can just delete it afterwards. Something like this:
Set qdfTemp = CurrentDb.CreateQueryDef("zzzTemp", SQLExportQuotes)
Set qdfTemp = Nothing
DoCmd.TransferText acExportDelim, , "zzzTemp", OutputPlace, True
DoCmd.DeleteObject acQuery, "zzzTemp"
You asked for a VBA solution, and I detect a preference for not creating new Access objects; you may well have good reasons for that, but the 'pure' VBA solution is a lot of work.
A solution that implements encapsulating text fields in quotes is the bare minimum for a competent answer. After that, you need to address the three big issues:
Optimising away VBA's clunky string-handling;
The Byte Order Marker, which VBA embeds in every string it saves to
file, ensuring that some of the most common consumers of a csv file
cannot read it properly;
...And there's rarely any middle ground between writing the file
line-by-line, forever, and writing it in one big chunk that'll throw
an out-of-memory error on larger recordsets.
Beginners in VBA may find the string-optimisations difficult to understand: the biggest performance gain available in native VBA is to avoid string allocation and concatenation ( here's why: http://www.aivosto.com/vbtips/stringopt2.html#huge ) - so I use join, split, and replace instead of myString = MyString & MoreString
The trailing loop, with the RecordSet.GetRows() call at the very end, will raise eyebrows among coders with strong opinions about structured programming: but there are constraints on how you can order the code so that the 'chunks' are concatenated into the file without any missed bytes, out-of-register shifts in the byte order, or blank lines.
So here goes:
Public Function RecordsetToCSV(ByRef rst As ADODB.Recordset, _
ByRef OutputFile As String, _
Optional ByRef FieldList As Variant, _
Optional ByVal CoerceText As Boolean = True, _
Optional ByVal CleanupText As Boolean = True _
) As Long
' Output a recordset to a csv file and returns the row count.
' If the output file is locked, or specified in an inaccessible location, the
' 'ByRef' OutputFile parameter becomes a file in the user's local temp folder
' You can supply your own field list. This isn't a substituted file header of
' aliased field names: it is a subset of the field names, which ADO will read
' selectively from the recordset. Each item in the list matches a named field
' CoerceText=TRUE will encapsulate all items, numeric or not, in quote marks.
' CleanupText=TRUE strips quotes and linefeeds from the data: FALSE is faster
' You should only set them FALSE if you're confident that the data is 'clean'
' with no quote marks, commas or line breaks in any unencapsulated text field
' This code handles unicode, and outputs a file that can be read by Microsoft
' ODBC and OLEDB database drivers by removing the Byte Order Marker.
On Error Resume Next
' Coding note: we're not doing any string-handling in VBA.Strings: allocating
' deallocating and (especially!) concatenating are SLOW. We are using the VBA
' Join and Split functions ONLY. Feel free to optimise further by declaring a
' faster set of string functions from the Kernel if you want to.
'
' Other optimisations: type pun. Byte Arrays are interchangeable with strings
' Some of our loops through these arrays have a 'step' of 2. This optimises a
' search-and-replace for ANSI chars in an array of 2-byte unicodes. Note that
' it's only used to remove known ANSI 'Latin' characters with a 'low' byte of
' zero: any other use of the two-byte 'step' will fail on non-Latin unicodes.
' ** THIS CODE IS IN THE PUBLIC DOMAIN **
' Nigel Heffernan Excellerando.Blogspot.com
Const FETCH_ROWS As Long = 4096
Dim COMMA As String * 1
Dim BLANK As String * 4
Dim EOROW As String * 2
COMMA = ChrW$(44)
BLANK = ChrW$(13) & ChrW$(10) & ChrW$(13) & ChrW$(10)
EOROW = ChrW$(13) & ChrW$(10)
Dim FetchArray As Variant
Dim i As Long ' i for rows in the output file, records in the recordset
Dim j As Long ' j for columns in the output file, fields in the recordset
Dim k As Long ' k for all other loops: bytes in individual data items
Dim i_Offset As Long
Dim i_LBound As Long
Dim i_UBound As Long
Dim j_LBound As Long
Dim j_UBound As Long
Dim k_lBound As Long
Dim k_uBound As Long
Dim hndFile As Long
Dim varField As Variant
Dim iRowCount As Long
Dim arrBytes() As Byte
Dim arrTemp1() As String
Dim arrTemp2() As String
Dim arrTemp3(0 To 2) As String
Dim boolNumeric As Boolean
Dim strHeader As String
Dim arrHeader() As Byte
Dim strFile As String
Dim strPath As String
Dim strExtn As String
strFile = FileName(OutputFile)
strPath = FilePath(OutputFile)
strExtn = FileExtension(strFile)
If rst Is Nothing Then Exit Function
If rst.State <> 1 Then Exit Function
If strExtn = "" Then
strExtn = ".csv"
End If
With FSO
If strFile = "" Then
strFile = .GetTempName
strFile = Left(strFile, Len(strFile) - Len(".tmp"))
strFile = strFile & strExtn
End If
If strPath = "" Then
strPath = TempSQLFolder
End If
If Right(strPath, 1) <> "\" Then
strPath = strPath & "\"
End If
strExtn = FileExtension(strFile)
If strExtn = "" Then
strExtn = ".csv"
strFile = strFile & strExtn
End If
OutputFile = strPath & strFile
End With
If FileName(OutputFile) <> "" Then
If Len(VBA.FileSystem.Dir(OutputFile, vbNormal)) <> 0 Then
Err.Clear
VBA.FileSystem.Kill OutputFile ' do it now, and reduce wait for deletion
If Err.Number = 70 Then ' permission denied: change the output file name
OutputFile = FileStripExtension(OutputFile) & "_" & FileStripExtension(FSO.GetTempName) & FileExtension(OutputFile)
End If
End If
End If
' ChrW$() gives a 2-byte 'Wide' char. This coerces all subsequent operations to UTF16
arrTemp3(0) = ChrW$(34) ' Encapsulating quote
arrTemp3(1) = vbNullString ' The field value will go here
arrTemp3(2) = ChrW$(34) ' Encapsulating quote
If rst.EOF And rst.BOF Then
FetchArray = Empty
ElseIf rst.EOF Then
rst.MoveFirst
End If
' An empty recordset must still write a header row of field names: we put this in the
' output buffer and write it to the file before we start looping through the records.
ReDim FetchArray(0 To rst.Fields.Count, 0 To 0)
i_LBound = 0
i_UBound = 0
If IsMissing(FieldList) Then
For j = LBound(FetchArray, 1) To UBound(FetchArray, 1) - 1 Step 1
FetchArray(j, i_UBound) = rst.Fields(j).Name
Next j
Else
j = 0
For Each varField In FieldList
j_UBound = j_UBound + 1
Next varField
ReDim arrTemp2(j_LBound To j_UBound)
For Each varField In FieldList
FetchArray(j, i_UBound) = CStr(varField)
j = j + 1
Next varField
End If
ReDim arrTemp1(i_LBound To i_UBound) ' arrTemp1 is the rowset we write to file
ReDim arrTemp2(j_LBound To j_UBound) ' arrTemp2 represents a single record
Do Until IsEmpty(FetchArray)
i_LBound = LBound(FetchArray, 2)
i_UBound = UBound(FetchArray, 2)
j_LBound = LBound(FetchArray, 1)
j_UBound = UBound(FetchArray, 1)
If UBound(arrTemp1) <> i_UBound + 1 Then
ReDim arrTemp1(i_LBound To i_UBound + 1)
arrTemp1(i_UBound + 1) = vbNullString ' The 'Join' operation will insert a trailing row
End If ' delimiter here (Not required by the last chunk)
If UBound(arrTemp2) <> j_UBound Then
ReDim arrTemp2(j_LBound To j_UBound)
End If
' Data body. This is heavily optimised to avoid VBA String functions with allocations
For i = i_LBound To i_UBound Step 1
' If this is confusing... Were you expecting FetchArray(i,j)? i for row, j for column?
' FetchArray comes from RecordSet.GetRows(), which returns a TRANSPOSED array: i and j
' are still the field and record ordinals, row(i) and column(j) in the output file.
For j = j_LBound To j_UBound
If IsNull(FetchArray(j, i)) Then
arrTemp2(j) = ""
Else
arrTemp2(j) = FetchArray(j, i) ' confused? see he note above
End If
If CleanupText Or (i_UBound = 0) Then ' (i_UBound=0): always clean up field names
arrBytes = arrTemp2(j) ' Integer arithmetic is faster than string-handling for
' this: all VBA string operations require an allocation
For k = LBound(arrBytes) To UBound(arrBytes) Step 2
Select Case arrBytes(k)
Case 10, 13, 9, 160
If arrBytes(k + 1) = 0 Then
arrBytes(k) = 32 ' replaces CR, LF, Tab, and non-breaking
End If ' spaces with the standard ANSI space
Case 44
If Not CoerceText Then
If arrBytes(k + 1) = 0 Then
arrBytes(k) = 32 ' replace comma with the ANSI space
End If
End If
Case 34
If arrBytes(k + 1) = 0 Then
arrBytes(k) = 39 ' replaces double-quote with single quote
End If
End Select
Next k
arrTemp2(j) = arrTemp2(j)
End If ' cleanup
If CoerceText Then ' encapsulate all fields in quotes, numeric or not
arrTemp3(1) = arrTemp2(j)
arrTemp2(j) = Join$(arrTemp3, vbNullString)
ElseIf (i = 0) And (i = i_UBound) Then ' always encapsulate field names
arrTemp3(1) = arrTemp2(j)
arrTemp2(j) = Join$(arrTemp3, vbNullString)
Else ' selective encapsulation, leaving numeric fields unencapsulated:
' we *could* do this by reading the ADODB field types: but that's
' slower, and you may be 'caught out' by provider-specific types.
arrBytes = arrTemp2(j)
boolNumeric = True
For k = LBound(arrBytes) To UBound(arrBytes) Step 2
If arrBytes(k) < 43 Or arrBytes(k) > 57 Then
If arrBytes(k) <> 69 Then
boolNumeric = False
Exit For
Else
If k > UBound(arrBytes) - 5 Then
boolNumeric = False
Exit For
ElseIf arrBytes(k + 2) = 45 Then
' detect "1.234E-05"
ElseIf arrBytes(k + 2) = 43 Then
' detect "1.234E+05"
Else
boolNumeric = False
Exit For
End If
End If
End If
Next k
If boolNumeric Then
For k = 1 + LBound(arrBytes) To UBound(arrBytes) Step 2
If arrBytes(k) <> 0 Then
boolNumeric = False
Exit For
End If
Next k
End If
arrBytes = vbNullString
If Not boolNumeric Then ' text field, encapsulate it
arrTemp3(1) = arrTemp2(j)
arrTemp2(j) = Join(arrTemp3, vbNullString)
End If
End If ' CoerceText
Next j
arrTemp1(i) = Join(arrTemp2, COMMA)
Next i
iRowCount = iRowCount + i - 2
' **** WHY WE 'PUT' A BYTE ARRAY INSTEAD OF A VBA STRING VARIABLE **** ****
'
' Put #hndFile, , StrConv(Join(arrTemp1, EOROW), vbUnicode)
' Put #hndFile, , Join(arrTemp1, EOROW)
'
' If you pass unicode, Wide or UTF-16 string variables to PUT, it prepends a
' Unicode Byte Order Mark to the data which, when written to your file, will
' render the field names illegible to Microsoft's JET ODBC and ACE-OLEDB SQL
' drivers (which can actually read unicode field names, if the helpful label
' isn't in the way). The primeval 'PUT' statement writes a Byte array as-is.
'
' **** **** **** **** **** **** **** **** **** **** **** **** **** **** ****
arrBytes = Join$(arrTemp1, vbCrLf)
If hndFile = 0 Then
i_Offset = 1
If Len(Dir(OutputFile)) > 0 Then
VBA.FileSystem.Kill OutputFile
End If
WaitForFileDeletion OutputFile
hndFile = FreeFile
Open OutputFile For Binary Access Write As #hndFile
End If
Put #hndFile, i_Offset, arrBytes
i_Offset = i_Offset + 1 + UBound(arrBytes)
Erase arrBytes
If rst.EOF Then
Erase FetchArray
FetchArray = Empty
Else
If IsMissing(FieldList) Then
FetchArray = rst.GetRows(FETCH_ROWS)
Else
FetchArray = rst.GetRows(FETCH_ROWS, , FieldList)
End If
End If
Loop ' until isempty(FetchArray)
If iRowCount < 1 Then '
iRowCount = 0 ' Row Count excludes the header
End If
RecordsetToCSV = iRowCount
ExitSub:
On Error Resume Next
If hndFile <> 0 Then
Close #hndFile
End If
Erase arrBytes
Erase arrTemp1
Erase arrTemp2
Exit Function
ErrSub:
Resume ExitSub
End Function
Public Function FilePath(Path As String) As String
' Strip the filename from a path, leaving only the path to the folder
' The last char of this path will be the backslash
' This does not check for the existence or accessibility of the file:
' all we're doing here is string-handling
Dim strPath As String
Dim arrPath() As String
Const BACKSLASH As String * 1 = "\"
strPath = Trim(Path)
If strPath = "" Then Exit Function
If Right$(strPath, 1) = BACKSLASH Then Exit Function
arrPath = Split(strPath, BACKSLASH)
If UBound(arrPath) = 0 Then ' does not contain "\"
FilePath = ""
Else
arrPath(UBound(arrPath)) = vbNullString
FilePath = Join$(arrPath, BACKSLASH)
End If
Erase arrPath
End Function
Public Function FileName(Path As String) As String
' Strip the folder and path from a file's path string, leaving only the file name
' This does not check for the existence or accessibility of the file:
' all we're doing here is string-handling
Dim strPath As String
Dim arrPath() As String
Const BACKSLASH As String * 1 = "\"
strPath = Trim(Path)
If strPath = "" Then Exit Function
If Right$(strPath, 1) = BACKSLASH Then Exit Function
arrPath = Split(strPath, BACKSLASH)
If UBound(arrPath) = 0 Then ' does not contain "\"
FileName = Path
Else
FileName = arrPath(UBound(arrPath))
End If
Erase arrPath
End Function
Public Function FileExtension(Path As String) As String
' Return the extension of the file
' This is just string-handling: no file or path validation is attempted
' The file extension is deemed to be whatever comes after the final '.'
' The extension is returned with the dot, eg: ".txt" not "txt"
' If no extension is detected, FileExtension returns an empty string
Dim strFile As String
Dim arrFile() As String
Const DOT_EXT As String * 1 = "."
strFile = FileName(Path)
strFile = Trim(strFile)
If strFile = "" Then Exit Function
If Right$(strFile, 1) = DOT_EXT Then Exit Function
arrFile = Split(strFile, DOT_EXT)
If UBound(arrFile) = 0 Then ' does not contain "\"
FileExtension = vbNullString
Else
FileExtension = arrFile(UBound(arrFile))
FileExtension = Trim(FileExtension)
If Len(FileExtension) > 0 Then
FileExtension = DOT_EXT & FileExtension
End If
End If
Erase arrFile
End Function
Public Function FileStripExtension(Path As String) As String
' Return the filename, with the extension removed
' This is just string-handling: no file validation is attempted
' The file extension is deemed to be whatever comes after the final '.'
' Both the dot and the extension are removed
Dim strFile As String
Dim arrFile() As String
Const DOT_EXT As String * 1 = "."
strFile = FileName(Path)
If strFile = "" Then Exit Function
If Right$(strFile, 1) = DOT_EXT Then Exit Function
strFile = Trim(strFile)
arrFile = Split(strFile, DOT_EXT)
If UBound(arrFile) = 0 Then ' does not contain "\"
FileStripExtension = vbNullString
Else
ReDim Preserve arrFile(LBound(arrFile) To UBound(arrFile) - 1)
FileStripExtension = Join$(arrFile, DOT_EXT)
End If
Erase arrFile
End Function
You'll also need the three path-and-file-name utility functions, if you don't have your own versions already:
FileName()
FilePath()
FileStripExtension()
There's room for improvement in the string-encapsulation logic: the correct approach is to look up the recordset's field types and apply quote marks accordingly, and it may well turn out to be faster than my clunky byte-counting.
However, my approach is all about the file consumers and what they expect to see; and that doesn't always line up with what they ought to accept.
If you succeed in coding a faster and more robust version do, please, let me know: if I'm asked to, I may well code up encapsulation by field type myself.
just thought I would toss in; macros offer this feature - and it is quite simple to set up;
select the export macro, select the query to export, select the format.... if you leave the destination selector blank it will launch the standard Windows file picker....
after a decade+ of coding in vba - macros have won me over for this particular function.....
I have a bunch of text files that I need to import into MS Access (thousands) - can use 2007 or 2010. The text files have categories that are identified in square brackets and have relevant data between the categories - for example:
[Location]Tenessee[Location][Model]042200[Model][PartNo]113342A69447B6[PartNo].
I need to capture both the categories and the data between them and import them into Access - the categories to one table, the data to another. There are hundreds of these categories in a single file and the text file has no structure - they are all run together as in the example above. The categories in the brackets are the only clear delimiters.
Through research on the web I have come up with a script for VBS (I am not locked into VBS, willing to use VBA or another method), but when I run it, I am getting a VBS info window with nothing displaying in it. Any advice or guidance would be most gratefully appreciated (I do not tend to use VBS and VBA) and I thank you.
The Script:
Const ForReading = 1
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objFile = objFSO.OpenTextFile("C:\Users\testGuy\Documents\dmc_db_test\DMC-TEST-A-00-00-00-00A-022A-D_000 - Copy01.txt", ForReading)
strContents = objFile.ReadAll
objFile.Close
Set objRegEx = CreateObject("VBScript.RegExp")
objRegEx.Global = True
objRegEx.Pattern = "\[.{0,}\]"
Set colMatches = objRegEx.Execute(strContents)
If colMatches.Count > 0 Then
For Each strMatch in colMatches
strMatches = strMatches & strMatch.Value
Next
End If
strMatches = Replace(strMatches, "]", vbCrlf)
strMatches = Replace(strMatches, "[", "")
Wscript.Echo strMatches
Regular expressions are wonderful things, but in your case it looks like they might be overkill. The following code uses plain old InStr() to find the [Tags] and parses the file(s) out to a single CSV file. That is, for input files
testfile1.txt:
[Location]Tennessee[Location][Model]042200[Model][PartNo]113342A69447B6[PartNo]
[Location]Mississippi[Location][Model]042200[Model][SerialNo]3212333222355[SerialNo]
and testfile2.txt:
[Location]Missouri[Location][Model]042200[Model][PartNo]AAABBBCCC111222333[PartNo]
...the code will write the following output file...
"FileName","LineNumber","ItemNumber","FieldName","FieldValue"
"testfile1.txt",1,1,"Location","Tennessee"
"testfile1.txt",1,2,"Model","042200"
"testfile1.txt",1,3,"PartNo","113342A69447B6"
"testfile1.txt",2,1,"Location","Mississippi"
"testfile1.txt",2,2,"Model","042200"
"testfile1.txt",2,3,"SerialNo","3212333222355"
"testfile2.txt",1,1,"Location","Missouri"
"testfile2.txt",1,2,"Model","042200"
"testfile2.txt",1,3,"PartNo","AAABBBCCC111222333"
...which you can then import into Access (or whatever) and proceed from there. This is VBA code, but it could easily be tweaked to run as a VBScript.
Sub ParseSomeFiles()
Const InFolder = "C:\__tmp\parse\in\"
Const OutFile = "C:\__tmp\parse\out.csv"
Dim fso As FileSystemObject, f As File, tsIn As TextStream, tsOut As TextStream
Dim s As String, Lines As Long, Items As Long, i As Long
Set fso = New FileSystemObject
Set tsOut = fso.CreateTextFile(OutFile, True)
tsOut.WriteLine """FileName"",""LineNumber"",""ItemNumber"",""FieldName"",""FieldValue"""
For Each f In fso.GetFolder(InFolder).Files
Debug.Print "Parsing """ & f.Name & """..."
Set tsIn = f.OpenAsTextStream(ForReading)
Lines = 0
Do While Not tsIn.AtEndOfStream
s = Trim(tsIn.ReadLine)
Lines = Lines + 1
Items = 0
Do While Len(s) > 0
Items = Items + 1
tsOut.Write """" & f.Name & """," & Lines & "," & Items
i = InStr(1, s, "]", vbBinaryCompare)
' write out FieldName
tsOut.Write ",""" & Replace(Mid(s, 2, i - 2), """", """""", 1, -1, vbBinaryCompare) & """"
s = Mid(s, i + 1)
i = InStr(1, s, "[", vbBinaryCompare)
' write out FieldValue
tsOut.Write ",""" & Replace(Mid(s, 1, i - 1), """", """""", 1, -1, vbBinaryCompare) & """"
s = Mid(s, i)
i = InStr(1, s, "]", vbBinaryCompare)
' (no need to write out ending FieldName tag)
s = Mid(s, i + 1)
tsOut.WriteLine
Loop
Loop
tsIn.Close
Set tsIn = Nothing
Next
Set f = Nothing
tsOut.Close
Set tsOut = Nothing
Set fso = Nothing
Debug.Print "Done."
End Sub
I have code that will list tables names, how can I export this to a text file?
For Each tbl In db.TableDefs
If Left$(tbl.Name, 4) <> "MSys" Then
Debug.Print tbl.Name & " " & tbl.DateCreated & " " & _
tbl.LastUpdated & " " & tbl.RecordCount
See the MSDN article on how to create a text file:
http://msdn.microsoft.com/en-us/library/aa265018(v=vs.60).aspx
Modified slightly for your needs, you will have to tweak it to define db and TableDefs etc:
Sub CreateAfile
Dim fs as Object, a as Object
Dim lineText as String
#Create and open text file for writing:
Set fs = CreateObject("Scripting.FileSystemObject")
Set a = fs.CreateTextFile("c:\testfile.txt", True)
'#Iterate over your TableDefs
For Each tbl In db.TableDefs
If Left$(tbl.Name, 4) <> "MSys" Then
lineText = tbl.Name & " " & tbl.DateCreated & " " & _
tbl.LastUpdated & " " & tbl.RecordCount
'# Adds a line to the text file
a.WriteLine(lineText)
End If
Next
'#Close the textfile
a.Close
End Sub
You can use simple File I/O to write to a textfile. MSDN: Write# Statement
Here is the example from that page:
Open "TESTFILE" For Output As #1 ' Open file for output.
Write #1, "Hello World", 234 ' Write comma-delimited data.
Write #1, ' Write blank line.
Dim MyBool, MyDate, MyNull, MyError
' Assign Boolean, Date, Null, and Error values.
MyBool = False: MyDate = #2/12/1969#: MyNull = Null
MyError = CVErr(32767)
' Boolean data is written as #TRUE# or #FALSE#. Date literals are
' written in universal date format, for example, #1994-07-13#
'represents July 13, 1994. Null data is written as #NULL#.
' Error data is written as #ERROR errorcode#.
Write #1, MyBool; " is a Boolean value"
Write #1, MyDate; " is a date"
Write #1, MyNull; " is a null value"
Write #1, MyError; " is an error value"
Close #1 ' Close file.
Change the file name, and extension, to, for example, "C:\SomeFolder\myfile.txt".
There are other, more sophisticated, ways to do this, including using the FileSystemObject as shown in the link David provided.
This will work as a straight copy/paste. Just change the output file name to whatever you want. It outputs the metadata you requested line by line toa .txt
Dim db As DAO.Database
Set db = CurrentDb
Dim filename As String
filename = "C:\Users\Scotch\Desktop\now\t.txt" 'add your file name here
Const ForReading = 1, ForWriting = 2, ForAppending = 3
Const TristateUseDefault = -2, TristateTrue = -1, TristateFalse = 0
Dim fs, f, ts, s
Set fs = CreateObject("Scripting.FileSystemObject")
fs.CreateTextFile filename 'Create a file
Set f = fs.GetFile(filename)
Set ts = f.OpenAsTextStream(ForWriting, TristateUseDefault)
For Each tbl In db.TableDefs
If Left$(tbl.name, 4) <> "MSys" Then
ts.Write tbl.name & " " & tbl.DateCreated & " " & _
tbl.LastUpdated & " " & tbl.RecordCount & vbNewLine
End If
Next
ts.Close
Okay, so I want to have a macro in Excel 2003 which saves the current worksheet as a .txt file. I've already got that part with the following code:
Dim filename As String
Dim path As String
filename = InputBox("Please enter file name", "Save as CSV", "CSV_" & Format(Now, "DD_MM_yyyy"))
path = "C:\Temp" & filename & ".txt"
ActiveWorkbook.SaveAs filename:=path, FileFormat:=xlTextMSDOS, CreateBackup:=False
But now to the actual problem: In my sheet there are some cells which contain a comma. If I use the macro shown above, the file gets saved as CSV, but the cells containing a comma have quotation marks around them. I do not want that.
If I save the file manually via File -> Save as -> CSV/TXT, the resulting file does not contain these quotation marks.
Does anyone know how to solve this problem?
Many thanks!
Edit: I forgot to say that, when saving manually, I select Text tab-seperated, and not comma-seperated.
OK, Let's see what I've got in the attic...
I have a VBA Array To File function which fits the bill: probably overkill for the work you're doing, as you don't need the options for header rows, transposing, and checking for pre-existing files with an error-trap that reads the file's datestamp and prevents repeated calls to the function continually overwriting the file. But it's the code I've got to hand, and simplifying it is more trouble than using it as-is.
The thing you do want is that this function uses the Tab character as a field delimiter by default. You could, of course, set it to the comma... The commonly-accepted definition of csv file is fields delimited by commas and text fields (which may contain the comma character) encapsulated in double-quotes. But I can't claim the moral high ground that would justify this kind of pedantry, because the code below doesn't impose the encapsulating quotes.
Coding Notes:
You need a reference to the Windows Scripting Runtime Library: scrrun.dll - this can be found in the system folder (usually C:\WINDOWS\system32) - as we're using the File System Object;
ArrayToFile writes the data to your named file in the temp folder. If you specify 'CopyFilePath', this will be copied elsewhere: never write to a network folder, it's always faster to write to a local drive and use the native file system functions to move or copy the finished file;
Data is written to the file in blocks, instead of line-by-line;
There is scope for further optimisation: using Split and Join functions would eliminate the string concatenations in the loops;
You might want to use VbCrLF as a row delimiter instead of VbCr: carriage returns usually work but some systems and applications need the Carriage-Return-and-LineFeed combination in order to read or display line breaks correctly.
Using the ArrayToFile function:
This is easy: just feed in the .Value2 property of the sheet's used range:
ArrayToFile Worksheets("Sheet1").UsedRange.Value2, "MyData.csv"
The reason for 'Value2' is that the 'Value' property captures formatting, and you probably want the underlying serial values of date fields.
Source code for the VBA ArrayToFile function:
Share and Enjoy... And watch out for helpful line breaks, inserted wherever they can break the code by your browser (or by StackOverflow's helpful formatting functions):
Public Sub ArrayToFile(ByVal arrData As Variant, _
ByVal strName As String, _
Optional MinFileAge As Double = 0, _
Optional Transpose As Boolean = False, _
Optional RowDelimiter As String = vbCr, _
Optional FieldDelimiter = vbTab, _
Optional CopyFilePath As String, _
Optional NoEmptyRows As Boolean = True, _
Optional arrHeader1 As Variant, _
Optional arrHeader2 As Variant)
' Output an array to a file. The field delimiter is tab (char 9); rows use CarriageReturn(char 13).
' The file will be named as specified by strName, and saved in the user's Windows Temp folder.
' Specify CopyFilePath (the full name and path) to copy this temporary file to another folder.
' Saving files locally and copying them is much faster than writing data across the network.
' If a Min File Age 'n' is specified, and n is greater than zero, an existing file will not be
' replaced, and no data will be written unless the file is more than MinFileAge seconds old.
' Transpose = TRUE is useful for arrays generated by Recordset.GetRows and ListControl.Column
' Note that ADODB.Recordset has a native 'save' method (rows delimited by VbCr, fields by Tab)
' **** This code is in the Public Domain **** Nigel Heffernan http://Excellerando.blogspot.com
On Error Resume Next
Dim objFSO As Scripting.FileSystemObject
Set objFSO = New Scripting.FileSystemObject
If objFSO Is Nothing Then
Shell "Regsvr32.exe /s scrrun.dll", vbHide
Application.Wait Now + (0.25 / 3600 / 24)
Set objFSO = CreateObject("Scripting.FileSystemObject")
End If
If objFSO Is Nothing Then
Exit Sub
End If
Dim strFile As String
Dim strTemp As String
Dim i As Long, j As Long
Dim strData As String
Dim strLine As String
Dim strEmpty As String
Dim dblCount As Double
Const BUFFERLEN As Long = 255
strName = Replace(strName, "[", "")
strName = Replace(strName, "]", "")
Set objFSO = New Scripting.FileSystemObject
If objFSO Is Nothing Then
Shell "Regsvr32.exe /s scrrun.dll", vbHide
Application.Wait Now + (0.25 / 3600 / 24)
Set objFSO = CreateObject("Scripting.FileSystemObject")
End If
If objFSO Is Nothing Then
Exit Sub
End If
strTemp = objFSO.GetSpecialFolder(Scripting.TemporaryFolder).ShortPath
strFile = objFSO.BuildPath(strTemp, strName)
If objFSO.FileExists(strFile) Then
If MinFileAge > 0 Then
If objFSO.GetFile(strFile).DateCreated + (MinFileAge / 3600 / 24) > Now Then
Set objFSO = Nothing
Exit Sub
End If
End If
Err.Clear
objFSO.DeleteFile strFile, True
If Err.Number = 70 Then
VBA.FileSystem.Kill strFile
End If
End If
If objFSO.FileExists(strFile) Then
Exit Sub
End If
Application.StatusBar = "Cacheing data in a temp file... "
strData = vbNullString
With objFSO.OpenTextFile(strFile, ForWriting, True)
' **** **** **** HEADER1 **** **** ****
If Not IsMissing(arrHeader1) Then
If Not IsEmpty(arrHeader1) Then
If InStr(1, TypeName(arrHeader1), "(") > 1 Then ' It's an array...
Select Case ArrayDimensions(arrHeader1)
Case 1 ' Vector array
.Write Join(arrHeader1, RowDelimiter)
Case 2 ' 2-D array... 3-D arrays are not handled
If Transpose = True Then
For i = LBound(arrHeader1, 2) To UBound(arrHeader1, 2)
For j = LBound(arrHeader1, 1) To UBound(arrHeader1, 1)
strData = strData & FieldDelimiter & CStr(arrHeader1(j, i))
Next j
strData = strData & RowDelimiter
Next i
Else ' not transposing:
For i = LBound(arrHeader1, 1) To UBound(arrHeader1, 1)
For j = LBound(arrHeader1, 2) To UBound(arrHeader1, 2)
strData = strData & CStr(arrHeader1(i, j))
If j < UBound(arrHeader1, 2) Then
strData = strData & FieldDelimiter
End If
Next j
strData = strData & RowDelimiter
Next i
End If ' Transpose
End Select
' .Write strData
' strData = vbNullString
Erase arrHeader1
Else ' treat it as a string
If LenB(arrHeader1) > 0 Then
.Write arrHeader1
End If
End If
End If 'Not IsMissing(arrHeader1)
End If 'Not IsEmpty(arrHeader1)
' **** **** **** HEADER2 **** **** ****
If Not IsMissing(arrHeader2) Then
If Not IsEmpty(arrHeader2) Then
If InStr(1, TypeName(arrHeader2), "(") > 1 Then ' It's an array...
Select Case ArrayDimensions(arrHeader2)
Case 1 ' Vector array
.Write Join(arrHeader2, RowDelimiter)
Case 2 ' 2-D array... 3-D arrays are not handled
If Transpose = True Then
For i = LBound(arrHeader2, 2) To UBound(arrHeader2, 2)
For j = LBound(arrHeader2, 1) To UBound(arrHeader2, 1)
strData = strData & FieldDelimiter & CStr(arrHeader2(j, i))
Next j
strData = strData & RowDelimiter
Next i
Else ' not transposing:
For i = LBound(arrHeader2, 1) To UBound(arrHeader2, 1)
For j = LBound(arrHeader2, 2) To UBound(arrHeader2, 2)
strData = strData & CStr(arrHeader2(i, j))
If j < UBound(arrHeader2, 2) Then
strData = strData & FieldDelimiter
End If
Next j
strData = strData & RowDelimiter
Next i
End If ' Transpose
End Select
' .Write strData
' strData = vbNullString
Erase arrHeader2
Else ' treat it as a string
If LenB(arrHeader2) > 0 Then
.Write arrHeader2
End If
End If
End If 'Not IsMissing(arrHeader2)
End If 'Not IsEmpty(arrHeader2)
' **** **** **** BODY **** **** ****
If InStr(1, TypeName(arrData), "(") > 1 Then
' It's an array...
Select Case ArrayDimensions(arrData)
Case 1
If NoEmptyRows Then
.Write Replace$(Join(arrData, RowDelimiter), RowDelimiter & RowDelimiter, "")
Else
.Write Join(arrData, RowDelimiter)
End If
Case 2
If Transpose = True Then
strEmpty = String(UBound(arrData, 1) - 1, FieldDelimiter) & RowDelimiter
For i = LBound(arrData, 2) To UBound(arrData, 2)
For j = LBound(arrData, 1) To UBound(arrData, 1)
strData = strData & FieldDelimiter & CStr(arrData(j, i))
Next j
strData = strData & RowDelimiter
If (Len(strData) \ 1024) > BUFFERLEN Then
If NoEmptyRows Then
strData = Replace$(strData, strEmpty, "")
'strData = Replace$(strData, RowDelimiter & RowDelimiter, "")
End If
Application.StatusBar = "Cacheing data in a temp file... (" & Format(dblCount + (Len(strData) \ 1024), "0,000") & "kB)"
dblCount = dblCount + (Len(strData) \ 1024)
.Write strData
strData = vbNullString
End If
Next i
Else ' not transposing:
strEmpty = String(UBound(arrData, 2) - 1, FieldDelimiter) & RowDelimiter
For i = LBound(arrData, 1) To UBound(arrData, 1)
For j = LBound(arrData, 2) To UBound(arrData, 2)
strData = strData & CStr(arrData(i, j))
If j < UBound(arrData, 2) Then
strData = strData & FieldDelimiter
End If
Next j
strData = strData & RowDelimiter
If (Len(strData) \ 1024) > BUFFERLEN Then
If NoEmptyRows Then
strData = Replace$(strData, strEmpty, "")
'strData = Replace$(strData, RowDelimiter & RowDelimiter, "")
End If
Application.StatusBar = "Cacheing data in a temp file... (" & Format(dblCount + (Len(strData) \ 1024), "0,000") & "kB)"
dblCount = dblCount + (Len(strData) \ 1024)
.Write strData
strData = vbNullString
End If
Next i
End If ' Transpose
End Select
If NoEmptyRows Then
strData = Replace$(strData, strEmpty, "")
'strData = Replace$(strData, RowDelimiter & RowDelimiter, "")
End If
If Right$(strData, Len(RowDelimiter)) = RowDelimiter Then
Mid$(strData, Len(strData) - Len(RowDelimiter), Len(RowDelimiter)) = ""
End If
.Write strData
strData = vbNullString
Erase arrData
Else ' treat it as a string
.Write arrData
End If
.Close
End With ' textstream object from objFSO.OpenTextFile
If CopyFilePath <> "" Then
Application.StatusBar = "Copying " & strName & " to " & CopyFilePath & "..."
objFSO.CopyFile strFile, CopyFilePath, True
End If
Application.StatusBar = False
Set objFSO = Nothing
strData = vbNullString
End Sub
For completeness, here's the complementary function that reads from files into an array, and a rough-and-ready subroutine to clean up your temp files:
Public Sub FileToArray(arrData As Variant, strName As String, Optional MaxFileAge As Double = 0, Optional RowDelimiter As String = vbCr, Optional FieldDelimiter = vbTab, Optional CoerceLowerBound As Long = 0) ' Load a file created by FileToArray into a 2-dimensional array
' The file name is specified by strName, and it is exected to exist in the user's temporary folder.
' This is a deliberate restriction: it's always faster to copy remote files to a local drive than to edit them across the network
' If a Max File Age 'n' is specified, and n is greater than zero, files more than n seconds old will NOT be read.
' **** This code is in the Public Domain **** Nigel Heffernan http://Excellerando.blogspot.com
On Error Resume Next
Dim objFSO As Scripting.FileSystemObject
Set objFSO = New Scripting.FileSystemObject
If objFSO Is Nothing Then
Shell "Regsvr32.exe /s scrrun.dll", vbHide
Application.Wait Now + (0.25 / 3600 / 24)
Set objFSO = CreateObject("Scripting.FileSystemObject")
End If
If objFSO Is Nothing Then
Exit Sub
End If
Dim strFile As String
Dim strTemp As String
Dim i As Long
Dim j As Long
Dim i_n As Long
Dim j_n As Long
Dim i_lBound As Long
Dim i_uBound As Long
Dim j_lBound As Long
Dim j_uBound As Long
Dim arrTemp1 As Variant
Dim arrTemp2 As Variant
Dim dblCount As Double
Set objFSO = New Scripting.FileSystemObject
If objFSO Is Nothing Then
Shell "Regsvr32.exe /s scrrun.dll", vbHide
Application.Wait Now + (0.25 / 3600 / 24)
Set objFSO = CreateObject("Scripting.FileSystemObject")
End If
If objFSO Is Nothing Then
Exit Sub
End If
strTemp = objFSO.GetSpecialFolder(Scripting.TemporaryFolder).ShortPath
strFile = objFSO.BuildPath(strTemp, strName)
If Not objFSO.FileExists(strFile) Then
Exit Sub
End If
If MaxFileAge > 0 Then
' If the file's a bit elderly, bail out - the calling function will refresh the data from source
If objFSO.GetFile(strFile).DateCreated + (MaxFileAge / 3600 / 24) < Now Then
Set objFSO = Nothing
Exit Sub
End If
End If
Application.StatusBar = "Reading the file... (" & strName & ")"
arrData = Split2d(objFSO.OpenTextFile(strFile, ForReading).ReadAll, RowDelimiter, FieldDelimiter, CoerceLowerBound)
Application.StatusBar = "Reading the file... Done"
Set objFSO = Nothing
End Sub
Public Sub RemoveTempFiles(ParamArray FileNames())
On Error Resume Next
Dim objFSO As Scripting.FileSystemObject
Set objFSO = New Scripting.FileSystemObject
If objFSO Is Nothing Then
Shell "Regsvr32.exe /s scrrun.dll", vbHide
Application.Wait Now + (0.25 / 3600 / 24)
Set objFSO = CreateObject("Scripting.FileSystemObject")
End If
If objFSO Is Nothing Then
Exit Sub
End If
Dim varName As Variant
Dim strName As String
Dim strFile As String
Dim strTemp As String
strTemp = objFSO.GetSpecialFolder(Scripting.TemporaryFolder).ShortPath
For Each varName In FileNames
strName = vbNullString
strFile = vbNullString
strName = CStr(varName)
strFile = objFSO.BuildPath(strTemp, strName)
If objFSO.FileExists(strFile) Then
objFSO.DeleteFile strFile, True
End If
Next varName
Set objFSO = Nothing
End Sub
I'd advise you to keep this in a module under Option Private Module - this isn't the kind of function I'd want other users calling from a worksheet directly.
This is impossible (sort of).
A field that contains the delimiter must be enclosed in quotes. Otherwise, that field would be "torn in two" by the delimiter.
The only solution is to use a different delimiter, for example tabs (effectively changing it to a TSV file), which of course only works if that new delimiter doesn't occur in the data either.
If none of the SaveAs formats work for you, write your parser, eg
Sub SaveFile()
Dim rng As Range
Dim rw As Range
Dim ln As Variant
' Set rng to yout data range, eg
Set rng = ActiveSheet.UsedRange
Open "C:\Temp\TESTFILE.txt" For Output As #1 ' Open file for output.
For Each rw In rng.Rows
ln = Join(Application.Transpose(Application.Transpose(rw)), vbTab)
Print #1, ln; vbNewLine;
Next
Close #1
End Sub