MS Access code bug

Hi Expert's,

When I run this code I am getting error on this line "testDate = Format(Lastrun, "Short Date")"

Please help to fix the issue


Public Function IsWeekend(dtmDate As Date) As Boolean

 

'****************************************

 

'Purpose:           Determine if the date provided is a weekend

'In:                dteDate is the date to be checked

'Out:               Returns either True if the date is a Saturday or Sunday and False if any other

'                   day of the week

'Example:           IsWeekend(#2/19/03#) returns False

'****************************************

 

Select Case Weekday(dtmDate)

        Case vbSaturday, vbSunday: IsWeekend = True

        Case Else: IsWeekend = False

    End Select

 

End Function

 

Public Function CountWorkDays(dtmStartDate As Date, dtmEndDate As Date) As Integer

 

'****************************************

'Purpose:           Determine the number of business days between two dates

'In:                dteStartDate is the first date, dtmEndDate is the last date

'Out:               Returns the number of business between start and end date

'Example:           CountWorkDays(#12/31/02#, #1/3/03#) returns 3

'                   (1/1/01 is a holiday (New Year's Day))

'****************************************

 

    Dim intWorkDayCount As Integer

    Dim intDaysBetweenDates As Integer

    Dim i As Integer

    Dim dtmTemp As Date

    

    If dtmStartDate > dtmEndDate Then

        dtmTemp = dtmStartDate

        dtmStartDate = dtmEndDate

        dtmEndDate = dtmTemp

    End If

    

    intWorkDayCount = 0

    intDaysBetweenDates = dtmEndDate - dtmStartDate

    For i = 0 To intDaysBetweenDates

        If IsWeekend(DateAdd("d", i, dtmStartDate)) = False Then intWorkDayCount = intWorkDayCount + 1

    Next i

    CountWorkDays = intWorkDayCount

 

End Function

 

 

 

Private Sub Schedule(Reschedule As Boolean)

On Error GoTo Err_Schedule

 

Dim TAM As Integer

Dim Com As String

Dim Standard As Integer

Dim strTest As String

Dim Stage As String

Dim Acc As String

Dim Count As Integer

Dim msg As String

Dim testDate As Date

Dim Eff As Single

Dim check As Integer

Dim BCount As Integer

Dim Side As String

Dim StartDate As Date

Dim Techs As Single

Dim checkDate As Date

Dim shrtCheckDate As Date

Dim ChkSchedled As Integer

Dim fileName As String

Dim XFile As String

Dim tDate As String

Dim FileDir As String

'Me.scheduleDate = Date

'checkDate = DLookup("Lastrun", "ScheduleLastRun")

If IsNull(Me.scheduleDate) Then Me.scheduleDate = Date

checkDate = Me.scheduleDate

'shrtCheckDate = Format(checkDate, "Short Date") ' need to get shortdate to eliminate the time so date is compaired only by date not date and time

'eliminated the code below added this check to the onlostfocus of the LastRun field==================================================================

    'If (shrtCheckDate <> Date And Reschedule = True) Then

    'msg = MsgBox("You hit the ReRun button and the schedule has not been run today." & Chr(10) & Chr(10) & "If you continue all Day One Braces will be deleted and rescheduled." & Chr(10) & Chr(10) & _

    '"The schedule was last run on " & checkDate & "." & Chr(10) & Chr(10) & "Is this okay?", vbExclamation + vbOKCancel, "Schedule Not Run Today")

     '   If msg = 2 Then

     '       Exit Sub

     '   End If

    'End If

'====================================================================================================================================================

 

If (Reschedule) Then ' if rescheduling then reset

    

    DoCmd.SetWarnings False

    DoCmd.OpenQuery "qryRescheduleDate" 'reset schedule date

    DoCmd.OpenQuery "QryReschedule" 'reset brace design

    DoCmd.OpenQuery "qryCleanScheduleForReschedule" 'remove day one items from schedule

    DoCmd.SetWarnings True

    

End If

 

DoCmd.SetWarnings False

DoCmd.OpenQuery "CleanBraceDesign" 'cleans out any empty rows in table before pulling data for schedule

DoCmd.SetWarnings True

 

StartDate = FormatDateTime(checkDate, vbShortDate) ' Date the schedule is for

 

'Check to see if lastrun date was a weekend if so advance date to next business day ============================

 

    If Weekday(StartDate) = 1 Then

        StartDate = DateAdd("d", 1, StartDate)

    ElseIf Weekday(StartDate) = 7 Then

        StartDate = DateAdd("d", 2, StartDate)

    End If

 '================================================================================================================

' USE THIS IF YOU WANT TO USE NUMBER OF TECHS SCHEDULED TO SCHDULE BY

'Techs = Nz(DLookup("Techs", "ShopHours", "ShopDate = #" & StartDate & "#")) 'check schedule to see how many techs on

' =======================================================================================================================

'WE STOPPED USING THE SCHDULED NUMBER OF TECHS IN FAVOR OF JUST PRINTING OUT THE ENTIRE SCHEDULE SO THIS IS BEING USED

' IF YOU WANT TO GO BACK TO SCHEDULING BY NUMBER OF TECH UNCOMMENT THE ABOVE CODE AND COMMENT THIS OUT

Techs = 20

'=======================================================================================================================

    

If Techs = 0 Then

    msg = MsgBox("Check the Schedule table." & Chr(10) & "It shows no Techs are scheduled for " & StartDate & ".", vbCritical + vbOKOnly, "Help No Techs")

Else

    checkDate = DLookup("Lastrun", "ScheduleLastRun")

    testDate = Format(checkDate, "Short Date")

    Eff = DLookup("Efficiency", "Efficiency") ' get the efficiency rating the shop is operating at

    'If testDate = Date Then

    '    msg = MsgBox("This schedule has already been run today." & Chr(10) & "You need to wait until tomorrow to run again." & Chr(10) & "Or use ReRun button to rerun a new schedule.", vbCritical + vbOKOnly, "Critical Error")

    '    Exit Sub

    'Else

        TAM = (Techs * 8) * 60 'Total available Tech minutes

        TAM = TAM * Eff 'techs at X efficency

        

        'Check to see if there are any unscheduled braces

        ChkSchedled = DCount("Scheduled", "BraceDesign", "Scheduled =" & False)

        If ChkSchedled = 0 Then ' if zero then consider it a reschedule and run the following

            DoCmd.SetWarnings False

            DoCmd.OpenQuery "qryRescheduleDate" 'reset schedule date

           ' DoCmd.OpenQuery "QryReschedule" 'reset brace design

           ' DoCmd.OpenQuery "qryCleanScheduleForReschedule" 'remove day one items from schedule

           ' DoCmd.SetWarnings True

            

        End If

              DoCmd.SetWarnings False

            DoCmd.OpenQuery "QryReschedule" 'reset brace design

            DoCmd.OpenQuery "qryCleanScheduleForReschedule" 'remove day one items from schedule

            DoCmd.SetWarnings True

        

        DoCmd.SetWarnings False

        

        If Not Me.CHKsHOWoNhOLD Then

        DoCmd.OpenQuery "qryTodaysBraces" 'build table "BRACESCHEDULE" from date on form

        Else

        DoCmd.OpenQuery "qryTodaysBracesNoHold" 'build table "BRACESCHEDULE" from date on form

        End If

        

        DoCmd.OpenQuery "SortBraceDesgns" 'sort them in priority order

        DoCmd.OpenQuery "CleanQueueFromSchedule" 'clean the braces marked 'Queue' from the schedule leave the ones marked 'Fabrication'

        DoCmd.OpenQuery "ClearBlankShopHours"

        Count = DCount("WONumber", "Schedule")

        'If Not (Reschedule) Then 'dont increment days if rerun it has already been done.

            'If Count > 0 Then ' if schedule is empty this will cause an error. this eliminates the error

               ' DoCmd.OpenQuery "IncrementDayOnSchedule"

           ' End If

        'End If

        DoCmd.SetWarnings True

        

        

        Set bd = CurrentDb.OpenRecordset("BraceDesign")

        Set sch = CurrentDb.OpenRecordset("Schedule")

        Set Rst = CurrentDb.OpenRecordset("BraceScheduleSorted")

        

            Rst.MoveFirst

            Do

            Stage = "Fabrication"

            If Rst.EOF Then

                Exit Do

            End If

            strTest = Rst!Orthosis

            Standard = Nz(DLookup("Standard", "Standards", "Part = '" & Rst!Orthosis & "'"), 0)

            Side = Nz(DLookup("side", "BraceScheduleSorted", "Orthosis = '" & Rst!Orthosis & "'"), "Not Specicified")

            If Side = "BiLateral" Then 'get number of braces to be made

                BCount = 2

            Else

                BCount = 1

            End If

    

            Acc = Nz(DLookup("UQR", "BraceKneeComp", "PriKey = " & Rst!PriKey & ""))

                If Acc = "" Then 'UQR is in standard if not used take it away

                    Standard = Standard - Nz(DLookup("UQR", "Standards", "Part = '" & Rst!Orthosis & "'"))

                End If

    

            Acc = Nz(DLookup("Bottom", "BraceFootSection", "PriKey = " & Rst!PriKey & ""))

                If Acc Like "Transfer Base*" Then

                'nothing it is being used leave standard time at full time

                Else ' if it is not being used then take away the time

                Standard = Standard - Nz(DLookup("TransferBase", "Standards", "Part = '" & Rst!Orthosis & "'"))

                End If

                'Check =

              ' TAM = TAM - (Standard * BCount) 'standard multipled by number of braces to be made

               

                                        'If Check < -70 Then ' CHECK TO MAKE SURE THERE IS ENOUGH TIME IN DAY LEFT

                                        '    TAM = -70

                                        'Else

                                        '    TAM = TAM - (Standard * BCount)

                                        'End If

            

           

            If TAM <= 0 Then

                Stage = "Queue"

            End If

                

                    'sch.MoveLast

                    sch.AddNew

                   

                    sch!ShipBy = Rst!ShipBy

                    sch!Priority = Rst!Priority

                    'sch!Jobs = DLookup("Jobs", "Standards", "Part = '" & Rst!Orthosis & "'")

                    sch!ShipMethod = Rst!ShipMethod

                    sch!InShopDate = Me.scheduleDate

                    sch!PriKey = Rst!PriKey

                    sch!WONumber = Rst!WONumber

                    sch!Patient = Rst!Patient

                    sch!AccountNumber = Rst!AccountNumber & " " & Rst!Practitioner

                    sch!Orthosis = Rst!Orthosis

                    sch!Casts = IIf(Rst!Side = "BiLateral", 2, 1)

                    sch!Day = CountWorkDays(Rst!DesignDate, Me.scheduleDate) - 1

                    

                    Com = Rst!Clam1 & " " & Rst.Clam2 & " " & Rst!Clam3

                    Com = Replace(Com, "NONE", "")

                    sch!Comments = Com

                    sch!DesignDate = Rst!DesignDate

                    sch!Stage = Stage

                    Dim result As String

                    result = Nz(Rst!SpecialNotes, "")

                    result = Replace(result, "Save Mold", "")

                    'result = Replace(result, "TransferBase", "")

                    'result = Replace(result, "SMO", "")

                    

                    ' sch!SpecialNotes = Rst!SpecialNotes & IIf(Rst!PracName = "", " - " & Rst!PracName, "")

                    sch!SpecialNotes = result & IIf(Rst!PracName <> "", " - " & Rst!PracName, "")

                    sch!Bottom = Nz(Rst.Bottom, "None")

                    sch!DateIn = Rst!DateIn

                    sch!StandardsTime = Nz(Rst!StandardsTime, 0)

                    sch.Update

                    

                    

                If Stage = "Fabrication" Then 'only mark as scheduled if sent to fabrication if in queue it is not scheduled

                    bd.MoveFirst

                   ' Do ' find row in brace design

                   ' bd.MoveNext

                    bd.FindFirst "PriKey = " & Rst!PriKey

                   ' Loop Until bd!PriKey = Rst!PriKey

                    bd.Edit

                    bd!Scheduled = True 'mark as being scheduled

                    bd.Update

                End If

         

             Rst.MoveNext

            

            Loop Until (Rst.EOF)

                sch.Close

                bd.Close

                Rst.Close

            Set Lst = CurrentDb.OpenRecordset("ScheduleLastRun")

            Lst.MoveFirst

            Lst.Edit

            Lst!Lastrun = Format(Now(), "Short Date")

            Lst!ScheduleFor = Me.scheduleDate

            Lst.Update

            Lst.Close

        

            

        'End If 'msg

    End If 'Techs

  

        

        

    DoCmd.OpenReport "Custom Fab Schedule", acViewPreview

    'DoCmd.close acForm, "frmSchedule"

    Dim stDocName As String

 

 

stDocName = "SchedToXLS"

fileName = "FabSched"

tDate = Format(Me.scheduleDate, "mm-dd-yy")

FileDir = Environ("USERPROFILE") + "\Desktop\"

XFile = FileDir & fileName & tDate & " .xls"

 

DoCmd.OpenQuery stDocName, acNormal, acEdit

DoCmd.OutputTo acOutputQuery, "SchedToXLS", acFormatXLS, XFile, False

 

ModSchedule (XFile)

DoCmd.Close acQuery, "SchedToXLS", acSaveNo

test = MsgBox("An Excel Spreadsheet file has been made for you." & Chr(13) & "The Schedule " & fileName & tDate & " .xls has been saved to your Desktop.", vbInformation + vbOKOnly)

OpenSpecific_xlFile (XFile)

 

Exit_Schedule:

    Exit Sub

 

Err_Schedule:

    MsgBox Err.Description

    Resume Exit_Schedule

    

End Sub

Sub OpenSpecific_xlFile(fileName)

     '   Late Binding (Needs no reference set)

    Dim oXL As Object

    Dim oExcel As Object

    Dim sFullPath As String

    Dim sPath As String

     

     

     '   Create a new Excel instance

    Set oXL = CreateObject("Excel.Application")

     

     

     '   Only XL 97 supports UserControl Property

    On Error Resume Next

    oXL.UserControl = True

    On Error GoTo 0

     

     

     '   Full path of excel file to open

    On Error GoTo ErrHandle

    'sFullPath = CurrentProject.Path & "\TestFile.xls"

     sFullPath = fileName

     

     '   Open it

    With oXL

        .Visible = True

        .Workbooks.Open (sFullPath)

    End With

     

     

ErrExit:

    Set oXL = Nothing

    Exit Sub

     

ErrHandle:

    oXL.Visible = False

    MsgBox Err.Description

    GoTo ErrExit

End Sub

 

Private Sub btnRunSchedule_Click()

Call Schedule(False)

End Sub

Private Sub btnRerun_Click()

On Error GoTo Err_btnRerun_Click

 

 

    Call Schedule(True)

 

Exit_btnRerun_Click:

    Exit Sub

 

Err_btnRerun_Click:

    MsgBox Err.Description

    Resume Exit_btnRerun_Click

    

End Sub

Private Sub btnClose_Click()

On Error GoTo Err_btnClose_Click

 

 

    DoCmd.Close

 

Exit_btnClose_Click:

    Exit Sub

 

Err_btnClose_Click:

    MsgBox Err.Description

    Resume Exit_btnClose_Click

    

End Sub

 

Private Sub Form_Open(Cancel As Integer)

Dim testDate As Date

testDate = Format(Lastrun, "Short Date")[quote][/quote]

If Date = testDate Then

    Me.btnRunSchedule.Visible = False

    Me.btnRerun.Visible = True

Else

    Me.btnRunSchedule.Visible = True

    Me.btnRerun.Visible = False

End If

Me.CHKsHOWoNhOLD = False

Me.scheduleDate.SetFocus



End Sub

Open in new window

LVL 3
LearnReporting Automation ExpertAsked:
Who is Participating?

[Product update] Infrastructure Analysis Tool is now available with Business Accounts.Learn More

x
I wear a lot of hats...

"The solutions and answers provided on Experts Exchange have been extremely helpful to me over the last few years. I wear a lot of hats - Developer, Database Administrator, Help Desk, etc., so I know a lot of things but not a lot about one thing. Experts Exchange gives me answers from people who do know a lot about one thing, in a easy to use platform." -Todd S.

Gustav BrockCIOCommented:
You have to return a date, not a string:

shrtCheckDate = DateValue(checkDate) 

Open in new window

0
John TsioumprisSoftware & Systems EngineerCommented:
maybe ensure LastRun is a date
If IsDate(lastRun) then
testDate = Format(CDate(Lastrun), "Short Date")"

Open in new window

end if
0
LearnReporting Automation ExpertAuthor Commented:
Hi Expert's

Thanks Gustav & John, i will try your suggestion, today and get back to you,

This is the code reflecting error exactly,


Private Sub Form_Open(Cancel As Integer)

Dim testDate As Date

testDate = Format(Lastrun, "Short Date")

If Date = testDate Then

    Me.btnRunSchedule.Visible = False

    Me.btnRerun.Visible = True

Else

    Me.btnRunSchedule.Visible = True

    Me.btnRerun.Visible = False

End If

Me.CHKsHOWoNhOLD = False

Me.scheduleDate.SetFocus

Open in new window

0
Determine the Perfect Price for Your IT Services

Do you wonder if your IT business is truly profitable or if you should raise your prices? Learn how to calculate your overhead burden with our free interactive tool and use it to determine the right price for your IT services. Download your free eBook now!

Gustav BrockCIOCommented:
It can be reduced to:

Private Sub Form_Open(Cancel As Integer)

    Dim ReRun As Boolean

    ReRun = (DateDiff("d", Date, Lastrun) <> 0)

    Me.btnRunSchedule.Visible = Not ReRun
    Me.btnRerun.Visible = ReRun

    Me.CHKsHOWoNhOLD = False
    Me.scheduleDate.SetFocus

End Sub

Open in new window

0

Experts Exchange Solution brought to you by

Your issues matter to us.

Facing a tech roadblock? Get the help and guidance you need from experienced professionals who care. Ask your question anytime, anywhere, with no hassle.

Start your 7-day free trial
Vadim RappCommented:
Where is LastRun coming from? is it populated? I would insert debug.print LastRun before it to see if it really has date value.
0
Hamed NasrRetired IT ProfessionalCommented:
The statement looks ok. The error may be in a different line.
Debug the code and step through.

What error are you getting?
0
LearnReporting Automation ExpertAuthor Commented:
Hi Hnas,

I am getting following error message while running code "Run time error 3151  ODBC - connection to 'FabDesignSql' Failed "
0
Gustav BrockCIOCommented:
That error is unrelated and has to be solved before attempting anything else.
0
mbizupCommented:
As the error states, it is a connection issue (to the back- end data) - which could be caused by a variety of problems.  A few that immediately come to mind:

1.  You need to refresh the links to the back-end through the Linked Table Manager (you need to do this anytime you modify the SQL back-end)
2.  You are connected to the wrong BE (again, Linked Table Manager)
3.  You need to correct connection string(s), if any, somewhere in your code.
4.  Your SQL Server database is down/experiencing problems
0
LearnReporting Automation ExpertAuthor Commented:
Thanks you all for your response, i am unable to connect with my client network via remote to check the solutions provided on this, i will get back to you as soon as i have connected with client DB.

Regards
LET
0
It's more than this solution.Get answers and train to solve all your tech problems - anytime, anywhere.Try it for free Edge Out The Competitionfor your dream job with proven skills and certifications.Get started today Stand Outas the employee with proven skills.Start learning today for free Move Your Career Forwardwith certification training in the latest technologies.Start your trial today
Microsoft Access

From novice to tech pro — start learning today.