求助：excel表里到期的项目在Outlook的行事历里自动出现提示

ck1668

Dear lotustower高手，这下正确了，非常感谢您这么耐心的帮忙！

lotustower

好極

[em10][em10][em10]

ck1668

Dear lotustower高手，这一刻我的心情真的是非常高兴，因为有了这个功能，使我的工作变简单了。这个帖子我是发了好几个月，请教了好多的高手，专家，但今天您终于帮我解决了这个可谓是超级的难题。真的要非常感谢您这么耐心，这么热情的帮忙！再次感谢您！愿您好人一生平安！

ck1668

啊，对了，lotustower高手，如果有２个或更多的Excel表，各个Excel表到期的项目又能不能一样的在Outlook里自动出现？多谢！

ck1668

lotustower高手，34楼这个请您还是别理会了，可能根本就做不到。现想您帮我看看这样的条件能做到吗？请看附件，将原来的栏位作小许变动，希望在Outlook里出现的生产单号是：8364，8365，8369，请问代码应该如何修改？多谢！ UxOkBb9E.rar (6.74 KB, 下载次数: 10)

2006-3-3 20:29 上传

点击文件名下载附件

[此贴子已经被作者于2006-3-3 20:29:47编辑过]

lotustower

With XL_app.Workbooks("OL_Reminder.xls").Sheets(2)
Do While .Cells(i, 9) <> ""
If CDate(.Cells(i, 9)) = Date Then
Bodytxt = Bodytxt & .Cells(i, "B") & Chr(10)
End If
i = i + 1
Loop
End With

這又要用 2/F

改以上如下

With Sheet4 ' With XL_app.Workbooks("OL_Reminder.xls").Sheets(2)

Do While .Cells(i, 1) <> ""
If Cells(i, 7) = 0 Or Cells(i, 10) = 0 Then ' 0 = 今天到期 (你的自定格式)
Bodytxt = Bodytxt & .Cells(i, "A") & Chr(10)
End If
i = i + 1
Loop
End With

加 XL_app.Quit 在 Set XL_app = Nothing 前

Good Luck !!!

[此贴子已经被作者于2006-3-4 0:01:59编辑过]

ck1668

lotustower高手，您深夜还在回贴，我真是感激不尽！

刚按照您的方法，将相应的代码套用在Outlook，另外，我看到现在的生产单号改为B栏，故我也把Excel 里的这句代码Bodytxt = Bodytxt & .Cells(i, "B") & Chr(10)中的B改为了A，但当再打开Outlook时，出现：＂编译错误，变数未定义＂的对话框。我找来找去，就是不知道哪里出了错，现把套用的代码附上来，麻烦您帮我再看看。多谢！

Option Explicit
Private Sub Application_Startup()
CreateNewAM
End Sub
Private Sub CreateNewAM()
Dim XL_app As Excel.Application
Dim XL_wb As Excel.Workbook
Dim OLAitem As Outlook.AppointmentItem
Dim Bodytxt As String
Dim i As Integer


Set XL_app = CreateObject("Excel.Application")
Set XL_wb = XL_app.Workbooks.Open("E:\OL_Reminder.xls")


Bodytxt = "今天到期生產單號" & Chr(10)
i = 9
With Sheet4 'With XL_app.Workbooks("OL_Reminder.xls").Sheets(2)

Do While .Cells(i, 1) <> ""
If Cells(i, 7) = 0 Or Cells(i, 10) = 0 Then ' 0 = 今天到期
Bodytxt = Bodytxt & .Cells(i, "A") & Chr(10)
End If
i = i + 1
Loop
End With

On Error GoTo 0
Set OLAitem = CreateItem(olAppointmentItem) '工作
On Error Resume Next
With OLAitem
.Subject = "今天到期的工作"
.Start = Now
.End = Now
.ReminderMinutesBeforeStart = 30 '30分鐘前提醒
.Body = Bodytxt
.Save
.Display
End With

XL_app.ActiveWorkbook.Saved = True
XL_app.Workbooks.Close
XL_app.QuitSet XL_app = Nothing

End Sub

[此贴子已经被作者于2006-3-4 8:46:55编辑过]

lotustower

Bodytxt = "今天到期生產單號" & Chr(10)
i = 9
With Sheet4 'With XL_app.Workbooks("OL_Reminder.xls").Sheets(2)

With XL_app.Workbooks("OL_Reminder.xls").Sheets(2)

ck1668

lotustower高手，更换上面的代码后，又出现＂编译错误，不正确的物件用法＂。

lotustower

你的 Excel 像上圖？ (Excel: Alt F11) 22/F

With XL_app.Workbooks("OL_Reminder.xls").Sheets(2) Set Rng = ActiveSheet.Range("A8:N" & Range("A65536").End(xlUp).Row) ' Assume Row 8 is header Rng.AutoFilter Field:=11, Criteria1:="今天到期" Set Rng = Rng.Offset(1, 0).Resize(Rng.Rows.Count - 1, Rng.Columns.Count) On Error Resume Next Set Rng = Rng.Columns(1).SpecialCells(xlCellTypeVisible) If Err = 0 Then For i = 1 To Rng.Count Bodytxt = Bodytxt & Range("B" & Rng.Cells(i, 1).Row) & Chr(10) Next Else Err.Clear Bodytxt = "今天沒有到期生產單號!" End If Selection.AutoFilter Cells(9, 1).Select End With

i = 9 With XL_app.Workbooks("OL_Reminder.xls").Sheets(2) Do While .Cells(i, 1) <> "" If Cells(i, 7) = 0 Or Cells(i, 10) = 0 Then ' 0 = 今天到期 Bodytxt = Bodytxt & .Cells(i, "A") & Chr(10) End If i = i + 1 Loop End With