Question

我有一个模块，我过去用过从我的Outlook日历中提取数据，并且基本上将“计费”信息放入位置字段，因此我不必进行自定义字段。当然，直到某人使用位置发送邀请才有效...所以我需要进化并创建一个新领域。我的问题当然是我的VBA必须更改为使用自定义字段。

以下是我所拥有的 - “BillingInfo”或以下内容 .End(xlDown).End(xlUp).Offset(NextRow, 3).Value = ThisAppt.BillingInfo正在被标记。

这里是完整的...

' this is the sub to tell outlook what to pull in -
' select the dates as needed
'

Sub GetApptsFromOutlook()
Dim dteStart As Date
Dim dteEnd As Date

dteStart = InputBox("What is the start date?")
dteEnd = InputBox("What is the end date?")
Call GetCalData(dteStart, dteEnd)
End Sub




Private Sub GetCalData(StartDate As Date, Optional EndDate As Date)

' -------------------------------------------------
' Notes:
' If Outlook is not open, it still works, but much slower (~8 secs vs. 2 secs w/ Outlook open).
' Make sure to reference the Outlook object library before running the code
' End Date is optional, if you want to pull from only one day, use: Call GetCalData("7/14/2008")
' -------------------------------------------------

Dim olApp As Outlook.Application
Dim olNS As Outlook.Namespace
Dim myCalItems As Outlook.Items
Dim ItemstoCheck As Outlook.Items
Dim ThisAppt As Outlook.AppointmentItem

Dim MyItem As Object

Dim StringToCheck As String

Dim MyBook As Excel.Workbook
Dim rngStart As Excel.Range

Dim i As Long
Dim NextRow As Long

' if no end date was specified, then the requestor only wants one day, so set EndDate = StartDate
' this will let us return appts from multiple dates, if the requestor does in fact set an appropriate end date
If EndDate = "12:00:00 AM" Then
  EndDate = StartDate
End If

If EndDate < StartDate Then
  MsgBox "Those dates seem switched, please check them and try again.", vbInformation
  GoTo ExitProc
End If

If EndDate - StartDate > 28 Then
  ' ask if the requestor wants so much info
  If MsgBox("This could take some time. Continue anyway?", vbInformation + vbYesNo) = vbNo Then
      GoTo ExitProc
  End If
End If

' get or create Outlook object and make sure it exists before continuing
On Error Resume Next
  Set olApp = GetObject(, "Outlook.Application")
  If Err.Number <> 0 Then
    Set olApp = CreateObject("Outlook.Application")
  End If
On Error GoTo 0
If olApp Is Nothing Then
  MsgBox "Cannot start Outlook.", vbExclamation
  GoTo ExitProc
End If

Set olNS = olApp.GetNamespace("MAPI")
Set myCalItems = olNS.GetDefaultFolder(olFolderCalendar).Items

' ------------------------------------------------------------------
' the following code adapted from:
' http://www.outlookcode.com/article.aspx?id=30
'
With myCalItems
  .Sort "[Start]", False
  .IncludeRecurrences = True
End With
'
StringToCheck = "[Start] >= " & Quote(StartDate & " 12:00 AM") & " AND [End] <= " & _
  Quote(EndDate & " 11:59 PM")
Debug.Print StringToCheck
'
Set ItemstoCheck = myCalItems.Restrict(StringToCheck)
Debug.Print ItemstoCheck.Count
' ------------------------------------------------------------------

If ItemstoCheck.Count > 0 Then
  ' we found at least one appt
  ' check if there are actually any items in the collection, otherwise exit
  If ItemstoCheck.Item(1) Is Nothing Then GoTo ExitProc

  Set MyBook = Excel.Workbooks.Add
  Set rngStart = MyBook.Sheets(1).Range("A1")

  With rngStart
    .Offset(0, 0).Value = "Start"
    .Offset(0, 1).Value = "Duration"
    .Offset(0, 2).Value = "Categories"
    .Offset(0, 3).Value = "BillingInfo"
    .Offset(0, 4).Value = "Subject"

  End With

  For Each MyItem In ItemstoCheck
    If MyItem.Class = olAppointment Then
    ' MyItem is the appointment or meeting item we want,
    ' set obj reference to it
      Set ThisAppt = MyItem
      NextRow = WorksheetFunction.CountA(Range("A:A"))

      With rngStart

        .End(xlDown).End(xlUp).Offset(NextRow, 0).Value = Format(ThisAppt.Start, "MM/DD/YYYY")
        .End(xlDown).End(xlUp).Offset(NextRow, 1).Value = ThisAppt.Duration
        .End(xlDown).End(xlUp).Offset(NextRow, 2).Value = ThisAppt.Categories
        .End(xlDown).End(xlUp).Offset(NextRow, 3).Value = ThisAppt.BillingInfo
        .End(xlDown).End(xlUp).Offset(NextRow, 4).Value = ThisAppt.Subject


        If ThisAppt.Categories <> "" Then
          .End(xlDown).End(xlUp).Offset(NextRow, 6).Value = ThisAppt.Categories
        Else
          .End(xlDown).End(xlUp).Offset(NextRow, 6).Value = "n/a"
        End If
      End With
    End If
  Next MyItem

  ' make it pretty
  Call Cool_Colors(rngStart)

Else
    MsgBox "There are no appointments or meetings during" & _
      "the time you specified. Exiting now.", vbCritical
End If

ExitProc:
Set myCalItems = Nothing
Set ItemstoCheck = Nothing
Set olNS = Nothing
Set olApp = Nothing
Set rngStart = Nothing
Set ThisAppt = Nothing
End Sub


Private Function Quote(MyText)
' from Sue Mosher's excellent book "Microsoft Outlook Programming"
  Quote = Chr(34) & MyText & Chr(34)
End Function


Private Sub Cool_Colors(rng As Excel.Range)
'
' Lt Blue BG with white letters
'
'
With Range(rng, rng.End(xlToRight))
  .Font.ColorIndex = 2
  .Font.Bold = True
  .HorizontalAlignment = xlCenter
  .MergeCells = False
  .AutoFilter
  .CurrentRegion.Columns.AutoFit
  With .Interior
    .ColorIndex = 41
    .Pattern = xlSolid
  End With
End With

End Sub

Answer 1

ThisAppt不直接包含BillingInfo。您需要通过UserProperties集合检索它，如下所示：

.End(xlDown).End(xlUp).Offset(NextRow, 3).Value = ThisAppt.UserProperties.Item("BillingInfo").Value

Outlook将自定义字段导出到Excel

1 个答案: