|
|
楼主 |
发表于 2009-10-22 23:25
|
显示全部楼层
今晚静下心来看了会帮助，似乎已经找到了。最终还得再等等！
Sub CreateNewAM()
'请在工具－》引用中选中Microsoft Outlook的library
Dim olApp As Object
Dim olappointment As Object
Dim Maxrow As Long
Dim myRequiredAttendee As Outlook.Recipient
Dim myOptionalAttendee As Outlook.Recipient
Dim myResourceAttendee As Outlook.Recipient
Worksheets("Sheet1").Activate
Maxrow = ActiveSheet.Range("a65536").End(xlUp).Row
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
For i = 2 To Maxrow
Set olappointment = olApp.CreateItem(olAppointmentItem)
With olappointment
.MeetingStatus = olMeeting
.Subject = ActiveSheet.Cells(i, 2).Value
.Start = CDate(DateValue(ActiveSheet.Cells(i, 1)) + ActiveSheet.Cells(i, 3))
.Duration = (ActiveSheet.Cells(i, 4) - ActiveSheet.Cells(i, 3)) * 1440
Set myRequiredAttendee = .Recipients.Add("参加人员") '必须人员
myRequiredAttendee.Type = olRequired
Set myResourceAttendee = .Recipients.Add("会议室") '资源
myResourceAttendee.Type = olResource
.ReminderMinutesBeforeStart = 15
.ReminderSet = True
.Send
End With
Next i
Set olApp = Nothing
'Set objApt = Nothing
'Set Application = Nothing
End Sub
在版主的文件上修改了，已经测试通过了，只是在发送时，会出现提醒，不知如何取消！附上文件！(参加人员我这是以部门发送，所以比较方便），因为测试，在公司内网发了好几次的会议预约，还不知道会不会挨骂呢！
EXCEL加约会到OUTLOOK.rar
(33.36 KB, 下载次数: 83)
[ 本帖最后由 Love_ycy 于 2009-10-23 00:01 编辑 ] |
|
沪公网安备 31011702000001号 沪ICP备11019229号-2
发表于 2009-10-12 20:16
