Related
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
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
I've created an Excel worksheet and I would like to track who in my company uses it. Currently, it's freely available on our company intranet for downloading without any restriction.
I would like to implement a restriction where the Excel worksheet's VBA functionality stops working after 12 months of use. The user would have to contact me for an "reactivation code" of some sort to let the user continue using the sheet for another 12 months.
If the user doesn't find the Excel worksheet useful then they simply don't need a reactivation code. Is this possible to do within Excel?
EDIT 1: I need to stay within the confines of Excel. I don't want to bring in other options like embedding with an .exe or creating restrictions on the downloading of the Excel file on the company website. Thanks.
I have run into a similar situation previously.
If you expect that your users are going to be online when they use the application, you can make a simple http request from within a sub that's called when the worksheet is opened; that request can include the user name, and your server can log the request (and thus know who is using the application). To make it less inconvenient for the users, make sure that you include some failsafe code so that the application works normally when the server cannot be reached / is down.
You need to know how to do five things:
Run code when the worksheet is opened
Request the user (network) name to insert in the request
Make an http request from inside VBA (handle differences between PC and Mac...)
Handle failure of the request gracefully (don't cripple the worksheet)
Log the request so you have information about the use
Let me know if you don't know how to do one of these, and I can help further (but there will be a bit of delay in my response...). Answers for all these can be found on SO, but the synthesis may take some effort.
solution
Warning - this is a bit of a monster piece of code. I wrote it as much for myself as for you... It may need further explanation.
step 1 Add this code to ThisWorkbook in order to respond to the file being opened:
Private Sub Workbook_Open()
On Error GoTo exitSub
registerUse
exitSub:
End Sub
This calls the registerUse Sub when the workbook is opened.
step 2 get the user name. This is quite complex; create a module called "username" and paste in all the following code (note - a chunk of this was copied from Dev Ashish, the rest - in particular, dealing with the Mac solution - is my own work). Call the function currentUserName() to get the current user name (if it can resolve the "long name" from the network, it will; otherwise it will use the name/ID you use to log in with):
' ******** Code Start ********
'This code was originally written by Dev Ashish.
'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
'Dev Ashish
'
' Modifications by Floris - mostly to make Mac compatible
Private Type USER_INFO_2
usri2_name As Long
usri2_password As Long ' Null, only settable
usri2_password_age As Long
usri2_priv As Long
usri2_home_dir As Long
usri2_comment As Long
usri2_flags As Long
usri2_script_path As Long
usri2_auth_flags As Long
usri2_full_name As Long
usri2_usr_comment As Long
usri2_parms As Long
usri2_workstations As Long
usri2_last_logon As Long
usri2_last_logoff As Long
usri2_acct_expires As Long
usri2_max_storage As Long
usri2_units_per_week As Long
usri2_logon_hours As Long
usri2_bad_pw_count As Long
usri2_num_logons As Long
usri2_logon_server As Long
usri2_country_code As Long
usri2_code_page As Long
End Type
Private Declare Function apiNetGetDCName _
Lib "netapi32.dll" Alias "NetGetDCName" _
(ByVal servername As Long, _
ByVal DomainName As Long, _
bufptr As Long) As Long
' function frees the memory that the NetApiBufferAllocate
' function allocates.
Private Declare Function apiNetAPIBufferFree _
Lib "netapi32.dll" Alias "NetApiBufferFree" _
(ByVal buffer As Long) _
As Long
' Retrieves the length of the specified wide string.
Private Declare Function apilstrlenW _
Lib "kernel32" Alias "lstrlenW" _
(ByVal lpString As Long) _
As Long
Private Declare Function apiNetUserGetInfo _
Lib "netapi32.dll" Alias "NetUserGetInfo" _
(servername As Any, _
username As Any, _
ByVal level As Long, _
bufptr As Long) As Long
' moves memory either forward or backward, aligned or unaligned,
' in 4-byte blocks, followed by any remaining bytes
Private Declare Sub sapiCopyMem _
Lib "kernel32" Alias "RtlMoveMemory" _
(Destination As Any, _
Source As Any, _
ByVal Length As Long)
Private Declare Function apiGetUserName Lib _
"advapi32.dll" Alias "GetUserNameA" _
(ByVal lpBuffer As String, _
nSize As Long) _
As Long
Private Const MAXCOMMENTSZ = 256
Private Const NERR_SUCCESS = 0
Private Const ERROR_MORE_DATA = 234&
Private Const MAX_CHUNK = 25
Private Const ERROR_SUCCESS = 0&
Function currentUserID()
' added this function to isolate user from windows / mac differences
' hoping this works!
' note - one can also use Application.OperatingSystem like "*Mac*" etc.
Dim tempString
On Error GoTo CUIerror
tempString = "Unknown"
#If Win32 Or Win64 Then
tempString = fGetUserName
#Else
tempString = whoIsThisMacID
#End If
' trim string to correct length ... there's some weirdness in the returned value
' we fall to this point if there's an error in the lower level functions, too
' in that case we will have the default value "Unknown"
CUIerror:
currentUserID = Left(tempString, Len(tempString))
End Function
Function currentUserName()
Dim tempString
On Error GoTo CUNerror
tempString = "Unknown"
#If Win32 Or Win64 Then
tempString = fGetFullNameOfLoggedUser
#Else
tempString = whoIsThisMacName
#End If
' trim string to get rid of weirdness at the end...
' and fall through on error:
CUNerror:
currentUserName = Left(tempString, Len(tempString))
' in some cases the lower level functions return a null string:
If Len(currentUserName) = 0 Then currentUserName = currentUserID
End Function
#If Mac Then
Function whoIsThisMacID()
Dim sPath As String, sCmd As String
On Error GoTo WIDerror
sPath = "/usr/bin/whoami"
sCmd = "set RetVal1 to do shell script """ & sPath & """"
whoIsThisMacID = MacScript(sCmd)
Exit Function
WIDerror:
whoIsThisMacID = "unknown"
End Function
Function whoIsThisMacName()
' given the user ID, find the user name using some magic finger commands...
Dim cmdString As String
Dim sCmd As String
On Error GoTo WHOerror
' use finger command to find out more information about the current user
' use grep to strip the line with the Name: tag
' use sed to strip out string up to and including 'Name: "
' the rest of the string is the user name
cmdString = "/usr/bin/finger " & whoIsThisMacID & " | /usr/bin/grep 'Name:' | /usr/bin/sed 's/.*Name: //'"
' send the command to be processed by AppleScript:
sCmd = "set RetVal1 to do shell script """ & cmdString & """"
whoIsThisMacName = MacScript(sCmd)
Exit Function
WHOerror:
whoIsThisMacName = "unknown"
End Function
Sub testName()
MsgBox whoIsThisMacName
End Sub
#End If
' do not compile this code if it's not a windows machine... it's not going to work!
#If Win32 Or Win64 Then
Function fGetFullNameOfLoggedUser(Optional strUserName As String) As String
'
' Returns the full name for a given UserID
' NT/2000 only
' Omitting the strUserName argument will try and
' retrieve the full name for the currently logged on user
'
On Error GoTo ErrHandler
Dim pBuf As Long
Dim dwRec As Long
Dim pTmp As USER_INFO_2
Dim abytPDCName() As Byte
Dim abytUserName() As Byte
Dim lngRet As Long
Dim i As Long
' Unicode
abytPDCName = fGetDCName() & vbNullChar
If (Len(strUserName) = 0) Then strUserName = fGetUserName()
abytUserName = strUserName & vbNullChar
' Level 2
lngRet = apiNetUserGetInfo( _
abytPDCName(0), _
abytUserName(0), _
2, _
pBuf)
If (lngRet = ERROR_SUCCESS) Then
Call sapiCopyMem(pTmp, ByVal pBuf, Len(pTmp))
fGetFullNameOfLoggedUser = fStrFromPtrW(pTmp.usri2_full_name)
End If
Call apiNetAPIBufferFree(pBuf)
ExitHere:
Exit Function
ErrHandler:
fGetFullNameOfLoggedUser = vbNullString
Resume ExitHere
End Function
Function fGetUserName() As String
' Returns the network login name
On Error GoTo FGUerror
Dim lngLen As Long, lngRet As Long
Dim strUserName As String
strUserName = String$(254, 0)
lngLen = 255
lngRet = apiGetUserName(strUserName, lngLen)
If lngRet Then
fGetUserName = Left$(strUserName, lngLen - 1)
End If
Exit Function
FGUerror:
MsgBox "Error getting user name: " & Err.Description
fGetUserName = ""
End Function
Function fGetDCName() As String
Dim pTmp As Long
Dim lngRet As Long
Dim abytBuf() As Byte
On Error GoTo FGDCerror
lngRet = apiNetGetDCName(0, 0, pTmp)
If lngRet = NERR_SUCCESS Then
fGetDCName = fStrFromPtrW(pTmp)
End If
Call apiNetAPIBufferFree(pTmp)
Exit Function
FGDCerror:
MsgBox "Error in fGetDCName: " & Err.Description
fGetDCName = ""
End Function
Private Function fStrFromPtrW(pBuf As Long) As String
Dim lngLen As Long
Dim abytBuf() As Byte
On Error GoTo FSFPerror
' Get the length of the string at the memory location
lngLen = apilstrlenW(pBuf) * 2
' if it's not a ZLS
If lngLen Then
ReDim abytBuf(lngLen)
' then copy the memory contents
' into a temp buffer
Call sapiCopyMem( _
abytBuf(0), _
ByVal pBuf, _
lngLen)
' return the buffer
fStrFromPtrW = abytBuf
End If
Exit Function
FSFPerror:
MsgBox "Error in fStrFromPtrW: " & Err.Description
fStrFromPtrW = ""
End Function
' ******** Code End *********
#End If
steps 3 & 4 form an HTTP request, and send it to a server; handle failure gracefully (note - right now "gracefully" involves an error message; you can comment it out, and then the user will notice just a slight delay when opening the workbook and nothing else). Paste the following code in another module (call it 'registration'):
Option Explicit
Option Compare Text
' use the name of the workbook you want to identify:
Public Const WB_NAME = "logMe 1.0"
' use the URL of the script that handles the request
' this one works for now and you can use it to test until you get your own solution up
Public Const DB_SERVER = "http://www.floris.us/SO/logUsePDO.php"
Sub registerUse()
' send http request to a server
' to log "this user is using this workbook at this time"
Dim USER_NAME As String
Dim regString As String
Dim response As String
' find the login name of the user:
USER_NAME = currentUserName()
' create a "safe" registration string by URLencoding the user name and workbook name:
regString = "?user=" & URLEncode(USER_NAME) & "&application=" & URLEncode(WB_NAME, True)
' log the use:
response = logUse(DB_SERVER & regString)
' remove the success / fail message box when you are satisfied this works; it gets annoying quickly:
If response = "user " & USER_NAME & " logged successfully" Then
MsgBox "logging successful"
Else
MsgBox "Response: " & response
End If
End Sub
'----------------------
' helper functions
' URLencode
' found at http://stackoverflow.com/a/218199/1967396
Public Function URLEncode( _
StringVal As String, _
Optional SpaceAsPlus As Boolean = False _
) As String
Dim StringLen As Long: StringLen = Len(StringVal)
If StringLen > 0 Then
ReDim result(StringLen) As String
Dim i As Long, CharCode As Integer
Dim Char As String, Space As String
If SpaceAsPlus Then Space = "+" Else Space = "%20"
For i = 1 To StringLen
Char = Mid$(StringVal, i, 1)
CharCode = Asc(Char)
Select Case CharCode
Case 97 To 122, 65 To 90, 48 To 57, 45, 46, 95, 126
result(i) = Char
Case 32
result(i) = Space
Case 0 To 15
result(i) = "%0" & Hex(CharCode)
Case Else
result(i) = "%" & Hex(CharCode)
End Select
Next i
URLEncode = Join(result, "")
End If
End Function
Function logUse(s As String)
Dim MyRequest As Object
Set MyRequest = CreateObject("WinHttp.WinHttpRequest.5.1")
On Error GoTo noLog
' MsgBox "Sending request " & s
MyRequest.Open "GET", s
' Send Request.
MyRequest.Send
'And we get this response
logUse = MyRequest.ResponseText
Exit Function
noLog:
logUse = "Error: " & Err.Description
End Function
step 5: log the request. For this I wrote a small php script that updates a table softwareReg with three columns: user, application, and date (a system generated timestamp). The use is logged by making a request of the form:
http://www.floris.us/SO/logUse.php?name=myName&application=thisApplication
where myName is the name of the user according to currentUserName() and thisApplication is the name (maybe including the version number) of the application / workbook you want to register. You can do this right from your browser if you want to try (although the idea is that the VBA script will do it for you...)
You can request a summary of use with the following request to the same page:
http://www.floris.us/SO/logUse.php?summary=thisApplication
This will create a summary table of use, with names of users and the last date of use, sorted by "most number of registrations" - in other words, the most frequent users will be at the top. Obviously you could change the format, sort order, etc - but this should fulfill your basic requirement. I obfuscated the user names, passwords etc, but otherwise this is the code that runs at the above URL. Play with it and see if you can get it to work. The same database can record registrations for multiple applications / workbooks; right now the script will spit out results for one application at a time when the argument is the name of the application, or a table of all the applications and their use when the argument is all:
http://www.floris.us/SO/logUse.php?summary=all
Will produce a table like this (for testing I used application names something and nothing):
<?php
if (isset($_GET)) {
if (isset($_GET['user']) && isset($_GET['application'])) {
$user = $_GET['user'];
$application = $_GET['application'];
$mode = 1;
}
if (isset($_GET['summary'])) {
$application = $_GET['summary'];
$mode = 2;
}
// create database handle:
$dbhost = 'localhost';
$dbname = 'LoneStar';
$dbuser = 'DarkHelmet';
$dbpass = '12345';
try {
$DBH = new PDO("mysql:host=$dbhost;dbname=$dbname", $dbuser, $dbpass);
$DBH->setAttribute( PDO::ATTR_ERRMODE, PDO::ERRMODE_WARNING );
$STHinsert = $DBH->prepare("INSERT INTO softwareReg( user, application ) value (?, ?)");
if($mode == 1) {
$dataInsert = array($user, $application);
$STHinsert->execute($dataInsert);
echo "user " . $user . " logged successfully";
}
if($mode == 2) {
if ($application == "all") {
$astring = "";
$table_hstring = "</td><td width = 200 align = center>application";
}
else {
$astring = "WHERE application = ?";
$table_hstring = "";
}
$STHread = $DBH->prepare("SELECT user, date, max(date) as mDate, count(user) as uCount, application FROM softwareReg ".$astring." GROUP BY user, application ORDER BY application, uCount DESC");
$dataRead = array($application);
$STHread->setFetchMode(PDO::FETCH_ASSOC);
$STHread->execute($dataRead);
echo "<html><center><h1>The following is the last time these users accessed '" . $application . "'</h1><br>";
echo "<table border=1>";
echo "<t><td width = 100 align = center>user</td><td width = 200 align=center>last access</td><td width = 100 align = center>count".$table_hstring."</td></tr>";
while ($row = $STHread->fetch()){
if($application == "all") {
echo "<tr><td align = center>" . $row['user'] .
"</td><td align = center>" . $row['mDate'] .
"</td><td align = center>" . $row['uCount'] .
"</td><td align = center>" . $row['application'] . "</tr>";
}
else {
echo "<tr><td align = center>" . $row['user'] . "</td><td align = center>" . $row['mDate'] . "</td><td align = center>" . $row['uCount'] . "</tr>";
}
}
echo "</table></html>";
}
}
catch(PDOException $e) {
echo "error connecting!<br>";
echo $e->getMessage();
}
}
?>
Check this answer How to hide code in VBA applications
Apperantly you can lock VBA code. And in your VBA code you can connect to DB and run the checks for each user. Make user enter some password and make VBA close the file if user access expired.
Another question, user may turn off macros. So you need to create functionality, wich doesn't work without macros
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
I have approx. 12000 cells in excel containing RTF (including formatting tags). I need to parse them to get to the unformatted text.
This is the example of one of the cells with text:
{\rtf1\ansi\deflang1060\ftnbj\uc1
{\fonttbl{\f0 \froman \fcharset0 Times New Roman;}{\f1 \fswiss \fcharset238
Arial;}}
{\colortbl ;\red255\green255\blue255 ;\red0\green0\blue0 ;}
{\stylesheet{\fs24\cf2\cb1 Normal;}{\cs1\cf2\cb1 Default Paragraph Font;}}
\paperw11908\paperh16833\margl1800\margr1800\margt1440\margb1440\headery720\footery720
\deftab720\formshade\aendnotes\aftnnrlc\pgbrdrhead\pgbrdrfoot
\sectd\pgwsxn11908\pghsxn16833\marglsxn1800\margrsxn1800\margtsxn1440\margbsxn1440
\headery720\footery720\sbkpage\pgncont\pgndec
\plain\plain\f1\fs24\pard TPR 0160 000\par IPR 0160 000\par OB-R-02-28\par}
And all I really need is this:
TPR 0160 000
IPR 0160 000
OB-R-02-28
The problem with simple looping over the cells and removing unnecessary formatting is, that not everything in those 12000 cells is as straightforward as this is. So I would need to manually inspect many different versions and write several variations; and still at the end there would be a lot of manual work to do.
But if I copy the contents of one cell to empty text document and save it as RTF, then open it with MS Word, it instantly parses the text and I get exactly what I want. Unfortunately it's extremely inconvenient to do so for a 12000 cells.
So I was thinking about VBA macro, to move cell contents to Word, force parsing and then copy the result back to the originating cell. Unfortunately I'm not really sure how to do it.
Does anybody has any idea? Or a different approach? I will be really grateful for a solution or a push in the right direction.
TNX!
If you did want to go down the route of using Word to parse the text, this function should help you out. As the comments suggest, you'll need a reference to the MS Word Object Library.
Function ParseRTF(strRTF As String) As String
Dim wdDoc As Word.Document 'Ref: Microsoft Word 11.0 Object Library'
Dim f As Integer 'Variable to store the file I/O number'
'File path for a temporary .rtf file'
Const strFileTemp = "C:\TempFile_ParseRTF.rtf"
'Obtain the next valid file I/O number'
f = FreeFile
'Open the temp file and save the RTF string in it'
Open strFileTemp For Output As #f
Print #f, strRTF
Close #f
'Open the .rtf file as a Word.Document'
Set wdDoc = GetObject(strFileTemp)
'Read the now parsed text from the Word.Document'
ParseRTF = wdDoc.Range.Text
'Delete the temporary .rtf file'
Kill strFileTemp
'Close the Word connection'
wdDoc.Close False
Set wdDoc = Nothing
End Function
You could call it for each of your 12,000 cells using something similar to this:
Sub ParseAllRange()
Dim rngCell As Range
Dim strRTF As String
For Each rngCell In Range("A1:A12000")
'Parse the cell contents'
strRTF = ParseRTF(CStr(rngCell))
'Output to the cell one column over'
rngCell.Offset(0, 1) = strRTF
Next
End Sub
The ParseRTF function takes about a second to run (on my machine at least), so for 12,000 cells this will work out at about three and a half hours.
Having thought about this problem over the weekend, I was sure there was a better (quicker) solution for this.
I remembered the RTF capabilities of the clipboard, and realised that a class could be created that would copy RTF data to the clipboard, paste to a word doc, and output the resulting plain text. The benefit of this solution is that the word doc object would not have to be opened and closed for each rtf string; it could be opened before the loop and closed after.
Below is the code to achieve this. It is a Class module named clsRTFParser.
Private Declare Function GlobalAlloc Lib "kernel32" _
(ByVal wFlags&, ByVal dwBytes As Long) As Long
Private Declare Function GlobalLock Lib "kernel32" _
(ByVal hMem As Long) As Long
Private Declare Function GlobalUnlock Lib "kernel32" _
(ByVal hMem As Long) As Long
Private Declare Function lstrcpy Lib "kernel32" _
(ByVal lpString1 As Any, ByVal lpString2 As Any) As Long
Private Declare Function OpenClipboard Lib "user32" _
(ByVal Hwnd As Long) As Long
Private Declare Function EmptyClipboard Lib "user32" () As Long
Private Declare Function RegisterClipboardFormat Lib "user32" Alias _
"RegisterClipboardFormatA" (ByVal lpString As String) As Long
Private Declare Function SetClipboardData Lib "user32" _
(ByVal wFormat As Long, ByVal hMem As Long) As Long
Private Declare Function CloseClipboard Lib "user32" () As Long
'---'
Dim wdDoc As Word.Document 'Ref: Microsoft Word 11.0 Object Library'
Private Sub Class_Initialize()
Set wdDoc = New Word.Document
End Sub
Private Sub Class_Terminate()
wdDoc.Close False
Set wdDoc = Nothing
End Sub
'---'
Private Function CopyRTF(strCopyString As String) As Boolean
Dim hGlobalMemory As Long
Dim lpGlobalMemory As Long
Dim hClipMemory As Long
Dim lngFormatRTF As Long
'Allocate and copy string to memory'
hGlobalMemory = GlobalAlloc(&H42, Len(strCopyString) + 1)
lpGlobalMemory = GlobalLock(hGlobalMemory)
lpGlobalMemory = lstrcpy(lpGlobalMemory, strCopyString)
'Unlock the memory and then copy to the clipboard'
If GlobalUnlock(hGlobalMemory) = 0 Then
If OpenClipboard(0&) <> 0 Then
Call EmptyClipboard
'Save the data as Rich Text Format'
lngFormatRTF = RegisterClipboardFormat("Rich Text Format")
hClipMemory = SetClipboardData(lngFormatRTF, hGlobalMemory)
CopyRTF = CBool(CloseClipboard)
End If
End If
End Function
'---'
Private Function PasteRTF() As String
Dim strOutput As String
'Paste the clipboard data to the wdDoc and read the plain text result'
wdDoc.Range.Paste
strOutput = wdDoc.Range.Text
'Get rid of the new lines at the beginning and end of the document'
strOutput = Left(strOutput, Len(strOutput) - 2)
strOutput = Right(strOutput, Len(strOutput) - 2)
PasteRTF = strOutput
End Function
'---'
Public Function ParseRTF(strRTF As String) As String
If CopyRTF(strRTF) Then
ParseRTF = PasteRTF
Else
ParseRTF = "Error in copying to clipboard"
End If
End Function
You could call it for each of your 12,000 cells using something similar to this:
Sub CopyParseAllRange()
Dim rngCell As Range
Dim strRTF As String
'Create new instance of clsRTFParser'
Dim RTFParser As clsRTFParser
Set RTFParser = New clsRTFParser
For Each rngCell In Range("A1:A12000")
'Parse the cell contents'
strRTF = RTFParser.ParseRTF(CStr(rngCell))
'Output to the cell one column over'
rngCell.Offset(0, 1) = strRTF
Next
End Sub
I have simulated this using example RTF strings on my machine. For 12,000 cells it took two and a half minutes, a much more reasonable time frame!
You can try to parse every cell with regular expression and leave only the content you need.
Every RTF control code start with "\" and ends with space, without any additional space between. "{}" are use for grouping. If your text won't contain any, you can just remove them (the same for ";"). So now you stay with your text and some unnecessary words as "Arial", "Normal" etc. You can build the dictionary to remove them also. After some tweaking, you will stay with only the text you need.
Look at http://www.regular-expressions.info/ for more information and great tool to write RegExp's (RegexBuddy - unfortunately it isn't free, but it's worth the money. AFAIR there is also trial).
UPDATE: Of course, I don't encourage you to do it manually for every cell. Just iterate through active range:
Refer this thread:
SO: About iterating through cells in VBA
Personally, I'll give a try to this idea:
Sub Iterate()
For Each Cell in ActiveSheet.UsedRange.Cells
'Do something
Next
End Sub
And how to use RegExp's in VBA (Excel)?
Refer:
Regex functions in Excel
and
Regex in VBA
Basically you've to use VBScript.RegExp object through COM.
Some of the solutions here require a reference to the MS Word Object Library. Playing with the cards I am dealt, I found a solution that does not rely on it. It strips RTF tags, and other fluff like font tables and stylesheets, all in VBA. It might be helpful to you. I ran it across your data, and other than the whitespace, I get the same output as what you expected.
Here is the code.
First, something to check if a string is alphanumeric or not. Give it a string that's one character long. This function is used to work out delimitation here and there.
Public Function Alphanumeric(Character As String) As Boolean
If InStr("ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789-", Character) Then
Alphanumeric = True
Else
Alphanumeric = False
End If
End Function
Next up is to remove an entire group. I use this to remove font tables and other rubbish.
Public Function RemoveGroup(RTFString As String, GroupName As String) As String
Dim I As Integer
Dim J As Integer
Dim Count As Integer
I = InStr(RTFString, "{\" & GroupName)
' If the group was not found in the RTF string, then just return that string unchanged.
If I = 0 Then
RemoveGroup = RTFString
Exit Function
End If
' Otherwise, we will need to scan along, from the start of the group, until we find the end of the group.
' The group is delimited by { and }. Groups may be nested, so we need to count up if we encounter { and
' down if we encounter }. When that count reaches zero, then the end of the group has been found.
J = I
Do
If Mid(RTFString, J, 1) = "{" Then Count = Count + 1
If Mid(RTFString, J, 1) = "}" Then Count = Count - 1
J = J + 1
Loop While Count > 0
RemoveGroup = Replace(RTFString, Mid(RTFString, I, J - I), "")
End Function
Okay, and this function removes any tags.
Public Function RemoveTags(RTFString As String) As String
Dim L As Long
Dim R As Long
L = 1
' Search to the end of the string.
While L < Len(RTFString)
' Append anything that's not a tag to the return value.
While Mid(RTFString, L, 1) <> "\" And L < Len(RTFString)
RemoveTags = RemoveTags & Mid(RTFString, L, 1)
L = L + 1
Wend
'Search to the end of the tag.
R = L + 1
While Alphanumeric(Mid(RTFString, R, 1)) And R < Len(RTFString)
R = R + 1
Wend
L = R
Wend
End Function
We can remove curly braces in the obvious way:
Public Function RemoveBraces(RTFString As String) As String
RemoveBraces = Replace(RTFString, "{", "")
RemoveBraces = Replace(RemoveBraces, "}", "")
End Function
Once you have the functions above copy-pasted into your module, you can create a function that uses them to strip away any stuff you don't need or want. The following works perfectly in my case.
Public Function RemoveTheFluff(RTFString As String) As String
RemoveTheFluff = Replace(RTFString, vbCrLf, "")
RemoveTheFluff = RemoveGroup(RemoveTheFluff, "fonttbl")
RemoveTheFluff = RemoveGroup(RemoveTheFluff, "colortbl")
RemoveTheFluff = RemoveGroup(RemoveTheFluff, "stylesheet")
RemoveTheFluff = RemoveTags(RemoveBraces(RemoveTheFluff))
End Function
I hope this helps. I wouldn't use it in a word processor or anything, but it might do for scraping data if that's what you're doing.
Your post made it sound as if each RTF document was stored in a single Excell cell. If so, then
Solution using .Net Framework RichTextBox control
will convert the RTF in each cell to plain text in 2 lines of code (after a little system configuration to get the right .tlb file to allow reference to the .Net Framework). Put the cell value in rtfsample and
Set miracle = New System_Windows_Forms.RichTextBox
With miracle
.RTF = rtfText
PlainText = .TEXT
End With