Bug in my code that opens up Excel files from Access to edit.

[ry94080]

In my opinion the Range("B3").Activate is not qualified and Excel doesn't know what to do. I also believe that you have an unended IF statement within your Do Loop, however I shall await the gurus to comment.

The thing is after a fresh restart, it works just fine. Then when it tries to process the next file, it bombs out.


I must've cut that piece of code with the end if. here it is again:

Sub ProcessPriorityCalls(sAffiliatePriorityFile As String)On Error GoTo ProcessPriorityCalls_Err
    Dim ExcelApp As Object
    Dim Workbook As Object
    Dim Worksheet As Object
    Dim sDir As String
    Dim sfile As String
    sDir = "D:\Reports\AffiliatePriorityCalls\"
    '
    '' Create an instance of Excel
    ''Set excelApp = CreateObject("Excel.Application")
    'Set ExcelApp = New Excel.Application
    'ExcelApp.Visible = True
    '
    '' Open the workbook (replace with your actual file path)
    'Set Workbook = ExcelApp.Workbooks.Open(sAffiliatePriorityFile)
    '
    '' Set the active sheet (you can adjust this as needed)
    'Set sheet = Workbook.ActiveSheet
    Set ExcelApp = CreateObject("Excel.Application")
    ExcelApp.Visible = True
    Set Workbook = ExcelApp.Workbooks.Open(sAffiliatePriorityFile)
    Set Worksheet = Workbook.Worksheets(1)
    WaitFor 100000
    Range("B3").Activate
    'Do Until ActiveCell.Value = "End Of Report"
    Do Until Len(ActiveCell.Value) < 1
        Start:
        If GetPrinter(ActiveCell.Value) <> "" Then
            sfile = ActiveCell.Value & "_" & Range("I" & ActiveCell.Row & "").Value & "_" & Format(Now(), "MMDDYYYY_HHMM") & ".pdf"
            DoCmd.OpenReport "rptAffiliatePriorityCalls", acViewDesign
            With Reports("rptAffiliatePriorityCalls")
                .Controls("txtPTNumber").ControlSource = "='" & Range("C" & ActiveCell.Row & "").Value & "'"
                .Controls("txtPtName").ControlSource = "='" & Range("E" & ActiveCell.Row & "").Value & "'"
                .Controls("txtAccession").ControlSource = "='" & Range("I" & ActiveCell.Row & "").Value & "'"
                .Controls("txtOrderCode").ControlSource = "='" & Range("K" & ActiveCell.Row & "").Value & "'"
                .Controls("txtTestcode").ControlSource = "='" & Range("N" & ActiveCell.Row & "").Value & "'"
                .Controls("txtResult").ControlSource = "='" & Range("P" & ActiveCell.Row & "").Value & "'"
                .Controls("txtResulTranslation").ControlSource = "='" & Range("R" & ActiveCell.Row & "").Value & "'"
                .Controls("txtSource").ControlSource = "='" & Range("T" & ActiveCell.Row & "").Value & "'"
                .Controls("txtPhysName").ControlSource = "='" & Range("F" & ActiveCell.Row & "").Value & "'"
            End With
            DoCmd.OutputTo acOutputReport, "rptAffiliatePriorityCalls", acFormatPDF, sDir & "\" & sfile
            DoCmd.Close acReport, "rptAffiliatePriorityCalls", acSaveNo
            Range("A" & ActiveCell.Row & ":T" & ActiveCell.Row & "").Interior.ColorIndex = 4
            'send to printer
            'Shell "RUNDLL32 PRINTUI.DLL,PrintUIEntry /y /n ""SSSLIFTBP014 on vpsxspl"""
            Shell "RUNDLL32 PRINTUI.DLL,PrintUIEntry /y /n """ & sPrinter & """"
            PrintAnyDocument sDir & "\" & sfile
            Shell "RUNDLL32 PRINTUI.DLL,PrintUIEntry /y /n ""SSSLIFTBP014 on vpsxspl"""
        End If
        ActiveCell.Offset(1, 0).Activate
    Loop
    Debug.Print
    Workbook.Close True
    ExcelApp.Quit
    'Set workbook = Nothing
    'Set sheet = Nothing
    'Set excelApp = Nothing
    'TaskKill "EXCEL.exe"
    CopyFile sAffiliatePriorityFile, Mid(sAffiliatePriorityFile, 1, InStrRev(sAffiliatePriorityFile, "\")) & "\Processed\" & _
    Right(sAffiliatePriorityFile, Len(sAffiliatePriorityFile) - InStrRev(sAffiliatePriorityFile, "\"))
    Kill sAffiliatePriorityFile
    Exit Sub
    ProcessPriorityCalls_Err:
    If Err.Number = 3045 Then
         GoTo Start
    Else
         TaskKill "EXCEL.exe"
         LogError Err.Number, Err.Description, "ProcessPriorityCalls", , False
         Set Workbook = Nothing
         Set sheet = Nothing
         Set ExcelApp = Nothing
    End If
End Sub