Вы должны ввести положительную длительность-VBA

---

Привет Эксперты,

У меня есть приложение vba, которое я должен поддерживать.
На самом деле я не эксперт по vba, но стараюсь!
приложение в основном получает данные из БД и отправляет эти данные в outlook для создания встречи.
данные сначала отображаются пользователю в форме windows, а затем пользователь должен нажать кнопку, чтобы создать встречу/напоминание в календаре outlook.

при запуске приложения. он дает эту ошибку (-2147467259 вы должны ввести положительную длительность). не совсем уверен, почему, но я уверен, что все даты верны. Я позаботился о том, чтобы дата заказа была до даты прибытия, а также дата встречи всегда была сегодняшней.

Я не создавал это приложение, но я отследил код, и все записи для объекта outlook выглядят правильно. Даже приложение. работает на других машинах, к которым я не могу получить доступ для тестирования. Если он действительно работает на других машинах, то это какие-то конфигурации outlook?

Было бы также здорово, если бы кто-нибудь предложил пример кода, использующего VBA для создания встречи outlook.

Пожалуйста, посоветуйте.

Что я уже пробовал:

' 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

---