Escaping non-ASCII characters (or how to remove the BOM?) - ms-access

I need to create an ANSI text file from an Access recordset that outputs to JSON and YAML. I can write the file, but the output is coming out with the original characters, and I need to escape them. For example, an umlaut-O (ö) should be "\u00f6".
I thought encoding the file as UTF-8 would work, but it doesn't. However, having looked at the file coding again, if you write "UTF-8 without BOM" then everything works.
Does anyone know how to either
a) Write text out as UTF-8 without BOM, or
b) Write in ANSI but escaping the non-ASCII characters?
Public Sub testoutput()
Set db = CurrentDb()
str_filename = "anothertest.json"
MyFile = CurrentProject.Path & "\" & str_filename
str_temp = "Hello world here is an ö"
fnum = FreeFile
Open MyFile For Output As fnum
Print #fnum, str_temp
Close #fnum
End Sub

... ok .... i found some example code on how to remove the BOM. I would have thought it would be possible to do this more elegantly when actually writing the text in the first place. Never mind. The following code removes the BOM.
(This was originally posted by Simon Pedersen at http://www.imagemagick.org/discourse-server/viewtopic.php?f=8&t=12705)
' Removes the Byte Order Mark - BOM from a text file with UTF-8 encoding
' The BOM defines that the file was stored with an UTF-8 encoding.
Public Function RemoveBOM(filePath)
' Create a reader and a writer
Dim writer, reader, fileSize
Set writer = CreateObject("Adodb.Stream")
Set reader = CreateObject("Adodb.Stream")
' Load from the text file we just wrote
reader.Open
reader.LoadFromFile filePath
' Copy all data from reader to writer, except the BOM
writer.Mode = 3
writer.Type = 1
writer.Open
reader.Position = 5
reader.CopyTo writer, -1
' Overwrite file
writer.SaveToFile filePath, 2
' Return file name
RemoveBOM = filePath
' Kill objects
Set writer = Nothing
Set reader = Nothing
End Function
It might be useful for someone else.

Late to the game here, but I can't be the only coder who got got fed up with my SQL imports being broken by text files with a Byte Order Marker. There are very few 'Stack questions that touch on the problem - this is one of closest - so I'm posting an overlapping answer here.
I say 'overlapping' because the code below is solving a slightly different problem to yours - the primary purpose is writing a Schema file for a folder with a heterogeneous collection of files - but the BOM-handling segment is clearly marked.
The key functionality is that we iterate through all the '.csv' files in a folder, and we test each file with a quick nibble of the first four bytes: and we only only strip out the Byte Order Marker if we see one.
After that, we're working in low-level file-handling code from the primordial C. We have to, all the way down to using byte arrays, because everything else that you do in VBA will deposit the Byte Order Markers embedded in the structure of a string variable.
So, without further adodb, here's the code:
BOM-Disposal code for text files in a schema.ini file:
Public Sub SetSchema(strFolder As String)
On Error Resume Next
' Write a Schema.ini file to the data folder.
' This is necessary if we do not have the registry privileges to set the
' correct 'ImportMixedTypes=Text' registry value, which overrides IMEX=1
' The code also checks for ANSI or UTF-8 and UTF-16 files, and applies a
' usable setting for CharacterSet ( UNICODE|ANSI ) with a horrible hack.
' OEM codepage-defined text is not supported: further coding is required
' ...And we strip out Byte Order Markers, if we see them - the OLEDB SQL
' provider for textfiles can't deal with a BOM in a UTF-16 or UTF-8 file
' Not implemented: handling tab-delimited files or other delimiters. The
' code assumes a header row with columns, specifies 'scan all rows', and
' imposes 'read the column as text' if the data types are mixed.
Dim strSchema As String
Dim strFile As String
Dim hndFile As Long
Dim arrFile() As Byte
Dim arrBytes(0 To 4) As Byte
If Right(strFolder, 1) <> "\" Then strFolder = strFolder & "\"
' Dir() is an iterator function when you call it with a wildcard:
strFile = VBA.FileSystem.Dir(strFolder & "*.csv")
Do While Len(strFile) > 0
hndFile = FreeFile
Open strFolder & strFile For Binary As #hndFile
Get #hndFile, , arrBytes
Close #hndFile
strSchema = strSchema & "[" & strFile & "]" & vbCrLf
strSchema = strSchema & "Format=CSVDelimited" & vbCrLf
strSchema = strSchema & "ImportMixedTypes=Text" & vbCrLf
strSchema = strSchema & "MaxScanRows=0" & vbCrLf
If arrBytes(2) = 0 Or arrBytes(3) = 0 Then ' this is a hack
strSchema = strSchema & "CharacterSet=UNICODE" & vbCrLf
Else
strSchema = strSchema & "CharacterSet=ANSI" & vbCrLf
End If
strSchema = strSchema & "ColNameHeader = True" & vbCrLf
strSchema = strSchema & vbCrLf
' BOM disposal - Byte order marks confuse OLEDB text drivers:
If arrBytes(0) = &HFE And arrBytes(1) = &HFF _
Or arrBytes(0) = &HFF And arrBytes(1) = &HFE Then
hndFile = FreeFile
Open strFolder & strFile For Binary As #hndFile
ReDim arrFile(0 To LOF(hndFile) - 1)
Get #hndFile, , arrFile
Close #hndFile
BigReplace arrFile, arrBytes(0) & arrBytes(1), ""
hndFile = FreeFile
Open strFolder & strFile For Binary As #hndFile
Put #hndFile, , arrFile
Close #hndFile
Erase arrFile
ElseIf arrBytes(0) = &HEF And arrBytes(1) = &HBB And arrBytes(2) = &HBF Then
hndFile = FreeFile
Open strFolder & strFile For Binary As #hndFile
ReDim arrFile(0 To LOF(hndFile) - 1)
Get #hndFile, , arrFile
Close #hndFile
BigReplace arrFile, arrBytes(0) & arrBytes(1) & arrBytes(2), ""
hndFile = FreeFile
Open strFolder & strFile For Binary As #hndFile
Put #hndFile, , arrFile
Close #hndFile
Erase arrFile
End If
strFile = ""
strFile = Dir
Loop
If Len(strSchema) > 0 Then
strFile = strFolder & "Schema.ini"
hndFile = FreeFile
Open strFile For Binary As #hndFile
Put #hndFile, , strSchema
Close #hndFile
End If
End Sub
Public Sub BigReplace(ByRef arrBytes() As Byte, ByRef SearchFor As String, ByRef ReplaceWith As String)
On Error Resume Next
Dim varSplit As Variant
varSplit = Split(arrBytes, SearchFor)
arrBytes = Join$(varSplit, ReplaceWith)
Erase varSplit
End Sub
The code's easier to understand if you know that a Byte Array can be assigned to a VBA.String, and vice versa. The BigReplace() function is a hack that sidesteps some of VBA's inefficient string-handling, especially allocation: you'll find that large files cause serious memory and performance problems if you do it any other way.

Related

copyhere doesn't respect overwrite parameter in VBA

I'm writing a VBA code to add files, which are into several folders, into a ZIP file.
This procedure should run automatically, by a scheduled job, and I try to add a parameter to force "yes to all".
In Microsoft support there are some constants but if I add to my code, I don't have the aspected result.
the code is the following
Public Sub ZipFolder(ZipFileName As Variant, _
FolderPath As Variant, _
Optional ByVal FileFilter As String, _
Optional ByVal Overwrite As Boolean = False)
Dim fso As Object, tf As Object
Dim strZIPHeader As String, sFile As String
On Error GoTo done
' create zip file header
strZIPHeader = Chr(80) & Chr(75) & Chr(5) & Chr(6) & String(18, Chr(0))
With CreateObject("Shell.Application")
sFile = Dir(FolderPath, vbNormal)
Do Until sFile = vbNullString
.Namespace(ZipFileName).CopyHere FolderPath & sFile, **"&H10&"**
sFile = Dir
Loop
End With
Set fso = Nothing
Set tf = Nothing
done:
If Err.Number <> 0 Then MsgBox Err.Description, vbApplicationModal + vbInformation
End Sub
The parameter &H10& doesn't work. I have tried with "&0X14&" as well but same result.
Any idea?
Thank you
You can study the article and full code here on exactly this subject:
Zip and unzip files and folders with VBA the Windows Explorer way
You'll see, that shall the file be overwritten, it is simply deleted before proceeding:
If FileSystemObject.FileExists(ZipFile) Then
If Overwrite = True Then
' Delete an existing file.
FileSystemObject.DeleteFile ZipFile, True
' At this point either the file is deleted or an error is raised.
Else
ZipBase = FileSystemObject.GetBaseName(ZipFile)
' Modify name of the zip file to be created to preserve an existing file:
' "Example.zip" -> "Example (2).zip", etc.
Version = Version + 1
Do
Version = Version + 1
ZipFile = FileSystemObject.BuildPath(ZipPath, ZipBase & Format(Version, " \(0\)") & ZipExtension)
Loop Until FileSystemObject.FileExists(ZipFile) = False Or Version > MaxZipVersion
If Version > MaxZipVersion Then
' Give up.
Err.Raise ErrorPathFile, "Zip Create", "File could not be created."
End If
End If
End If

How do I prevent this Error Message

I have created a VBA access application to find a PDF file in a folder by doing one sweep to get all the sub-folders in the root folder. Then another sweep to collect and compare all the file names to the one that is selected. We are then using the following code to open the file when it is found:
Private Sub Command132_Click()
On Error GoTo Err_Command132_Click
Dim rootFolder As String
Dim subFolder As String
Dim fileSpec As String
Dim filename As String
Dim foundfile As String
Dim filepath As String
Dim subfolders() As String
Dim co As String
Dim intSubFolderCount As Integer
rootFolder = "T:\Scanned Work Orders (Archives)\"
subFolder = Dir(rootFolder & "*.*", vbDirectory)
'*** Get subfolders in array ***
While subFolder <> ""
If subFolder <> "." And subFolder <> ".." Then
ReDim Preserve subfolders(intSubFolderCount)
subfolders(intSubFolderCount) = subFolder
intSubFolderCount = intSubFolderCount + 1
Debug.Print subFolder
End If
subFolder = Dir()
Wend
'*** Loop over array and find files ***
For intSubFolderCount = 0 To UBound(subfolders)
fileSpec = Trim(Me.Combo_History) & "*.pdf"
co = subfolders(intSubFolderCount)
filename = Dir(rootFolder & subfolders(intSubFolderCount) & "\" & fileSpec)
Do While filename <> ""
filepath = rootFolder & subfolders(intSubFolderCount)
foundfile = filepath & "\" & filename
Application.FollowHyperlink foundfile
GoTo Exit_Command132_Click
Exit Do
Loop
Next intSubFolderCount
MsgBox "No Scanned work order found for " & Me.Combo_History & "!"
Exit_Command132_Click:
Exit Sub
Err_Command132_Click:
Select Case Err.Number
Case 52
MsgBox "No Scanned work order found for " & Me.Combo_History & "!"
Case Else
MsgBox Err.Number & "-" & Err.Description
End Select
End Sub
But on some of the computers in my office they get this error message:
"Some Files can contain viruses or otherwise be harmful to your computer.
It is important to be certain that this file is from a trustworthy source.
Would you like to open this file?"
Is it possible to suppress this? We are running windows 7 professional.
This is a windows feature. Microsoft have KB on removing it here.
https://support.microsoft.com/en-us/kb/925757
It is possible to use VBA to change the registry settings, but follow the KB instructions first to ensure it solves your issue.

Importing csv file with hidden characters into Excel using vba

With the help of this forum have been able to solve most problem but this has me stuck.
I have a comma delimited csv file ("xxxx","zzz",) that has hidden chr(10) and chr(13) in the file. If I use a script to replace both these characters, I lose the end of record chr(10) so only imports as one record.
In notepad the file shows perfect - one record per line. If I open as a an excel file it is ok, its only when I import as a csv delimited file
With thanks to other contributors, below is what I have been using.
Ideally what I would like to do is:
select the csv file
copy the file to keep the original <<< extra function
clean up all hidden characters that would affect the import
then import
-
Private Sub CSV_ImportRepl()
Dim strFile As String
Dim strBuffer As String
Dim ff As Integer
Dim strFileName As String
Dim ws As Worksheet
'ENTRIES CSV FILE ----------------------------------
' ---open file ----------
strFile = Application.GetOpenFilename("Text Files (*.csv),*.*", _
, "SELECT ENTRIES csv FILE")
strFileName = strFile
MsgBox strFileName
' ---start cleaning file ----------
strBuffer = Space(FileLen(strFile))
ff = FreeFile
Open strFile For Binary Access Read As #ff
Get #ff, , strBuffer
Close #ff
strBuffer = Replace(strBuffer, Chr(13), "")
Kill strFile
Open strFile For Binary Access Write As #ff
Put #ff, , strBuffer
Close #ff
' --- clear contents & import ----------
Sheets("Entries").Cells.ClearContents
Set ws = ActiveWorkbook.Sheets("Entries") 'set to current worksheet name
strFile = strFileName
With ws.QueryTables.Add(Connection:="TEXT;" & strFile, _
Destination:=ws.Range("A1"))
.TextFileParseType = xlDelimited
.TextFileCommaDelimiter = True
.Refresh
End With
End Sub
Any help would be most appreciated.
Sub opencsv()
strFile = Application.GetOpenFilename("Text Files (*.csv),*.*", , "Please selec text file...")
strFileName = strFile
Set src = Workbooks.Open(Filename:=strFile, Local:=True)
Cells.Copy
ThisWorkbook.Activate
Sheets("Entries").Activate
Range("A1").Select
ActiveSheet.Paste
Application.CutCopyMode = False
src.Close
End Sub

Is it possible to batch convert csv to xls using a macro?

I have a large amount of csv files that I need in .xls format. Is it possible to run a batch conversion with a macro or best done with another language?
I have used this code http://www.ozgrid.com/forum/showthread.php?t=71409&p=369573#post369573 to reference my directory but I'm not sure of the command to open each file and save them. Here's what I have:
Sub batchconvertcsvxls()
Dim wb As Workbook
Dim CSVCount As Integer
Dim myVar As String
myVar = FileList("C:\Documents and Settings\alistairw\My Documents\csvxlstest")
For i = LBound(myVar) To UBound(myVar)
With wb
Application.Workbooks.OpenText 'How do I reference the myvar string ?
wb.SaveAs '....
End With
Next
End Sub
Function FileList(fldr As String, Optional fltr As String = "*.*") As Variant
Dim sTemp As String, sHldr As String
If Right$(fldr, 1) <> "\" Then fldr = fldr & "\"
sTemp = Dir(fldr & fltr)
If sTemp = "" Then
FileList = Split("No files found", "|") 'ensures an array is returned
Exit Function
End If
Do
sHldr = Dir
If sHldr = "" Then Exit Do
sTemp = sTemp & "|" & sHldr
Loop
FileList = Split(sTemp, "|")
End Function
Edit: The files are .txt files formatted as csv
By combining the code given by Scott Holtzman and 'ExcelFreak', the conversion works quite well. The final code looks something like this:
Sub CSV_to_XLS()
Dim wb As Workbook
Dim strFile As String, strDir As String
strDir = "U:\path\"
strFile = Dir(strDir & "*.csv")
Do While strFile <> ""
Set wb = Workbooks.Open(Filename:=strDir & strFile, Local:=True)
wb.SaveAs Replace(wb.FullName, ".csv", ".xls"), 50 'UPDATE:
wb.Close True
Set wb = Nothing
strFile = Dir
Loop
End Sub
Opening the converted .xls file throws a warning everytime:
"The file you are trying to open, 'filename', is in a different format than specified by the file extension. Verify that the file is not corrupted and is from a trusted source before opening the file. Do you want to open the file now?"
Clicking Yes then opens the .xls file.
Is there a way to get rid of this warning message? Excel throws a warning everytime the .xls file is opened.
In a lot less lines of code, this should get you what you want. However, I will say this may not be the fastest way to get it done, because you are opening, saving, and closing the workbook every time. I will look for a faster way, but I forget the method off the top of my head.
Sub batchconvertcsvxls()
Dim wb As Workbook
Dim strFile As String, strDir As String
strDir = "C:\"
strFile = Dir(strDir & "*.csv")
Do While strFile <> ""
Set wb = Workbooks.Open(strDir & strFile)
With wb
.SaveAs Replace(wb.FullName, ".csv", ".xls"), 50 'UPDATE:
.Close True
End With
Set wb = Nothing
Loop
End Sub
** UPDATE **
you need the proper fileformat enumeration for a .xls file. I think its 50, but you can check here Excel File Type Enumeration, if it's not.
The Code of Scott Holtzman nearly did it for me. I had to make two changes to get it to work:
He forgot to add the line that makes our loop continue with the next file. The last line before the Loop should read
strFile = Dir
The Workbooks.Open method did not read my CSV files as expected (the whole line ended up to be text in the first cell). When I added the parameter Local:=True it worked:
Set wb = Workbooks.Open(Filename:=strDir & strFile, Local:=True)
This works properly at least on Excel 2013. Using FileFormat:=xlExcel8 parameter instead of the filetype tag 50 creates files that open without security nags.
Sub CSV_to_XLS()
Dim wb As Workbook
Dim strFile As String, strDir As String
strDir = "C:\temp\"
strFile = Dir(strDir & "*.csv")
Do While strFile <> ""
Set wb = Workbooks.Open(Filename:=strDir & strFile, Local:=True)
wb.SaveAs Replace(wb.FullName, ".csv", ".xls"), FileFormat:=xlExcel8
wb.Close True
Set wb = Nothing
strFile = Dir
Loop
End Sub
This was a good question and I have found in the internet several answers. Just making very small changes (I couldn't edit any of the codes already published) I could make things work a bit better:
Sub CSV_to_XLSX()
Dim wb As Workbook
Dim strFile As String, strDir As String
strDir = "C:\Users\acer\OneDrive\Doctorado\Study 1\data\Retest Bkp\Day 1\Sart\"
strFile = Dir(strDir & "*.csv")
Do While strFile <> ""
Set wb = Workbooks.Open(Filename:=strDir & strFile, Local:=True)
With wb
.SaveAs Replace(wb.FullName, ".csv", ".xlsx"), 51
.Close True
End With
Set wb = Nothing
strFile = Dir
Loop
End Sub

How to export report to ONE SINGLE html file?

When I use the Export to html function with Report, Access generate multiple pages of html (each page has about 30 lines or so of data).
How can I force Access to generate ONE SINGLE html file for the whole report? Thanks.
I created a function that may be helpful for others. It takes the a file path and then follows the links until the document is done. You need to export the report to an html file and then use that path in this function. I use it for creating a message for Outlook.
This requires a reference to the Windows Script Host Object Model
Public Function fReadFile(strFile As String) As String
On Error GoTo ErrHandler
Dim FSO As FileSystemObject
Dim tsInput As TextStream
Dim strLine, strMessage As String
Dim strNextFile As String
Dim blnEnd As Boolean
Do While Not blnEnd
Set FSO = New FileSystemObject
Set tsInput = FSO.OpenTextFile(strFile, 1)
Do While Not tsInput.AtEndOfStream
strLine = tsInput.ReadLine
If InStr(1, strLine, ">First<", vbTextCompare) > 0 And InStr(1, strLine, ">Previous<", vbTextCompare) > 0 And InStr(1, strLine, ">Next<", vbTextCompare) > 0 And InStr(1, strLine, ">Last<", vbTextCompare) > 0 Then
Debug.Print strLine
strNextFile = Mid(strLine, InStr(1, strLine, ">Previous</A> Next<", vbTextCompare) - (InStr(1, strLine, ">Previous <A HREF=", vbTextCompare) + 23))
rem put the directory back in the file name
strNextFile = IIf(strNextFile <> "#", Mid(strFile, 1, (InStrRev(strFile, "\"))) & strNextFile, strFile)
blnEnd = (strNextFile = strFile)
Else
strMessage = strMessage & strLine
End If
Loop
tsInput.Close
Set FSO = Nothing
strFile = strNextFile
Loop
fReadFile = strMessage
Exit Function
ErrHandler:
Debug.Print Err.Description & " " & "fReadFile"
Resume Next
End Function
well it's kind of a funny workaround but you could export as an .rtf, then open in word and save as .htm. voila!
Can't be done. Paper size has to be set based on printer driver. Access does not allow User Defined paper size even though this option exists in Page Setup.