Proper Error Handling (1 Viewer)

psyc0tic1

Access Moron
Local time
Today, 17:08
Joined
Jul 10, 2017
Messages
360
Hello again,

I have this database that has been mentioned a few times to keep track of electrical parts auditing and testing.

There has been much help here on the export to excel feature I needed added to send weekly reports to testers to show them. The export works great and does exactly what I was looking for.... however

I just discovered today that if there are no records in my database with a status of "Waiting on Lab Testing", the database appears to lock up and I have to get my desktop to show again to see the error prompt that pops up which I have attached a screenshot of.

Is there any way to put in code to make a popup tell me there are no records to export or something like that? I am afraid to tinker with this code... I don't want to break it.

Here is the module:
Code:
Public Function fnLastRow(sh As Object)
On Error Resume Next
        With sh
                fnLastRow = .Cells.Find(What:="*", _
                                After:=.Range("A1"), _
                                Lookat:=2, _
                                LookIn:=5, _
                                SearchOrder:=1, _
                                SearchDirection:=2, _
                                MatchCase:=False).Row
        End With
End Function

Here is the button code:
Code:
Private Sub Command35_Click()

Const FileNameBase As String = "\Weekly Reports\Waiting on Lab Weekly Report [CurrentDate].xlsx"
    Dim strFileName As String
    strFileName = Replace(FileNameBase, "[CurrentDate]", Format$(Date, "m-dd-yyyy"))

If DCount("*", "qry_advancewaitlab") > 0 Then
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12Xml, "qry_advancewaitlab", strFileName, True, "Advance"
End If
If DCount("*", "qry_arcadiawaitlab") > 0 Then
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12Xml, "qry_arcadiawaitlab", strFileName, True, "Arcadia"
End If
If DCount("*", "qry_ecruwaitlab") > 0 Then
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12Xml, "qry_ecruwaitlab", strFileName, True, "Ecru"
End If
If DCount("*", "qry_leesportwaitlab") > 0 Then
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12Xml, "qry_leesportwaitlab", strFileName, True, "Leesport"
End If
If DCount("*", "qry_wanekwaitlab") > 0 Then
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12Xml, "qry_wanekwaitlab", strFileName, True, "Wanek"
End If
If DCount("*", "qry_wanvogwaitlab") > 0 Then
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12Xml, "qry_wanvogwaitlab", strFileName, True, "Wanvog"
End If

Dim xlWB As Object
    Dim xlObj As Object
    Dim xlSheet As Object
    Dim lngRow As Long
    
    Set xlObj = CreateObject("Excel.Application")
    Set xlWB = xlObj.Workbooks.Open(strFileName, False, False)
    
    For Each xlSheet In xlWB.Worksheets
        
        With xlSheet
            
            .Activate
            lngRow = .Cells(.Rows.Count, 1).End(-4162).Row 'xlUp
            Debug.Print lngRow
            .Range("F1:F" & lngRow).Select
            xlObj.Selection.FormatConditions.Add Type:=2, Formula1:= _
                    "=TODAY()-F1>13"
            xlObj.Selection.FormatConditions(xlObj.Selection.FormatConditions.Count).SetFirstPriority
            With xlObj.Selection.FormatConditions(1).Interior
                .PatternColorIndex = -4105
                .Color = 255
                .TintAndShade = 0
            End With
            xlObj.Selection.FormatConditions(1).StopIfTrue = False
            .Range("A1:H1").Select
            With xlObj.Selection
                .HorizontalAlignment = xlLeft
                .VerticalAlignment = xlBottom
                .WrapText = False
                .Orientation = 0
                .AddIndent = False
                .IndentLevel = 0
                .ReadingOrder = xlContext
                .MergeCells = False
                
                With .Font
                    .Name = "Calibri"
                    .FontStyle = "Bold"
                    .Size = 11
                End With
                .Borders(xlDiagonalDown).LineStyle = xlNone
                .Borders(xlDiagonalUp).LineStyle = xlNone
                With .Borders(xlEdgeLeft)
                    .LineStyle = xlContinuous
                    .ColorIndex = xlAutomatic
                    .TintAndShade = 0
                    .Weight = xlThin
                End With
                With .Borders(xlEdgeTop)
                    .LineStyle = xlContinuous
                    .ColorIndex = xlAutomatic
                    .TintAndShade = 0
                    .Weight = xlThin
                End With
                With .Borders(xlEdgeBottom)
                    .LineStyle = xlContinuous
                    .ColorIndex = xlAutomatic
                    .TintAndShade = 0
                    .Weight = xlThin
                End With
                With .Borders(xlEdgeRight)
                    .LineStyle = xlContinuous
                    .ColorIndex = xlAutomatic
                    .TintAndShade = 0
                    .Weight = xlThin
                End With
                With .Borders(xlInsideVertical)
                    .LineStyle = xlContinuous
                    .ColorIndex = xlAutomatic
                    .TintAndShade = 0
                    .Weight = xlThin
                End With
                .Borders(xlInsideHorizontal).LineStyle = xlNone
                With .Interior
                    .Pattern = xlSolid
                    .PatternColorIndex = xlAutomatic
                    .ThemeColor = xlThemeColorDark1
                    .TintAndShade = -0.14996795556505
                    .PatternTintAndShade = 0
                End With
            End With
            .Columns("A:A").Select
            xlObj.Selection.ColumnWidth = 8.3
            .Columns("B:B").Select
            xlObj.Selection.ColumnWidth = 28.86
            .Columns("C:C").Select
            xlObj.Selection.ColumnWidth = 13.29
            .Columns("D:D").Select
            xlObj.Selection.ColumnWidth = 12.57
            .Columns("E:E").Select
            xlObj.Selection.ColumnWidth = 13.57
            .Columns("F:F").Select
            xlObj.Selection.ColumnWidth = 11
            .Columns("G:G").Select
            xlObj.Selection.ColumnWidth = 15
            .Columns("H:H").Select
            xlObj.Selection.ColumnWidth = 13.29
            .Range("A1").Select
            xlObj.ActiveWindow.FreezePanes = False

                        
        End With

    Next
    xlObj.Sheets(1).Activate
    xlWB.Close True
    Set xlSheet = Nothing
    Set xlWB = Nothing
    xlObj.Quit
    Set xlObj = Nothing

End Sub
 

Attachments

  • Capture.JPG
    Capture.JPG
    40.6 KB · Views: 561

CJ_London

Super Moderator
Staff member
Local time
Today, 22:08
Joined
Feb 19, 2013
Messages
16,553
Ok, so the excel file has not been created, so it is likely this is the line of code causing the error when executed

Set xlWB = xlObj.Workbooks.Open(strFileName, False, False)

you can step through the code to check this is the case.

Assuming it is this line, then you need some error handing, suggest

Code:
On Error Resume Next
Set xlWB = xlObj.Workbooks.Open(strFileName, False, False)
If Err=0 then

    For Each xlSheet In xlWB.Worksheets

        With xlSheet
            ...
            ....
        End With

    Next
    xlObj.Sheets(1).Activate
    xlWB.Close True
    Set xlSheet = Nothing
    Set xlWB = Nothing
    xlObj.Quit
    Set xlObj = Nothing
end if
 

isladogs

MVP / VIP
Local time
Today, 22:08
Joined
Jan 14, 2017
Messages
18,186
Here's another method though not quite as neat as CJ London's solution
Additional code in RED

Code:
Private Sub Command35_Click()

Const FileNameBase As String = "\Weekly Reports\Waiting on Lab Weekly Report [CurrentDate].xlsx"
    Dim strFileName As String
    strFileName = Replace(FileNameBase, "[CurrentDate]", Format$(Date, "m-dd-yyyy"))
    [COLOR="Red"]Dim N As Integer

    N=0 'count at start[/COLOR]

If DCount("*", "qry_advancewaitlab") > 0 Then
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12Xml, "qry_advancewaitlab", strFileName, True, "Advance"
[COLOR="red"]N=N+1[/COLOR]
End If
If DCount("*", "qry_arcadiawaitlab") > 0 Then
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12Xml, "qry_arcadiawaitlab", strFileName, True, "Arcadia"
[COLOR="red"]N=N+1[/COLOR]
End If
If DCount("*", "qry_ecruwaitlab") > 0 Then
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12Xml, "qry_ecruwaitlab", strFileName, True, "Ecru"
[COLOR="red"]N=N+1[/COLOR]
End If
If DCount("*", "qry_leesportwaitlab") > 0 Then
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12Xml, "qry_leesportwaitlab", strFileName, True, "Leesport"
[COLOR="red"]N=N+1[/COLOR]
End If
If DCount("*", "qry_wanekwaitlab") > 0 Then
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12Xml, "qry_wanekwaitlab", strFileName, True, "Wanek"
[COLOR="red"]N=N+1[/COLOR]
End If
If DCount("*", "qry_wanvogwaitlab") > 0 Then
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12Xml, "qry_wanvogwaitlab", strFileName, True, "Wanvog"
[COLOR="red"]N=N+1[/COLOR]
End If

[COLOR="red"]
'If N=0 the spreadsheet hasn't been created so exit sub ...
If N=0 Then Exit Sub[/COLOR]

    Dim xlWB As Object

    'rest of your code here .....

End Sub
 

psyc0tic1

Access Moron
Local time
Today, 17:08
Joined
Jul 10, 2017
Messages
360
Ok, so the excel file has not been created, so it is likely this is the line of code causing the error when executed

Set xlWB = xlObj.Workbooks.Open(strFileName, False, False)

you can step through the code to check this is the case.

Assuming it is this line, then you need some error handing, suggest

Code:
On Error Resume Next
Set xlWB = xlObj.Workbooks.Open(strFileName, False, False)
If Err=0 then

    For Each xlSheet In xlWB.Worksheets

        With xlSheet
            ...
            ....
        End With

    Next
    xlObj.Sheets(1).Activate
    xlWB.Close True
    Set xlSheet = Nothing
    Set xlWB = Nothing
    xlObj.Quit
    Set xlObj = Nothing
end if

CJ_London... Indeed that was the line that was highlighted when it would lock up my database front end. However I tried adding in your code and it didn't change anything... still locked up the same way. Thank you for trying.
 

psyc0tic1

Access Moron
Local time
Today, 17:08
Joined
Jul 10, 2017
Messages
360
Here's another method though not quite as neat as CJ London's solution
Additional code in RED

Code:
Private Sub Command35_Click()

Const FileNameBase As String = "\Weekly Reports\Waiting on Lab Weekly Report [CurrentDate].xlsx"
    Dim strFileName As String
    strFileName = Replace(FileNameBase, "[CurrentDate]", Format$(Date, "m-dd-yyyy"))
    [COLOR="Red"]Dim N As Integer

    N=0 'count at start[/COLOR]

If DCount("*", "qry_advancewaitlab") > 0 Then
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12Xml, "qry_advancewaitlab", strFileName, True, "Advance"
[COLOR="red"]N=N+1[/COLOR]
End If
If DCount("*", "qry_arcadiawaitlab") > 0 Then
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12Xml, "qry_arcadiawaitlab", strFileName, True, "Arcadia"
[COLOR="red"]N=N+1[/COLOR]
End If
If DCount("*", "qry_ecruwaitlab") > 0 Then
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12Xml, "qry_ecruwaitlab", strFileName, True, "Ecru"
[COLOR="red"]N=N+1[/COLOR]
End If
If DCount("*", "qry_leesportwaitlab") > 0 Then
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12Xml, "qry_leesportwaitlab", strFileName, True, "Leesport"
[COLOR="red"]N=N+1[/COLOR]
End If
If DCount("*", "qry_wanekwaitlab") > 0 Then
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12Xml, "qry_wanekwaitlab", strFileName, True, "Wanek"
[COLOR="red"]N=N+1[/COLOR]
End If
If DCount("*", "qry_wanvogwaitlab") > 0 Then
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12Xml, "qry_wanvogwaitlab", strFileName, True, "Wanvog"
[COLOR="red"]N=N+1[/COLOR]
End If

[COLOR="red"]
'If N=0 the spreadsheet hasn't been created so exit sub ...
If N=0 Then Exit Sub[/COLOR]

    Dim xlWB As Object

    'rest of your code here .....

End Sub

ridders... I tried your code and it worked... it didn't lock up the database front end anymore. This is simple enough to not care about getting a popup notification explaining there are no records to export. Thank you very much for helping.
 

Gasman

Enthusiastic Amateur
Local time
Today, 22:08
Joined
Sep 21, 2011
Messages
14,047
Or test if the file exists?
 

MarkK

bit cruncher
Local time
Today, 15:08
Joined
Mar 17, 2004
Messages
8,178
Also, if a second DCount() > 0 = True, the file will be overwritten. You should create a new filename too, for each acExport.

And whenever I see a repeating block like that I want to write a loop...
Code:
Private Sub Command35_Click()
    Const FILE_BASE As String = "\Weekly Reports\WaitingOnLabWeeklyReport_{lab}_{date}.xlsx"
    Const LAB_LIST As String = "Advance Arcadia Ecru Leesport Wanek Wanvog"
    Const SHEET_TYPE = acSpreadsheetTypeExcel12Xml
    
    Dim fName As String
    Dim qName As String
    Dim vName
    Dim N As Integer
    
    fName = Replace(FILE_BASE, "{date}", Format$(Date, "yyyymmdd"))
    
    For Each vName In Split(LAB_LIST)
        qName = "qry_" & vName & "waitlab"
        If DCount("*", qName) Then
            DoCmd.TransferSpreadsheet _
               acExport, SHEET_TYPE, qName, Replace(fName, "{lab}", vName), True, vName
            N = N + 1
        End If
    Next
    
    If N > 0 Then
        Dim xlWB As Object
[COLOR="Green"]        'rest of your code here .....[/COLOR]
    End If
End Sub
I'd do something like that,
Mark
 

psyc0tic1

Access Moron
Local time
Today, 17:08
Joined
Jul 10, 2017
Messages
360
Also, if a second DCount() > 0 = True, the file will be overwritten. You should create a new filename too, for each acExport.

And whenever I see a repeating block like that I want to write a loop...
Code:
Private Sub Command35_Click()
    Const FILE_BASE As String = "\Weekly Reports\WaitingOnLabWeeklyReport_{lab}_{date}.xlsx"
    Const LAB_LIST As String = "Advance Arcadia Ecru Leesport Wanek Wanvog"
    Const SHEET_TYPE = acSpreadsheetTypeExcel12Xml
    
    Dim fName As String
    Dim qName As String
    Dim vName
    Dim N As Integer
    
    fName = Replace(FILE_BASE, "{date}", Format$(Date, "yyyymmdd"))
    
    For Each vName In Split(LAB_LIST)
        qName = "qry_" & vName & "waitlab"
        If DCount("*", qName) Then
            DoCmd.TransferSpreadsheet _
               acExport, SHEET_TYPE, qName, Replace(fName, "{lab}", vName), True, vName
            N = N + 1
        End If
    Next
    
    If N > 0 Then
        Dim xlWB As Object
[COLOR="Green"]        'rest of your code here .....[/COLOR]
    End If
End Sub
I'd do something like that,
Mark

The file created already has a new file name by using the date. I only run the report once a week on Monday. Also the file gets overwritten already if one with that file name exists.

I have not tested your code yet but I am about to.
 

Gasman

Enthusiastic Amateur
Local time
Today, 22:08
Joined
Sep 21, 2011
Messages
14,047
I *thought* it was writing to different ranges?

Also, if a second DCount() > 0 = True, the file will be overwritten. You should create a new filename too, for each acExport.

And whenever I see a repeating block like that I want to write a loop...
Code:
Private Sub Command35_Click()
    Const FILE_BASE As String = "\Weekly Reports\WaitingOnLabWeeklyReport_{lab}_{date}.xlsx"
    Const LAB_LIST As String = "Advance Arcadia Ecru Leesport Wanek Wanvog"
    Const SHEET_TYPE = acSpreadsheetTypeExcel12Xml
    
    Dim fName As String
    Dim qName As String
    Dim vName
    Dim N As Integer
    
    fName = Replace(FILE_BASE, "{date}", Format$(Date, "yyyymmdd"))
    
    For Each vName In Split(LAB_LIST)
        qName = "qry_" & vName & "waitlab"
        If DCount("*", qName) Then
            DoCmd.TransferSpreadsheet _
               acExport, SHEET_TYPE, qName, Replace(fName, "{lab}", vName), True, vName
            N = N + 1
        End If
    Next
    
    If N > 0 Then
        Dim xlWB As Object
[COLOR="Green"]        'rest of your code here .....[/COLOR]
    End If
End Sub
I'd do something like that,
Mark
 

isladogs

MVP / VIP
Local time
Today, 22:08
Joined
Jan 14, 2017
Messages
18,186
Or test if the file exists?

Much simpler ...!
Remove all the code in RED from my previous post
Add the line shown in BLUE

You could still do a loop as well following Mark's suggestion

Code:
Private Sub Command35_Click()

Const FileNameBase As String = "\Weekly Reports\Waiting on Lab Weekly Report [CurrentDate].xlsx"
    Dim strFileName As String
    strFileName = Replace(FileNameBase, "[CurrentDate]", Format$(Date, "m-dd-yyyy"))
 
If DCount("*", "qry_advancewaitlab") > 0 Then
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12Xml, "qry_advancewaitlab", strFileName, True, "Advance"
End If
If DCount("*", "qry_arcadiawaitlab") > 0 Then
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12Xml, "qry_arcadiawaitlab", strFileName, True, "Arcadia"
End If
If DCount("*", "qry_ecruwaitlab") > 0 Then
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12Xml, "qry_ecruwaitlab", strFileName, True, "Ecru"
End If
If DCount("*", "qry_leesportwaitlab") > 0 Then
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12Xml, "qry_leesportwaitlab", strFileName, True, "Leesport"
End If
If DCount("*", "qry_wanekwaitlab") > 0 Then
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12Xml, "qry_wanekwaitlab", strFileName, True, "Wanek"
End If
If DCount("*", "qry_wanvogwaitlab") > 0 Then
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12Xml, "qry_wanvogwaitlab", strFileName, True, "Wanvog"
End If

'If file length  = 0, spreadsheet doesn't exist ... exit routine
[COLOR="Blue"]If Len(Dir(strFileName)=0 Then Exit Sub[/COLOR]

    Dim xlWB As Object

    'rest of your code here .....

End Sub
 

psyc0tic1

Access Moron
Local time
Today, 17:08
Joined
Jul 10, 2017
Messages
360
Much simpler ...!
Remove all the code in RED from my previous post
Add the line shown in BLUE

You could still do a loop as well following Mark's suggestion

Code:
Private Sub Command35_Click()

Const FileNameBase As String = "\Weekly Reports\Waiting on Lab Weekly Report [CurrentDate].xlsx"
    Dim strFileName As String
    strFileName = Replace(FileNameBase, "[CurrentDate]", Format$(Date, "m-dd-yyyy"))
 
If DCount("*", "qry_advancewaitlab") > 0 Then
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12Xml, "qry_advancewaitlab", strFileName, True, "Advance"
End If
If DCount("*", "qry_arcadiawaitlab") > 0 Then
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12Xml, "qry_arcadiawaitlab", strFileName, True, "Arcadia"
End If
If DCount("*", "qry_ecruwaitlab") > 0 Then
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12Xml, "qry_ecruwaitlab", strFileName, True, "Ecru"
End If
If DCount("*", "qry_leesportwaitlab") > 0 Then
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12Xml, "qry_leesportwaitlab", strFileName, True, "Leesport"
End If
If DCount("*", "qry_wanekwaitlab") > 0 Then
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12Xml, "qry_wanekwaitlab", strFileName, True, "Wanek"
End If
If DCount("*", "qry_wanvogwaitlab") > 0 Then
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12Xml, "qry_wanvogwaitlab", strFileName, True, "Wanvog"
End If

'If file length  = 0, spreadsheet doesn't exist ... exit routine
[COLOR="Blue"]If Len(Dir(strFileName)=0 Then Exit Sub[/COLOR]

    Dim xlWB As Object

    'rest of your code here .....

End Sub

That code throws a syntax error
 

psyc0tic1

Access Moron
Local time
Today, 17:08
Joined
Jul 10, 2017
Messages
360
Screenshot not necessary... the error said syntax error and the debugger highlighted the line above he said to insert
Code:
If Len(Dir(strFileName)=0 Then Exit Sub

I removed his previous code as instructed and inserted the new line as instructed but the line of code stayed red which told me it was not correct and it gave the syntax error when clicking the button
 

isladogs

MVP / VIP
Local time
Today, 22:08
Joined
Jan 14, 2017
Messages
18,186
My fault. Missing bracket

Code:
If Len(Dir(strFileName))=0 Then Exit Sub
 

Users who are viewing this thread

Top Bottom