T
tmort
I have some code that I've switched from ADO to DAO. Now I'm getting an Else
without if error at:
Else
'written by Crystal
'(e-mail address removed)
'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
I thought I might ghave accidentally deleted an if or something while I was
doing my editing, but, I'm not finding any extra elses or missing ifs
Here's the code:
Function compexport()
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 stpermnumber As String
Dim ststartdateatt As String
Dim stenddateatt 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 stendate As String
Dim pfilename As String
Dim precordsetname As String
Dim pbooDelimitFields As Boolean
Dim pFieldDeli As String
Dim oApp As Object, outApp As Object, objOutlook As Object, outmsg As
Object, olmailitem 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("[Comp_format]", "export format settings")
stsubject = stconame & " " & "Compliance 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, "compliance export qry", acFormatXLS, [stto],
[stcc], , stconame & " " & "Compliance Sampling Data" & " " & ststartDate & "
" & "to" & " " & stenddate, [stmessage], False
pfilename = stconame & " P" & stpermnumber & " " & ststartdateatt & " to " &
stenddateatt & " Compliance Data.xls"
MsgBox CurrentProject.Path & "\" & pfilename
DoCmd.OutputTo acOutputQuery, "compliance export qry", acFormatXLS,
CurrentProject.Path & "\" & pfilename, 0
'DoCmd.OutputTo acOutputQuery, "compliance export qry", acFormatXLS,
CurrentProject.Path & "\" & "test.xls", 0
'DoCmd.TransferSpreadsheet acExport, , "compliance export qry",
CurrentProject.Path & "\" & pFilename, True
'DoCmd.TransferSpreadsheet acImport, 3,"Employees","C:\Lotus\Newemps.wk3",
True, "A1:G12"
mPathAndFile = CurrentProject.Path & "\" & pfilename
'*************************
'Set oapp = CreateObject("Excel.Application")
Set oApp = CreateObject("Excel.Application")
Set oexcel = oApp.Workbooks.Open(Filename:=mPathAndFile)
Set osheet = oexcel.Worksheets("compliance export qry")
oApp.Visible = False
oApp.DisplayAlerts = False
osheet.Activate
With oexcel.Worksheets("compliance export qry").Columns
..Columns("A:S").AutoFit
End With
With oexcel.Worksheets("compliance export qry").PageSetup
..Zoom = False
..FitToPagesTall = 1000
..FitToPagesWide = 1
..Orientation = 2
..PrintGridlines = 0
..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("compliance export
qry").Range("S1"), .Cells(osheet.Rows.Count, "C").end(-4162).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).LineStyle = xlNone
'oapp.Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
'oapp.Selection.Interior.ColorIndex = xlNone
'End With
'With borders
oApp.Selection.Interior.ColorIndex = 2
oApp.Selection.Interior.Pattern = 1
With oApp.Selection.Borders(5)
'.xlDiagonalDown = 5
.LineStyle = -4142
End With
With oApp.Selection.Borders(6)
.LineStyle = -4142
End With
With oApp.Selection.Borders(7)
.LineStyle = 1
.Weight = 2
.ColorIndex = -4105
End With
With oApp.Selection.Borders(8)
.LineStyle = 1
.Weight = 2
.ColorIndex = -4105
End With
With oApp.Selection.Borders(9)
.LineStyle = 1
.Weight = 2
.ColorIndex = -4105
End With
With oApp.Selection.Borders(10)
.LineStyle = 1
.Weight = 2
.ColorIndex = -4105
End With
With oApp.Selection.Borders(11)
.LineStyle = 1
.Weight = 2
.ColorIndex = -4105
End With
With oApp.Selection.Borders(12)
.LineStyle = 1
.Weight = 2
.ColorIndex = -4105
End With
With osheet.Range("A1:S1")
..Font.ColorIndex = 1
..Font.Bold = -1
..Interior.ColorIndex = 15
..Interior.Pattern = 1
End With
Set osheet = Nothing 'disconnect from the Worksheet
oexcel.Close SaveChanges:=True 'Save (and disconnect from) the Workbook
' old quit code
'Set oexcel = Nothing
'oApp.Quit 'Close (and disconnect from) Excel
'Set oApp = Nothing
oApp.Application.Quit 'Close (and disconnect from)
Excel
Set oexcel = Nothing
Set oApp = Nothing
'*******************************************
Set outApp = CreateObject("Outlook.Application")
Set outmsg = outApp.CreateItem(olmailitem)
If stcc = "" Then
With outmsg
.Recipients.Add (stto)
.subject = stsubject
.ReadReceiptRequested = -1
.body = stmessage
.Importance = 2
.Attachments.Add (mPathAndFile)
.Send
End With
Else
With outmsg
.Recipients.Add(stto).Type = 1
.Recipients.Add(stcc).Type = 2
.subject = stsubject
.ReadReceiptRequested = -1
.body = stmessage
.Importance = 2
.Attachments.Add (mPathAndFile)
.Send
End With
End If
Kill mPathAndFile
Else
'written by Crystal
'(e-mail address removed)
'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 & " Compliance Data.txt"
precordsetname = "SELECT Results.[Company Name] AS [Sample Name],
Results.[Outfall Number] AS OFN, Results.[Collection Date] AS [Sample Date],
Samples.CollectionEndDate AS Expr2, Samples.[Sample Type] AS Composite,
Results.Sampler AS [Sampled by], Results.[Date Lab Received] AS [Received
Date], Results.[Analysis Date], '""' AS Expr3, Results.[Method ID] AS Method,
Results.[Method Description] AS Expr4, Results.Analyte AS Parameter,
Results.Result, '""' AS Expr5, Results.Units, Results.[Reporting Limit] AS
Expr1, '""' AS [Detection Limit], Results.[Lab Sample ID] AS [Lab Number],
Results.[Lab Name] AS Expr7" & 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], Results.[Outfall
Number], Results.[Collection Date], Samples.CollectionEndDate,
Samples.[Sample Type], Results.Sampler, Results.[Date Lab Received],
Results.[Analysis Date], '""', Results.[Method ID], Results.[Method
Description], Results.Analyte, Results.Result, '""', Results.Units,
Results.[Reporting Limit], '""', 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])=Yes)) 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 = 2
.Attachments.Add (mPathAndFile)
.Send
End With
Else
With outmsg
.Recipients.Add(stto).Type = 1
.Recipients.Add(stcc).Type = 2
.subject = stsubject
.ReadReceiptRequested = -1
.body = stmessage
.Importance = 2
.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
without if error at:
Else
'written by Crystal
'(e-mail address removed)
'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
I thought I might ghave accidentally deleted an if or something while I was
doing my editing, but, I'm not finding any extra elses or missing ifs
Here's the code:
Function compexport()
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 stpermnumber As String
Dim ststartdateatt As String
Dim stenddateatt 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 stendate As String
Dim pfilename As String
Dim precordsetname As String
Dim pbooDelimitFields As Boolean
Dim pFieldDeli As String
Dim oApp As Object, outApp As Object, objOutlook As Object, outmsg As
Object, olmailitem 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("[Comp_format]", "export format settings")
stsubject = stconame & " " & "Compliance 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, "compliance export qry", acFormatXLS, [stto],
[stcc], , stconame & " " & "Compliance Sampling Data" & " " & ststartDate & "
" & "to" & " " & stenddate, [stmessage], False
pfilename = stconame & " P" & stpermnumber & " " & ststartdateatt & " to " &
stenddateatt & " Compliance Data.xls"
MsgBox CurrentProject.Path & "\" & pfilename
DoCmd.OutputTo acOutputQuery, "compliance export qry", acFormatXLS,
CurrentProject.Path & "\" & pfilename, 0
'DoCmd.OutputTo acOutputQuery, "compliance export qry", acFormatXLS,
CurrentProject.Path & "\" & "test.xls", 0
'DoCmd.TransferSpreadsheet acExport, , "compliance export qry",
CurrentProject.Path & "\" & pFilename, True
'DoCmd.TransferSpreadsheet acImport, 3,"Employees","C:\Lotus\Newemps.wk3",
True, "A1:G12"
mPathAndFile = CurrentProject.Path & "\" & pfilename
'*************************
'Set oapp = CreateObject("Excel.Application")
Set oApp = CreateObject("Excel.Application")
Set oexcel = oApp.Workbooks.Open(Filename:=mPathAndFile)
Set osheet = oexcel.Worksheets("compliance export qry")
oApp.Visible = False
oApp.DisplayAlerts = False
osheet.Activate
With oexcel.Worksheets("compliance export qry").Columns
..Columns("A:S").AutoFit
End With
With oexcel.Worksheets("compliance export qry").PageSetup
..Zoom = False
..FitToPagesTall = 1000
..FitToPagesWide = 1
..Orientation = 2
..PrintGridlines = 0
..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("compliance export
qry").Range("S1"), .Cells(osheet.Rows.Count, "C").end(-4162).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).LineStyle = xlNone
'oapp.Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
'oapp.Selection.Interior.ColorIndex = xlNone
'End With
'With borders
oApp.Selection.Interior.ColorIndex = 2
oApp.Selection.Interior.Pattern = 1
With oApp.Selection.Borders(5)
'.xlDiagonalDown = 5
.LineStyle = -4142
End With
With oApp.Selection.Borders(6)
.LineStyle = -4142
End With
With oApp.Selection.Borders(7)
.LineStyle = 1
.Weight = 2
.ColorIndex = -4105
End With
With oApp.Selection.Borders(8)
.LineStyle = 1
.Weight = 2
.ColorIndex = -4105
End With
With oApp.Selection.Borders(9)
.LineStyle = 1
.Weight = 2
.ColorIndex = -4105
End With
With oApp.Selection.Borders(10)
.LineStyle = 1
.Weight = 2
.ColorIndex = -4105
End With
With oApp.Selection.Borders(11)
.LineStyle = 1
.Weight = 2
.ColorIndex = -4105
End With
With oApp.Selection.Borders(12)
.LineStyle = 1
.Weight = 2
.ColorIndex = -4105
End With
With osheet.Range("A1:S1")
..Font.ColorIndex = 1
..Font.Bold = -1
..Interior.ColorIndex = 15
..Interior.Pattern = 1
End With
Set osheet = Nothing 'disconnect from the Worksheet
oexcel.Close SaveChanges:=True 'Save (and disconnect from) the Workbook
' old quit code
'Set oexcel = Nothing
'oApp.Quit 'Close (and disconnect from) Excel
'Set oApp = Nothing
oApp.Application.Quit 'Close (and disconnect from)
Excel
Set oexcel = Nothing
Set oApp = Nothing
'*******************************************
Set outApp = CreateObject("Outlook.Application")
Set outmsg = outApp.CreateItem(olmailitem)
If stcc = "" Then
With outmsg
.Recipients.Add (stto)
.subject = stsubject
.ReadReceiptRequested = -1
.body = stmessage
.Importance = 2
.Attachments.Add (mPathAndFile)
.Send
End With
Else
With outmsg
.Recipients.Add(stto).Type = 1
.Recipients.Add(stcc).Type = 2
.subject = stsubject
.ReadReceiptRequested = -1
.body = stmessage
.Importance = 2
.Attachments.Add (mPathAndFile)
.Send
End With
End If
Kill mPathAndFile
Else
'written by Crystal
'(e-mail address removed)
'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 & " Compliance Data.txt"
precordsetname = "SELECT Results.[Company Name] AS [Sample Name],
Results.[Outfall Number] AS OFN, Results.[Collection Date] AS [Sample Date],
Samples.CollectionEndDate AS Expr2, Samples.[Sample Type] AS Composite,
Results.Sampler AS [Sampled by], Results.[Date Lab Received] AS [Received
Date], Results.[Analysis Date], '""' AS Expr3, Results.[Method ID] AS Method,
Results.[Method Description] AS Expr4, Results.Analyte AS Parameter,
Results.Result, '""' AS Expr5, Results.Units, Results.[Reporting Limit] AS
Expr1, '""' AS [Detection Limit], Results.[Lab Sample ID] AS [Lab Number],
Results.[Lab Name] AS Expr7" & 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], Results.[Outfall
Number], Results.[Collection Date], Samples.CollectionEndDate,
Samples.[Sample Type], Results.Sampler, Results.[Date Lab Received],
Results.[Analysis Date], '""', Results.[Method ID], Results.[Method
Description], Results.Analyte, Results.Result, '""', Results.Units,
Results.[Reporting Limit], '""', 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])=Yes)) 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 = 2
.Attachments.Add (mPathAndFile)
.Send
End With
Else
With outmsg
.Recipients.Add(stto).Type = 1
.Recipients.Add(stcc).Type = 2
.subject = stsubject
.ReadReceiptRequested = -1
.body = stmessage
.Importance = 2
.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