You must enter a positive duration - VBA

Question

1.00/5 (1 vote)

See more:

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:

VB.NET

' 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

Posted 6-Dec-16 2:35am

Samira Radwan

Updated 6-Dec-16 4:41am

Add a Solution

Comments

Richard Deeming 6-Dec-16 13:01pm

Your code is vulnerable to SQL Injection[^]. NEVER use string concatenation to build a SQL query. ALWAYS use a parameterized query.

Everything you wanted to know about SQL injection (but were afraid to ask) | Troy Hunt[^]
How can I explain SQL injection without technical jargon? | Information Security Stack Exchange[^]
Query Parameterization Cheat Sheet | OWASP[^]

And no, calling a SQLSafe function to "escape" special characters doesn't make your code invulnerable to SQLi!

Samira Radwan 6-Dec-16 14:32pm

thank you Richard, I'm aware of SQL injection and agree with you , it's just happened that i have to maintain a code written by someone else and fix the errors too.
thanks again

2 solutions

Add a Solution

This content, along with any associated source code and files, is licensed under The Code Project Open License (CPOL)

CHill60 · Answer 1 · 2016-12-06T04:41:00

The VBA compiler is not case sensitive (unfortunately).

I can find nowhere in your code where dDate is either declared or initialised - if it is null, empty or whatever then you will be not be setting either the Start or End for the appointment and will generate the error you are getting.

You've mentioned a load of dates that you are sure are correct - I presume on the database, but you don't appear to be putting those dates into the object.

You asked for sample code - what you have seems fine, but here is another example Create Appointments Using Spreadsheet Data[^]

EDIT - I have found a link that suggests this error can arise if the user permissions have not been set up correctly. This would be consistent with "works on another machine" scenario. See IT.TheLibrarie.Com » You must enter a positive duration[^]

Andy Lanng · Answer 2 · 2016-12-06T03:08:00

Solution 1

It looks like all of your casing is off. User this segment:

With objAppointment
                        .Start = DateValue(dDate) + TimeValue("08:00")
            .End = DateValue(dDate) + TimeValue("09:00")
            .AllDayEvent = False
            .Subject = sSubject 
            .Body = "CONTAINTER CALENDAR APPOINTMENT" & vbCrLf & "Container: " & sContainerNo & vbCrLf & "Auto UPDATED: " & Now() & " By User: " & UCase(Trim(macForm.ConnInfo.User)) & vbCrLf & vbCrLf & sPOs

Posted 6-Dec-16 3:08am

Andy Lanng

Updated 6-Dec-16 4:11am

v2

Comments

Samira Radwan 6-Dec-16 9:34am

Hi Andy, what did you mean by 'all your casing is off'. the code you have provided here is the same like I already have. please explain. thank you

Andy Lanng 6-Dec-16 10:13am

I mean case as in UPPERCASE, lowercase, TitleCase and camelCase.
All of the properties of objAppointment should be TitleCase:
Start not start,
End is fine
AllDayEvent not alldayevent
Subject is fine
Body not body

Samira Radwan 6-Dec-16 10:38am

I changed to (Titlecase) with no luck. any other suggestion for what could be the reason?
thank you!

Andy Lanng 6-Dec-16 10:41am

Ok, try replacing .End = DateValue(dDate) + TimeValue("09:00") with the following:
.Duration = 60

You must enter a positive duration - VBA

2 solutions

Solution 2

Solution 1

Add your solution here

Preview 0

You must enter a positive duration - VBA

2 solutions

Solution 2

Solution 1

Add your solution here

Preview 0

Existing Members

...or Join us