VBA cannot create UTF-8 XML [duplicate] - excel

how can I write UTF-8 encoded strings to a textfile from vba, like
Dim fnum As Integer
fnum = FreeFile
Open "myfile.txt" For Output As fnum
Print #fnum, "special characters: äöüß" 'latin-1 or something by default
Close fnum
Is there some setting on Application level?

I found the answer on the web:
Dim fsT As Object
Set fsT = CreateObject("ADODB.Stream")
fsT.Type = 2 'Specify stream type - we want To save text/string data.
fsT.Charset = "utf-8" 'Specify charset For the source text data.
fsT.Open 'Open the stream And write binary data To the object
fsT.WriteText "special characters: äöüß"
fsT.SaveToFile sFileName, 2 'Save binary data To disk
Certainly not as I expected...

You can use CreateTextFile or OpenTextFile method, both have an attribute "unicode" useful for encoding settings.
object.CreateTextFile(filename[, overwrite[, unicode]])
object.OpenTextFile(filename[, iomode[, create[, format]]])
Example: Overwrite:
CreateTextFile:
fileName = "filename"
Set fso = CreateObject("Scripting.FileSystemObject")
Set out = fso.CreateTextFile(fileName, True, True)
out.WriteLine ("Hello world!")
...
out.close
Example: Append:
OpenTextFile Set fso = CreateObject("Scripting.FileSystemObject")
Set out = fso.OpenTextFile("filename", ForAppending, True, 1)
out.Write "Hello world!"
...
out.Close
See more on MSDN docs

This writes a Byte Order Mark at the start of the file, which is unnecessary in a UTF-8 file and some applications (in my case, SAP) don't like it.
Solution here: Can I export excel data with UTF-8 without BOM?

Here is another way to do this - using the API function WideCharToMultiByte:
Option Explicit
Private Declare Function WideCharToMultiByte Lib "kernel32.dll" ( _
ByVal CodePage As Long, _
ByVal dwFlags As Long, _
ByVal lpWideCharStr As Long, _
ByVal cchWideChar As Long, _
ByVal lpMultiByteStr As Long, _
ByVal cbMultiByte As Long, _
ByVal lpDefaultChar As Long, _
ByVal lpUsedDefaultChar As Long) As Long
Private Sub getUtf8(ByRef s As String, ByRef b() As Byte)
Const CP_UTF8 As Long = 65001
Dim len_s As Long
Dim ptr_s As Long
Dim size As Long
Erase b
len_s = Len(s)
If len_s = 0 Then _
Err.Raise 30030, , "Len(WideChars) = 0"
ptr_s = StrPtr(s)
size = WideCharToMultiByte(CP_UTF8, 0, ptr_s, len_s, 0, 0, 0, 0)
If size = 0 Then _
Err.Raise 30030, , "WideCharToMultiByte() = 0"
ReDim b(0 To size - 1)
If WideCharToMultiByte(CP_UTF8, 0, ptr_s, len_s, VarPtr(b(0)), size, 0, 0) = 0 Then _
Err.Raise 30030, , "WideCharToMultiByte(" & Format$(size) & ") = 0"
End Sub
Public Sub writeUtf()
Dim file As Integer
Dim s As String
Dim b() As Byte
s = "äöüßµ#€|~{}[]²³\ .." & _
" OMEGA" & ChrW$(937) & ", SIGMA" & ChrW$(931) & _
", alpha" & ChrW$(945) & ", beta" & ChrW$(946) & ", pi" & ChrW$(960) & vbCrLf
file = FreeFile
Open "C:\Temp\TestUtf8.txt" For Binary Access Write Lock Read Write As #file
getUtf8 s, b
Put #file, , b
Close #file
End Sub

I looked into the answer from Máťa whose name hints at encoding qualifications and experience. The VBA docs say CreateTextFile(filename, [overwrite [, unicode]]) creates a file "as a Unicode or ASCII file. The value is True if the file is created as a Unicode file; False if it's created as an ASCII file. If omitted, an ASCII file is assumed." It's fine that a file stores unicode characters, but in what encoding? Unencoded unicode can't be represented in a file.
The VBA doc page for OpenTextFile(filename[, iomode[, create[, format]]]) offers a third option for the format:
TriStateDefault 2 "opens the file using the system default."
TriStateTrue 1 "opens the file as Unicode."
TriStateFalse 0 "opens the file as ASCII."
Máťa passes -1 for this argument.
Judging from VB.NET documentation (not VBA but I think reflects realities about how underlying Windows OS represents unicode strings and echoes up into MS Office, I don't know) the system default is an encoding using 1 byte/unicode character using an ANSI code page for the locale. UnicodeEncoding is UTF-16. The docs also describe UTF-8 is also a "Unicode encoding," which makes sense to me. But I don't yet know how to specify UTF-8 for VBA output nor be confident that the data I write to disk with the OpenTextFile(,,,1) is UTF-16 encoded. Tamalek's post is helpful.

I didn't want to change all my code just to support several UTF8 strings so i let my code do it's thing, and after the file was saved (in ANSI code as it is the default of excel) i then convert the file to UTF-8 using this code:
Sub convertTxttoUTF(sInFilePath As String, sOutFilePath As String)
Dim objFS As Object
Dim iFile As Double
Dim sFileData As String
'Init
iFile = FreeFile
Open sInFilePath For Input As #iFile
sFileData = Input$(LOF(iFile), iFile)
sFileData = sFileData & vbCrLf
Close iFile
'Open & Write
Set objFS = CreateObject("ADODB.Stream")
objFS.Charset = "utf-8"
objFS.Open
objFS.WriteText sFileData
'Save & Close
objFS.SaveToFile sOutFilePath, 2 '2: Create Or Update
objFS.Close
'Completed
Application.StatusBar = "Completed"
End Sub
and i use this sub like this (this is an example):
Call convertTxttoUTF("c:\my.json", "c:\my-UTF8.json")
i found this code here: VBA to Change File Encoding ANSI to UTF8 – Text to Unicode
and since this is written with BOM marker, in order to remove the bom i changed the Sub to this:
Sub convertTxttoUTF(sInFilePath As String, sOutFilePath As String)
Dim objStreamUTF8 As Object
Dim objStreamUTF8NoBOM As Object
Dim iFile As Double
Dim sFileData As String
Const adSaveCreateOverWrite = 2
Const adTypeBinary = 1
Const adTypeText = 2
'Init
iFile = FreeFile
Open sInFilePath For Input As #iFile
sFileData = Input(LOF(iFile), iFile)
Close iFile
'Open files
Set objStreamUTF8 = CreateObject("ADODB.Stream")
Set objStreamUTF8NoBOM = CreateObject("ADODB.Stream")
' wrute the fules
With objStreamUTF8
.Charset = "UTF-8"
.Open
.WriteText sFileData
.Position = 0
.SaveToFile sOutFilePath, adSaveCreateOverWrite
.Type = adTypeText
.Position = 3
End With
With objStreamUTF8NoBOM
.Type = adTypeBinary
.Open
objStreamUTF8.CopyTo objStreamUTF8NoBOM
.SaveToFile sOutFilePath, 2
End With
' close the files
objStreamUTF8.Close
objStreamUTF8NoBOM.Close
End Sub
i used this answer to solve the BOM unknown character at the beginning of the file

The traditional way to transform a string to a UTF-8 string is as follows:
StrConv("hello world",vbFromUnicode)
So put simply:
Dim fnum As Integer
fnum = FreeFile
Open "myfile.txt" For Output As fnum
Print #fnum, StrConv("special characters: äöüß", vbFromUnicode)
Close fnum
No special COM objects required

Related

Appending 2 CSV files, but produces garbage characters [duplicate]

how can I write UTF-8 encoded strings to a textfile from vba, like
Dim fnum As Integer
fnum = FreeFile
Open "myfile.txt" For Output As fnum
Print #fnum, "special characters: äöüß" 'latin-1 or something by default
Close fnum
Is there some setting on Application level?
I found the answer on the web:
Dim fsT As Object
Set fsT = CreateObject("ADODB.Stream")
fsT.Type = 2 'Specify stream type - we want To save text/string data.
fsT.Charset = "utf-8" 'Specify charset For the source text data.
fsT.Open 'Open the stream And write binary data To the object
fsT.WriteText "special characters: äöüß"
fsT.SaveToFile sFileName, 2 'Save binary data To disk
Certainly not as I expected...
You can use CreateTextFile or OpenTextFile method, both have an attribute "unicode" useful for encoding settings.
object.CreateTextFile(filename[, overwrite[, unicode]])
object.OpenTextFile(filename[, iomode[, create[, format]]])
Example: Overwrite:
CreateTextFile:
fileName = "filename"
Set fso = CreateObject("Scripting.FileSystemObject")
Set out = fso.CreateTextFile(fileName, True, True)
out.WriteLine ("Hello world!")
...
out.close
Example: Append:
OpenTextFile Set fso = CreateObject("Scripting.FileSystemObject")
Set out = fso.OpenTextFile("filename", ForAppending, True, 1)
out.Write "Hello world!"
...
out.Close
See more on MSDN docs
This writes a Byte Order Mark at the start of the file, which is unnecessary in a UTF-8 file and some applications (in my case, SAP) don't like it.
Solution here: Can I export excel data with UTF-8 without BOM?
Here is another way to do this - using the API function WideCharToMultiByte:
Option Explicit
Private Declare Function WideCharToMultiByte Lib "kernel32.dll" ( _
ByVal CodePage As Long, _
ByVal dwFlags As Long, _
ByVal lpWideCharStr As Long, _
ByVal cchWideChar As Long, _
ByVal lpMultiByteStr As Long, _
ByVal cbMultiByte As Long, _
ByVal lpDefaultChar As Long, _
ByVal lpUsedDefaultChar As Long) As Long
Private Sub getUtf8(ByRef s As String, ByRef b() As Byte)
Const CP_UTF8 As Long = 65001
Dim len_s As Long
Dim ptr_s As Long
Dim size As Long
Erase b
len_s = Len(s)
If len_s = 0 Then _
Err.Raise 30030, , "Len(WideChars) = 0"
ptr_s = StrPtr(s)
size = WideCharToMultiByte(CP_UTF8, 0, ptr_s, len_s, 0, 0, 0, 0)
If size = 0 Then _
Err.Raise 30030, , "WideCharToMultiByte() = 0"
ReDim b(0 To size - 1)
If WideCharToMultiByte(CP_UTF8, 0, ptr_s, len_s, VarPtr(b(0)), size, 0, 0) = 0 Then _
Err.Raise 30030, , "WideCharToMultiByte(" & Format$(size) & ") = 0"
End Sub
Public Sub writeUtf()
Dim file As Integer
Dim s As String
Dim b() As Byte
s = "äöüßµ#€|~{}[]²³\ .." & _
" OMEGA" & ChrW$(937) & ", SIGMA" & ChrW$(931) & _
", alpha" & ChrW$(945) & ", beta" & ChrW$(946) & ", pi" & ChrW$(960) & vbCrLf
file = FreeFile
Open "C:\Temp\TestUtf8.txt" For Binary Access Write Lock Read Write As #file
getUtf8 s, b
Put #file, , b
Close #file
End Sub
I looked into the answer from Máťa whose name hints at encoding qualifications and experience. The VBA docs say CreateTextFile(filename, [overwrite [, unicode]]) creates a file "as a Unicode or ASCII file. The value is True if the file is created as a Unicode file; False if it's created as an ASCII file. If omitted, an ASCII file is assumed." It's fine that a file stores unicode characters, but in what encoding? Unencoded unicode can't be represented in a file.
The VBA doc page for OpenTextFile(filename[, iomode[, create[, format]]]) offers a third option for the format:
TriStateDefault 2 "opens the file using the system default."
TriStateTrue 1 "opens the file as Unicode."
TriStateFalse 0 "opens the file as ASCII."
Máťa passes -1 for this argument.
Judging from VB.NET documentation (not VBA but I think reflects realities about how underlying Windows OS represents unicode strings and echoes up into MS Office, I don't know) the system default is an encoding using 1 byte/unicode character using an ANSI code page for the locale. UnicodeEncoding is UTF-16. The docs also describe UTF-8 is also a "Unicode encoding," which makes sense to me. But I don't yet know how to specify UTF-8 for VBA output nor be confident that the data I write to disk with the OpenTextFile(,,,1) is UTF-16 encoded. Tamalek's post is helpful.
I didn't want to change all my code just to support several UTF8 strings so i let my code do it's thing, and after the file was saved (in ANSI code as it is the default of excel) i then convert the file to UTF-8 using this code:
Sub convertTxttoUTF(sInFilePath As String, sOutFilePath As String)
Dim objFS As Object
Dim iFile As Double
Dim sFileData As String
'Init
iFile = FreeFile
Open sInFilePath For Input As #iFile
sFileData = Input$(LOF(iFile), iFile)
sFileData = sFileData & vbCrLf
Close iFile
'Open & Write
Set objFS = CreateObject("ADODB.Stream")
objFS.Charset = "utf-8"
objFS.Open
objFS.WriteText sFileData
'Save & Close
objFS.SaveToFile sOutFilePath, 2 '2: Create Or Update
objFS.Close
'Completed
Application.StatusBar = "Completed"
End Sub
and i use this sub like this (this is an example):
Call convertTxttoUTF("c:\my.json", "c:\my-UTF8.json")
i found this code here: VBA to Change File Encoding ANSI to UTF8 – Text to Unicode
and since this is written with BOM marker, in order to remove the bom i changed the Sub to this:
Sub convertTxttoUTF(sInFilePath As String, sOutFilePath As String)
Dim objStreamUTF8 As Object
Dim objStreamUTF8NoBOM As Object
Dim iFile As Double
Dim sFileData As String
Const adSaveCreateOverWrite = 2
Const adTypeBinary = 1
Const adTypeText = 2
'Init
iFile = FreeFile
Open sInFilePath For Input As #iFile
sFileData = Input(LOF(iFile), iFile)
Close iFile
'Open files
Set objStreamUTF8 = CreateObject("ADODB.Stream")
Set objStreamUTF8NoBOM = CreateObject("ADODB.Stream")
' wrute the fules
With objStreamUTF8
.Charset = "UTF-8"
.Open
.WriteText sFileData
.Position = 0
.SaveToFile sOutFilePath, adSaveCreateOverWrite
.Type = adTypeText
.Position = 3
End With
With objStreamUTF8NoBOM
.Type = adTypeBinary
.Open
objStreamUTF8.CopyTo objStreamUTF8NoBOM
.SaveToFile sOutFilePath, 2
End With
' close the files
objStreamUTF8.Close
objStreamUTF8NoBOM.Close
End Sub
i used this answer to solve the BOM unknown character at the beginning of the file
The traditional way to transform a string to a UTF-8 string is as follows:
StrConv("hello world",vbFromUnicode)
So put simply:
Dim fnum As Integer
fnum = FreeFile
Open "myfile.txt" For Output As fnum
Print #fnum, StrConv("special characters: äöüß", vbFromUnicode)
Close fnum
No special COM objects required

Functions work separately but not together, returns 0 value

I recently got help here with the first function but I am stumped about why my code is not working..
I'm trying to use the ReportTimeByOP function to find the newest file located in "sFolder" that begins with "sName" and that has a "sOPID" that matches the "value38" result of the ReadTextFile function.
For whatever reason I have no trouble getting both functions to work independently but my attempts to combine them into one seamless operation have failed. What I currently have is:
Function ReadTextFile(fpath)
Dim fline As String
Dim fnumb As Long
Dim i As Long
Dim Wanted As String
fnumb = FreeFile
Open fpath For Input As #fnumb
i = 1
Do While Not EOF(fnumb)
Line Input #fnumb, fline
If i = 2 Then
Wanted = Split(fline, vbTab)(38)
Exit Do
End If
i = i + 1
Loop
Close #fnumb
MsgBox fpath
ReadTextFile = Wanted
End Function
Function ReportTimeByOP(ByVal sName As String, ByVal sFolder As String, ByVal sOPID As String)
Dim FileName As String
Dim MostRecentFile As String
Dim MostRecentDate As Date
Dim value38 As String
Dim oFSO As FileSystemObject
If Right(sFolder, 1) <> "\" Then sFolder = sFolder & "\"
Set oFSO = CreateObject("Scripting.FileSystemObject")
If oFSO.FolderExists(sFolder) Then
FileName = Dir(sFolder & sName & "*hdr.txt", 0)
If FileName <> "" Then
MostRecentFile = FileName
MostRecentDate = FileDateTime(sFolder & FileName)
Do While FileName <> ""
value38 = ReadTextFile(sFolder & FileName)
If FileDateTime(sFolder & FileName) > MostRecentDate And Trim(value38) = Trim(sOPID) Then
MostRecentFile = FileName
MostRecentDate = FileDateTime(sFolder & FileName)
value38 = ReadTextFile(sFolder & FileName)
End If
FileName = Dir
DoEvents
Loop
End If
Else
MostRecentFile = "Err: folder not found."
End If
Set oFSO = Nothing
ReportTimeByOP = MostRecentDate
End Function
Given the huge number of files, I'd skip the Dir function entirely. I'd also skip the manual sorting of the results by creation date (I'm assuming this is the criteria - if not, it should be fairly easy to modify). Let the Windows Shell do the heavy lift for you. Unlike the VBA Dir() function or the Scripting.FileSystemObject, the shell dir command has a ton of parameters that allow you to retrieve sorted output. For this purpose, going through a list of files sorted in reverse order is much, much more efficient. You can see all of the dir options here.
So, I'd approach this by shelling to a dir command that retrieves the list of files in reverse date order, pipe it to a temp file, and then pick up the temp file to go through the list. That way you can just exit when you find your first match. Then you can simplify both your loop and ReadTextFile function by using the FileSystemObject:
ReadTextFile:
Public Function ReadTextFile(target As File) As String
With target.OpenAsTextStream
If Not .AtEndOfStream Then .SkipLine
Dim values() As String
If Not .AtEndOfStream Then
values = Split(.ReadLine, vbTab)
If UBound(values) >= 38 Then
ReadTextFile = values(38)
End If
End If
.Close
End With
End Function
ReportTimeByOP:
Function ReportTimeByOP(ByVal sName As String, ByVal sFolder As String, _
ByVal sOPID As String) As Date
With New Scripting.FileSystemObject
Dim temp As String
temp = .BuildPath(.GetSpecialFolder(TemporaryFolder), .GetTempName)
Dim seeking As String
seeking = .BuildPath(sFolder, sName & "*hdr.txt")
Shell "cmd /c dir """ & seeking & """ /b /a:-d /o:-d > " & temp
'Shell is asychronous - wait .2 seconds for it to complete.
Sleep 200
With .GetFile(temp).OpenAsTextStream
Dim directory() As String
directory = Split(.ReadAll, vbNewLine)
.Close
End With
.DeleteFile temp
Dim i As Long
Dim value38 As String
Dim candidate As File
'Temp file will end with a newline, so the last element is empty.
For i = LBound(directory) To UBound(directory) - 1
Set candidate = .GetFile(.BuildPath(sFolder, directory(i)))
value38 = ReadTextFile(candidate)
If Trim$(value38) = Trim$(sOPID) Then
ReportTimeByOP = candidate.DateCreated
Exit Function
End If
Next i
End With
End Function
And this declaration somewhere:
Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

VBA - Opening a website and saving it as a .GIF extension

I am trying to open and then save a web page which contains an image as a .GIF extension to my desktop. The below code opens a test page for me:
Sub test()
Dim IE As Object, Doc As Object
Set IE = CreateObject("internetexplorer.application")
IE.Visible = True
IE.Navigate "http://www.orseu-concours.com/54-189-thickbox/epso-numerical-reasoning-test-2-en.jpg"
Do While IE.ReadyState <> 4: DoEvents: Loop
Set Doc = CreateObject("htmlfile")
Set Doc = IE.Document
End Sub
The next step is saving the page as a .GIF. The manual process for doing this is either right clicking the image and pressing save and then adding the .gif extension to the name or another way is to just press CTRL+S on the page and save it as an image that way.
I have tried API function URLDownloadToFile however the image I am using for my application updates every time the page is refreshed and I require the saved image to be the same as the one open therefore, cannot use the above function as it results in the two different images.
If possible, I am trying to avoid using SendKeys for this.
As per my comment, try the following (original code here):
Sub main()
'downloads google logo
HTTPDownload "https://www.google.tn/images/srpr/logo11w.png", "d:\logo11w.png"
End Sub
Sub HTTPDownload(myURL, myPath)
' This Sub downloads the FILE specified in myURL to the path specified in myPath.
'
' myURL must always end with a file name
' myPath may be a directory or a file name; in either case the directory must exist
'
' Written by Rob van der Woude
' http://www.robvanderwoude.com
'
' Based on a script found on the Thai Visa forum
' http://www.thaivisa.com/forum/index.php?showtopic=21832
' Standard housekeeping
Dim i, objFile, objFSO, objHTTP, strFile, strMsg
Const ForReading = 1, ForWriting = 2, ForAppending = 8
' Create a File System Object
Set objFSO = CreateObject("Scripting.FileSystemObject")
' Check if the specified target file or folder exists,
' and build the fully qualified path of the target file
If objFSO.FolderExists(myPath) Then
strFile = objFSO.BuildPath(myPath, Mid(myURL, InStrRev(myURL, "/") + 1))
ElseIf objFSO.FolderExists(Left(myPath, InStrRev(myPath, "\") - 1)) Then
strFile = myPath
Else
WScript.Echo "ERROR: Target folder not found."
Exit Sub
End If
' Create or open the target file
Set objFile = objFSO.OpenTextFile(strFile, ForWriting, True)
' Create an HTTP object
Set objHTTP = CreateObject("WinHttp.WinHttpRequest.5.1")
' Download the specified URL
objHTTP.Open "GET", myURL, False
objHTTP.Send
' Write the downloaded byte stream to the target file
For i = 1 To LenB(objHTTP.ResponseBody)
objFile.Write Chr(AscB(MidB(objHTTP.ResponseBody, i, 1)))
Next
' Close the target file
objFile.Close
End Sub
Edit:
IE stores the image in the temp folder so you can pick it up from there and change the extension using the function above.
this is the same resonse on the poste here: Open webpage and save image
Private Declare Function URLDownloadToFile Lib "urlmon" Alias "URLDownloadToFileA" ( _
ByVal pCaller As Long, ByVal szURL As String, ByVal szFileName As String, ByVal dwReserved As Long, ByVal lpfnCB As Long) As Long
Private Sub Command1_Click()
Dim sin As String
Dim sout As String
Dim ret As Long
sin = "https://www.google.tn/images/srpr/logo11w.png"
sout = Environ("HOMEPATH") & "\Desktop\" & "logo11w.png"
ret = URLDownloadToFile(0, sin, sout, 0, 0)
If (ret = 0) Then MsgBox "Succedded" Else MsgBox "failed"
End Sub

Access VBA: how to return path of file you browsed to

I want to return the entire path of an excel file I browsed to.
Using the following,
Set dlg = Application.FileDialog(msoFileDialogFilePicker)
dlg.Title = "Select Excel Spreadsheet to import"
dlg.AllowMultiSelect = False
If dlg.Show = -1 Then
dataPath = dlg.InitialFileName
Me!browseDataPath = dlg.InitialFileName
End If
I'm able to open the dialog and return the directory in which the file is located, but this code doesn't append the name of the file (e.g. blabla.xls) at the end of the path.
For example, if there is blabla.xls my C drive, it will simply return C:\
How do I get it to return C:\blabla.xls (or whatever the name of the excel file is)?
Thanks!
dataPath = dlg.SelectedItems(1)
Me!browseDataPath = dataPath
As you have multi-select disabled, getting the first (one-based) item is enough.
'Paste this code in the module
Option Compare Database
'***************** Code Start **************
'This code was originally written by Ken Getz.
'It is not to be altered or distributed,
'except as part of an application.
'You are free to use it in any application,
'provided the copyright notice is left unchanged.
'
' Code courtesy of:
' Microsoft Access 95 How-To
' Ken Getz and Paul Litwin
' Waite Group Press, 1996
Type tagOPENFILENAME
lStructSize As Long
hwndOwner As Long
hInstance As Long
strFilter As String
strCustomFilter As String
nMaxCustFilter As Long
nFilterIndex As Long
strFile As String
nMaxFile As Long
strFileTitle As String
nMaxFileTitle As Long
strInitialDir As String
strTitle As String
Flags As Long
nFileOffset As Integer
nFileExtension As Integer
strDefExt As String
lCustData As Long
lpfnHook As Long
lpTemplateName As String
End Type
Declare Function aht_apiGetOpenFileName Lib "comdlg32.dll" _
Alias "GetOpenFileNameA" (OFN As tagOPENFILENAME) As Boolean
Declare Function aht_apiGetSaveFileName Lib "comdlg32.dll" _
Alias "GetSaveFileNameA" (OFN As tagOPENFILENAME) As Boolean
Declare Function CommDlgExtendedError Lib "comdlg32.dll" () As Long
Global Const ahtOFN_READONLY = &H1
Global Const ahtOFN_OVERWRITEPROMPT = &H2
Global Const ahtOFN_HIDEREADONLY = &H4
Global Const ahtOFN_NOCHANGEDIR = &H8
Global Const ahtOFN_SHOWHELP = &H10
' You won't use these.
'Global Const ahtOFN_ENABLEHOOK = &H20
'Global Const ahtOFN_ENABLETEMPLATE = &H40
'Global Const ahtOFN_ENABLETEMPLATEHANDLE = &H80
Global Const ahtOFN_NOVALIDATE = &H100
Global Const ahtOFN_ALLOWMULTISELECT = &H200
Global Const ahtOFN_EXTENSIONDIFFERENT = &H400
Global Const ahtOFN_PATHMUSTEXIST = &H800
Global Const ahtOFN_FILEMUSTEXIST = &H1000
Global Const ahtOFN_CREATEPROMPT = &H2000
Global Const ahtOFN_SHAREAWARE = &H4000
Global Const ahtOFN_NOREADONLYRETURN = &H8000
Global Const ahtOFN_NOTESTFILECREATE = &H10000
Global Const ahtOFN_NONETWORKBUTTON = &H20000
Global Const ahtOFN_NOLONGNAMES = &H40000
' New for Windows 95
Global Const ahtOFN_EXPLORER = &H80000
Global Const ahtOFN_NODEREFERENCELINKS = &H100000
Global Const ahtOFN_LONGNAMES = &H200000
Function TestIt()
Dim strFilter As String
Dim lngFlags As Long
strFilter = ahtAddFilterItem(strFilter, "Access Files (*.mda, *.mdb)", _
"*.MDA;*.MDB")
strFilter = ahtAddFilterItem(strFilter, "dBASE Files (*.dbf)", "*.DBF")
strFilter = ahtAddFilterItem(strFilter, "Text Files (*.txt)", "*.TXT")
strFilter = ahtAddFilterItem(strFilter, "All Files (*.*)", "*.*")
MsgBox "You selected: " & ahtCommonFileOpenSave(InitialDir:="C:\", _
Filter:=strFilter, FilterIndex:=3, Flags:=lngFlags, _
DialogTitle:="Hello! Open Me!")
' Since you passed in a variable for lngFlags,
' the function places the output flags value in the variable.
Debug.Print Hex(lngFlags)
End Function
Function GetOpenFile(Optional varDirectory As Variant, _
Optional varTitleForDialog As Variant) As Variant
' Here's an example that gets an Access database name.
Dim strFilter As String
Dim lngFlags As Long
Dim varFileName As Variant
' Specify that the chosen file must already exist,
' don't change directories when you're done
' Also, don't bother displaying
' the read-only box. It'll only confuse people.
lngFlags = ahtOFN_FILEMUSTEXIST Or _
ahtOFN_HIDEREADONLY Or ahtOFN_NOCHANGEDIR
If IsMissing(varDirectory) Then
varDirectory = ""
End If
If IsMissing(varTitleForDialog) Then
varTitleForDialog = ""
End If
' Define the filter string and allocate space in the "c"
' string Duplicate this line with changes as necessary for
' more file templates.
strFilter = ahtAddFilterItem(strFilter, _
"Access (*.mdb)", "*.MDB;*.MDA")
' Now actually call to get the file name.
varFileName = ahtCommonFileOpenSave( _
OpenFile:=True, _
InitialDir:=varDirectory, _
Filter:=strFilter, _
Flags:=lngFlags, _
DialogTitle:=varTitleForDialog)
If Not IsNull(varFileName) Then
varFileName = TrimNull(varFileName)
End If
GetOpenFile = varFileName
End Function
Function ahtCommonFileOpenSave( _
Optional ByRef Flags As Variant, _
Optional ByVal InitialDir As Variant, _
Optional ByVal Filter As Variant, _
Optional ByVal FilterIndex As Variant, _
Optional ByVal DefaultExt As Variant, _
Optional ByVal FileName As Variant, _
Optional ByVal DialogTitle As Variant, _
Optional ByVal hWnd As Variant, _
Optional ByVal OpenFile As Variant) As Variant
' This is the entry point you'll use to call the common
' file open/save dialog. The parameters are listed
' below, and all are optional.
'
' In:
' Flags: one or more of the ahtOFN_* constants, OR'd together.
' InitialDir: the directory in which to first look
' Filter: a set of file filters, set up by calling
' AddFilterItem. See examples.
' FilterIndex: 1-based integer indicating which filter
' set to use, by default (1 if unspecified)
' DefaultExt: Extension to use if the user doesn't enter one.
' Only useful on file saves.
' FileName: Default value for the file name text box.
' DialogTitle: Title for the dialog.
' hWnd: parent window handle
' OpenFile: Boolean(True=Open File/False=Save As)
' Out:
' Return Value: Either Null or the selected filename
Dim OFN As tagOPENFILENAME
Dim strFileName As String
Dim strFileTitle As String
Dim fResult As Boolean
' Give the dialog a caption title.
If IsMissing(InitialDir) Then InitialDir = CurDir
If IsMissing(Filter) Then Filter = ""
If IsMissing(FilterIndex) Then FilterIndex = 1
If IsMissing(Flags) Then Flags = 0&
If IsMissing(DefaultExt) Then DefaultExt = ""
If IsMissing(FileName) Then FileName = ""
If IsMissing(DialogTitle) Then DialogTitle = ""
If IsMissing(hWnd) Then hWnd = Application.hWndAccessApp
If IsMissing(OpenFile) Then OpenFile = True
' Allocate string space for the returned strings.
strFileName = Left(FileName & String(256, 0), 256)
strFileTitle = String(256, 0)
' Set up the data structure before you call the function
With OFN
.lStructSize = Len(OFN)
.hwndOwner = hWnd
.strFilter = Filter
.nFilterIndex = FilterIndex
.strFile = strFileName
.nMaxFile = Len(strFileName)
.strFileTitle = strFileTitle
.nMaxFileTitle = Len(strFileTitle)
.strTitle = DialogTitle
.Flags = Flags
.strDefExt = DefaultExt
.strInitialDir = InitialDir
' Didn't think most people would want to deal with
' these options.
.hInstance = 0
'.strCustomFilter = ""
'.nMaxCustFilter = 0
.lpfnHook = 0
'New for NT 4.0
.strCustomFilter = String(255, 0)
.nMaxCustFilter = 255
End With
' This will pass the desired data structure to the
' Windows API, which will in turn it uses to display
' the Open/Save As Dialog.
If OpenFile Then
fResult = aht_apiGetOpenFileName(OFN)
Else
fResult = aht_apiGetSaveFileName(OFN)
End If
' The function call filled in the strFileTitle member
' of the structure. You'll have to write special code
' to retrieve that if you're interested.
If fResult Then
' You might care to check the Flags member of the
' structure to get information about the chosen file.
' In this example, if you bothered to pass in a
' value for Flags, we'll fill it in with the outgoing
' Flags value.
If Not IsMissing(Flags) Then Flags = OFN.Flags
ahtCommonFileOpenSave = TrimNull(OFN.strFile)
Else
ahtCommonFileOpenSave = vbNullString
End If
End Function
Function ahtAddFilterItem(strFilter As String, _
strDescription As String, Optional varItem As Variant) As String
' Tack a new chunk onto the file filter.
' That is, take the old value, stick onto it the description,
' (like "Databases"), a null character, the skeleton
' (like "*.mdb;*.mda") and a final null character.
If IsMissing(varItem) Then varItem = "*.*"
ahtAddFilterItem = strFilter & _
strDescription & vbNullChar & _
varItem & vbNullChar
End Function
Private Function TrimNull(ByVal strItem As String) As String
Dim intPos As Integer
intPos = InStr(strItem, vbNullChar)
If intPos > 0 Then
TrimNull = Left(strItem, intPos - 1)
Else
TrimNull = strItem
End If
End Function
'************** Code End *****************
**'Now paste this part on the button click event:**
Private Sub cmd_file_Click()
Dim s_Filter As String
Dim s_InputFileName As String
s_Filter = ahtAddFilterItem(s_Filter, "Excel Files (*.XLS)", "*.XLS")
s_InputFileName = ahtCommonFileOpenSave( _
Filter:=s_Filter, OpenFile:=True, _
DialogTitle:="Please select an input file...", _
Flags:=ahtOFN_HIDEREADONLY)
Me.txt_file.Value = s_InputFileName
End Sub
Paste this code in the module.
Function GetFolder(strPath As String) As String
Dim fldr As FileDialog
Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
With fldr
.Title = "Select a Folder"
.AllowMultiSelect = False
.InitialFileName = strPath
If .Show <> -1 Then GoTo NextCode
sItem = .SelectedItems(1)
End With
NextCode:
GetFolder = sItem
Sheets("Home").OLEObjects("TextBox1").Object.Value = sItem
Set fldr = Nothing
End Function
'**And then call it by using**
Private sub button1_click()
call GetFolder("Any default folder path")
end sub

trying to store text file rows in VBA

Greetings, I'm hoping for help in figuring out how to store each row of a text file read into a VBA program as a string. I want to modify one of the strings and then put them all back together, but do not know how to read through a text file and store each row as a separate variable in an intelligent way. Thanks for any help you can provide!
If you don't want to add references, you could just go with straight vba code.
Take for instance the following file wordlist.txt:
realize
empty
theorize
line
socialize
here
analyze
The following code uses two methods to do as you described (one more common than the other):
Option Explicit
Sub main()
Dim sFileName As String
Dim sMergedLineArray() As String
Dim sTextToFind As String
Dim sReplacementText As String
Dim sOutputFile As String
Const MY_DELIMITER = "|"
sFileName = "C:\deleteme\wordlist.txt"
sMergedLineArray = ReadFileIntoArray(sFileName)
sTextToFind = "ze"
sReplacementText = "se"
'Loop through each value in the array and make a change if you need to
Dim x As Integer
For x = 0 To UBound(sMergedLineArray)
If InStr(1, sMergedLineArray(x), sTextToFind, vbTextCompare) > 0 Then
sMergedLineArray(x) = Replace(sMergedLineArray(x), sTextToFind, sReplacementText, 1, -1, vbTextCompare)
End If
Next x
sOutputFile = "C:\deleteme\UK_Version.txt"
If Not SpitFileOut(sOutputFile, sMergedLineArray) Then
MsgBox "It didn't work :("
End If
'OR...put it all together, make a mass change and split it back out (this seems unlikely, but throwing it in there anyway)
sTextToFind = "se"
sReplacementText = "ze"
Dim sBigString As String
Dim sNewArray As Variant
sBigString = Join(sMergedLineArray, MY_DELIMITER)
sBigString = Replace(sBigString, sTextToFind, sReplacementText, 1, -1, vbTextCompare)
sNewArray = Split(sBigString, MY_DELIMITER, -1, vbTextCompare)
sOutputFile = "C:\deleteme\American_Version.txt"
If Not SpitFileOut(sOutputFile, sNewArray) Then
MsgBox "It didn't work"
End If
MsgBox "Finished!"
End Sub
Function ReadFileIntoArray(sFileName As String) As String()
Dim sText As String
Dim sLocalArray() As String
Dim iFileNum As Integer
Dim iLineCount As Integer
iFileNum = FreeFile
Open sFileName For Input As #iFileNum
Do Until EOF(iFileNum)
Input #iFileNum, sText
ReDim Preserve sLocalArray(iLineCount)
sLocalArray(iLineCount) = sText
iLineCount = iLineCount + 1
Loop
Close #iFileNum
ReadFileIntoArray = sLocalArray
End Function
Function SpitFileOut(sFileName As String, sMyArray As Variant) As Boolean
Dim iFileNum As Integer
Dim iCounter As Integer
SpitFileOut = False
iFileNum = FreeFile
Open sFileName For Output As #iFileNum
For iCounter = 0 To UBound(sMyArray)
Print #iFileNum, sMyArray(iCounter)
Next
Close #iFileNum
SpitFileOut = True
End Function
If you run the main sub, you'll end up with two files:
UK_Version.txt: This is the result of the first method
American_Version.txt: This is the result of the second
There's lesson 1 of VBA, young Padawan; absorb it, learn and change your login name :P
Look into the FileSystemObject (ref: 1, 2, 3)
You have to go to <Tools/References> menu and include the Microsoft Scripting Runtime and create a global variable Global fso as New FileSystemObject. Now anywhere in your code do things like fso.OpenTextFile() which returns a TextStream. Each TextStream has methods loke ReadLine(), ReadAll(), SkipLine(), WriteLine(), etc ...
Here is a quick sample code.
Global fso as New FileSystemObject
Sub TEST()
Dim ts As TextStream
Set ts = fso.OpenTextFile("text_file.txt", ForReading, False)
Dim s As String
s = ts.ReadAll()
End Sub

Resources