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

ck1668

Dear lotustower，您好！很抱歉！是我没有说清楚。

76楼我讲的是两个问题，而且这两个问题分别讲的是两个不同的Sheet。另外，Bulk-Ann Taylor那个sheet少一个叫做"品牌"的栏位。

第一个问题说的是 Bulk-Ann Taylor那个sheet不会显示到期的生产单号；

第二个问题说的是 Bulk-Liz Claiborne那个sheet。如果L9栏显示的是＂已过1天＂或已过几天，那就算下面的L10或更后的栏位出现了＂今天到期＂的，那Outlook里也不会显示到期的生产单号，但是，当我在K９栏输入日期后，再打开Outlook，则L10或更后的是今天到期的都会在Outlook里出现了。

ck1668

Dear lotustower，您好！有没有试试我81楼讲的问题 ？谢！

lotustower

以下是引用[I]ck1668[/I]在2006-3-19 10:31:26的发言：[BR]Dear lotustower，您好！有没有试试我81楼讲的问题 ？谢！

ck1668

Dear lotustower，您好！可能又是我没有表达清楚。

我的意思是：如果L9栏已过期，但却并没有在K９单元格输入日期，在这个条件下， L10 或更后的栏位就算出现了＂今天到期＂的，那Outlook里也不会显示到期的生产单号。

您上面图示里出现了提醒，那正是因为K9单元格里输入了日期。

麻烦您再试试！

lotustower

那麼 更改/修改 Worksheet

ck1668

Dear lotustower，您好！

Sorry！迟了复你，因这几天电脑坏了。

您说更改/修改 Worksheet，指的是更改/修改工作表吗？怎样修改？

ck1668

Dear lotustower，您好！您在线吗？

人生旅途

请问高手们，有没有最终的程序？

lustymancn

fdbfdbfdfd

久居山水间

Option Explicit
Private Sub Application_Startup()
  CreateNewAM
End Sub

Private Sub CreateNewAM()

  Dim YD_app As Excel.Application
  Dim YD_wb As Excel.Workbook
  
  Dim OLAitem As Outlook.AppointmentItem
  Dim strTitle As String
  Dim Bodytxt As String
  Dim i As Integer
  
  Dim nSheetIndex As Integer
  Dim nSheetCount As Integer
  Dim strPath As String
  Dim strFileName As String
  Dim nStartSearch As Integer
  Dim nMatchingIndex As Integer
  

'''''''''''''''''''''''''''''''''''''''''''''''''''''''
                                                      '
strPath = "D:\J\"                                  '输入存放表格的根目录
strFileName = "process development plan-MG7.xls"     '输入表格的名字
nStartSearch = 6                                     '填入表格中开始记录工作日期的行号，默认从第六行开始
nMatchingIndex = 4                                   '填入表格中记录日期的列号，默认为第四列
'''''''''''''''''''''''''''''''''''''''''''''''''''''''

  nSheetIndex = 1
  '创建一个Excel应用实例
  Set YD_app = CreateObject("Excel.Application")
  '配置打开的表格，路经和文件名可自己设置，但必须对应
  Set YD_wb = YD_app.Workbooks.Open(strPath & strFileName)
  nSheetCount = YD_wb.Sheets.Count                     '获取表格中的页数
    Do While nSheetIndex < nSheetCount + 1
       i = nStartSearch     '从nStartSearch开始搜索，这个需要根据具体的表格来定义
       With YD_app.Workbooks(strFileName).Sheets(nSheetIndex)
      
        Do While .Cells(i, nMatchingIndex) <> ""  '从第六条记录开始 逐条记录判断是否今天有到期的任务，当获取的日期为空时，停止往下搜索
            If CDate(.Cells(i, nMatchingIndex)) = Date Then
        '下列为获取表格的 第i行 第4列 第B列 和C列的信息，最后显示为outlook提醒的标题
               Bodytxt = "项目：" & .Name & Chr(10) & Chr(10) & "任务：" & .Cells(i, "C") & Chr(10) & Chr(10) & "姓名：" & .Cells(i, "B") & Chr(10) & Chr(10) & "日期：" & .Cells(i, 4) & Chr(10) & Chr(10)
               strTitle = .Name & "      " & .Cells(i, "C")
                 On Error GoTo 0:
                 Set OLAitem = CreateItem(olAppointmentItem)  '工作
                 On Error Resume Next
                 
                 With OLAitem
                 .Subject = strTitle                         '"今天到期的项目的工作等信息"
                 .Start = Now                                 '开始时间需要自己订制，目前为打开OUTLOOK的当前时间
                 .End = Now
                 .ReminderMinutesBeforeStart = 5    '30分鐘前提醒，这个需要设置上两步的开始时间才起作用
                 .Body = Bodytxt             '提醒的内容，可以写入更多的信息
                 .Save
                 .Display
                 End With
   
                 Bodytxt = ""                '设为空
   
            End If
            i = i + 1
        Loop
       End With
      
       nSheetIndex = nSheetIndex + 1
    Loop
   
    YD_app.ActiveWorkbook.Saved = True
    YD_app.Workbooks.Close
    Set YD_app = Nothing
   
End Sub


已经解决了 引用excel 11.0 object library时候漏了

[ 本帖最后由 久居山水间 于 2009-8-20 13:24 编辑 ]