I'm creating a program that helps me download images from a weather website, so I can get radar images. It creates a file named "radar" and then the time. For example if it was 5:00 PM it would be named Radar500.png.
The downloading works fine, but it says I have an error on a certain line:
Const adSaveCreateOverWrite = 2
Const adTypeBinary = 1
if hour(time) > 12 then
a=hour(time)-12
else
if hour(time) = 0 then
a="12"
else
a=hour(time)
b=minute(time)
end if
end if
b=minute(time)
strSource = ""
strDest = "C:\Users\Gabriel\Desktop\Overnight weather\radar"+a+"s"+b+".jpg"
WScript.Echo "path: "+strDest
'*****************************************************************
'** Download the image
strResult = GetImage(strSource, strDest)
If strResult = "OK" Then
wscript.quit(0)
Else
wscript.quit(1)
End If
Function GetImage(strPath, strDest)
Dim objXMLHTTP, nF, arr, objFSO, objFile
Dim objRec, objStream
'create XMLHTTP component
Set objXMLHTTP = CreateObject("Microsoft.XMLHTTP")
'get the image specified by strPath
objXMLHTTP.Open "GET", strPath, False
objXMLHTTP.Send
'check if retrieval was successful
If objXMLHTTP.statusText = "OK" Then
'create binary stream to write image output
Set objStream = CreateObject("ADODB.Stream")
objStream.Type = adTypeBinary
objStream.Open
objStream.Write objXMLHTTP.ResponseBody
objStream.SavetoFile strDest, adSaveCreateOverwrite
objStream.Close
GetImage = "OK"
Else
GetImage = objXMLHTTP.statusText
End If
End Function
They say the error is at Line 29 Char 1.
Use strDest = "C:\Users\...\radar" & a & "s" & b & ".jpg". As per MSDN: Addition Operator (+) (VBScript)
Although you can also use the + operator to concatenate two
character strings, you should use the & operator for concatenation
to eliminate ambiguity. When you use the + operator, you may not be
able to determine whether addition or string concatenation will occur.
The type of the expressions determines the behavior of the +
operator in the following way:
If Then
Both expressions are numeric Add
Both expressions are strings Concatenate
One expression is numeric and the other is a string Error: type mismatch
...
Your script should work with next changes:
assign a valid strSource value, e.g. strSource = "http://www.goes.noaa.gov/FULLDISK/GMIR.JPG"
objXMLHTTP.Open "GET", strSource, False. Note strSource instead of your strDest
Related
I have a script that is supposed to grab a file from a folder and attach it to an email.
The code runs but nothing happens. I assume it's because strLocation is empty.
Here is an example of the file path I am trying to grab:
"C:\Users\MChambers\Desktop\Pricing Reports\Pricing_Report_201908121239 Formatted.xlsx"
Option Explicit
Const olMailItem = 0
Function FindFirstFile(strDirPath, strPattern)
Dim strResult
Dim objRegExp, objMatches
Set objRegExp = New RegExp
objRegExp.Pattern = strPattern
objRegExp.IgnoreCase = True
Dim objFso, objFolder, objFile
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objFolder = objFSO.GetFolder(strDirPath)
For Each objFile in objFolder.Files
Set objMatches = objRegExp.Execute(objFile.Name)
If objMatches.Count > 0 Then
strResult = objMatches(0).Value
Exit For
End If
Next
If Len(strResult) > 0 Then
If Right(strDirPath, 1) <> "\" Then strDirPath = strDirPath & "\"
strResult = strDirPath & strResult
End If
FindFirstFile = strResult
End Function
Sub SendBasicEmail()
Dim olApp: Set olApp = CreateObject("Outlook.Application")
Dim olEmail: Set olEmail = olApp.CreateItem(olMailItem)
Dim strLocation
Dim strPattern
strPattern = "Pricing_Report_*Formatted.xlsx"
strLocation = FindFirstFile("C:\Users\MChambers\Desktop\Pricing Reports\", strPattern)
If strLocation <> "" Then
With olEmail
.SentOnBehalfOfName = "genericemail"
.Attachments.Add (strLocation)
.To = "myemail"
.Subject = "Subject"
.Send
End With
End If
End Sub
SendBasicEmail
Update: The solution below was correct. In addition, I had to call the sub directly at the end of the file which I have updated in the code above.
The pattern you're using doesn't do what you apparently think it does.
strPattern = "Pricing_Report_*Formatted.xlsx"
You seem to expect the above to do a wildcard match (i.e. "Pricing_Report_" followed by any amount of text and "Formatted.xlsx"). That is not how regular expressions work. * in a regular expression means "zero or more times the preceding expression". The character . also has a special meaning in regular expressions, which is "any character except line-feed. Because of that your pattern would actually match the string "Pricing_Report" followed by any number of consecutive underscores, the string "Formatted", any single character except line-feed, and the string "xlsx".
Change the pattern to this
strPattern = "Pricing_Report_.*Formatted\.xlsx"
and the code will do what you want.
For further information about regular expressions in VBScript see here.
I got some script to convert string to base64 and write encoded data to text file that's all goes fine and result stored in encoded.txt but I need each line to be double quoted at the start and '& _' with double quotes at the end so how to make this script do that automatically for each line? here is my script
Option Explicit
Const fsDoOverwrite = true
Const fsAsASCII = false
Const adTypeBinary = 1
Dim objFSO
Dim objFileOut
Dim objXML
Dim objDocElem
Dim objStream
Set objStream = CreateObject("ADODB.Stream")
objStream.Type = adTypeBinary
objStream.Open()
objStream.LoadFromFile(Wscript.scriptfullname)
Set objXML = CreateObject("MSXml2.DOMDocument")
Set objDocElem = objXML.createElement("Base64Data")
objDocElem.dataType = "bin.base64"
objDocElem.nodeTypedValue = objStream.Read()
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objFileOut = objFSO.CreateTextFile("encoded.txt", fsDoOverwrite, fsAsASCII)
objFileOut.Write objDocElem.text
objFileOut.Close()
Set objFSO = Nothing
Set objFileOut = Nothing
Set objXML = Nothing
Set objDocElem = Nothing
Set objStream = Nothing
Sub encodeFileBase64( inputFile, outputFile )
Const fsDoOverwrite = True
Const fsAsASCII = False
Const adTypeBinary = 1
Dim stream, strBuffer
Set stream = WScript.CreateObject("ADODB.Stream")
With stream
.Type = adTypeBinary
.Open
.LoadFromFile inputFile
End With
With WScript.CreateObject("MSXML2.DOMDocument").CreateElement("Base64Data")
.dataType = "bin.base64"
.nodeTypedValue = stream.Read()
strBuffer = .Text
End With
stream.Close
With New RegExp
.Multiline = True
.Global = True
.IgnoreCase = False
.Pattern = "[\r\n]+(?=[0-9A-Za-z])"
strBuffer = Chr(34) & .Replace(strBuffer, Chr(34) & " & _" & vbCrLf & Chr(34) ) & Chr(34)
End With
WScript.CreateObject("Scripting.FileSystemObject").CreateTextFile( outputFile, fsDoOverwrite, fsAsASCII ).Write strBuffer
End Sub
encodeFileBase64 WScript.ScriptFullName, WScript.ScriptFullName & ".b64"
This will use a regular expression object to replace all intermediate line endings with the adecuated line termination/start and two aditional quotes, one at the start and one at the end.
Split the text by a line break, then loop through and put it all back together while you add the quotes. (not tested, but probably close, code follows; there is a strong chance you'll need to find the right type of line feed for your situation - I picked vbCr as an example):
allTextArray = SPLIT(originalText, vbCr)
For i=0 to UBound(allTextArray)
allTextWithQuotes = allTextWithQuotes & """" & allTextArray(i) & """"
Next
I'm working with the below code
Dim objFSO, objFile, maxRetry, numRetries, newRetries
CONST ForReading = 1
CONST ForWriting = 2
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objFile = objFSO.OpenTextFile(MICacheFilename(), ForReading)
maxRetry = CInt(MIGetTaskParam("maxRetry"))
strText = objFile.ReadAll
Set numRetries = CInt(objFile.ReadLine)
IF numRetries >= maxRetry THEN
MISetTaskParam "RerunTask", "False"
strLine = Replace(strLine,numRetries ,0)
Else
MISetTaskParam "RerunTask", "True"
Set newRetries = numRetries + 1
strLine = Replace(strLine,numRetries ,newRetries)
END IF
MICacheFilename() and MIGetTaskParam are passed into the script as a file path and an integer. My goal is to compare the max value passed in to the value in the file and set MISetTaskParam based on the comparison. I'm very new to VB and this seems like it shoudl be easier than I'm finding. The input file is a text file that only contains an integer.
While my first instinct would be to stay in a loop this script is only called periodically and needs to be an IF.
I am currently getting the error object requried with set numRetries = CInt(objFile.ReadLine)
mhopkins321, you say:
I am currently getting the error object requried with set numRetries =
CInt(objFile.ReadLine)
That is because the Set keyword is used only for setting a variable that holds an instance of an object. In your case, the purpose numRetries is to hold an integer.
So, try this instead:
numRetries = CInt(objFile.ReadLine)
I found a few other issues with your script. Here is my edited version with some comments:
Option Explicit ' Checks that you have declared all variables
Dim objFSO, objFile, maxRetry, numRetries, newRetries
Dim strText, strLine ' declare these also
CONST ForReading = 1
CONST ForWriting = 2
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objFile = objFSO.OpenTextFile(MICacheFilename(), ForReading)
maxRetry = CInt(MIGetTaskParam("maxRetry"))
' strText = objFile.ReadAll ' Not needed
numRetries = CInt(objFile.ReadLine) ' just read the one line in the file
WScript.Echo "numRetries = [" & numRetries & "]"
IF numRetries >= maxRetry THEN
MISetTaskParam "RerunTask", "False"
strLine = Replace(strLine,numRetries ,0) ' does nothing, 'strline' is empty
Else
MISetTaskParam "RerunTask", "True"
newRetries = numRetries + 1
strLine = Replace(strLine,numRetries ,newRetries) ' does nothing, 'strline' is empty
END IF
WScript.Echo "strLine = [" & strLine & "]"
' Dummy Function.
Function MICacheFilename()
MICacheFilename = "retries.txt"
End Function
' Dummy Function.
Function MIGetTaskParam(key)
MIGetTaskParam = 13
End Function
' Dummy Sub.
Sub MISetTaskParam(arg1, arg2)
End Sub
I have inherited a VB6 program that uses Crystal Reports 8.5 to run reports & then export the output to a PDF. It then uses the Adobe Acrobat 5.0 Type Library to merge the resulting PDFs into a single PDF document. Our problem is that we need to upgrade the Acrobat 5.0 Type Library but it appears that the most current version of Acrobat doesn’t provide a type library that will work with VB6. Does anyone know the most recent version of Acrobat that is supported within VB6? Also, does anyone have any suggestions of how this can be upgraded without upgrading the entire application to .Net? Thanks in advance for any help that can be provided.
I'd shell out to pdftk. Example from the man page:
Merge Two or More PDFs into a New Document
pdftk 1.pdf 2.pdf 3.pdf cat output 123.pdf
Note that if your app is distributed and non-GPL you'll need a commercial license for it, but it's only $24 at the moment.
I had this same requirement 15 years ago and created a mod in vb6 to do just that:
modMergePDF
Public Function MergePDFFiles
I recently updated the code to handle Acrobat 10.0 Type Library, so you would need to install the latest as of 8/1/2020, Acrobat DC Pro, to...
Use the below code
Use the compiled MergePDF.exe
Also, the mod adds bookmarks using the file names of the many PDF, with scrub code to
get rid of some ugly file names (you may have to expound upon that if you need to
scrub the file names to bookmark names), into the single pdf file.
Also included a function to generate batch file code:
Public Function BuildBatchFileCode
to call the MergePDF.exe passing in a command
line which consists of the Many pdf directory and the single pdf merged file directory
and file name. You can also pass in a flag to sort CaseSensitive (Any Capitalized
file names will sort above lowercase) and you can pass in another flag to maintain the .pdf extension in the bookmark name.
Find the MergePDF.exe on git up with all supporting code here:
https://github.com/Brad-Skidmore/MergePDF
Note: the error handling refers to goUtil.utErrorLog you can also find that on GitHub or you can replace it with your own error handling.
Here's the Mod code: modMergePDF
' http://www.xlsure.com 2020.07.30
' *********************************************************************
' You are free to use this code within your own applications, but you
' are expressly forbidden from selling or otherwise distributing this
' source code without prior written consent.
' Merge PDF Files - modMergePDF
' *********************************************************************
Option Explicit
'PDF documents must be declared in general declaration space and not local!
Private moMainDoc As Acrobat.AcroPDDoc
Private moTempDoc As Acrobat.AcroPDDoc
Private Property Get msClassName() As String
msClassName = "modMergePDF"
End Property
Public Function MergePDFFiles(psRawPDFFilesDir As String, _
psSinglePDFOutputDir As String, _
psSinglePDFOutputName As String, _
Optional ByVal pbRemovePdfExtFromBookMark As Boolean = True, _
Optional pbCaseSensitiveSort As Boolean = False, _
Optional ByVal pbShowError As Boolean = False) As Boolean
On Error GoTo EH
Dim bFirstDoc As Boolean
Dim sRawPDFFilesDir As String
Dim sSinglePDFOutputDir As String
Dim sSinglePDFOutputName As String
Dim saryFileSort() As String
Dim sBMName As String
'Track pos of things
Dim lBMPageNo As Long
Dim lPos As Long
Dim lFile As Long
Dim lInsertPageAfter As Long
Dim lNumPages As Long
Dim lRet As Long
'Need to use Adobe internal Java Object
'in order to Add Book marks
Dim oJSO As Object 'JavaScript Object
Dim oBookMarkRoot As Object
'File I/O
Dim oFolder As Scripting.Folder
Dim oFile As Scripting.File
Dim oFSO As Scripting.FileSystemObject
sRawPDFFilesDir = psRawPDFFilesDir
'ensure backslash for the 2 b merged PDF files directory
If StrComp(Right(sRawPDFFilesDir, 1), "\", vbBinaryCompare) <> 0 Then
sRawPDFFilesDir = sRawPDFFilesDir & "\"
psRawPDFFilesDir = sRawPDFFilesDir
End If
sSinglePDFOutputDir = psSinglePDFOutputDir
sSinglePDFOutputName = psSinglePDFOutputName
'ensure .pdf for the PDFOutputName (If it's CAP .PDF should be okay)
If StrComp(Right(sSinglePDFOutputName, 4), ".pdf", vbTextCompare) <> 0 Then
sSinglePDFOutputName = sSinglePDFOutputName & ".pdf"
psSinglePDFOutputName = sSinglePDFOutputName
End If
Set oFSO = New Scripting.FileSystemObject
Set oFolder = oFSO.GetFolder(sRawPDFFilesDir)
bFirstDoc = True
If oFolder.Files.Count = 0 Then
Exit Function
End If
'Because the FSO folder files collection does not allow for
'Native sorting, need to plug all the files into an array and sort that motha
ReDim saryFileSort(1 To oFolder.Files.Count)
lFile = 0
For Each oFile In oFolder.Files
lFile = lFile + 1
saryFileSort(lFile) = oFile.Name
Next
'Once they is all in der sor the array
'Sort is Case Sensitive
If pbCaseSensitiveSort Then
goUtil.utBubbleSort saryFileSort
End If
For lFile = 1 To UBound(saryFileSort, 1)
If LCase(Right(saryFileSort(lFile), 4)) = ".pdf" Then
If bFirstDoc Then
bFirstDoc = False
Set moMainDoc = CreateObject("AcroExch.PDDoc") 'New AcroPDDoc
lRet = moMainDoc.Open(sRawPDFFilesDir & saryFileSort(lFile))
Set oJSO = moMainDoc.GetJSObject
Set oBookMarkRoot = oJSO.BookMarkRoot
sBMName = saryFileSort(lFile)
lPos = InStr(1, sBMName, "_{", vbBinaryCompare)
If lPos > 0 Then
sBMName = left(sBMName, lPos - 1) & ".pdf"
End If
If pbRemovePdfExtFromBookMark Then
sBMName = Replace(sBMName, ".pdf", vbNullString, , , vbTextCompare)
End If
lRet = oBookMarkRoot.CreateChild(sBMName, "this.pageNum =0", lFile - 1)
Else
Set moTempDoc = CreateObject("AcroExch.PDDoc") 'New AcroPDDoc
lRet = moTempDoc.Open(sRawPDFFilesDir & saryFileSort(lFile))
'get the Book mark page number before the actual instert of new pages
lBMPageNo = moMainDoc.GetNumPages
lInsertPageAfter = lBMPageNo - 1
lNumPages = moTempDoc.GetNumPages
lRet = moMainDoc.InsertPages(lInsertPageAfter, moTempDoc, 0, lNumPages, 0)
moTempDoc.Close
If lRet = 0 Then
sBMName = saryFileSort(lFile)
lPos = InStr(1, sBMName, "_{", vbBinaryCompare)
If lPos > 0 Then
sBMName = left(sBMName, lPos - 1) & ".pdf"
End If
'Need to copy the errored document over to be included in the enitre document
goUtil.utCopyFile sRawPDFFilesDir & saryFileSort(lFile), sSinglePDFOutputDir & "\" & sBMName
sBMName = "PDF Insert Page Error_" & sBMName
Else
sBMName = saryFileSort(lFile)
lPos = InStr(1, sBMName, "_{", vbBinaryCompare)
If lPos > 0 Then
sBMName = left(sBMName, lPos - 1) & ".pdf"
End If
End If
If pbRemovePdfExtFromBookMark Then
sBMName = Replace(sBMName, ".pdf", vbNullString, , , vbTextCompare)
End If
lRet = oBookMarkRoot.CreateChild(sBMName, "this.pageNum =" & lBMPageNo, lFile - 1)
End If
End If
Next
lRet = moMainDoc.Save(1, sSinglePDFOutputDir & "\" & sSinglePDFOutputName)
moMainDoc.Close
MergePDFFiles = True
CLEAN_UP:
Set oFolder = Nothing
Set oFile = Nothing
Set oFSO = Nothing
Set oBookMarkRoot = Nothing
Set oJSO = Nothing
Set moMainDoc = Nothing
Set moTempDoc = Nothing
Exit Function
EH:
goUtil.utErrorLog Err, App.EXEName, msClassName, "Public Function MergePDFFiles", pbShowError
End Function
Public Function BuildBatchFileCode(psRawPDFFilesDir As String, _
psSinglePDFOutputDir As String, _
psSinglePDFOutputName As String, _
pbRemovePdfExtFromBookMark As Boolean, _
pbCaseSensitiveSort As Boolean) As String
On Error GoTo EH
Dim sRawPDFFilesDir As String: sRawPDFFilesDir = psRawPDFFilesDir
Dim sSinglePDFOutputDir As String: sSinglePDFOutputDir = psSinglePDFOutputDir
Dim sSinglePDFOutputName As String: sSinglePDFOutputName = psSinglePDFOutputName
Dim bRemovePdfExtFromBookMark As Boolean: bRemovePdfExtFromBookMark = pbRemovePdfExtFromBookMark
'ensure backslash for the 2 b merged PDF files directory
If StrComp(Right(sRawPDFFilesDir, 1), "\", vbBinaryCompare) <> 0 Then
sRawPDFFilesDir = sRawPDFFilesDir & "\"
psRawPDFFilesDir = sRawPDFFilesDir
End If
'ensure .pdf for the PDFOutputName (If it's CAP .PDF should be okay)
If StrComp(Right(sSinglePDFOutputName, 3), ".pdf", vbTextCompare) <> 0 Then
sSinglePDFOutputName = sSinglePDFOutputName & ".pdf"
psSinglePDFOutputName = sSinglePDFOutputName
End If
Dim sCommandLine As String
sCommandLine = "RawPDFFilesDir|" & sRawPDFFilesDir _
& "|SinglePDFOutputDir|" & sSinglePDFOutputDir _
& "|SinglePDFOutputName|" & sSinglePDFOutputName _
& "|RemovePdfExtFromBookMark|" & CStr(bRemovePdfExtFromBookMark) _
& "|CaseSensitiveSort|" & CStr(pbCaseSensitiveSort)
BuildBatchFileCode = """" & App.Path & "\" & App.EXEName & ".exe"" """ & sCommandLine
Exit Function
EH:
goUtil.utErrorLog Err, App.EXEName, msClassName, "Public Function BuildBatchFileCode"
End Function
I would like to export a file I have created in UTF-8 CSV using VBA. From searching message boards, I have found the following code that converts a file to UTF-8 (from this thread):
Sub SaveAsUTF8()
Dim fsT, tFileToOpen, tFileToSave As String
tFileToOpen = InputBox("Enter the name and location of the file to convert" & vbCrLf & "With full path and filename ie. C:\MyFolder\ConvertMe.Txt")
tFileToSave = InputBox("Enter the name and location of the file to save" & vbCrLf & "With full path and filename ie. C:\MyFolder\SavedAsUTF8.Txt")
tFileToOpenPath = tFileToOpen
tFileToSavePath = tFileToSave
Set fsT = CreateObject("ADODB.Stream"): 'Create Stream object
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
fsT.LoadFromFile tFileToOpenPath: 'And write the file to the object stream
fsT.SaveToFile tFileToSavePath, 2: 'Save the data to the named path
End Sub
However, this code only converts a non-UTF-8 file to UTF-8. If I were to save my file in non-UTF-8 and then convert it to UTF-8, it would have already lost all the special characters it contained, thus rendering the process pointless!
What I'm looking to do is save an open file in UTF-8 (CSV). Is there any way of doing this with VBA?
n.b. I have also asked this question on the 'ozgrid' forum. Will close both threads together if I find a solution.
Finally in Office 2016, you can simply savs as CSV in UTF8.
Sub SaveWorkSheetAsCSV()
Dim wbNew As Excel.Workbook
Dim wsSource As Excel.Worksheet, wsTemp As Excel.Worksheet
Dim name As String
Set wsSource = ThisWorkbook.Worksheets(1)
name = "test"
Application.DisplayAlerts = False 'will overwrite existing files without asking
Set wsTemp = ThisWorkbook.Worksheets(1)
Set wbNew = ActiveWorkbook
Set wsTemp = wbNew.Worksheets(1)
wbNew.SaveAs name & ".csv", xlCSVUTF8 'new way
wbNew.Close
Application.DisplayAlerts = True
End Sub
This will save the worksheet 1 into csv named test.
Update of this code. I used this one to change all .csv files in a specified folder (labeled "Bron") and save them as csv utf-8 in another folder (labeled "doel")
Sub SaveAsUTF8()
Dim fsT As Variant, tFileToOpen As String, tFileToSave As String
Dim Message As String
Dim wb As Workbook
Dim fileName As String
Set wb = ActiveWorkbook
With Application
.ScreenUpdating = False
.DisplayAlerts = False
End With
Message = "Source folder incorrect"
SourceFolder = wb.Worksheets("Menu").Range("Bron") & "\"
If Dir(SourceFolder, vbDirectory) = "" Or IsEmpty(SourceFolder) Then GoTo errorhandler
Message = "Target folder incorrect"
TargetFolder = wb.Worksheets("Menu").Range("Doel") & "\"
If Dir(TargetFolder, vbDirectory) = "" Or IsEmpty(TargetFolder) Then GoTo errorhandler
fileName = Dir(SourceFolder & "\*.csv", vbNormal)
Message = "No files available."
If Len(fileName) = 0 Then GoTo errorhandler
Do Until fileName = ""
tFileToOpen = SourceFolder & fileName
tFileToSave = TargetFolder & fileName
tFileToOpenPath = tFileToOpen
tFileToSavePath = tFileToSave
Set fsT = CreateObject("ADODB.Stream"): 'Create Stream object
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
fsT.LoadFromFile tFileToOpenPath: 'And write the file to the object stream
fsT.SaveToFile tFileToSavePath, 2: 'Save the data to the named path
fileName = Dir()
Loop
Message = "Okay to remove all old files?"
If QuestionMessage(Message) = False Then
GoTo the_end
Else
On Error Resume Next
Kill SourceFolder & "*.csv"
On Error GoTo errorhandler
End If
the_end:
With Application
.ScreenUpdating = True
.DisplayAlerts = True
End With
Exit Sub
errorhandler:
With Application
.ScreenUpdating = True
.DisplayAlerts = True
End With
CriticalMessage (Message)
Exit Sub
End Sub
'----------
Function CriticalMessage(Message As String)
MsgBox Message
End Function
'----------
Function QuestionMessage(Message As String)
If MsgBox(Message, vbQuestion + vbYesNo) = vbNo Then
QuestionMessage = False
Else
QuestionMessage = True
End If
End Function
Here's my solution based on Excel VBA - export to UTF-8, which user3357963 linked to earlier. It includes macros for exporting a range and a selection.
Option Explicit
Const strDelimiter = """"
Const strDelimiterEscaped = strDelimiter & strDelimiter
Const strSeparator = ","
Const strRowEnd = vbCrLf
Const strCharset = "utf-8"
Function CsvFormatString(strRaw As String) As String
Dim boolNeedsDelimiting As Boolean
boolNeedsDelimiting = InStr(1, strRaw, strDelimiter) > 0 _
Or InStr(1, strRaw, Chr(10)) > 0 _
Or InStr(1, strRaw, strSeparator) > 0
CsvFormatString = strRaw
If boolNeedsDelimiting Then
CsvFormatString = strDelimiter & _
Replace(strRaw, strDelimiter, strDelimiterEscaped) & _
strDelimiter
End If
End Function
Function CsvFormatRow(rngRow As Range) As String
Dim arrCsvRow() As String
ReDim arrCsvRow(rngRow.Cells.Count - 1)
Dim rngCell As Range
Dim lngIndex As Long
lngIndex = 0
For Each rngCell In rngRow.Cells
arrCsvRow(lngIndex) = CsvFormatString(rngCell.Text)
lngIndex = lngIndex + 1
Next rngCell
CsvFormatRow = Join(arrCsvRow, ",") & strRowEnd
End Function
Sub CsvExportRange( _
rngRange As Range, _
Optional strFileName As Variant _
)
Dim rngRow As Range
Dim objStream As Object
If IsMissing(strFileName) Or IsEmpty(strFileName) Then
strFileName = Application.GetSaveAsFilename( _
InitialFileName:=ActiveWorkbook.Path & "\" & rngRange.Worksheet.Name & ".csv", _
FileFilter:="CSV (*.csv), *.csv", _
Title:="Export CSV")
End If
Set objStream = CreateObject("ADODB.Stream")
objStream.Type = 2
objStream.Charset = strCharset
objStream.Open
For Each rngRow In rngRange.Rows
objStream.WriteText CsvFormatRow(rngRow)
Next rngRow
objStream.SaveToFile strFileName, 2
objStream.Close
End Sub
Sub CsvExportSelection()
CsvExportRange ActiveWindow.Selection
End Sub
Sub CsvExportSheet(varSheetIndex As Variant)
Dim wksSheet As Worksheet
Set wksSheet = Sheets(varSheetIndex)
CsvExportRange wksSheet.UsedRange
End Sub