2013-06-20 31 views
7

3〜4人の "忙しい"人とミーティングをスケジュールします。スケジュールアシスタントを使用して利用可能な時間を取得および更新するのは面倒な作業です。複数の電子メールアドレスの空き時間を取得します。

提供された電子メールアドレスに基づいて利用可能な時間を表示するために、Excelマクロを作成しようとしています(Outlookを開いた状態で)。

このマクロは、日付がわかっている(完了している)場合に会議を作成します。日付がわからない場合は、誰もが自由である日付をスプレッドシートに印刷する必要があります。
すべてのユーザーが同じサーバーにあります。

Sub GetFreeBusyInfo()私は助けが必要です。
1.それは、個々の可用性を印刷することができます - しかし、私は、私は結果が「2013年7月1日午前三時に表示してもらうにはどうすればよいグループ全体
2.ための空き/予約済み情報が必要 - 4:00 PM EST "フォーマット?

Option Explicit 
Sub CheckAvail() 
Dim myOutlook As Object 
Dim myMeet As Object 
Dim i As Long 

'Create the Outlook Session 
Set myOutlook = CreateObject("Outlook.Application") 
'Create the AppointmentItem 
Set myMeet = myOutlook.CreateItem(1) 
myMeet.MeetingStatus = 1 

i = 23 
'Start at row 23 
If Cells(i, 11) <> "" Then 
    'Add Recipients 
    Do Until Trim(Cells(i, 10).Value) = "" 
     'Add all recipients 
     myMeet.Recipients.Add Cells(i, 10) 
     i = i + 1 
    Loop 

    i = 23 
    myMeet.Start = Cells(i, 11).Value 

    'Set the appointment properties 
    myMeet.Subject = Cells(i, 12).Value 
    myMeet.Location = Cells(i, 13).Value 
    myMeet.Duration = Cells(i, 14).Value 
    myMeet.ReminderMinutesBeforeStart = 88 
    myMeet.BusyStatus = 2 
    myMeet.Body = Cells(i, 15).Value 
    myMeet.Save 
    myMeet.Display 

Else 
    Call GetFreeBusyInfo 

End If 

End Sub 

Public Sub GetFreeBusyInfo() 
Dim myOutlook As Object 
Dim myMeet As Object 

Dim myNameSpace As Object 
Dim myRecipient As Object 
Dim myFBInfo As String, k As Long, j As Long, i As Long 

'Create the Outlook Session 
Set myOutlook = CreateObject("Outlook.Application") 
Set myMeet = myOutlook.CreateItem(1) 
myMeet.MeetingStatus = 1 
i = 23 
Do Until Trim(Cells(i, 10).Value) = "" 
    'Add all recipients 
    myMeet.Recipients.Add Cells(i, 10) 
    i = i + 1 
Loop  

Set myNameSpace = myOutlook.GetNamespace("MAPI") 
k = 1 
i = 23 
Do Until Trim(Cells(i, 10).Value) = "" 
    k = k + 1 
    Set myRecipient = myNameSpace.CreateRecipient(Cells(i, 10).Value) 
    On Error GoTo ErrorHandler 
    j = 2 
    Cells(k, j) = Cells(i, 10).Value 
    Do Until Trim(Cells(i, 10).Value) = "" 
     myFBInfo = myRecipient.FreeBusy(#7/1/2013#, 60) 
     j = j + 1 
     Cells(k, j) = myFBInfo 
     i = i + 1 
    Loop 
Loop 
myMeet.Close 
ErrorHandler: 
    MsgBox "Cannot access the information. " 
End Sub 
+0

@KazJaw私はそれを追加しました。可能であればお手伝いください。ありがとう! – todayspresent

+0

おそらく左のフィールドからの質問ですが、Excelの代わりにOutlookにVBAを書くことを検討しましたか? ただし、FreeBusyの場合、これは役に立ちますか? https://msdn.microsoft.com/en-us/library/office/aa220097(v=office.11​​).aspx カスタムdatetime形式の場合は、format()関数と文字列関数の組み合わせを使用します。異なるタイムゾーンを処理する必要がある場合は、それらをすべてGMT/UTCなどの標準タイムゾーンに変換する関数も作成します。 – stifin

答えて

1

私は、私はあなたの会議の情報与えられたすべての受信者のために、相互に利用可能な時間帯を、見つける問題を解決し、いくつかのコードを書いた同様の問題に興味がありました。

私はあなたが出力として欲しかったものを正確には分かっていませんでした。今は、すべての利用可能なタイムアウトを一番上の行に書き込んでいます。コードは、すべてタイムスロットと個々の受信者の空き時間情報を表示するように簡単に調整できます。

コードの全体的な構造は次のとおりです。(あなたが行ったように)

まず、すべての受信者の空き/予約済みの状態を収集します。これは、指定された期間(指定された期間(特定のの期間はの間隔)でのアベイラビリティを表す桁の数字(0/1/2/3)です。指定された日付(今日)から開始し、各時間帯に適切なDateTimeを取得するための分を追加することができます。

すべての可用性情報を配列のコレクションに格納します。おそらくこれを行うためのよりよい方法ですが、私はそれを簡単にしたいと思っていました。

各タイムスロットを通過して、すべての可用性配列が0(0 =フリー)になる時間を見つけます。この場合、この特定のタイムスロットをプリントアウトし、次のタイムスロットに移動します。

Option Explicit 

Sub CheckAvail() 
Dim myOutlook As Object 
Dim myMeet As Object 
Dim i As Long 

'Create the Outlook Session 
Set myOutlook = CreateObject("Outlook.Application") 
'Create the AppointmentItem 
Set myMeet = myOutlook.CreateItem(1) 
myMeet.MeetingStatus = 1 

i = 23 
'Start at row 23 
If Cells(i, 11) <> "" Then 
    'Add Recipients 
    Do Until Trim(Cells(i, 10).Value) = "" 
     'Add all recipients 
     myMeet.Recipients.Add Cells(i, 10) 
     i = i + 1 
    Loop 

    i = 23 
    myMeet.Start = Cells(i, 11).Value 

    'Set the appointment properties 
    myMeet.Subject = Cells(i, 12).Value 
    myMeet.Location = Cells(i, 13).Value 
    myMeet.Duration = Cells(i, 14).Value 
    myMeet.ReminderMinutesBeforeStart = 88 
    myMeet.BusyStatus = 2 
    myMeet.Body = Cells(i, 15).Value 
    myMeet.Save 
    myMeet.Display 

Else 
    Call GetFreeBusyInfo 

End If 

End Sub 

Public Sub GetFreeBusyInfo() 
Dim myOutlook As Object 
Dim myMeet As Object 

Dim myNameSpace As Object 
Dim myRecipient As Object 
Dim i As Integer, totalMinutesElapsed As Long 
Dim myMeetingDuration As Integer, intFreeBusy As Integer, intTimeslot As Integer, intEarliestHour As Integer, intLatestHour As Integer 
Dim dtStartTime As Date, dtFinishTime As Date 
Dim myFBInfo As String 
Dim doHeaders As Boolean 
Dim intFreeBusyCode As Integer 

Dim recipStartRow As Integer 
recipStartRow = 23 ' defined by question/asker 

'Create the Outlook Session 
Set myOutlook = CreateObject("Outlook.Application") 
Set myMeet = myOutlook.CreateItem(1) 
myMeet.MeetingStatus = 1 

myMeetingDuration = CInt(Cells(recipStartRow, 14).Value) ' same as above - need duration 

'Add all recipients 
i = 0 
Do Until Trim(Cells(recipStartRow + i, 10).Value) = "" 
    myMeet.Recipients.Add Cells(recipStartRow + i, 10) 
    i = i + 1 
Loop 

Set myNameSpace = myOutlook.GetNamespace("MAPI") 

' uncomment to have all possible timeslots write out 
Dim debugRow As Integer, debugCol As Integer 
debugRow = 2 
debugCol = 2 

' --> define the general 'working hours' here 
' (anything timeslots that start before this period or end after this period will be ignored) 
intEarliestHour = 8 '8am 
intLatestHour = 17 '5pm 

' set up structure to store free/busy info 
Dim colAvailability As Collection, colRecipients As Collection 
Dim strRecipientName As String 
Dim arrayAvailability(1 To 1000) As Integer 
Dim arrayStartDates(1 To 1000) As Date 
Set colAvailability = New Collection 
Set colRecipients = New Collection 

' loop through each recipient (same as above) 
doHeaders = True 
i = 0 
Do Until Trim(Cells(recipStartRow + i, 10).Value) = "" 

    intTimeslot = 1 

    strRecipientName = Cells(recipStartRow + i, 10).Value 
    Set myRecipient = myNameSpace.CreateRecipient(strRecipientName) 

    'Cells(debugRow + i, debugCol) = strRecipientName 
    colRecipients.Add strRecipientName ' collections respect order of addition 
    myFBInfo = myRecipient.FreeBusy(Date, myMeetingDuration, True) 

    ' parse FB info string - stored as digits that represent Free/Busy constants, starting at midnight, in given time intervals 
    For intFreeBusy = 1 To Len(myFBInfo) 

     totalMinutesElapsed = CLng(intFreeBusy - 1) * myMeetingDuration 

     dtStartTime = DateAdd("n", totalMinutesElapsed, Date) 
     dtFinishTime = DateAdd("n", (totalMinutesElapsed + myMeetingDuration), Date) 

     If Hour(dtStartTime) < intEarliestHour Or Hour(dtFinishTime) > intLatestHour Then 

      ' skip this potential time slot 
     Else 

      intFreeBusyCode = CInt(Mid(myFBInfo, intFreeBusy, 1)) 

      ' Cells(debugRow + i, debugCol + intTimeslot) = GetFreeBusyStatus(intFreeBusyCode) 
      arrayAvailability(intTimeslot) = intFreeBusyCode 


      If doHeaders = True Then 
       ' Cells(debugRow - 1, debugCol + intTimeslot) = dtStartTime 
       arrayStartDates(intTimeslot) = dtStartTime 
      End If 

      intTimeslot = intTimeslot + 1 

     End If 

    Next intFreeBusy 

    colAvailability.Add arrayAvailability ' save each recipients array of availability codes 

    doHeaders = False 
    i = i + 1 
Loop 

' search through each array to find times where everyone is available 
For intTimeslot = 1 To 1000 
    ' stop when we run out of time slots 
    If arrayStartDates(intTimeslot) = #12:00:00 AM# Then 
     Exit For 
    End If 

    dtStartTime = arrayStartDates(intTimeslot) 

    ' loop through each meeting recipient at that time slot 
    intFreeBusy = 0 
    For i = 1 To colRecipients.Count 
     intFreeBusy = intFreeBusy + colAvailability.Item(i)(intTimeslot) 
    Next i 

    If intFreeBusy = 0 Then ' everyone is free! 
     debugCol = debugCol + 1 
     Cells(debugRow - 1, debugCol).Value = dtStartTime 


    End If 

Next intTimeslot 


'myMeet.Close 


End Sub 

Function GetFreeBusyStatus(code As Integer) As String 

' https://msdn.microsoft.com/en-us/library/office/ff864234.aspx 
' 0 = free 
' 1 = tentative 
' 2 = busy 
' 3 = out of office 
' 4 = "working elsewhere" 

If code = 0 Then 
    GetFreeBusyStatus = "Free" 
ElseIf code = 1 Then 
    GetFreeBusyStatus = "Tentative" 
ElseIf code = 2 Then 
    GetFreeBusyStatus = "Busy" 
ElseIf code = 3 Then 
    GetFreeBusyStatus = "Out" 
ElseIf code = 4 Then 
    GetFreeBusyStatus = "WFH" 
Else 
    GetFreeBusyStatus = "??" 
End If 

End Function 
関連する問題