Getting the conditional formatting into the HTMLBody - html

Is there a possibility to have the HTML Body:
.HTMLBody = strText & RangetoHTML(rng) & "<br><br>" & GetBoiler(Environ("appdata") & "\Microsoft\Signatures\" & strFilename & ".htm")
...when criteria > 1 is fulfilled and ...
.HTMLBody = strText2 & "<br><br>" & GetBoiler(Environ("appdata") & "\Microsoft\Signatures\" & strFilename & ".htm")
' in this case the range is missing and the text is different when criteria = 0 is fulfilled.
I thought of the "if" function into the HTML Body?
GetBoiler Function:
Function GetBoiler(ByVal sFile As String) As String
Dim fso As Object, ts As Object
Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.GetFile(sFile).OpenAsTextStream(1, -2)
GetBoiler = ts.readall
ts.Close
End Function
Range function:
Function RangetoHTML(rng As Range)
Dim fso As Object, ts As Object, TempWB As Workbook
With Worksheets("Auswertung")
loLetzte = .Cells(.Rows.Count, 1).End(xlUp).Row
.Range("$A$7:$D$" & loLetzte).AutoFilter Field:=3, Criteria1:=">0"
If .AutoFilter.Range.SpecialCells(xlCellTypeVisible).Rows.Count > 1 Then
.AutoFilter.Range.Offset(1).Resize(.AutoFilter.Range.Rows.Count - 1). _
SpecialCells(xlCellTypeVisible).Copy
Else
'copy only the strText2
End If
.AutoFilterMode = False
End With
End Function
Main Sub function:
Sub Mail_Klicken()
Dim olApp As Object, datDatum As Date, StrBody As String, intZeile As Integer
Dim OutMail As Object, rng As Range, strMailverteilerTo As String
Dim strText As String, strFilename As String, loLetzte As Long
strMailverteilerTo = "sdfgsdf#gmx.de"
strText = "<span style='font-size:10.0pt;font-family:""Arial"",""sans" & _
"-serif"";color:black'>hello,<br><br>hello fellows.<br><br>"
strText2 = "<span style='font-size:10.0pt;font-family:""Arial"",""sans" & _
"-serif"";color:black'>dfgfg,<br><br>gfgfgfgfg.<br><br>"
Application.DisplayAlerts = True
Set rng = Selection.SpecialCells(xlCellTypeVisible)
Set olApp = CreateObject("Outlook.Application")
With olApp.CreateItem(0)
.to = strMailverteilerTo
.Subject = "check"
strFilename = "Standard"
If Application.UserName = "asd" Then strFilename = "asd"
.HTMLBody = strText & RangetoHTML(rng) & "<br><br>" & _
GetBoiler(Environ("appdata") & "\Microsoft\Signatures\" & _
strFilename & ".htm")
.Display
End With
Set olApp = Nothing
End Sub

You cant, AFAIK, put a statement like that since its expecting a string argument, here's one way you can do it is to call a function that builds the string,
Set olApp = CreateObject("Outlook.Application")
setStrText criteria, strText, rng
With olApp.CreateItem(0)
'rest of your code
.HTMLBody = strText
'rest of your code
function setStrText(crit as integer, strTe as string, tmpRng as range)
if crit >= 1 then
strTe = "<span style='font-size:10.0pt;font-family:""Arial"",""sans" & "-serif"";color:black'>hello,<br><br>hello fellows.<br><br>" & RangetoHTML(tmpRng) & "<br><br>" & GetBoiler(Environ("appdata") & "\Microsoft\Signatures\" & strFilename & ".htm")
else
strTe = "<span style='font-size:10.0pt;font-family:""Arial"",""sans" & "-serif"";color:black'>dfgfg,<br><br>gfgfgfgfg.<br><br>" & "<br><br>" & GetBoiler(Environ("appdata") & "\Microsoft\Signatures\" & strFilename & ".htm")
end if
end function

Related

Embedding an HTML file with images in an Outlook email generated by Excel VBA

I want to send a personalized email generated by Excel VBA.
The email contains personalized text followed by a html file that contains images.
I tried the following code but the images are not displayed.
Sub Mail_Outlook_With_Html_Doc()
Dim OutApp As Object
Dim OutMail As Object
Dim strbody As String
Dim oFSO As Object
Dim oFS As Object
Dim sText As String
Set oFSO = CreateObject("Scripting.FileSystemObject")
Set oFS = oFSO.OpenTextFile("C:\....\invite.htm")
Do Until oFS.AtEndOfStream
sText = oFS.ReadAll()
Loop
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
'strbody = personalized email body generated here
On Error Resume Next
With OutMail
.display
.To = ToAdd
.CC =
.BCC = ""
.Subject = "Test Email"
.ReadReceiptRequested = True
' the html file is appended here to the personalized email body generated
.HTMLBody = strbody & sText
.Send
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
The invite.htm referred above contains images which are not visible when the email is sent. Neither in the email messages sent nor in the email messages received.
Here ia an example that works for me you need to adapt it according to your needs.
This will embed the image in the body of the email and will attach it from what I remember. Please note you need to display the email first and then send it that is the only way to show on different device, i learn that the hard way. It can be done via code as the below example if you want to display and review the email just comment out the .Send after you are happy you can press manually send.
Option Explicit
Dim titleName As String
Dim firstName As String
Dim lastName As String
Dim fullName As String
Dim clientEmail As String
Dim ccEmail As String
Dim bccEmail As String
Dim emailMessage As String
Sub GenerateInfo()
Dim WS As Worksheet
Dim lrow As Long
Dim cRow As Long
Set WS = ActiveSheet
With WS
lrow = .Range("E" & .Rows.Count).End(xlUp).Row
Application.ScreenUpdating = False
For cRow = 2 To lrow
If Not .Range("L" & cRow).value = "" Then
titleName = .Range("D" & cRow).value
firstName = .Range("E" & cRow).value
lastName = .Range("F" & cRow).value
fullName = firstName & " " & lastName
clientEmail = .Range("L" & cRow).value
Call SendEmail
.Range("Y" & cRow).value = "Yes"
.Range("Y" & cRow).Font.Color = vbGreen
Else
.Range("Y" & cRow).value = "No"
.Range("Y" & cRow).Font.Color = vbRed
End If
Next cRow
End With
Application.ScreenUpdating = True
MsgBox "Process completed!", vbInformation
End Sub
Sub SendEmail()
Dim outlookApp As Object
Dim outlookMail As Object
Dim sigString As String
Dim Signature As String
Dim insertPhoto As String
Dim photoSize As String
Set outlookApp = CreateObject("Outlook.Application")
Set outlookMail = outlookApp.CreateItem(0)
'Change only Mysig.htm to the name of your signature
sigString = Environ("appdata") & _
"\Microsoft\Signatures\Marius.htm"
If Dir(sigString) <> "" Then
Signature = GetBoiler(sigString)
Else
Signature = ""
End If
insertPhoto = "C:\Users\marius\Desktop\Presale.jpg" 'Picture path
photoSize = "<img src=""cid:Presale.jpg""height=400 width=400>" 'Change image name here
emailMessage = "<BODY style=font-size:11pt;font-family:Calibri>Dear " & titleName & " " & fullName & "," & _
"<p>I hope my email will find you very well." & _
"<p>Our <strong>sales preview</strong> starts on Thursday the 22nd until Sunday the 25th of November." & _
"<p>I look forward to welcoming you into the store to shop on preview.<p>" & _
"<p> It really is the perfect opportunity to get some fabulous pieces for the fast approaching festive season." & _
"<p>Please feel free to contact me and book an appointment." & _
"<p>I look forward to seeing you then." & _
"<p>" & photoSize & _
"<p>Kind Regards," & _
"<br>" & _
"<br><strong>Marius</strong>" & _
"<br>Assistant Store Manager" & _
"<p>"
With outlookMail
.To = clientEmail
.CC = ""
.BCC = ""
.Subject = "PRIVATE SALE"
.BodyFormat = 2
.Attachments.Add insertPhoto, 1, 0
.HTMLBody = emailMessage & Signature 'Including photo insert and signature
'.HTMLBody = emailMessage & Signature 'Only signature
.Importance = 2
.ReadReceiptRequested = True
.Display
.Send
End With
Set outlookApp = Nothing
Set outlookMail = Nothing
End Sub
Function GetBoiler(ByVal sFile As String) As String
Dim fso As Object
Dim ts As Object
Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.GetFile(sFile).OpenAsTextStream(1, -2)
GetBoiler = ts.readall
ts.Close
End Function

Sending attachments using access vba

I am using the below code. It works find without the attachment line of code. But once I add the attachment line if get an error and can not work out how to correct it:
Dim Email
Dim CC
Dim objOutlook As Object
Dim objEmail As Object
Dim db As Database
Dim rec As Recordset
'Export report in same folder as db with date stamp
todayDate = Format(Date, "MMDDYYYY")
fileName = Application.CurrentProject.Path & "\XXDispute_" & todayDate & ".pdf"
DoCmd.OutputTo acReport, "XXDispute", acFormatPDF, fileName, False
strItem = "http://schemas.microsoft.com/cdo/configuration/"
strFrom = "XX Disputes <asd#asd.com>"
Set objOutlook = CreateObject("Outlook.Application")
Set objEmail = CreateObject("CDO.Message")
With objEmail
.To = "asd#asd.com"
.CC = ""
.From = strFrom
.Subject = "XXDispute Report: " & Now()
.Textbody = "Your XX dispute has been reviewed and responded to:" & vbNewLine & vbNewLine
.Attachments Add = fileName
With .Configuration.Fields
.Item(strItem & "sendusing") = 2
.Item(strItem & "smtpserver") = "mailhost"
.Item(strItem & "smtpserverport") = 25
.Update
End With
.Send
End With
This is the particular line causing the problem:
.Attachments Add = fileName

Add image from Excel sheet to Outlook HTML body using Excel VBA

I am trying to add an image from an Excel sheet to an Outlook email.
I tried using a link to an image stored in a network location and on the Internet. However, not all users will have access to these locations.
Is it possible to store the image in another worksheet and then copy it into the email body?
I know the below won't work because you can't export shapes but can I do something like this?
ActiveUser = Environ$("UserName")
TempFilePath = "C:\Users\" & ActiveUser & "\Desktop\"
Sheets("Images").Shapes("PanelComparison").Export TempFilePath & "\PanelComparison.png"
panelimage = "<img src = ""TempFilePath\PanelComparison.png"" width=1000 height=720 border=0>"
The CreateEmail Sub calls the SaveToImage Sub. The SaveToImage sub grabs a range, creates a chart on a new page and then saves the picture(objChart) to a specified directory.
The LMpic string variable calls the image just saved and inputs it into the HTML body.
Public Sub CreateEmail()
Dim OutApp As Object
Dim OutMail As Object
Dim cell As Range
Dim FN, LN, EmBody, EmBody1, EmBody2, EmBody3 As String
Dim wb As Workbook
Dim ws As Worksheet
Application.ScreenUpdating = False
Set OutApp = CreateObject("Outlook.Application")
Set wb = ActiveWorkbook
Set ws = Worksheets("Sheet1")
Call SaveToImage
ws.Activate
LMpic = wb.Path & "\ClarityEmailPic.jpg'"
On Error GoTo cleanup
For Each cell In Columns("D").Cells.SpecialCells(xlCellTypeConstants)
If cell.Value Like "?*#?*.?*" Then
FN = Cells(cell.Row, "B").Value
LN = Cells(cell.Row, "A").Value
EmBody = Range("Email_Body").Value
EmBody1 = Range("Email_Body1").Value
EmBody2 = Range("Email_Body2").Value
'EmBody3 = Range("Email_Body3").Value
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.To = cell.Value
.Subject = "Volt Clarity Reminder "
.Importance = olImportanceHigh
.HTMLBody = "<html><br><br><br>" & _
"<table border width=300 align=center>" & _
"<tr bgcolor=#FFFFFF>" & _
"<td align=right>" & _
"<img src='" & objRange & "'>" & _
"</td>" & _
"</tr>" & _
"<tr border=0.5 height=7 bgcolor=#102561><td colspan=2></td></tr>" & _
"<tr>" & _
"<td colspan=2 bgcolor=#E6E6E6>" & _
"<body style=font-family:Arial style=backgroung-color:#FFFFFF align=center>" & _
"<p> Dear " & FN & " " & LN & "," & "</p>" & _
"<p>" & EmBody & "</p>" & _
"<p>" & EmBody2 & "<i><font color=red>" & EmBody1 & "</i></font>" & "</p>" & _
"</body></td></tr></table></html>"
.Display 'Or use Display
End With
On Error GoTo 0
Set OutMail = Nothing
End If
Next cell
cleanup:
Set OutApp = Nothing
Application.ScreenUpdating = True
End Sub
Public Sub SaveToImage()
'
' SaveToImage Macro
'
Dim DataObj As Shape
Dim objChart As Chart
Dim folderpath As String
Dim picname As String
Dim ws As Worksheet
Application.ScreenUpdating = False
Set ws = Worksheets("Sheet2")
folderpath = Application.ActiveWorkbook.Path & Application.PathSeparator 'locating & assigning current folder path
picname = "ClarityEmailPic.jpg" 'image file name
Application.ScreenUpdating = False
Call ws.Range("Picture").CopyPicture(xlScreen, xlPicture) 'copying the range as an image
Worksheets.Add(after:=Worksheets(1)).Name = "Sheet4" 'creating a new sheet to insert the chart
ActiveSheet.Shapes.AddChart.Select
Set objChart = ActiveChart
ActiveSheet.Shapes.Item(1).Width = ws.Range("Picture").Width 'making chart size match image range size
ActiveSheet.Shapes.Item(1).Height = ws.Range("Picture").Height
objChart.Paste 'pasting the range to the chart
objChart.Export (folderpath & picname) 'creating an image file with the activechart
Application.DisplayAlerts = False
ActiveWindow.SelectedSheets.Delete 'deleting sheet4
Application.DisplayAlerts = True
End Sub
In general email images are stored on a web server, with the SRC pointing to that server (http://...). They're not embedded in the email itself.

Sending Emails from Access DB containing attachment with dynamic name

I do not know how to get this thing to work beyond this point.
My code below sends an email containing an attachment out of MS Access 2010.
The problem is if it requires a fixed file name, my file name changes as I am using the date at the end of each file. example: green_12_04_2012.csv. I also do not know how to make this not fail if the folder is empty or the directory changes. It would be great for it to just skip to the next sub rather than crashing.
My Code:
Dim strGetFilePath As String
Dim strGetFileName As String
strGetFilePath = "C:\datafiles\myfolder\*.csv"
strGetFileName = Dir(strGetFilePath)
Dim appOutLook As Outlook.Application
Dim MailOutLook As Outlook.MailItem
Set appOutLook = CreateObject("Outlook.Application")
Set MailOutLook = appOutLook.CreateItem(olMailItem)
With MailOutLook
.BodyFormat = olFormatRichText
.To = "bob#builder.com"
''.cc = ""
''.bcc = ""
.Subject = "text here"
.HTMLBody = "text here"
.Attachments.Add (strGetFileName & "*.csv")
.Send
End With
End Sub
I think I am getting there.
I found a suitable resolution and in addition to the solution posted, I wanted to add this in-case anyone is searching for the solution. I was up until 3am, this is a very popular question but there was not any resolution in regards to looping an attaching all files in a specific folder.
Here is the code:
Public Sub sendEmail()
Dim appOutLook As Outlook.Application
Dim MailOutLook As Outlook.MailItem
Dim strPath As String
Dim strFilter As String
Dim strFile As String
strPath = "C:\Users\User\Desktop\" 'Edit to your path
strFilter = "*.csv"
strFile = Dir(strPath & strFilter)
If strFile <> "" Then
Set appOutLook = CreateObject("Outlook.Application")
Set MailOutLook = appOutLook.CreateItem(olMailItem)
With MailOutLook
.BodyFormat = olFormatRichText
.To = "bob#builder.com"
''.cc = ""
''.bcc = ""
.Subject = "text here"
.HTMLBody = "text here"
.Attachments.Add (strPath & strFile)
.Send
'.Display 'Used during testing without sending (Comment out .Send if using this line)
End With
Else
MsgBox "No file matching " & strPath & strFilter & " found." & vbCrLf & _
"Processing terminated.
Exit Sub 'This line only required if more code past End If
End If
End Sub
heres code i found on one of the forums and cant remember where, but i modified it slightly
this gives you full path of the file, it searches folder and subfolders using wildcard
Function fSearchFileWild(FileName As String, Extenstion As String)
Dim strFileName As String
Dim strDirectory As String
strFileName = "*" & FileName & "*." & Extenstion
strDirectory = "C:\Documents and Settings\"
fSearchFileWild = ListFiles(strDirectory, strFileName, True)
End Function
Public Function ListFiles(strPath As String, Optional strFileSpec As String, _
Optional bIncludeSubfolders As Boolean, Optional lst As ListBox)
On Error GoTo Err_Handler
Dim colDirList As New Collection
Dim varItem As Variant
Call FillDir(colDirList, strPath, strFileSpec, bIncludeSubfolders)
Dim counter As Integer
counter = 0
Dim file1 As String
Dim file2 As String
Dim file3 As String
For Each varItem In colDirList
If file1 = "" Then
file1 = varItem
counter = 1
ElseIf file2 = "" Then
file2 = varItem
counter = 2
ElseIf file3 = "" Then
file3 = varItem
counter = 3
End If
Next
'if there is more than 1 file, msgbox displays first 3 files
If counter = 1 Then
ListFiles = file1
ElseIf counter > 1 Then
MsgBox "Search has found Multiple files for '" & strFileSpec & "', first 3 files are: " & vbNewLine _
& vbNewLine & "file1: " & file1 & vbNewLine _
& vbNewLine & "file2: " & file2 & vbNewLine _
& vbNewLine & "file3: " & file3
ListFiles = "null"
Else
ListFiles = "null"
End If
Exit_Handler:
Exit Function
Err_Handler:
MsgBox "Error " & Err.Number & ": " & Err.Description
Resume Exit_Handler
End Function
Private Function FillDir(colDirList As Collection, ByVal strFolder As String, strFileSpec As String, _
bIncludeSubfolders As Boolean)
'Build up a list of files, and then add add to this list, any additional folders
Dim strTemp As String
Dim colFolders As New Collection
Dim vFolderName As Variant
'Add the files to the folder.
strFolder = TrailingSlash(strFolder)
strTemp = Dir(strFolder & strFileSpec)
Do While strTemp <> vbNullString
colDirList.Add strFolder & strTemp
strTemp = Dir
Loop
If bIncludeSubfolders Then
'Build collection of additional subfolders.
strTemp = Dir(strFolder, vbDirectory)
Do While strTemp <> vbNullString
If (strTemp <> ".") And (strTemp <> "..") Then
If (GetAttr(strFolder & strTemp) And vbDirectory) <> 0& Then
colFolders.Add strTemp
End If
End If
strTemp = Dir
Loop
'Call function recursively for each subfolder.
For Each vFolderName In colFolders
Call FillDir(colDirList, strFolder & TrailingSlash(vFolderName), strFileSpec, True)
Next vFolderName
End If
End Function
Public Function TrailingSlash(varIn As Variant) As String
If Len(varIn) > 0& Then
If Right(varIn, 1&) = "\" Then
TrailingSlash = varIn
Else
TrailingSlash = varIn & "\"
End If
End If
End Function

exporting code from Microsoft Access

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