tmort
01-02-2008, 10:03 AM
I'm trying to convert some code from early binding to late binding. I've muddled my way through changing outlook from application to object and it compiles (at least it seems to) but it didn't work right so I'm starting over.
I have two command buttons on a form. One coomand button is for one subset of the data and the other for another. Each button can be configured so that the dataset will be either an Excel spreadsheet or as tabdelimited text attachment.
The code is below, thanks for any help:
Function Processexport()
Dim stto As String
Dim stcc As String
Dim stsubject As String
Dim ststartDate As String
Dim stenddate As String
Dim stfrmt As String
Dim stconame As String
Dim stmessage As String
Dim stnoto As String
Dim stnodate As String
Dim stnoconame As String
Dim ststartdateatt As String
Dim stenddateatt As String
Dim stpermnumber As String
Dim mPathAndFile As String, mFileNumber As Integer
Dim R As Recordset, mFieldNum As Integer
Dim mOutputString As String
Dim booDelimitFields As Boolean
Dim booIncludeFieldnames As Boolean
Dim mFieldDeli As String
Dim pbooIncludeFieldnames As String
Dim oapp As Object
Dim oexcel As Object
'Dim osheet As Worksheet
Dim osheet As Object
'Dim rngToFormat As Range
Dim rngToFormat As Object
stconame = Nz([Forms]![export form]![coname], "none")
ststartDate = Nz([Forms]![export form]![begin], "none")
ststartdateatt = Replace(ststartDate, "/", "-")
stenddate = Nz([Forms]![export form]![end], "none")
stenddateatt = Replace(stenddate, "/", "-")
stpermnumber = Nz([Forms]![export form]![cmbpermnumber], "none")
stfrmt = DLookup("[PC_format]", "export format settings")
stsubject = stconame & " " & "Process Control Sampling Data" & " " & ststartDate & " " & "to" & " " & stenddate
stto = Nz([Forms]![export form]![to], "none")
stcc = Nz([Forms]![export form]![cc], "")
stmessage = Nz([Forms]![export form]![Message], "")
stnoto = "You forgot to enter a Send To email address"
stnodate = "You must enter a beginning and ending date for the data you wish to export"
stnoconame = "You forgot to enter a company name"
pbooIncludeFieldnames = "true"
If stto = "none" Then
MsgBox stnoto
Exit Function
Else
If stconame = "none" Then
MsgBox stnoconame
Exit Function
Else
If ststartDate = "none" Then
MsgBox stnodate
Exit Function
Else
If stendate = "none" Then
MsgBox stnodate
Exit Function
Else
If stfrmt = "acFormatXLS" Then
'DoCmd.SendObject acSendQuery, "process export qry", acFormatXLS, [stto], [stcc], , stconame & " " & "Process Control Sampling Data" & " " & ststartDate & " " & "to" & " " & stenddate, stmessage, False
pFilename = stconame & " P" & stpermnumber & " " & ststartdateatt & " to " & stenddateatt & " Process Control Data.xls"
DoCmd.OutputTo acOutputQuery, "process export qry", acFormatXLS, CurrentProject.Path & "\" & pFilename, 0
mPathAndFile = CurrentProject.Path & "\" & pFilename
Set oapp = CreateObject("Excel.Application")
Set oexcel = oapp.Workbooks.Open(Filename:=mPathAndFile)
Set osheet = oexcel.Worksheets("process export qry")
oapp.Visible = False
oapp.DisplayAlerts = False
osheet.Activate
With oexcel.Worksheets("process export qry").Columns
.Columns("A:S").AutoFit
End With
With oexcel.Worksheets("process export qry").PageSetup
.Zoom = False
.FitToPagesTall = 1000
.FitToPagesWide = 1
.Orientation = xlLandscape
.PrintGridlines = False
.PrintTitleRows = "A1:S1"
'.LeftHeader =
.CenterHeader = "&14" & pFilename & "&10"
'.RightHeader =
.LeftFooter = "Report Created &D &T"
'.CenterFooter =
.RightFooter = "Page &P of &N"
.LeftMargin = oapp.InchesToPoints(0.25)
.RightMargin = oapp.InchesToPoints(0.25)
.TopMargin = oapp.InchesToPoints(0.75)
.BottomMargin = oapp.InchesToPoints(0.5)
.HeaderMargin = oapp.InchesToPoints(0.5)
.FooterMargin = oapp.InchesToPoints(0.25)
End With
With osheet.Range("A1:S1")
Set rngToFormat = osheet.Range(oexcel.Worksheets("process export qry").Range("S1"), .Cells(osheet.Rows.Count, "C").end(xlUp).Offset(0, -2)) '
End With
With rngToFormat.Cells.Select
'No Borders
'oapp.Selection.Interior.ColorIndex = 2
'oapp.Selection.Interior.Pattern = xlSolid
'oapp.Selection.Borders(xlDiagonalDown).LineStyle = xlNone
'oapp.Selection.Borders(xlDiagonalUp).LineStyle = xlNone
'oapp.Selection.Borders(xlEdgeLeft).LineStyle = xlNone
'oapp.Selection.Borders(xlEdgeTop).LineStyle = xlNone
'oapp.Selection.Borders(xlEdgeBottom).LineStyle = xlNone
'oapp.Selection.Borders(xlEdgeRight).LineStyle = xlNone
'oapp.Selection.Borders(xlInsideVertical).LineStyl e = xlNone
'oapp.Selection.Borders(xlInsideHorizontal).LineSt yle = xlNone
'oapp.Selection.Interior.ColorIndex = xlNone
'End With
'With borders
oapp.Selection.Interior.ColorIndex = 2
oapp.Selection.Interior.Pattern = xlSolid
oapp.Selection.Borders(xlDiagonalDown).LineStyle = xlNone
oapp.Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With oapp.Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With oapp.Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With oapp.Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With oapp.Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With oapp.Selection.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With oapp.Selection.Borders(xlInsideHorizontal)
.LineStyle = xlNone
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
End With
With osheet.Range("A1:S1")
.Font.ColorIndex = 1
.Font.Bold = True
.Interior.ColorIndex = 15
.Interior.Pattern = xlSolid
End With
Set osheet = Nothing 'disconnect from the Worksheet
oexcel.Close SaveChanges:=True 'Save (and disconnect from) the Workbook
Set oexcel = Nothing
oapp.Quit 'Close (and disconnect from) Excel
Set oapp = Nothing
Set outApp = CreateObject("Outlook.Application")
Set outmsg = outApp.CreateItem(olMailItem)
If stcc = "" Then
With outmsg
.Recipients.Add (stto)
.subject = stsubject
.ReadReceiptRequested = True
.body = stmessage
.Importance = olImportanceHigh
.Attachments.Add (mPathAndFile)
.Send
End With
Else
With outmsg
.Recipients.Add(stto).Type = 1
.Recipients.Add(stcc).Type = 2
.subject = stsubject
.ReadReceiptRequested = True
.body = stmessage
.Importance = olImportanceHigh
.Attachments.Add (mPathAndFile)
.Send
End With
End If
Else
'written by Crystal
'strive4peace2004@yahoo.ca
'NEEDS reference to Microsoft DAO Library
'BASIC USEAGE
' ExportDelimitedText "QueryName", "c:\path\filename.csv"
' testexport("process export qry",mPathAndFile)
'set up error handler
On Error GoTo ExportDelimitedText_error
pFilename = stconame & " P" & stpermnumber & " " & ststartdateatt & " to " & stenddateatt & " Process Control Data.txt"
precordsetname = "SELECT Results.[Company Name], Samples.[Permit Number], Results.[Outfall Number], Results.[Collection Date], Samples.CollectionEndDate, Results.Sampler, Results.[Sample Type], Results.[Date Lab Received], Results.[Analysis Date], Results.[Method ID], Results.[Method Description], Results.Analyte, Results.Result, Results.Units, Results.[Lab Sample ID], Results.[Lab Name], Results.[Compliance Sample]" & Chr(13) _
& "FROM (Samples RIGHT JOIN Results ON (Samples.[Compliance Sample] = Results.[Compliance Sample]) AND (Samples.Sampler = Results.Sampler) AND (Samples.[Collection Date] = Results.[Collection Date]) AND (Samples.[Outfall Number] = Results.[Outfall Number])) LEFT JOIN [Results and Limits] ON Results.ID = [Results and Limits].ID" & Chr(13) _
& "GROUP BY Results.[Company Name], Samples.[Permit Number], Results.[Outfall Number], Results.[Collection Date], Samples.CollectionEndDate, Results.Sampler, Results.[Sample Type], Results.[Date Lab Received], Results.[Analysis Date], Results.[Method ID], Results.[Method Description], Results.Analyte, Results.Result, Results.Units, Results.[Lab Sample ID], Results.[Lab Name], Results.[Compliance Sample]" & Chr(13) _
& "HAVING (((Results.[Collection Date]) Between #" & [Forms]![export form]![begin] & "# And #" & [Forms]![export form]![end] & "#) AND ((Results.Sampler)=""IU"") AND ((Results.[Compliance Sample])=No)) ORDER BY Results.[Collection Date];"
booDelimitFields = Nz(pbooDelimitFields, False)
booIncludeFieldnames = Nz(pbooIncludeFieldnames, False)
'make the delimiter a TAB character unless specified
If Nz(pFieldDeli, "") = "" Then
mFieldDeli = Chr(9)
Else
mFieldDeli = pFieldDeli
End If
'if there is no path specfied, put file in current directory
If InStr(pFilename, "\") = 0 Then
mPathAndFile = CurrentProject.Path
Else
mPathAndFile = ""
End If
mPathAndFile = mPathAndFile & "\" & pFilename
'if there is no extension specified, add TXT
If InStr(pFilename, ".") = 0 Then
mPathAndFile = mPathAndFile & ".txt"
End If
'get a handle
mFileNumber = FreeFile
'close file handle if it is open
'ignore any error from trying to close it if it is not
On Error Resume Next
Close #mFileNumber
On Error GoTo ExportDelimitedText_error
'delete the output file if already exists
If Dir(mPathAndFile) <> "" Then
Kill mPathAndFile
DoEvents
End If
'open file for output
Open mPathAndFile For Output As #mFileNumber
'open the recordset
Set R = CurrentDb.OpenRecordset(precordsetname)
'write fieldnames if specified
If booIncludeFieldnames Then
mOutputString = ""
For mFieldNum = 0 To R.Fields.Count - 1
If booDelimitFields Then
mOutputString = mOutputString & """" _
& R.Fields(mFieldNum) & """" & mFieldDeli
Else
mOutputString = mOutputString _
& R.Fields(mFieldNum).name & mFieldDeli
End If
Next mFieldNum
'remove last delimiter
mOutputString = Left(mOutputString, Len(mOutputString) - Len(mFieldDeli))
'write a line to the file
Print #mFileNumber, mOutputString
End If
'loop through all records
Do While Not R.EOF()
'tell OS (Operating System) to pay attention to things
DoEvents
mOutputString = ""
For mFieldNum = 0 To R.Fields.Count - 1
If booDelimitFields Then
Select Case R.Fields(mFieldNum).Type
'string
Case 10, 12
mOutputString = mOutputString & """" _
& R.Fields(mFieldNum) & """" & mFieldDeli
'date
Case 8
mOutputString = mOutputString & "#" _
& R.Fields(mFieldNum) & "#" & mFieldDeli
'number
Case Else
mOutputString = mOutputString _
& R.Fields(mFieldNum) & mFieldDeli
End Select
Else
mOutputString = mOutputString & R.Fields(mFieldNum) & mFieldDeli
End If
Next mFieldNum
'remove last TAB
mOutputString = Left(mOutputString, Len(mOutputString) - Len(mFieldDeli))
'write a line to the file
Print #mFileNumber, mOutputString
'move to next record
R.MoveNext
Loop
'close the file
Close #mFileNumber
'close the recordset
R.Close
'release object variables
Set R = Nothing
'Dim outmsg As Object
'Dim Item As Outlook.MailItem
'Dim objMe As Object
Set outApp = CreateObject("Outlook.Application")
Set outmsg = outApp.CreateItem(olMailItem)
If stcc = "" Then
With outmsg
.Recipients.Add (stto)
.subject = stsubject
.ReadReceiptRequested = True
.body = stmessage
.Importance = olImportanceHigh
.Attachments.Add (mPathAndFile)
.Send
End With
Else
With outmsg
.Recipients.Add(stto).Type = 1
.Recipients.Add(stcc).Type = 2
.subject = stsubject
.ReadReceiptRequested = True
.body = stmessage
.Importance = olImportanceHigh
.Attachments.Add (mPathAndFile)
.Send
End With
End If
Kill mPathAndFile
Exit Function
'ERROR HANDLER
ExportDelimitedText_error:
'MsgBox Err.Description, , "ERROR " & Err.Number & " ExportDelimitedText"
MsgBox Err.Description, , "ERROR " & Err.Number & " testxport"
'press F8 to step through code and correct problem
Stop
Resume
End If
End If
End If
End If
End If
End Function
I have two command buttons on a form. One coomand button is for one subset of the data and the other for another. Each button can be configured so that the dataset will be either an Excel spreadsheet or as tabdelimited text attachment.
The code is below, thanks for any help:
Function Processexport()
Dim stto As String
Dim stcc As String
Dim stsubject As String
Dim ststartDate As String
Dim stenddate As String
Dim stfrmt As String
Dim stconame As String
Dim stmessage As String
Dim stnoto As String
Dim stnodate As String
Dim stnoconame As String
Dim ststartdateatt As String
Dim stenddateatt As String
Dim stpermnumber As String
Dim mPathAndFile As String, mFileNumber As Integer
Dim R As Recordset, mFieldNum As Integer
Dim mOutputString As String
Dim booDelimitFields As Boolean
Dim booIncludeFieldnames As Boolean
Dim mFieldDeli As String
Dim pbooIncludeFieldnames As String
Dim oapp As Object
Dim oexcel As Object
'Dim osheet As Worksheet
Dim osheet As Object
'Dim rngToFormat As Range
Dim rngToFormat As Object
stconame = Nz([Forms]![export form]![coname], "none")
ststartDate = Nz([Forms]![export form]![begin], "none")
ststartdateatt = Replace(ststartDate, "/", "-")
stenddate = Nz([Forms]![export form]![end], "none")
stenddateatt = Replace(stenddate, "/", "-")
stpermnumber = Nz([Forms]![export form]![cmbpermnumber], "none")
stfrmt = DLookup("[PC_format]", "export format settings")
stsubject = stconame & " " & "Process Control Sampling Data" & " " & ststartDate & " " & "to" & " " & stenddate
stto = Nz([Forms]![export form]![to], "none")
stcc = Nz([Forms]![export form]![cc], "")
stmessage = Nz([Forms]![export form]![Message], "")
stnoto = "You forgot to enter a Send To email address"
stnodate = "You must enter a beginning and ending date for the data you wish to export"
stnoconame = "You forgot to enter a company name"
pbooIncludeFieldnames = "true"
If stto = "none" Then
MsgBox stnoto
Exit Function
Else
If stconame = "none" Then
MsgBox stnoconame
Exit Function
Else
If ststartDate = "none" Then
MsgBox stnodate
Exit Function
Else
If stendate = "none" Then
MsgBox stnodate
Exit Function
Else
If stfrmt = "acFormatXLS" Then
'DoCmd.SendObject acSendQuery, "process export qry", acFormatXLS, [stto], [stcc], , stconame & " " & "Process Control Sampling Data" & " " & ststartDate & " " & "to" & " " & stenddate, stmessage, False
pFilename = stconame & " P" & stpermnumber & " " & ststartdateatt & " to " & stenddateatt & " Process Control Data.xls"
DoCmd.OutputTo acOutputQuery, "process export qry", acFormatXLS, CurrentProject.Path & "\" & pFilename, 0
mPathAndFile = CurrentProject.Path & "\" & pFilename
Set oapp = CreateObject("Excel.Application")
Set oexcel = oapp.Workbooks.Open(Filename:=mPathAndFile)
Set osheet = oexcel.Worksheets("process export qry")
oapp.Visible = False
oapp.DisplayAlerts = False
osheet.Activate
With oexcel.Worksheets("process export qry").Columns
.Columns("A:S").AutoFit
End With
With oexcel.Worksheets("process export qry").PageSetup
.Zoom = False
.FitToPagesTall = 1000
.FitToPagesWide = 1
.Orientation = xlLandscape
.PrintGridlines = False
.PrintTitleRows = "A1:S1"
'.LeftHeader =
.CenterHeader = "&14" & pFilename & "&10"
'.RightHeader =
.LeftFooter = "Report Created &D &T"
'.CenterFooter =
.RightFooter = "Page &P of &N"
.LeftMargin = oapp.InchesToPoints(0.25)
.RightMargin = oapp.InchesToPoints(0.25)
.TopMargin = oapp.InchesToPoints(0.75)
.BottomMargin = oapp.InchesToPoints(0.5)
.HeaderMargin = oapp.InchesToPoints(0.5)
.FooterMargin = oapp.InchesToPoints(0.25)
End With
With osheet.Range("A1:S1")
Set rngToFormat = osheet.Range(oexcel.Worksheets("process export qry").Range("S1"), .Cells(osheet.Rows.Count, "C").end(xlUp).Offset(0, -2)) '
End With
With rngToFormat.Cells.Select
'No Borders
'oapp.Selection.Interior.ColorIndex = 2
'oapp.Selection.Interior.Pattern = xlSolid
'oapp.Selection.Borders(xlDiagonalDown).LineStyle = xlNone
'oapp.Selection.Borders(xlDiagonalUp).LineStyle = xlNone
'oapp.Selection.Borders(xlEdgeLeft).LineStyle = xlNone
'oapp.Selection.Borders(xlEdgeTop).LineStyle = xlNone
'oapp.Selection.Borders(xlEdgeBottom).LineStyle = xlNone
'oapp.Selection.Borders(xlEdgeRight).LineStyle = xlNone
'oapp.Selection.Borders(xlInsideVertical).LineStyl e = xlNone
'oapp.Selection.Borders(xlInsideHorizontal).LineSt yle = xlNone
'oapp.Selection.Interior.ColorIndex = xlNone
'End With
'With borders
oapp.Selection.Interior.ColorIndex = 2
oapp.Selection.Interior.Pattern = xlSolid
oapp.Selection.Borders(xlDiagonalDown).LineStyle = xlNone
oapp.Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With oapp.Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With oapp.Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With oapp.Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With oapp.Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With oapp.Selection.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With oapp.Selection.Borders(xlInsideHorizontal)
.LineStyle = xlNone
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
End With
With osheet.Range("A1:S1")
.Font.ColorIndex = 1
.Font.Bold = True
.Interior.ColorIndex = 15
.Interior.Pattern = xlSolid
End With
Set osheet = Nothing 'disconnect from the Worksheet
oexcel.Close SaveChanges:=True 'Save (and disconnect from) the Workbook
Set oexcel = Nothing
oapp.Quit 'Close (and disconnect from) Excel
Set oapp = Nothing
Set outApp = CreateObject("Outlook.Application")
Set outmsg = outApp.CreateItem(olMailItem)
If stcc = "" Then
With outmsg
.Recipients.Add (stto)
.subject = stsubject
.ReadReceiptRequested = True
.body = stmessage
.Importance = olImportanceHigh
.Attachments.Add (mPathAndFile)
.Send
End With
Else
With outmsg
.Recipients.Add(stto).Type = 1
.Recipients.Add(stcc).Type = 2
.subject = stsubject
.ReadReceiptRequested = True
.body = stmessage
.Importance = olImportanceHigh
.Attachments.Add (mPathAndFile)
.Send
End With
End If
Else
'written by Crystal
'strive4peace2004@yahoo.ca
'NEEDS reference to Microsoft DAO Library
'BASIC USEAGE
' ExportDelimitedText "QueryName", "c:\path\filename.csv"
' testexport("process export qry",mPathAndFile)
'set up error handler
On Error GoTo ExportDelimitedText_error
pFilename = stconame & " P" & stpermnumber & " " & ststartdateatt & " to " & stenddateatt & " Process Control Data.txt"
precordsetname = "SELECT Results.[Company Name], Samples.[Permit Number], Results.[Outfall Number], Results.[Collection Date], Samples.CollectionEndDate, Results.Sampler, Results.[Sample Type], Results.[Date Lab Received], Results.[Analysis Date], Results.[Method ID], Results.[Method Description], Results.Analyte, Results.Result, Results.Units, Results.[Lab Sample ID], Results.[Lab Name], Results.[Compliance Sample]" & Chr(13) _
& "FROM (Samples RIGHT JOIN Results ON (Samples.[Compliance Sample] = Results.[Compliance Sample]) AND (Samples.Sampler = Results.Sampler) AND (Samples.[Collection Date] = Results.[Collection Date]) AND (Samples.[Outfall Number] = Results.[Outfall Number])) LEFT JOIN [Results and Limits] ON Results.ID = [Results and Limits].ID" & Chr(13) _
& "GROUP BY Results.[Company Name], Samples.[Permit Number], Results.[Outfall Number], Results.[Collection Date], Samples.CollectionEndDate, Results.Sampler, Results.[Sample Type], Results.[Date Lab Received], Results.[Analysis Date], Results.[Method ID], Results.[Method Description], Results.Analyte, Results.Result, Results.Units, Results.[Lab Sample ID], Results.[Lab Name], Results.[Compliance Sample]" & Chr(13) _
& "HAVING (((Results.[Collection Date]) Between #" & [Forms]![export form]![begin] & "# And #" & [Forms]![export form]![end] & "#) AND ((Results.Sampler)=""IU"") AND ((Results.[Compliance Sample])=No)) ORDER BY Results.[Collection Date];"
booDelimitFields = Nz(pbooDelimitFields, False)
booIncludeFieldnames = Nz(pbooIncludeFieldnames, False)
'make the delimiter a TAB character unless specified
If Nz(pFieldDeli, "") = "" Then
mFieldDeli = Chr(9)
Else
mFieldDeli = pFieldDeli
End If
'if there is no path specfied, put file in current directory
If InStr(pFilename, "\") = 0 Then
mPathAndFile = CurrentProject.Path
Else
mPathAndFile = ""
End If
mPathAndFile = mPathAndFile & "\" & pFilename
'if there is no extension specified, add TXT
If InStr(pFilename, ".") = 0 Then
mPathAndFile = mPathAndFile & ".txt"
End If
'get a handle
mFileNumber = FreeFile
'close file handle if it is open
'ignore any error from trying to close it if it is not
On Error Resume Next
Close #mFileNumber
On Error GoTo ExportDelimitedText_error
'delete the output file if already exists
If Dir(mPathAndFile) <> "" Then
Kill mPathAndFile
DoEvents
End If
'open file for output
Open mPathAndFile For Output As #mFileNumber
'open the recordset
Set R = CurrentDb.OpenRecordset(precordsetname)
'write fieldnames if specified
If booIncludeFieldnames Then
mOutputString = ""
For mFieldNum = 0 To R.Fields.Count - 1
If booDelimitFields Then
mOutputString = mOutputString & """" _
& R.Fields(mFieldNum) & """" & mFieldDeli
Else
mOutputString = mOutputString _
& R.Fields(mFieldNum).name & mFieldDeli
End If
Next mFieldNum
'remove last delimiter
mOutputString = Left(mOutputString, Len(mOutputString) - Len(mFieldDeli))
'write a line to the file
Print #mFileNumber, mOutputString
End If
'loop through all records
Do While Not R.EOF()
'tell OS (Operating System) to pay attention to things
DoEvents
mOutputString = ""
For mFieldNum = 0 To R.Fields.Count - 1
If booDelimitFields Then
Select Case R.Fields(mFieldNum).Type
'string
Case 10, 12
mOutputString = mOutputString & """" _
& R.Fields(mFieldNum) & """" & mFieldDeli
'date
Case 8
mOutputString = mOutputString & "#" _
& R.Fields(mFieldNum) & "#" & mFieldDeli
'number
Case Else
mOutputString = mOutputString _
& R.Fields(mFieldNum) & mFieldDeli
End Select
Else
mOutputString = mOutputString & R.Fields(mFieldNum) & mFieldDeli
End If
Next mFieldNum
'remove last TAB
mOutputString = Left(mOutputString, Len(mOutputString) - Len(mFieldDeli))
'write a line to the file
Print #mFileNumber, mOutputString
'move to next record
R.MoveNext
Loop
'close the file
Close #mFileNumber
'close the recordset
R.Close
'release object variables
Set R = Nothing
'Dim outmsg As Object
'Dim Item As Outlook.MailItem
'Dim objMe As Object
Set outApp = CreateObject("Outlook.Application")
Set outmsg = outApp.CreateItem(olMailItem)
If stcc = "" Then
With outmsg
.Recipients.Add (stto)
.subject = stsubject
.ReadReceiptRequested = True
.body = stmessage
.Importance = olImportanceHigh
.Attachments.Add (mPathAndFile)
.Send
End With
Else
With outmsg
.Recipients.Add(stto).Type = 1
.Recipients.Add(stcc).Type = 2
.subject = stsubject
.ReadReceiptRequested = True
.body = stmessage
.Importance = olImportanceHigh
.Attachments.Add (mPathAndFile)
.Send
End With
End If
Kill mPathAndFile
Exit Function
'ERROR HANDLER
ExportDelimitedText_error:
'MsgBox Err.Description, , "ERROR " & Err.Number & " ExportDelimitedText"
MsgBox Err.Description, , "ERROR " & Err.Number & " testxport"
'press F8 to step through code and correct problem
Stop
Resume
End If
End If
End If
End If
End If
End Function