'***************************************************************************************************
' This sample project uses the MS Outlook Object Model read and write Microsoft Outlook Folder items.
'
'                NOTE: Outlook does not need to be running when using this program
'
' See also: 
' http://www.microsoft.com/office/previous/outlook/supreasy.asp
' http://msdn.microsoft.com/library/default.asp?url=/library/en-us/dnolbk02/html/odc_C11612730.asp
'
'                Tested on =>  Microsoft Outlook 2000 and Microsoft Windows 2000 
'                       ©2004 Microsoft Corporation. All rights reserved.
'
' Project created by Keith McKibbin "2Guys2PDAs© mindspring.com"
'
'***************************************************************************************************

Sub Outlook_Load

    TxtBoxStartTime.hide ' .show for troubleshooting
    TxtBoxEndTime.hide ' .show for troubleshooting

End Sub
    
Sub CmdBtnAddToOutlook_Click
       
    Dim OutlookApp
    Const olMailItem = 0 'reference numbers from Outlook VB documentation
    Const olAppointmentItem = 1
    Const olContactItem = 2
    Const olTaskItem = 3
    Const olJournalItem = 4
    Const olNoteItem = 5
    Const olPink = 2 'Used in CboxCreateNote below
    Set OutlookApp = CreateObject("Outlook.Application")
    
    If CboxSendMsg.value = 0 And CboxMakeAppt.value = 0 And CboxCreateContact.value = 0 And CboxCreateTask.value = 0 And CboxCreateJournalEntry.value = 0 And CboxCreateNote.value = 0 Then 
        MsgBox "Select Outlook Folder",0,"   NO FOLDERS SELECTED   "
        End If
    
    If CboxSendMsg.value = 1 Then
        With OutlookApp.CreateItem(olMailItem)
            .To = TxtBoxAddress.text
            .Subject = TxtBoxSubject.text
            .Body = TxtBBody.text
            '.Send 'Delete apostrophe to actually send an email
            .Save 'This Save will put message in Outlook Drafts folder
        End With
        MsgBox "Email Sent",0,"   SUCCESS   "
    End If
        
    If CboxMakeAppt.value = 1 Then
    
        Dim TimeSelectedStart
        Dim TimeSelectedEnd
        
        'Parse out seconds and format for Outlook
        If Left(TimeStart.text,1)=<9 Then 
            TimeSelectedStart = " "+Left(TimeStart.text,4)+" "+Right(TimeStart.text,2)
        End If
    
        If Left(TimeStart.text,1)=1 And Left(TimeStart.text,2) <> "1:" Then 
            TimeSelectedStart = " "+Left(TimeStart.text,5)+" "+Right(TimeStart.text,2)
        End If
        
        TxtBoxStartTime.text = TimeSelectedStart 'Display only for troubleshooting, 
                                                 'change TxtBoxStartTime.hide to TxtBoxStartTime.show
        
        'Parse out seconds and format for Outlook
        If Left(TimeEnd.text,1)=<9 Then 
            TimeSelectedEnd = " "+Left(TimeEnd.text,4)+" "+Right(TimeEnd.text,2)
        End If
    
        If Left(TimeEnd.text,1)=1 And Left(TimeEnd.text,2) <> "1:" Then 
            TimeSelectedEnd = " "+Left(TimeEnd.text,5)++" "+Right(TimeEnd.text,2)
        End If 
        
        TxtBoxEndTime.text = TimeSelectedEnd 'Display only for troubleshooting
                                             'change TxtBoxEndTime.hide to TxtBoxEndTime.show       
        
        With OutlookApp.CreateItem(olAppointmentItem)           
            .Start = DateSelected.text & TimeSelectedStart
            .End = DateSelected.text & TimeSelectedEnd
            .Subject = TxtBoxSubject.text
            .Body = TxtBBody.text
            .Save
        End With
        MsgBox "Appointment Creation",0,"   SUCCESS   "
    End If
    
    If CboxCreateContact.value = 1 Then
        With OutlookApp.CreateItem(olContactItem)
            .LastName = "Angelina "
            .FirstName = "Jolie"
            .BusinessTelephoneNumber = "(608) 555-1212"
            .Save
        End With
        MsgBox "Contact Creation",0,"   SUCCESS   "
    End If
      
    If CboxCreateTask.value = 1 Then
        With OutlookApp.CreateItem(olTaskItem)
            .Subject = TxtBoxSubject.text
            .Body = TxtBBody.text
            .DueDate = Now()
            '.ReminderSet = True
            .Save
        End With
        MsgBox "Task Creation",0,"   SUCCESS   "
    End If
    
    If CboxCreateJournalEntry.value = 1 Then
        With OutlookApp.CreateItem(olJournalItem)
            .Subject = TxtBoxSubject.text
            .Type = "This is type"
            .Body = TxtBBody.text
            .Start = Now
            .Save
        End With
        MsgBox "Journal Entry Creation",0,"   SUCCESS   "
    End If
    
    If CboxCreateNote.value = 1 Then
        Dim NoteText
        NoteText = TxtBoxSubject.text + vbCrLf + TxtBBody.text
        With OutlookApp.CreateItem(olNoteItem)
            .Body = NoteText
            .Color = olPink
            .Save
        End With
        MsgBox "Note Creation",0,"   SUCCESS   "
    End If

    ' Clean up
    Set OutlookApp = Nothing
    
End Sub

Sub CmdBtnGetOutlookTasks_Click

    Dim objOutlook
    Dim objNameSpace
    Dim objFolder
    Dim MyItems
    Dim CurrentTask
    Dim strText 
    Const olTaskItem = 3
    Const olFolderTasks = 13
    Set objOutlook = CreateObject("Outlook.application")
    Set objNameSpace = objOutlook.GetNameSpace("MAPI") 'See Outlook VB documentation for NameSpace and MAPI
    Set objFolder = objNameSpace.GetDefaultFolder(olFolderTasks)
    Set MyItems = objFolder.Items

    For Each CurrentTask in MyItems
        If CurrentTask.DueDate <= Now And CurrentTask.Complete = False Then
	        strText = strText & CurrentTask.Subject & vbCrLf
        End If
    Next

    If strText > "" Then
        MsgBox strText, vbExclamation, "   TODAYS TASKS   "
    Else
        MsgBox "There are no tasks for today in Outlook", vbInformation,"   TODAYS TASKS   "
    End If

    ' Clean up
    Set objFolder = Nothing
    Set objNameSpace = Nothing
    Set objOutlook = Nothing

End Sub