我有用于从Excel数据表在Outlook中创建Skype会议的代码。当前解决方案的问题是，例如，如果我有2个约会需要发送到Outlook日历，则代码将第一个约会创建为常规约会，而不是Skype会议。然后第二个就很好了。同样由于某种原因，尽管我有.save和.send，但它无法“保存并关闭”约会。因此，它正在创建第一个约会，然后将其更改为Skype会议，然后打开第二个约会，并首先创建约会，然后将其更改为Skype会议，而无需“保存并关闭”两者。
结果，我有一个标准的约会，第二个是Skype会议。两者都在Outlook中打开且未发送。可能是什么问题？
Sub CreateOutlookAppointments()
' This is a little sloppy. This selects the worksheet named Sheet1. It should be assigned to a variable instead
' It also assumes without providing instruction that your appointments are all on Sheet1
Sheets("Schedule").Select
' Error handling - when an error occurs it will jump to Err_Execute. However in this code, this Error Handler will never
' be used because it is replaced immediately after initial declaration.
On Error GoTo Err_Execute
' Declare the variables that will be used in this code
Dim olApp As Outlook.Application ' Object to refer to a specific instance of the Outlook Application
Dim olAppt As Outlook.AppointmentItem ' Object to refer to the new appointment
Dim blnCreated As Boolean ' Boolean is TRUE/FALSE. Typically used in tests, but is not used for anything in this code
Dim olNs As Outlook.Namespace ' Required in order to navigation the folders of the Outlook application
Dim CalFolder As Outlook.MAPIFolder ' Object to refer to the Calendar folder
'***************************************************************
' Added new object to interact with Appointment window
Dim insp As Inspector
'***************************************************************
' i is a standard variable name for a counter/index variable
Dim i As Long
' This forces the code to skip to the next line of code if an error occurs
On Error Resume Next
' Assign the Outlook Application to the object
Set olApp = Outlook.Application
' If the Set fails, try again
If olApp Is Nothing Then
Set olApp = Outlook.Application
' This is where the Boolean is assigned a value. It is pointless because there is no test of the variable anywhere
blnCreated = True
' Clear all error codes that may have been created when the olApp assignment failed initially
Err.Clear
Else
' A pointless boolean assignment. I guess they had intended for there to be a test of it later. Never happens
blnCreated = False
End If
' This clears all error handlers and means the default Excel error handling applies
On Error GoTo 0
' Assign the NameSpace to navigate the Outlook folder tree
Set olNs = olApp.GetNamespace("MAPI")
' Find the Calendar folder in the namespace
Set CalFolder = olNs.GetDefaultFolder(olFolderCalendar)
' Assign the counter, in this case i refers to the ROW so it starts at row 2 in your worksheet
i = 2
' DO everything between this line and LOOP until it finds a cell in column A that is empty. TRIM removes leading/trailing spaces so this treats any cell containing
' only spaces as blank
Do Until Trim(Cells(i, 1).Value) = ""
' Create a new appointment and assign it to the olAppt object
Set olAppt = CalFolder.Items.Add(olAppointmentItem)
' With is a shorthand so you don't need to type it to set values on every property of the object
With olAppt
'Define calendar item properties
' Column E value + Column F value
.Start = DateValue(Cells(i, 3).Value) + Cells(i, 4).Value '+ TimeValue("9:00:00")
' Column G value + Column H value
.Duration = Cells(i, 5).Value '+TimeValue("10:00:00")
' Subject is column A
.Subject = Cells(i, 1)
' Location is column B
.Location = Cells(i, 2)
' Body is column C
.Body = Cells(i, 7)
' BusyStatus will default to Busy
.BusyStatus = olBusy
' How many minutes before event starts should you be reminded is column I
.ReminderMinutesBeforeStart = Cells(i, 6)
' Reminders are on by default
.ReminderSet = True
' Required Attendees are on by default
.RequiredAttendees = "mail@mail.com"
' Category is column D
.Categories = Cells(i, 8)
'**********************************************************
' My inserted code goes here
' Assign the new appointment to an Inspector object
Set insp = .GetInspector
'Activate the appointment window
insp.Activate
' ALT+HOM to activate the HOME tab and select SFB button OM
Application.SendKeys ("%HOM")
' Body is column C. If you are using conferencing call codes, this should add your BODY text from Excel before the conferencing details
.Body = .Body & Chr(13) & Cells(i, 3)
'**********************************************************
Set insp = Nothing
' Save the appointment to the calendar
.Save
' For meetings, uncomment the following line to SEND the invitation
.Send
End With
' Move to the next row
i = i + 1
Loop
' Clean up, set objects to NOTHING to clear memory.
Set olAppt = Nothing
Set olApp = Nothing
' Missing cleanup follows
Set olNs = Nothing
Set CalFolder = Nothing
Exit Sub
Err_Execute:
MsgBox "An error occurred - Exporting items to Calendar."
End Sub