how do I check if the string variable is empty in vba?
if:
Dim StrFile1 As String, StrFile2 As String
Dim Text3 As String
Dim Len1 as Integer, Len2 As Integer
With NewMail
Text3 = Cells(i, 3).Value
StrPath = Cells(i, 2).Value & Text3
Text = Cells(i, 1).Value
.Subject =
' adds the data in column3 with space as subject
.From =
.To = Text
.BCC = ""
.TextBody =
StrFile1 = Dir(StrPath & "*.txt")
Len1 = Len(StrFile1)
Do While Len(StrFile1) > 0
.AddAttachment StrPath & StrFile1
StrFile1 = Dir
Loop
StrFile2 = Dir(StrPath & "*.pdf")
Len2 = Len(StrFile2)
Do While Len(StrFile2) > 0
.AddAttachment StrPath & StrFile2
StrFile2 = Dir
Loop
If (Len1 & Len2) = 0 Then
GoTo Last
'.AddAttachment Text3
.Send
End With
i = i + 1
Loop
Last:
End With
i = i + 1
Loop
Now i want to check simultaneously if Len1 and Len2 are 0, if so then I want to go to Last.
When I use this code I get a message/Compile error "Want to end with without with"
and
i am not sure if
If (Len1 & Len2) = 0 Then
GoTo Last
this is a proper code.
and Do i need to declare the label Last??
You have many way to do that like below :
Dim StrFiles As String
StrFiles = Trim(StrFile1 & StrFile2)
If IsEmpty(StrFiles) Then
If StrFiles = vbNullString Then
If StrFiles = "" Then
If StrFiles = Empty Then
If Len(StrFiles) = 0 Then
you can use + operator to check 2 strings are empty reference to your code, because Len Function returns an integer containing either the number of characters in a string
If (Len1 + Len2) = 0 Then
You can use Trim(strFile1 & vbNullString) = vbNullString to check if the string is empty.
So:
If Trim(strFile1 & vbNullString) = vbNullString Then
Debug.print "Empty String!"
End If
Thanks to #LordPeter
is.empty doesn't exist for VBA, but the second option works.
Alternatively, you can write:
(strFile1 & strFile2) = vbNullString
or
(strFile1 & strFile2) = ""
Yet another way is:
If Len(strFile1 & strFile2) > 0 Then
I did test to ensure that strings which aren't set return a length of 0, which appeared to be the case.
Related
Thank you in advance to looking and helping.
I'm trying to open a word document, then run some code on the document's contents, and save it. Here's what I have:
wordApp.Documents.Open (strFile)
wordApp.Visible = True
wordApp.Selection.WholeStory
strAll = wordApp.Selection.XML
This seems to get a handle to the contents of the document being opened. I can change search it, etc, and it appears to be changing the contents, however when I attempt to save it:
using this:
wordApp.ActiveDocument.Save NoPrompt:=True
or using this:
wordApp.ActiveDocument.SaveAs FileName:=folderName + "\test.xml", FileFormat:=wdFormatXML
the actual saved file isn't changed. If the actual document isn't being changed, and yet the changes are being made, where would the changes being made?
I can actually open the document, not as part of processing a folder, but opening it manually and run an action that has the same code in it and it makes the changes and prompts me to save when I close it. The ValidateFolder is the sub. It opens all .xml documents in a folder and validates contents, then I need to save any changes. The code for the whole things is:
Private Sub ValidateFolder_Click()
Dim wordApp
Dim folderName As Variant
Dim fileDir As String
Dim strAll As String
Dim strFile As String
Dim arrString() As String, occurInStr() As String, fldVal As String
Dim logResults As String
Dim dispVal As String
Dim i As Integer, v As Integer
Dim lnCount As Integer
Dim charPos As Long
folderName = BrowseForFolder("C:\")
lnCount = 0
If folderName <> "" Then
MsgBox ("check " + folderName)
fileDir = Dir$(folderName + "\*", 16)
Do While fileDir <> ""
If fileDir <> "." And fileDir <> ".." Then
Rem If entry is an xml file, then check the file.
If InStr(1, fileDir, ".xml", 5) > 0 Then
Set wordApp = CreateObject("word.Application")
strFile = folderName + "\" + fileDir
wordApp.Documents.Open strFile
wordApp.Visible = True
wordApp.Selection.WholeStory
strAll = wordApp.Selection.XML
arrString = Strings.Split(strAll, "»")
MsgBox ("Opened: " + strFile)
MsgBox (CStr(strAll))
For i = 0 To UBound(arrString)
'MsgBox (CStr(UBound(arrString)))
fldVal = strRight(arrString(i), "«")
'MsgBox (fldVal)
If fldVal <> "" Then
fldVal = fldVal & "»"
occurInStr = Split(fldVal, "»")
'MsgBox ("Match-" & CStr(i + 1) & ": " & fldVal & " occurances: " & CStr(UBound(occurInStr, 1)) & " error occur: " & CStr(InStrRegEx(fldVal, "«[A-Z_! ,d+0-9]*<.*»")))
If InStrRegEx(fldVal, "«[A-Z_! ,d+0-9]*<.*»") > 0 Then
Dim repVal As String
repVal = leftOfStrRightBack(fldVal, ">")
repVal = strRight(repVal, "<")
Dim newFldVal As String
newFldVal = Replace(fldVal, repVal, "")
Dim myRange As Range
Set myRange = ActiveDocument.Content
myRange.Find.Execute FindText:=newFldVal, Forward:=True
If myRange.Find.found = True Then
myRange.Find.Execute FindText:=newFldVal, ReplaceWith:="FLDSTART" & newFldVal, Format:=True, Replace:=wdReplaceAll
End If
Set myRange = ActiveDocument.Content
myRange.Find.Execute FindText:="FLDSTART", Forward:=True
If myRange.Find.found = True Then
myRange.Find.Execute FindText:="FLDSTART", ReplaceWith:="", Format:=True, Replace:=wdReplaceAll
End If
logResults = "errors"
If logResults = "" Then
logResults = "The Following Fields had errors:" & Chr(10) & " " & newFldVal
MsgBox (logResults = "The Following Fields had errors:" & Chr(10) & " " & newFldVal)
Else
logResults = logResults & Chr(10) & " " & newFldVal
End If
End If
End If
Next
If logResults = "" Then
MsgBox ("No errors")
Else
MsgBox ("errors")
End If
If logResults = "" Then
logResults = "Success!" & Chr(10) & Chr(10) & "There were no detected errors in fields."
Else
logResults = logResults & Chr(10) & Chr(10) & "They have been fixed." & Chr(10) & "Please save this document."
End If
MsgBox (logResults)
Rem Saving and closing the document.
wordApp.ActiveDocument.Save NoPrompt:=True
MsgBox ("Save and Quit now")
'wordApp.ActiveDocument.SaveAs FileName:=folderName + "\test.xml", FileFormat:=wdFormatXML
'wordApp.ActiveDocument.SaveAs (folderName + "\" + fileDir
'MsgBox ("Saved")
Exit Sub 'Stop here so you process only one document for testing.
wordApp.Quit SaveChanges:=wdSaveChanges, OriginalFormat:=wdWordDocument
End If
End If
fileDir = Dir$()
Loop
End If
End Sub
Function BrowseForFolder(Optional OpenAt As Variant) As Variant
Dim ShellApp As Object
'Create a file browser window at the default folder
Set ShellApp = CreateObject("Shell.Application"). _
BrowseForFolder(0, "Please choose a folder", 0, OpenAt)
'Set the folder to that selected. (On error in case cancelled)
On Error Resume Next
BrowseForFolder = ShellApp.self.Path
On Error GoTo 0
'Destroy the Shell Application
Set ShellApp = Nothing
'Check for invalid or non-entries and send to the Invalid error
'handler if found
'Valid selections can begin L: (where L is a letter) or
'\\ (as in \\servername\sharename. All others are invalid
Select Case Mid(BrowseForFolder, 2, 1)
Case Is = ":"
If Left(BrowseForFolder, 1) = ":" Then GoTo Invalid
Case Is = "\"
If Not Left(BrowseForFolder, 1) = "\" Then GoTo Invalid
Case Else
GoTo Invalid
End Select
Exit Function
Invalid:
'If it was determined that the selection was invalid, set to False
BrowseForFolder = False
End Function
Public Function GetFolder() As String
Dim fldr As FileDialog
Dim sItem As String
Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
MsgBox (fldr)
With fldr
.Title = "Select a Folder"
.AllowMultiSelect = False
.InitialFileName = OpenAt 'Application.DefaultFilePath
If .Show <> -1 Then GoTo NextCode
sItem = .SelectedItems(1)
End With
NextCode:
GetFolder = sItem
Set fldr = Nothing
End Function
Public Function leftOfStrRightBack(ByVal searchIn As String, ByVal searchFor As String) As String
Dim charPos As Long
Dim retStr As String
retStr = ""
If InStr(1, searchIn, searchFor, 5) > 0 Then
charPos = Len(searchIn)
While charPos > 0
If CStr(Mid(searchIn, charPos, 1)) = searchFor Then
'MsgBox ("Searched: " & searchIn & " found: " & searchFor & " at pos: " & charPos)
retStr = CStr(Mid(searchIn, 1, charPos))
'MsgBox ("Return: " & retStr)
GoTo BreakOut
End If
charPos = charPos - 1
Wend
BreakOut:
End If
leftOfStrRightBack = CStr(retStr)
End Function
Public Function strRight(ByVal searchIn As String, ByVal searchFor As String) As String
Dim charPos As Long
Dim retStr As String
retStr = ""
charPos = InStr(1, searchIn, searchFor, 5)
If charPos > 0 Then
retStr = CStr(Mid(searchIn, charPos, Len(searchIn)))
End If
'CStr(CStr(Mid(arrString(i), charPos, Len(arrString(i))) & "»"))
strRight = CStr(retStr)
End Function
Public Function InStrRegEx(ByVal searchIn As String, ByVal searchFor As String) As Long
Dim regEx As Object, found As Object
If Len(searchIn) > 0 And Len(searchFor) > 0 Then
Set regEx = CreateObject("VBScript.RegExp")
regEx.Pattern = searchFor
regEx.Global = True
regEx.IgnoreCase = True
Set found = regEx.Execute(searchIn)
If found.Count <> 0 Then InStrRegEx = found(0).FirstIndex + 1
End If
End Function
Public Function getText(ByVal searchIn As String, ByVal searchFor As String) As String
Dim regEx As Object, found As Object
If Len(searchIn) > 0 And Len(searchFor) > 0 Then
Set regEx = CreateObject("VBScript.RegExp")
regEx.Pattern = searchFor
regEx.Global = True
regEx.IgnoreCase = True
Set found = regEx.Execute(searchIn)
If found.Count <> 0 Then getText = CStr(found(0))
End If
End Function
I need to import into Access table this EDI text file ( ' as line terminator):
UNA:+.?'
UNB+UNOC:3+BRANDEUROPE+ANYCODE+180206:1121+5439'
UNH+5439-1+DESADV:D:99B:UN'
BGM+351+0089430043+9'
DTM+11:20180205:102'
DTM+137:20180205:102'
MEA+WT+AAD+KGM:2126.100'
MEA+CT+SQ+NMP:00000'
NAD+DP+0017309707++NameStreet 22+Rome++00100+IT'
CTA+DL'
NAD+SU+DE++BRAND Systems+Rome+Rome++00100+IT'
CTA+DL'
TOD+6++CIP'
CPS+1'
PAC+2++BX'
MEA+WT+G+KGM:88'
PCI+24'
GIN+ML+AL7B009435+AL7B009438'
LIN+1++46550705:VP'
PIA+1+4114793:BP'
IMD+A++:::C833dn-EURO'
QTY+12:2'
RFF+OP:44CKV07S:000001'
CPS+2'
PAC+1++BX'
MEA+WT+G+KGM:0.01'
PCI+24'
LIN+1++01182907:VP'
PIA+1+4113617:BP'
IMD+A++:::RAM-256MB-C3/C5/C6/C7/MC3/MC5/C8'
QTY+12:1'
RFF+OP:44CKV07S:000003'
CPS+3'
PAC+4++BX'
MEA+WT+G+KGM:43.2'
PCI+24'
LIN+1++46361802:VP'
PIA+1+4114805:BP'
IMD+A++:::Tray-C5x2/MC5x3'
QTY+12:4'
RFF+OP:44CKV07S:000006'
This is the result I need:
0089430043 05/02/2018 46550705 AL7B009435
0089430043 05/02/2018 46550705 AL7B009438
etc...
and this is what I tried:
Public Function import1()
Dim strFilename As String: strFilename = "C:\despatch.txt"
Dim strTextLine, CodProd, DataDoc As String
Dim SNarray() As String
Dim NumDoc As Long
Dim nPAC, NumRig, intCount As Integer
Dim iFile As Integer: iFile = FreeFile
Open strFilename For Input As #iFile
Do Until EOF(1)
Line Input #1, strTextLine
strTextLine = Replace(strTextLine, "'", "")
'BGM
If Left(strTextLine, 3) = "BGM" Then
NumDoc = Mid(strTextLine, 9, 10)
End If
'DTM
If Left(strTextLine, 6) = "DTM+11" Then
DataDoc = Mid(strTextLine, 14, 2) & "/" & Mid(strTextLine, 12, 2) & "/" & Mid(strTextLine, 8, 4)
End If
'CPS = numero record
If Left(strTextLine, 3) = "CPS" Then
NumRig = Val(Mid(strTextLine, 5, 3))
End If
'PAC = numero di matricole da estrarre
If Left(strTextLine, 3) = "PAC" Then
nPAC = Val(Mid(strTextLine, 5, 3))
End If
'GIN
If Left(strTextLine, 3) = "GIN" Then
'strTextLine.MoveNext
End If
'LIN
If Left(strTextLine, 3) = "LIN" Then
CodProd = Mid(strTextLine, 8, 8)
End If
'strTextLine.MovePrevious
SNarray = Split(Mid(strTextLine, 8), "+")
For intCount = LBound(SNarray) To UBound(SNarray)
Debug.Print NumDoc & " " & DataDoc & " " & NumRig & " " & CodProd & " " & SNarray(intCount)
Next
'strTextLine.MovePrevious
'strTextLine.MovePrevious
Loop
Close #iFile
End Function
Before to import GIN record with serial numbers, I need to achieve the LIN record with che product code, and then pass them to variables.
I've tried with .MoveNext and then with two .MovePrevious but it gives me error: object needed.
Any help would be appreciated.
Thanks.
This is an example of a function that parses an EDIFACT segment, it's not debugged but it shows the algorithm to read the EDI data. It can be easily adapted to read ANSI X12.
Function GetLine() as String()
Dim Elements as String(99,3)
Do Until EOF(1)
mychar = Input(1, #1) ' Get one character
If mychar = vbCr Or \
mychar = vbLf Then ' Skip Line Breaks
Continue
Else If mychar = "?" Then ' Process Escape
If EOF(1) Then Exit Do ' Reached end of file
mychar = Input(1, #1)
data = data & mychar ' Treat next char as regular
Else If mychar = "'" Then ' End of Segment
Exit Do
Else If mychar = "+" Then ' Element separator
Elements(Elem,Comp) = data
data = ""
Comp = 1
Elem = Elem + 1
Else If mychar = ":" Then ' Composite separator
Elements(Elem,Comp) = data
data = ""
Comp = Comp + 1
Else ' Regular data
data = data & mychar
End If
Loop
Elements(Elem,Comp) = data
GetLine = Elements
End Function
Example use
'BGM
If Elements(0,0) = "BGM" Then
NumDoc = Elements(2,1)
End If
Finally I solved (I really don't know how I did), here my code:
Function GetLine() As String()
Dim FSO As Object, objFile, objFolderIN, objFolderOUT As Object
Set FSO = CreateObject("Scripting.FileSystemObject")
Set objFolderIN = FSO.GetFolder("C:\IN")
Set objFolderOUT = FSO.GetFolder("C:\Archivio")
Dim data, elem, comp
Dim i As Integer
Dim iFile As Integer: iFile = FreeFile
Dim Elements(99, 3) As String
Dim mychar As String
Dim NumDoc As Long
i = 1
For Each objFile In objFolderIN.Files
Open objFile For Input As #iFile
Do Until EOF(1)
Line Input #1, data
'Debug.Print data
mychar = Input(1, #1) ' Get one character.
If mychar = "'" Then Exit Do ' End of Segment
If mychar = vbCr Or _
mychar = vbLf Then
'Continue
ElseIf mychar = "?" Then
mychar = Input(1, #1) ' Skip Line Breaks and Escape
data = data & mychar
ElseIf mychar = "'" Then
Exit Do
ElseIf mychar = "+" Then ' Element separator
Elements(elem, comp) = data
data = ""
comp = 1
elem = elem + 1
ElseIf mychar = ":" Then ' Composite separator
Elements(elem, comp) = data
data = ""
comp = comp + 1
Else ' Regular data
data = data & mychar
End If
Loop
Elements(elem, comp) = data
GetLine = Elements
Close #iFile
i = i + 1
Next objFile
'BGM
If Elements(0, 0) = "BGM" Then
NumDoc = Elements(2, 1)
Debug.Print NumDoc
End If
End Function
For Each cell In rng
workSheetName = Format(SaturdayIsComing(), "mm-dd-yyyy") & " " & cell.Value
If WorksheetExists(workSheetName) Then
Dim localRange, localCell As Range
Set localRange = Worksheets(workSheetName).Range("D8:D19")
Dim contents As Variant
contents = ""
Dim firstLine As Boolean
firstLine = True
For Each localCell In localRange
If Len(localCell.Value) > 0 Then
If firstLine Then
contents = contents & localCell.Value & Chr(11)
Else
contents = contents & Chr(9) & Chr(9) & Chr(9) & localCell.Value & Chr(11)
End If
Else
contents = fixString(contents)
End If
If Len(contents) > 0 Then
firstLine = False
End If
Next localCell
For Each cc In wDoc.SelectContentControlsByTag(cell.Value & "Notes")
If Len(contents) > 0 Then
cc.Range.Text = fixString(contents)
Else
cc.Range.Text = "No Issues Found"
End If
Next
Else
errorCodesString = errorCodesString & cell.Value & ":"
End If
Next cell
Output to Word
Forgot to terminate the meeting
This is a test message\'s
If my cell contains a ' then I get an error saying
One of the values passwed to this method or property is incorrect
I know a ' is a comment in VBA. How do I go around this while preserving the notes that someone had added to the Excel cell?
You need to write a piece of code to search for quotes, either the single (') or double (") variety and either add a backslash before them OR double the character so '' in place of ' and "" in place of " and run this on contents before assigning it to cc.Range.Text.
This routine can also check for other instances of incorrect strings and fix them.
Something like this would do:
Function fixString(ByVal strIn As Variant) As String
Dim i As Integer
Const strIllegals = "\'"""
For i = 1 To Len(strIllegals)
strIn = Replace(strIn, Mid$(strIllegals, i, 1), "\" & Mid$(strIllegals, i, 1))
Next i
fixString = strIn
End Function
Try changing cell.Value to Replace(cell.Value, "'", "")
Or is it contents that has the apostrophe in it? A bit confusing.
Try changing contents to Replace(contents , "'", "")
I am using the code below to save multiple selected emails in a standard file naming format in a folder, who's path is selected from a text box (textbox1). Depending on whether a checkbox (checkbox1) is selected or not will determine whether the emails are deleted after running the code. If the the checkbox is not selected then the emails are saved to the folder but not deleted from Outlook. If the checkbox is not selected then I want the email subject in Outlook to be changed in order that I know that I have previously saved the email. The code below pretty much does everything I want except changing the email subject. If I select only one email all works fine. However if I select more than one email then only the subject of the first email gets changed. Any help appreciated.
Sub SaveIncoming()
Dim lngC As Long
Dim msgItem As Outlook.MailItem
Dim strPath As String
Dim FiledSubject As String
On Error Resume Next
strPath = UserForm1.TextBox1.Value
On Error GoTo 0
If strPath = "" Then Exit Sub
If Right(strPath, 1) <> "\" Then strPath = strPath & "\"
If TypeName(Application.ActiveWindow) = "Explorer" Then
' save selected messages in Explorer window
If CBool(ActiveExplorer.Selection.Count) Then
With ActiveExplorer
For lngC = 1 To .Selection.Count
If .Selection(lngC).Class = olMail Then
MsgSaver3 strPath, .Selection(lngC)
If UserForm1.CheckBox1.Value = True Then
.Selection(lngC).Delete
End If
If UserForm1.CheckBox1.Value = False Then
FiledSubject = "[Filed" & " " & Date & "]" & " " & .Selection(lngC).Subject
.Selection(lngC).Subject = FiledSubject
End If
End If
Next lngC
End With
End If
ElseIf Inspectors.Count Then
' save active open message
If ActiveInspector.CurrentItem.Class = olMail Then
MsgSaver3 strPath, ActiveInspector.CurrentItem
End If
End If
End Sub
Private Sub MsgSaver3(strPath As String, msgItem As Outlook.MailItem)
Dim intC As Integer
Dim intD As Integer
Dim strMsgSubj As String
Dim strMsgFrom As String
strMsgSubj = msgItem.Subject
strMsgFrom = msgItem.SenderName
' Clean out characters from Subject which are not permitted in a file name
For intC = 1 To Len(strMsgSubj)
If InStr(1, ":<>""", Mid(strMsgSubj, intC, 1)) > 0 Then
Mid(strMsgSubj, intC, 1) = "-"
End If
Next intC
For intC = 1 To Len(strMsgSubj)
If InStr(1, "\/|*?", Mid(strMsgSubj, intC, 1)) > 0 Then
Mid(strMsgSubj, intC, 1) = "_"
End If
Next intC
' Clean out characters from Sender Name which are not permitted in a file name
For intD = 1 To Len(strMsgFrom)
If InStr(1, ":<>""", Mid(strMsgFrom, intD, 1)) > 0 Then
Mid(strMsgFrom, intD, 1) = "-"
End If
Next intD
For intD = 1 To Len(strMsgFrom)
If InStr(1, "\/|*?", Mid(strMsgFrom, intD, 1)) > 0 Then
Mid(strMsgFrom, intD, 1) = "_"
End If
Next intD
' add date to file name
strMsgSubj = Format(msgItem.SentOn, "yyyy-mm-dd Hh.Nn.Ss") & " " & "[From " & strMsgFrom & "]" & " " & strMsgSubj & ".msg"
msgItem.SaveAs strPath & strMsgSubj
Set msgItem = Nothing
UserForm1.Hide
End Sub
When you delete the remaining items move up so 2 becomes 1. You never process the original item 2.
Try replacing
For lngC = 1 To .Selection.count
with
For lngC = .Selection.count to 1 step -1
For the same reason a For Each loop does not work when moving or deleting.
I am trying to take code, go through it and delete all tags and then write it to a new document testfile.txt. For some reason I am getting an error with line 5:
Set ts = f.openastextstream(forwriting, tristateusedefault)
and am getting error invalid procedure.
Here is my code:
Sub elizabethwhite()
Set fs = CreateObject("scripting.filesystemobject")
fs.createtextfile "testfile.txt"
Set f = fs.getfile("testfile.txt")
Set ts = f.openastextstream(forwriting, tristateusedefault)
textline = ""
Do While f.opentextstream(forwriting, tristateusedefault).atendofstream <> True
textline = textline & f.opentextstream(forwriting, tristateusedefault).readline & "<BR>"
count = 0
pOne = 1
Do While InStr(textline, "<img") <> 0
count = count + 1
pOne = InStr(pOne, textline, "<img")
Do While InStr(pOne, textline, ">") = 0 & ts.atendofstream <> True
pTwo = InStr(pOne, textline, ">")
Loop
If 0 < count < 10 Then
textline = Left(textline, pOne - 1) & "{{image00" & count & ".jpg}}" & Right(textline, pTwo + 1)
ElseIf 9 < count < 100 Then
textline = Left(textline, pOne - 1) & "{{image0" & count & "}}.jpg" & Right(textline, pTwo + 1)
End If
Loop
Loop
ts.write textline
ts.Close
End Sub
Properly declaring your variables, and using Option Explict will identify the problem. Not tomention, these are good habits to develop and will help you write better code. They also enable the script assist feature, which comes in very handy.
The problem is that you have not enabled a reference to MS Scripting Runtime library AND because of this, ForReading and TriStateUseDefault are being interpreted by the compiler as variables and they are variables with no values, so you are passing invalid parameters to the OpenAsTextStream method.
Option Explicit would have helped you identified this error:
If you add a reference to the Microsoft Scripting Runtime, your code will work as-is, but would still urge you to declare ALL variables by type, and use Option Explicit. Both will save you a lot of trouble in the future :)
Sub elizabethwhite()
Dim fs As New Scripting.FileSystemObject
Dim f As Scripting.File
Dim ts As Scripting.TextStream
fs.CreateTextFile "testfile.txt"
Set f = fs.getfile("testfile.txt")
Set ts = f.OpenAsTextStream(ForWriting, TristateUseDefault)
ts.WriteLine "Hello!"
'
'### The rest of your code goes here... remember to declare any other variables :)
'
Set ts = Nothing
Set f = Nothing
Set fs = Nothing
End Sub
See also (documentation about the OpenAsTextStream method):
http://msdn.microsoft.com/en-us/library/aa265341(v=vs.60).aspx
I got this error when I tried to write unicode string to non-unicode text file. You have two options:
Open the file as unicode explicitly
Set ts = f.OpenAsTextStream(ForWriting, TristateTrue)
Convert string from unicode to ASCII before writing to the file
Following code will help you strip unicode characters from output string before writing to the file:
Dim regex
Set regex = CreateObject("vbscript.regexp")
With regex
.Global = True
.Pattern = "[^\u0000-\u007F]+"
End With
MsgBox regex.Replace(Replace(yourStringHere, Chr(160), Chr(32)), vbNullString)
Inner Replace function is just standard VBA Replace which translates one whitespace character to another. I had to add it because regex replace stripped the character \u00A0 too for some reason .
So your code will be:
Sub elizabethwhite()
Dim regex
Set regex = CreateObject("vbscript.regexp")
With regex
.Global = True
.Pattern = "[^\u0000-\u007F]+"
End With
Set fs = CreateObject("scripting.filesystemobject")
fs.createtextfile "testfile.txt"
Set f = fs.getfile("testfile.txt")
Set ts = f.openastextstream(forwriting, tristateusedefault)
textline = ""
Do While f.opentextstream(forwriting, tristateusedefault).atendofstream <> True
textline = textline & f.opentextstream(forwriting, tristateusedefault).readline & " <BR>"
count = 0
pOne = 1
Do While InStr(textline, "<img") <> 0
count = count + 1
pOne = InStr(pOne, textline, "<img")
Do While InStr(pOne, textline, ">") = 0 & ts.atendofstream <> True
pTwo = InStr(pOne, textline, ">")
Loop
If 0 < count < 10 Then
textline = Left(textline, pOne - 1) & "{{image00" & count & ".jpg}}" & Right(textline, pTwo + 1)
ElseIf 9 < count < 100 Then
textline = Left(textline, pOne - 1) & "{{image0" & count & "}}.jpg" & Right(textline, pTwo + 1)
End If
Loop
Loop
ts.write regex.Replace(Replace(textline, Chr(160), Chr(32)), vbNullString)
ts.Close
End Sub
Stripping unicode characters is just a quick-fix for diagnostics. You may have to do more thorough troubleshooting (and maybe to do some translation of unicode characters instead of simply stripping them).