从 Access 2010 将 Outlook 日历项目添加到公用文件夹答案

【问题标题】：Adding Outlook Calendar item to a Public Folder from Access 2010从 Access 2010 将 Outlook 日历项目添加到公用文件夹
【发布时间】：2014-05-03 13:13:03
【问题描述】：

我正在尝试将 Access 2010 中的日历约会添加到 Outlook 公共日历。我找到了几种方法来做到这一点，但似乎无法让它与我的代码一起使用。可能是问题的一件事是我不明白代码在设置要保存到的文件夹时在做什么。这是我保存到 Outlook 日历的代码。如何将其保存到名为 janettest 的公共 Outlook 日历中？

Private Sub Command60_Click()

     ' Exit the procedure if appointment has been added to Outlook.
     If Me.chkAddedToOutlook = True Then
         MsgBox "This appointment has already added to Microsoft Outlook.", vbCritical
         Exit Sub
     Else
  
         ' Use late binding to avoid the "Reference" issue
         Dim olApp As Object        'Outlook.Application
         Dim olAppt As Object        'olAppointmentItem
         Dim dteTempEnd As Date
         Dim dteStartDate As Date
         Dim dteEndDate As Date

         If isAppThere("Outlook.Application") = False Then
             ' Outlook is not open, create a new instance
             Set olApp = CreateObject("Outlook.Application")
             Else
             ' Outlook is already open--use this method
             Set olApp = GetObject(, "Outlook.Application")

         End If
        
        Set olAppt = olApp.CreateItem(1) ' 1 = olAppointmentItem
                
        With olAppt
        
             If Nz(Me.AllDay_YesNo) = True Then
             
                 .Alldayevent = True

                 ' Get the Start and the End Dates
                 dteStartDate = CDate(FormatDateTime(Me.TxtBeginDate, vbShortDate)) ' Begining Date 
                 dteTempEnd = CDate(FormatDateTime(Me.txtEndDate, vbShortDate))      ' End Date   
                 ' Add one day to dteEndDate so Outlook will set the number of days correctly
                 dteEndDate = DateSerial(Year(dteTempEnd + 1), Month(dteTempEnd + 1), Day(dteTempEnd + 1))
  
                 .Start = dteStartDate
                 .End = dteEndDate
  
             Else
             
                 .Alldayevent = False
                 
                 If (Me.TxtBeginDate = Me.txtEndDate) Then
                 
                    ' Set the Start Property Value
                    .Start = CDate(FormatDateTime(Me.TxtBeginDate, vbShortDate) _
                        & " " & FormatDateTime(Me.txtStartTime, vbShortTime))
  
                    ' Set the End Property Value
                    .End = CDate(FormatDateTime(Me.txtEndDate, vbShortDate) _
                         & " " & FormatDateTime(Me.txtEndTime, vbShortTime))
                  
                 Else
                 
                    ' Get the Start and the End Dates
                    dteStartDate = CDate(FormatDateTime(Me.TxtBeginDate, vbShortDate))      
                    dteEndDate = CDate(FormatDateTime(Me.txtEndDate, vbShortDate))     
  
                    ' Add one day to dteEndDate so Outlook will set the number of days correctly
                    .Start = dteStartDate
                    .End = dteEndDate + 1
                 
                 End If
             End If
  
             If Len(Me.Employee & vbNullString) > 0 Then
                Dim vname, vname2, vdesc As String
                vname = DLookup("FirstName", "tblEmployees", "EmployeeID =  " & Me.Employee)
                vname2 = DLookup("LastName", "tblEmployees", "EmployeeID =  " & Me.Employee)
                vdesc = DLookup("Description", "tblCodesWork", "WorkCodeID  = " & Me.WorkCode)
                 .Subject = vname & " " & vname2 & " - " & vdesc

             End If

             ' Save the Appointment Item Properties
             .Save
             
         End With
  
         ' Set chkAddedToOutlook to checked
         Me.chkAddedToOutlook = True
  
         ' Inform the user
         MsgBox "New Outlook Appointment Has Been Added!", vbInformation
     End If
  
ExitHere:
     ' Release Memory
     Set olAppt = Nothing
     Set olApp = Nothing
     Exit Sub
  
ErrHandle:
     MsgBox "Error " & Err.Number & vbCrLf & Err.Description _
     & vbCrLf & "In procedure btnAddApptToOutlook_Click in Module Module1"
     Resume ExitHere
  
End Sub

【问题讨论】：

标签： calendar ms-access-2010 outlook-2010 public-folders