I an application that generates and sends a HTML email to customers. This works with the exception that some characters namely ( ) & * % $ # # ! ~ ; _ = + / - ? ' does not work. The following is the code that I use. Please suggest how I can allow these special characters in my HTML email.
Sub subHtmlEmail(ByVal strAddresseeEmail As String, ByVal strGroup As String)
Try
Dim strTo, strFrom, strBody, strSubject, strBcc As String
Dim boolHtml As Boolean = True ' set the body content to plain text(false) or HTML(true)
strFrom = "sales#mycompany.com"
strTo = strAddresseeEmail ' ; Separates emails
strBcc = "" ' ; Separates emails
strSubject = txtEmailSubject.Text
strBody = "<html><head></head><body>"
strBody = strBody & "<img src=cid:Logo>"
strBody &= "<br><br>"
strBody &= "Dear " & clsGroupCustomers.RetrieveAddressee(strAddresseeEmail, strGroup) & ",<br><br>"
Dim strLines As String() = txtBody.Text.Split(New [Char]() {CChar(vbCrLf)})
For Each strLine As String In strLines
strBody &= strLine & "<br>"
Next
strBody &= "<br><br>"
Dim strFooterLines As String() = txtFooter.Text.Split(New [Char]() {CChar(vbCrLf)})
For Each strFooterLine As String In strFooterLines
strBody &= strFooterLine & "<br>"
Next
HTMLView = AlternateView.CreateAlternateViewFromString(strBody, Nothing, "text/html")
strBody &= "</body></html>"
subEmail(strFrom, strTo, strBcc, strSubject, strBody, boolHtml, strAddresseeEmail)
Catch ex As Exception
Cursor = Cursors.Default
MsgBox("An error has occurred in your application while attempting to create the email." & Chr(13) & Chr(13) & "Description: " & ex.Message & Chr(13) & Chr(13) & "Please contact your System Administrator.", MsgBoxStyle.Critical, "Application Error")
Exit Sub
End Try
End Sub
In HTML these characters should be encoded. For example: & (Ampersand) should be emitted as &
In .NET you can call HttpContext.Current.Server.HtmlEncode(myStringValue) to do this automatically for you.
Related
I currently have a code in a database that sends an email with a table
The table currently is not formatted it correctly and Im unable to apply cell padding. Any ideas?
enter image description here
Here is the code accompanying it
Function exporthtml()
Dim strline, strHTML, strMsg
Dim Cnt As String
Dim strFilt As String
Dim ACname As String
Dim filt As String
Dim strCC As String
Cnt = DCount("[PATS Action ID]", "tblPAT", "Bureau='" & Form_frmMainPATS.cboBur.Value & "'")
ACname = DLookup("FIRSTNAME", "qryAC", "Bureau='" & Form_frmMainPATS.txtFull.Value & "'")
strFilt = DLookup("WORKEMAIL", "qryAC", "Bureau='" & Form_frmMainPATS.txtFull.Value & "'")
Dim OL As Outlook.Application
Set OL = New Outlook.Application
Set MyItem = Outlook.Application.CreateItem(olMailItem)
Report_rptCurrentPATS.Filter = "Bureau='" & Form_frmMainPATS.cboBur.Value & "'"
Report_rptCurrentPATS.FilterOn = True
DoCmd.OutputTo acOutputReport, "rptCurrentPATS", acFormatHTML, "R:\Epi- Admin\Administrative Collaboration\Admin Review Meetings\Weekly Administrative Reports\Working Documents\Bureau Status Report Updates\TEST.html"
Open "R:\Epi-Admin\Administrative Collaboration\Admin Review Meetings\Weekly Administrative Reports\Working Documents\Bureau Status Report Updates\TEST.html" For Input As 1
Do While Not EOF(1)
Input #1, strline
strHTML = strHTML & strline
Loop
Close 1
If Left(OL.Version, 2) = "10" Then
MyItem.BodyFormat = olFormatHTML
End If
MyItem.To = strFilt
MyItem.Subject = "Updated PATS Status Report as of " & Date - 1
MyItem.HTMLBody = "<BODY bgcolor='#E6E6FA'>" & "<img src='R:\Epi-Admin\Fiscal Management and Reporting Unit\Database\PS Database\logo.png' ALT='Banner'" & "<p>" & "<FONT color = '#000000'>" & "Dear " & ACname & "," & "<br/>" & "<br/>" & Form_frmMainPATS.cboBur.Value & " currently has " & Cnt & " pending personnel actions." & "</p>" & "<p>" & "Please see the report below:" & "<br/>" & "<BODY>" & "<table border= '1'>" & "<bgcolor=#ffffff; cellspacing=10; table-layout: fixed; >" & "<table header= '1' bgcolor='#fffff'>" & strHTML & "</table>" & "</br>" & "<br/>" & "</br>" & "</br>" & "<p> If you have any questions, please contact your desingated Personnel Coordinator"
MyItem.Display
End Function
Any help would be appreciated
Expanding on my comment from above, you can try to see if something like this works or gets you in the right direction (not tested):
Dim strCell() as string
Do While Not EOF(1)
Input #1, strline
strCell() = Split(strline, vbTab) 'Replace vbTab with deliminator if needed
dim i as integer
for i = 0 to UBound(strCell)
strline = "<td>" & strCell(i) & "</td>"
next
strHTML = strHTML & "<tr>" & strline & "</tr>"
Loop
Close 1
I will be using excel to send emails to my clients requesting certain files from them. I have everything working except for 1 small detail and I do not want to use this until I have that 1 detail figured out.
My email populates almost perfectly, except for the fact that at the end, there is about 3 lines of space between "Regards" and my signature. I'm not sure why this is happening. It shows up like this:
Thank you for your attention in this matter.
Regards,
Signature
Does anyone know how to fix it. My code is listed below:
Sub KYC_FATCA()
Dim OutApp As Object
Dim OutMail As Object
Dim cell As Range
Dim signature As String
Dim AccOpen As String
Dim ConDoc As String
Dim SIP As String
Dim AFS As String
Dim W8 As String
Dim LEI As String
Application.ScreenUpdating = False
Set OutApp = CreateObject("Outlook.Application")
On Error GoTo cleanup
For Each cell In Columns("G").Cells.SpecialCells(xlCellTypeConstants)
'KYC Account Opening Form
If (Cells(cell.Row, "I").Value) = "No" Then
AccOpen = "<b>KYC Account Opening Form</b> ." & "<br>" & "<br>"
Else
AccOpen = ""
End If
'Constating Document
If (Cells(cell.Row, "J").Value) = "No" Then
ConDoc = "<b>Constating Document</b> - ." & "<br>" & "<br>"
Else
ConDoc = ""
End If
'Statement of Policy and Guidelines (SIP&G)
If (Cells(cell.Row, "L").Value) = "No" Then
SIP = "<b>Statement of Policy and Guidelines (SIP&G)</b> - " & "<br>" & "<br>"
Else
SIP = ""
End If
'Audited Financial Statements (AFS)
If (Cells(cell.Row, "M").Value) = "No" Then
AFS = "<b>Audited Financial Statements (AFS)</b> - ." & "<br>" & "<br>"
Else
AFS = ""
End If
'W-8BEN-E Form
If (Cells(cell.Row, "N").Value) = "No" Then
W8 = "<b>W-8BEN-E Form</b> - " & "<br>" & "<br>"
Else
W8 = ""
End If
'Legal Entity Identifier (LEI)
If (Cells(cell.Row, "O").Value) = "Needed" Then
LEI = "<b>Legal Entity Identifier (LEI)</b> - " & "<br>" & "<br>"
Else
LEI = ""
End If
If cell.Value Like "?*#?*.?*" And _
(Cells(cell.Row, "H").Value) = "yes" Then
Set OutMail = OutApp.CreateItem(0)
With OutMail
.Display
End With
signature = OutMail.HTMLbody
On Error Resume Next
With OutMail
.To = cell.Text 'Whatever is in cell G
.cc = Cells(cell.Row, "C").Value
'Testing if statements - The below one works perfect
'If LCase(Cells(cell.Row, "Z").Value) = "" Then
' .cc = Cells(cell.Row, "P").Value
'End If
.Subject = Cells(cell.Row, "A").Value & " - " & "Documentation Request" _
.HTMLbody = "<p style='font-family:calibri;font-size:11pt'>" & "Dear " & Cells(cell.Row, "D").Value & ",<br>" & "<br>" & _
"On behalf of " & Cells(cell.Row, "B").Value & ", please by " & "<b><u>" & Cells(cell.Row, "Q").Text & "</b></u>" & "." & "<br>" & "<br>" & _
AccOpen & _
ConDoc & _
SIP & _
AFS & _
W8 & _
LEI & _
"If you have any questions and/or concerns, please contract your Relationship Manager, " & Cells(cell.Row, "B").Value & "." & "<br>" & "<br>" & _
"Thank you for your attention in this matter." & "<br>" & "<br>" & _
"Regards," & "</p>" & _
signature _
'You can add files also like this
If (Cells(cell.Row, "I").Value) = "No" Then
.Attachments.Add ("C:doc")
End If
.Display 'This will open the message itself. If you'd like to send right away, use .Send
End With
On Error GoTo 0
Set OutMail = Nothing
End If
Next cell
cleanup:
Set OutApp = Nothing
Application.ScreenUpdating = True
End Sub
The problem is this line:
signature = OutMail.HTMLbody
This is a clever way to get the signature, but the default email body has a couple blank lines above the signature, and those are getting included when you concatenate the email.
I would visually check signature in a debugger and see what is in there, and remove the stuff you don't want. A simple example might be:
Function RemoveBlankStuff(ByVal text as string) as string
text = text.Replace("<P></P>","") 'Remove any empty paragraphs
text = text.Replace("<BR>","") 'Remove any line breaks
Return text;
End Function
signature = RemoveBlankStuff(OutMail.HTMLBody);
You will need to modify the above function depending on what you find in signature.
I was doing something similar and running into the same issue.
This should work if you replace this portion of code:
With OutMail
.Display
End With
signature = OutMail.HTMLbody
With the following code - it effectively opens, deletes whitespace, and deletes/discards the e-mail created to get the signature:
'gets default signature from e-mail
With OutMail
'2 = HTMLBody
.BodyFormat = 2
.Display
'deletes blank space present before signature
signature = Replace(OutMail.HTMLBody, "<p class=MsoNormal><o:p> </o:p></p>", "")
'removes entire e-mail contents and then closes with discard
OutMail.HTMLBody = Replace(OutMail.HTMLBody, OutMail.HTMLBody, "")
OutMail.Close 1
End With
Not sure if it makes a difference, but in .HTMLBody, I also start as -
.HTMLBody = .HTMLBody & "Good Afternoon," & "<br>" & "whateveryourtextis" & "Thanks," & "<br><br>" & signature
I have the below code in VBA which includes newline (vbnewline / vbcrlf) . Then I am calling the variable "Clientname" in .htmlbody. But it is putting the entire string in one line eliminating the newline
'Variable "un" will be assigned a value using a "For loop" above this code
Reading Text file:
Set oFS = oFSO.OpenTextFile("c:\test.txt")
TxtPro = oFS.ReadAll
If Not (InStr(ClientName, un)) > 0 Then
ClientName = ClientName & vbNewLine & un
End If
with objmail
.bodyformat = olformatHTML
.htmlbody = "<HTML><BODY> " & clientname & _
"<Br> Your File is given below <br> " & txtpro & "</body></html>"
end with
HTML doesn't understand/parse line feeds in the same way as VBA does. Use <BR> tag for HTML.
Change this line ClientName = ClientName & vbNewLine & un to ClientName = ClientName & "<BR>" & un
Edit as per your updated question:
Sub test()
Dim oFSO As New Scripting.FileSystemObject
Dim oFS As Object
Dim txtPro As String
Dim strHTML As String
Dim clientName As String
Set oFS = oFSO.OpenTextFile("C:\temp\test.txt")
txtPro = oFS.ReadAll()
'/ This will replace linefeeds with <BR> to render line breaks in HTML
txtPro = Replace(txtPro, vbCrLf, "<BR>")
strHTML = "<HTML><BODY> " & clientName & _
"<Br> Your File is given below <br> " & txtPro & "</body></html>"
End Sub
I am sending emails via a VB application. The following characters displays correctly on some email applications but on others, I get a weird replacement (See attached image). How can I go about making these characters always display correctly?
The character set : ( ) & * % $ # # ! ~ ; _ = + / - ?
The Message : 18cm – 22cm Wide; Fat O
The result :
No matter which one of the characters gets used, The result is always the same as the attached image. The applications that does not display correctly is outlook < 2013.
Here is the VB code:
Sub subHtmlEmail(ByVal strAddresseeEmail As String, ByVal strGroup As String)
Try
Dim strTo, strFrom, strBody, strSubject, strBcc As String
Dim boolHtml As Boolean = True ' set the body content to plain text(false) or HTML(true)
strFrom = "sales#humeat.com"
strTo = strAddresseeEmail ' ; Separates emails
strBcc = "" ' ; Separates emails
strSubject = txtEmailSubject.Text
strBody = "<html><head></head><body>"
strBody = strBody & "<img src=cid:Logo>"
strBody &= "<br><br>"
strBody &= "Dear " & clsGroupCustomers.RetrieveAddressee(strAddresseeEmail, strGroup) & ",<br><br>"
Dim strLines As String() = txtBody.Text.Split(New [Char]() {CChar(vbCrLf)})
For Each strLine As String In strLines
strBody &= strLine & "<br>"
Next
strBody &= "<br><br>"
Dim strFooterLines As String() = txtFooter.Text.Split(New [Char]() {CChar(vbCrLf)})
For Each strFooterLine As String In strFooterLines
strBody &= strFooterLine & "<br>"
Next
HTMLView = AlternateView.CreateAlternateViewFromString(strBody, Nothing, "text/html")
strBody &= "</body></html>"
subEmail(strFrom, strTo, strBcc, strSubject, strBody, boolHtml, strAddresseeEmail)
'subEmail(strFrom, strTo, strBcc, strSubject, System.Web.HttpUtility.HtmlEncode(strBody), boolHtml, strAddresseeEmail)
Catch ex As Exception
Cursor = Cursors.Default
MsgBox("An error has occurred in your application while attempting to create the email." & Chr(13) & Chr(13) & "Description: " & ex.Message & Chr(13) & Chr(13) & "Please contact your System Administrator.", MsgBoxStyle.Critical, "Application Error")
Exit Sub
End Try
End Sub
'Send the email
Sub subEmail(ByVal strFrom, ByVal strTo, ByVal strBcc, ByVal strSubject, ByVal strBody, ByVal bolHtml, ByVal strAddresseeEmail)
Try
'Dim strMailServer As String = "smtp.dsl.telkomsa.net"
Dim strMailServer As String = "smtp.insightsa.net"
'Dim strMailServer As String = "smtp.humeat.com"
'Dim strMailServer As String = "mail.humeat.com"
Dim intCount As Integer
Dim objAttachment As Attachment
Dim objMail As New MailMessage()
objMail.From = New MailAddress(strFrom)
Dim i As Integer
Dim arrArray As Array
arrArray = Split(strTo, ";")
For i = 0 To arrArray.Length - 1
objMail.To.Add(arrArray(i))
Next
arrArray = Split(strBcc, ";")
For i = 0 To arrArray.Length - 1
If Not arrArray(i) = "" Then objMail.Bcc.Add(arrArray(i))
Next
For intCount = 0 To lstAttachments.Items.Count - 1
objAttachment = New Attachment(lstAttachments.Items(intCount).ToString)
objMail.Attachments.Add(objAttachment)
Next
' [TW 20110309]
' Create the LinkedResource (embedded image)
Dim logo As New LinkedResource("C:\humeat.bmp")
logo.ContentId = "Logo"
' [TW 20110309]
' Add the LinkedResource to the appropriate view
HTMLView.LinkedResources.Add(logo)
' [TW 20110309]
' Add the views
objMail.AlternateViews.Add(PlainView)
objMail.AlternateViews.Add(HTMLView)
objMail.Subject = strSubject
objMail.Body = strBody
objMail.IsBodyHtml = bolHtml
Dim smtp As New SmtpClient(strMailServer)
smtp.Port = "587" ' This is not the default port of 25 but a special smtp port because they use Mweb. HC. 2-8-2011
smtp.Credentials = New System.Net.NetworkCredential("humeat#insightsa.net", "123Four56")
smtp.Send(objMail)
Catch ex As Exception
Cursor = Cursors.Default
'MsgBox("An error has occurred in your application while attempting to send the email to " & strTo & "." & Chr(13) & Chr(13) & "Description: " & ex.Message & Chr(13) & Chr(13) & "Please contact your System Administrator.", MsgBoxStyle.Critical, "Application Error")
lstEmailsNotSent.Items.Add(clsGroupCustomers.RetrieveAddressee(strAddresseeEmail, cboEmailGroup.Text) & " (" & strTo & ") - " & ex.Message)
Exit Sub
End Try
End Sub
Firstly, The – in 18cm – 22cm Wide; Fat O is a Unicode em-dash, not a hypen/minus sign. So your character set contains more than you think.
It's obviously a UTF-8 encoding problem. That's what you get if you display UTF-8-encoded text in Latin-1. Some MUAs have different defaults, or apply heuristics, when a specific character set is not declared.
There is an easy enough fix for this specific problem. Instead of giving a content-type of text/html, give text/html; charset=UTF-8.
Note that this hints at confusion about encodings in your database database and/or codebase if you've never seen this problem before, and it's a right pain to sort out. Consider fixing it to be a learning experience :)
Is there any way to bulk-export Microsoft Access code to files? I see I can export one file at a time, but there are hundreds and I'll be here all day. It there no "Export All" or multi-select export anywhere?
You can do this without having to write any code at all. From the menu, choose tools->analyze->database documenter.
This will give you a bunch of options to print out the code. You can then while viewing the report ether send it out to your PDF printer (if you have one). Or, simply print out to a text file printer. Or you can even then click on the word option in the report menu bar and the results will be sent out to word
The database documenter has provisions to print out all code, including code in forms.
So, in place of some of the suggested code examples you can do this without having to write any code at all. Do play with the additional options in the documenter. The documenter will produce HUGE volumes print out information for every single property and object in the database. So, if you don't un-check some of the options then you will easily empty a full size printer tray of paper. This documenter thus results in huge printouts.
To output all code to desktop, including code from forms and reports, you can paste this into a standard module and run it by pressing F5 or step through with F8. You may wish to fill in the name of the desktop folder first.
Sub AllCodeToDesktop()
''The reference for the FileSystemObject Object is Windows Script Host Object Model
''but it not necessary to add the reference for this procedure.
Dim fs As Object
Dim f As Object
Dim strMod As String
Dim mdl As Object
Dim i As Integer
Set fs = CreateObject("Scripting.FileSystemObject")
''Set up the file.
''SpFolder is a small function, but it would be better to fill in a
''path name instead of SpFolder(Desktop), eg "c:\users\somename\desktop"
Set f = fs.CreateTextFile(SpFolder(Desktop) & "\" _
& Replace(CurrentProject.Name, ".", "") & ".txt")
''For each component in the project ...
For Each mdl In VBE.ActiveVBProject.VBComponents
''using the count of lines ...
i = VBE.ActiveVBProject.VBComponents(mdl.Name).CodeModule.CountOfLines
''put the code in a string ...
If i > 0 Then
strMod = VBE.ActiveVBProject.VBComponents(mdl.Name).codemodule.Lines(1, i)
End If
''and then write it to a file, first marking the start with
''some equal signs and the component name.
f.writeline String(15, "=") & vbCrLf & mdl.Name _
& vbCrLf & String(15, "=") & vbCrLf & strMod
Next
''Close eveything
f.Close
Set fs = Nothing
End Sub
To get special folders, you can use the list supplied by Microsoft.
Enumerating Special Folders: http://www.microsoft.com/technet/scriptcenter/guide/sas_fil_higv.mspx?mfr=true
From: http://wiki.lessthandot.com/index.php/Code_and_Code_Windows
There is nothing in the interface to export more than one module at a time.
You can code your own "export all" equivalent easily:
Public Sub ExportModules()
Const cstrExtension As String = ".bas"
Dim objModule As Object
Dim strFolder As String
Dim strDestination As String
strFolder = CurrentProject.Path
For Each objModule In CurrentProject.AllModules
strDestination = strFolder & Chr(92) & objModule.Name & cstrExtension
Application.SaveAsText acModule, objModule.Name, strDestination
Next objModule
End Sub
Here's my version:
'============================================================'
' OutputCodeModules for Access
' Don Jewett, verion 2014.11.10
' Exports the following items from an Access database
' Modules
' Form Modules
' Report Modules
'
' Must be imported into Access database and run from there
'============================================================'
Option Explicit
Option Compare Database
Private Const KEY_MODULES As String = "Modules"
Private Const KEY_FORMS As String = "Forms"
Private Const KEY_REPORTS As String = "Reports"
Private m_bCancel As Boolean
Private m_sLogPath As String
'------------------------------------------------------------'
' >>>>>> Run this using F5 or F8 <<<<<<<<
'------------------------------------------------------------'
Public Sub OutputModuleHelper()
OutputModules
End Sub
Public Sub OutputModules(Optional ByVal sFolder As String)
Dim nCount As Long
Dim nSuccessful As Long
Dim sLine As String
Dim sMessage As String
Dim sFile As String
If sFolder = "" Then
sFolder = Left$(CurrentDb.Name, InStrRev(CurrentDb.Name, "\") - 1)
sFolder = InputBox("Enter folder for files", "Output Code", sFolder)
If sFolder = "" Then
Exit Sub
End If
End If
'normalize root path by removing trailing back-slash
If Right(sFolder, 1) = "\" Then
sFolder = Left(sFolder, Len(sFolder) - 1)
End If
'make sure this folder exists
If Not isDir(sFolder) Then
MsgBox "Folder does not exist", vbExclamation Or vbOKOnly
Exit Sub
End If
'get a new log filename
m_sLogPath = sFolder & "\_log-" & Format(Date, "yyyy-MM-dd-nn-mm-ss") & ".txt"
sLine = CurrentDb.Name
writeLog sLine
sMessage = sLine & vbCrLf
sLine = Format(Now, "yyyy-MM-dd nn:mm:ss") & vbCrLf
writeLog sLine
sMessage = sMessage & sLine & vbCrLf
'output modules
nCount = CurrentDb.Containers(KEY_MODULES).Documents.Count
nSuccessful = outputContainerModules(sFolder, KEY_MODULES)
'write to the log file and final message
sLine = nSuccessful & vbTab & "of" & vbTab & nCount & vbTab & KEY_MODULES & " exported"
writeFile m_sLogPath, sLine, True
sMessage = sMessage & vbTab & sLine & vbCrLf
'output form modules
If Not m_bCancel Then
nCount = CurrentDb.Containers(KEY_FORMS).Documents.Count
nSuccessful = outputContainerModules(sFolder, KEY_FORMS)
'write to the log file and final message
sLine = nSuccessful & vbTab & "of" & vbTab & nCount & vbTab & "Form Modules exported"
writeFile m_sLogPath, sLine, True
sMessage = sMessage & vbTab & sLine & vbCrLf
End If
'output report modules
If Not m_bCancel Then
nCount = CurrentDb.Containers(KEY_REPORTS).Documents.Count
nSuccessful = outputContainerModules(sFolder, KEY_REPORTS)
'write to the log file and final message
sLine = nSuccessful & vbTab & "of" & vbTab & nCount & vbTab & "Report Modules exported"
writeFile m_sLogPath, sLine, True
sMessage = sMessage & vbTab & sLine & vbCrLf
End If
If Len(sMessage) Then
MsgBox sMessage, vbInformation Or vbOKOnly, "OutputModules"
End If
End Sub
Private Function outputContainerModules( _
ByVal sFolder As String, _
ByVal sKey As String) As Long
Dim n As Long
Dim nCount As Long
Dim sName As String
Dim sPath As String
On Error GoTo EH
'refactored this to use reference to Documents,
'but the object reference doesn't stick around
'and I had to roll back to this which isn't as pretty.
'but this works (and if it ain't broke...)
For n = 0 To CurrentDb.Containers(sKey).Documents.Count - 1
nCount = nCount + 1
sName = CurrentDb.Containers(sKey).Documents(n).Name
Select Case sKey
Case KEY_FORMS
sName = "Form_" & sName
Case KEY_REPORTS
sName = "Report_" & sName
End Select
sPath = sFolder & "\" & sName & ".txt"
DoCmd.OutputTo acOutputModule, sName, acFormatTXT, sPath, False
Next 'n
outputContainerModules = nCount
Exit Function
EH:
nCount = nCount - 1
Select Case Err.Number
Case 2289 'can't output the module in the requested format.
'TODO: research - I think this happens when a Form/Report doesn't have a module
Resume Next
Case Else
Dim sMessage As String
writeError Err, sKey, sName, nCount
sMessage = "An Error ocurred outputting " & sKey & ": " & sName & vbCrLf & vbCrLf _
& "Number " & Err.Number & vbCrLf _
& "Description:" & Err.Description & vbCrLf & vbCrLf _
& "Click [Yes] to continue with export or [No] to stop."
If vbYes = MsgBox(sMessage, vbQuestion Or vbYesNo Or vbDefaultButton2, "Error") Then
Resume Next
Else
m_bCancel = True
outputContainerModules = nCount
End If
End Select
End Function
Private Function writeFile( _
ByVal sPath As String, _
ByRef sMessage As String, _
Optional ByVal bAppend As Boolean) As Boolean
'Dim oFSO as Object
'Dim oStream as Object
'Const ForWriting As Long = 2
'Const ForAppending As Long = 8
'Dim eFlags As Long
Dim oFSO As FileSystemObject
Dim oStream As TextStream
Dim eFlags As IOMode
On Error GoTo EH
'Set oFSO = Server.CreateObject("Scripting.FileSystemObject")
Set oFSO = New FileSystemObject
If bAppend Then
eFlags = ForAppending
Else
eFlags = ForWriting
End If
Set oStream = oFSO.OpenTextFile(sPath, eFlags, True)
oStream.WriteLine sMessage
writeFile = True
GoTo CLEAN
EH:
writeFile = False
CLEAN:
If Not oFSO Is Nothing Then
Set oFSO = Nothing
End If
If Not oStream Is Nothing Then
Set oStream = Nothing
End If
End Function
Private Sub writeError( _
ByRef oErr As ErrObject, _
ByVal sType As String, _
ByVal sName As String, _
ByVal nCount As Long)
Dim sMessage As String
sMessage = "An Error ocurred outputting " & sType & ": " & sName & " (" & nCount & ")" & vbCrLf _
& "Number " & oErr.Number & vbCrLf _
& "Description:" & oErr.Description & vbCrLf & vbCrLf
writeLog sMessage
End Sub
Private Sub writeLog( _
ByRef sMessage As String)
On Error GoTo EH
writeFile m_sLogPath, sMessage & vbCrLf, True
Exit Sub
EH:
'swallow errors?
End Sub
Private Function isDir(ByVal sPath As String) As Boolean
On Error GoTo EH
If Right$(sPath, 1) <> "\" Then
sPath = sPath & "\"
End If
If Dir$(sPath & ".", vbDirectory) = "." Then
isDir = True
ElseIf Len(sPath) = 3 Then
If Dir$(sPath, vbVolume) = Left(sPath, 1) Then
isDir = True
End If
End If
Exit Function
EH:
isDir = False
End Function