You must enter a positive duration - VBA

See more:

VB6

Outlook

VBA

calendar

Hi Experts,

I have a vba application which I have to maintain.
I'm not really a vba expert, but trying!
the application basically receives data from DB and send this data to outlook to create an appointment.
the data is first displayed to the user in windows form then the user has to click a button to create an appointment/reminder in outlook calendar.

when running the app. it gives this error (-2147467259 You must enter a positive duration). not really sure why but what I'm sure about is all the dates are correct. I made sure that the order date is before arrival date also appointment date is always today's date.

I didn't build this app. but I tracked down the code and all the entries for the outlook object look correct. Even the app. works on other machines which i can't access to test. If it does work on other machines is it some outlook configurations?

It would also be great if anyone suggest a sample of code using VBA to create outlook appointment.

Please advise.

What I have tried:

' part of the code been written so far
Dim appOutLook          As Object   'Outlook.Application  ' Object '
    Dim olAppt              As Object   'Outlook.AppointmentItem ' '
    Dim olApptFind          As Object   'Outlook.AppointmentItem ' '
    Dim objNameSpace        As Object   'Outlook.Namespace ' Object
    Dim objOutlookFolder    As Object   'Outlook.Folder ' Object
    Dim sFilter             As String
    Dim objAppointment      As Object
    Dim FoldersArray        As Variant
    Dim FolderPath          As String
    Dim sUserCalendar       As String
    Dim myRecipient         As Object   'Outlook.Recipient
    Dim iCalType            As Integer
    Dim sSharedCalendar     As String
    
    iCalType = 1
    RS.Open "SELECT * FROM Container WHERE isnull(UserName,'') = '" & SQLSafe(UCase(Trim(macForm.ConnInfo.User))) & "'", CN, adOpenDynamic, adLockOptimistic
    If Not RS.EOF Then
        sUserCalendar = Trim(F_CFNS(RS.Fields("CalendarLocation")))
        iCalType = F_CFND(RS.Fields("CalendarType"))
        sSharedCalendar = Trim(F_CFNS(RS.Fields("SharedCalendarLocation")))
    End If
    RS.Close
    If Trim(sUserCalendar) = "" And Trim(sSharedCalendar) = "" Then
        MsgBox "Cannot add Calendar Appointment as the Outlook options have not been setup yet."
        Exit Function
    End If
    
    
    Set appOutLook = CreateObject("Outlook.Application")
    Set objNameSpace = appOutLook.GetNamespace("MAPI")
    
    
    If iCalType = 1 Then
        FolderPath = Trim(sUserCalendar) 'Trim(Me.cboOutlookParent.Text) ' "Outlook/Calendar"
        If Trim(FolderPath) = "" Then Exit Function
        FoldersArray = Split(FolderPath, "/")
        Select Case UBound(FoldersArray, 1)
        Case 0
                Set objOutlookFolder = objNameSpace.Folders(FoldersArray(0))
        Case 1
                Set objOutlookFolder = objNameSpace.Folders(FoldersArray(0)).Folders(FoldersArray(1))
        Case 2
                Set objOutlookFolder = objNameSpace.Folders(FoldersArray(0)).Folders(FoldersArray(1)).Folders(FoldersArray(2))
        Case 3
                Set objOutlookFolder = objNameSpace.Folders(FoldersArray(0)).Folders(FoldersArray(1)).Folders(FoldersArray(2)).Folders(FoldersArray(3))
        Case 4
                Set objOutlookFolder = objNameSpace.Folders(FoldersArray(0)).Folders(FoldersArray(1)).Folders(FoldersArray(2)).Folders(FoldersArray(3)).Folders(FoldersArray(4))
        Case Else
                MsgBox "Error Getting Outlook Folder.  Cannot Continue."
                Exit Function
        End Select
    Else
        Set myRecipient = objNameSpace.CreateRecipient(Trim(sSharedCalendar))
        myRecipient.Resolve
        If myRecipient.Resolved Then
            Set objOutlookFolder = objNameSpace.GetSharedDefaultFolder(myRecipient, 9) 'olFolderCalendar)
        Else
            MsgBox "Erorr Accessing Shared Calendar"
            Exit Function
        End If
    End If
    
    
    
    '- Calendar Subject 

    sSubject = ""
    RS.Open "SELECT * FROM Container WHERE isnull(UserName,'') = '" & SQLSafe(UCase(Trim(macForm.ConnInfo.User))) & "'", CN, adOpenDynamic, adLockOptimistic
    If Not RS.EOF Then
        For j = 1 To 5
            If UCase(Trim(F_CFNS(RS.Fields("cboSubjectTab" & j)))) <> "" Or F_CFNS(RS.Fields("SubjectPrefix" & j)) <> "" Then
                sSubject = sSubject & F_CFNS(RS.Fields("SubjectPrefix" & j)) & f_GetSubjectFromOutlookField(UCase(Trim(sContainerNo)), UCase(Trim(F_CFNS(RS.Fields("cboSubjectTab" & j)))), F_CFND(RS.Fields("SubjectField" & j))) & F_CFNS(RS.Fields("SubjectSuffix" & j)) & F_CFNS(RS.Fields("SubjectSeperator"))
            End If
        Next j
    End If
    RS.Close
    '- PO List -                                                                                   
    Dim sPOs As String
    sPOs = "Order No | Line No | Item No" & vbCrLf
    RS.Open "SELECT * FROM ORDLIN WHERE ltrim(rtrim(isnull(POORDLIN_SQL.User_Def_Fld_4,''))) = '" & SQLSafe(sContainerNo) & "' ORDER BY Ord_NO, Line_No", CN, adOpenDynamic, adLockOptimistic
    Do While Not RS.EOF
        sPOs = sPOs & F_CFNS(RS.Fields("Ord_No")) & " | " & F_CFND(RS.Fields("Line_NO")) & " | " & F_CFNS(RS.Fields("Item_No")) & vbCrLf
        RS.MoveNext
    Loop
    RS.Close    
  
    If Trim(sSubject) = "" Then
        sSubject = "Container ETA Appointment: " & sContainerNo
    End If
    sFilter = "[Mileage] = Container:" & sContainerNo & ""
    
    Set objAppointment = objOutlookFolder.Items.Find(sFilter)
    If Not TypeName(objAppointment) = "Nothing" Then
        
        '- EDIT EXISTING APPOINTMENT -                                                                 
        With objAppointment
            '''------------------------------error starts here--- --------
            .start = DateValue(dDate) + TimeValue("08:00")
            .End = DateValue(dDate) + TimeValue("09:00")
            .alldayevent = False
            .Subject = sSubject 'Cntnr:" & sContainerNo & "-" &
            .body = "CONTAINTER CALENDAR APPOINTMENT" & vbCrLf & "Container: " & sContainerNo & vbCrLf & "Auto UPDATED: " & Now() & " By User: " & UCase(Trim(macForm.ConnInfo.User)) & vbCrLf & vbCrLf & sPOs
            If Trim(sCatValue) <> "" Then
                .Categories = Trim(sCatValue)
            End If
            .Save
        End With