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

lotustower

' 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 Dim HaveItem As Boolean Dim x As Integer Dim LastColumn As Integer Set XL_app = CreateObject("Excel.Application") Set XL_wb = XL_app.Workbooks.Open("E:\OL_Reminder.xls") Bodytxt = "今天到期生產單號" & Chr(10) With XL_wb For x = 1 To 2 Sheets(x).Select i = 9 With Selection LastColumn = Range("IV" & i).End(xlToLeft).Column Do While .Cells(i, 9) <> "" If Excel.Application.WorksheetFunction.CountIf(Range(Cells(i, 11), Cells(i, LastColumn)), 0) > 0 Then If HaveItem = False Then HaveItem = True Bodytxt = Bodytxt & Cells(i, "B") & Chr(10) End If i = i + 1 Loop End With Next If Not HaveItem Then Bodytxt = "今天沒有到期生產單號!" End With On Error GoTo 0 Set OLAitem = CreateItem(olAppointmentItem) On Error Resume Next With OLAitem .Subject = "今天到期的工作" .Start = Now .End = Now .ReminderMinutesBeforeStart = 30 .Body = Bodytxt .Save .Display End With XL_app.ActiveWorkbook.Saved = True XL_app.Workbooks.Close XL_app.Quit Set XL_app = Nothing End Sub ' Code End Kevin, please improve [em06] Do While .Cells(i, 9) <> "" [em06]

[此贴子已经被作者于2006-3-10 0:43:43编辑过]

ck1668

Dear Kevin

请帮忙看看61楼，是不是lotustower说的下面这句代码有问题？我试过，结果弹出"今天没有到期的生产单号＂，但实际上是有到期的生产单号。

Do While .Cells(i, 9) <> ""

Kevin

这句代码没有问题。

另外，建议您抽点时间学习一下最基本的VBA知识，或者不要频繁的变更自己的需求细节，否则很难获得理想的解决方案——您这个简单的问题，看起来真是《没完没了》，呵呵。

lotustower

XL_app.Quit 是必需的

如果 Outlook 執行中有Error, XL_app.Quit 可能會沒有執行, 這可能會產生 Error

這時你需要重開 Windows (因為你不懂得其他的方法)

ps, the code tested ok

ck1668

多谢两位！

ck1668

Dear Kevin / lotustower两位，真的要《没完没了》啦，还要麻烦您们一次。其实，说句心里话，不要说您们厌烦了，就是我自己也真的不知道如何办才好。

Dear lotustower，我重新开机，再打开Outlook，结果弹出的还是"今天没有到期的生产单号＂。但实际上是有到期的生产单号。56楼的附件里面的第一个sheet里今天是没有到期的生产单号，但第二个sheet里的O栏和U栏有到期的生产单号是8532，8533，8534。还有，您试着改变一下第一个sheet里的H栏或I栏里的时间，让几个生产单的K栏出现"今天到期"。然后关闭Outlook后再打开，它还是出现"今天没有到期的生产单号＂。

ck1668

Dear lotustower，您好！是不是原来的EXCEL里的代码也要相应改一下？因原来对应的是１个SHEET，现在对应的是２个SHEET，下面是EXCEL里的代码。

Sub ListmatureItem()

Dim OLapp As Outlook.Application

Dim OLAitem As Outlook.AppointmentItem

Bodytxt = "今天到期生產單號" & Chr(10)

i = 9

With Sheet1

Do While .Cells(i, "L") <> ""

If CDate(.Cells(i, "L")) = Date Then

Bodytxt = Bodytxt & .Cells(i, "B") & Chr(10)

End If

i = i + 1

Loop

End With

On Error Resume Next

Set OLapp = GetObject(, "Outlook.Application")

If Err.Number Then

Err.Clear

Set OLapp = CreateObject("Outlook.Application")

End If

On Error GoTo 0

Set OLAitem = OLapp.CreateItem(olAppointmentItem) '工作

On Error Resume Next

With OLAitem

.Subject = "今天到期的工作"

.Start = Now

.End = Now

.ReminderMinutesBeforeStart = 30 '30分鐘前提醒

.Body = Bodytxt

.Save

.Display

End With

Set OLcont = Nothing

Set OLapp = Nothing

End Sub

lotustower

Code in Outlook ONLY

ck1668

Dear lotustower，您好！我真的很感激您不厌其烦的为我回贴！ 我试多几次以后，终于出现了您上面的画面。但我发现有这样一个问题：第１个Sheet没问题（这个Sheet在Excel的VBA里的名字叫做：Sheet1 Bulk-Liz Claiborne），无论怎样修改里面的日期，当关闭Outlook后再打开时，总会出现正确生产单号的提醒。但第２个Sheet就不行（VBA里的名字叫做：Sheet4 Bulk-Ann Taylor），里面的日期本来是没有今天到期的，我试着改了一下，有几款生产单让它今天到期，但当关闭Outlook后再打开时，提醒视窗里不会出现到期的生产单号。我接着又试了好几次，都是这样。麻烦您再帮我看看，为什么第２个Sheet不行。 另外，Code in Outlook ONLY，还真的只在Outlook里设立代码就行，Excel里其实不用设立代码。多谢您的提醒！

[此贴子已经被作者于2006-3-11 8:41:20编辑过]

lotustower

"总会出现正确生产单号的提醒" 你不懂 Outlook ??