私は VBA に非常に慣れていないので、私の問題を説明するために最善を尽くします。タスクのリストを Outlook のタスクと双方向に同期するワークブックがありますが、問題なく動作しています。また、「ステータス」列 (列 D) が変更されるたびに静的タイムスタンプを作成するマクロもあります。問題は、ワークシートを開いて Outlook と同期するたびに、列 D が (ワークシートの残りの部分と共に) 更新され、ステータス テキストが同じままであってもタイム スタンプが更新されることです。以下は、タイム スタンプを作成するために使用しているマクロです。セル内の実際のテキスト (列 D) が変更されたとき (つまり、「進行中」が「待機中」になるとき) にのみタイム スタンプを作成するように変更する方法はありますか?ワークブックがすべてのデータを同期して更新するときだけではありませんか?
どうもありがとう!!!以下の改訂されたコード -- これは、"Microsoft Excel Objects" フォルダ内の "ThisWorkbook" から Outlook と同期するコードです。
'--> Declare some constants
'Edit the constants below as needed so they correctly reflect the column number they appear in in the spreadsheet'
Const EXC_CLIENT = 1
Const EXC_SUBJECT = 2
Const EXC_START = 5
Const EXC_STATUS = 4
Const EXC_DUE = 8
Const EXC_EID = 26
Const PROC_NAME = "Outlook Synchronization"
'Do not change any constants from this point on
Const olTaskNotStarted = 0
Const olTaskInProgress = 1
Const olTaskComplete = 2
Const olTaskWaiting = 3
Const olTaskDeferred = 4
Const olText = 1
Const olYesNo = 6
Const olFolderTasks = 13
Const DESKTOP_READOBJECTS = &H1&
'--> Declare some variables
Dim olkApp As Object, _
olkSes As Object, _
olkFld As Object, _
olkTsk As Object, _
olkPrp As Object, _
excWks As Excel.Worksheet, _
lngRow As Long, _
strRun As String, _
bolSkp As Boolean
Private Sub InitializeExcel()
Set excWks = Application.ActiveWorkbook.Sheets(1)
lngRow = 2
strRun = Format(Now, "yyyy-mm-dd-hh-nn-ss")
End Sub
Private Sub DeactivateExcel()
Set excWks = Nothing
End Sub
Private Sub InitializeOutlook()
Set olkApp = CreateObject("Outlook.Application")
Set olkSes = olkApp.GetNamespace("MAPI")
olkSes.Logon olkApp.DefaultProfileName
Set olkFld = olkSes.GetDefaultFolder(olFolderTasks)
End Sub
Private Sub DeactivateOutlook()
olkSes.Logoff
Set olkFld = Nothing
Set olkSes = Nothing
Set olkApp = Nothing
End Sub
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
'--> On saving the workbook you will be given an opportunity to synchronize from Excel to Outlook
InitializeExcel 'Prep Excel for a sync
InitializeOutlook 'Prep Outlook for a sync
Excel2Outlook 'Sync from Excel to Outlook
DeactivateExcel 'Clean-up Excel
DeactivateOutlook 'Clean-up Outlook
End Sub
Private Sub Workbook_Open()
'--> On opening the workbook you will be given an opportunity to syncronize data from Outlook to Excel
bolSkp = False 'Set this to True if you don't want to be prompted to run the sync when opening/closing the spreadsheet.
InitializeExcel 'Prep Excel for a sync
InitializeOutlook 'Prep Outlook for a sync
Outlook2Excel 'Sync from Outlook to Excel
DeactivateExcel 'Clean-up Excel
DeactivateOutlook 'Clean-up Outlook
End Sub
Private Sub Excel2Outlook()
If Not bolSkp Then
If MsgBox("Should I sync the tasks to Outlook?", vbQuestion + vbYesNo, PROC_NAME) = vbYes Then
Do Until excWks.Cells(lngRow, 1) = ""
Select Case excWks.Cells(lngRow, EXC_EID)
Case ""
Set olkTsk = olkFld.Items.Add()
With olkTsk
.UserProperties.Add "ExcelTaskList", olYesNo, True
.UserProperties.Item("ExcelTaskList").Value = True
.UserProperties.Add "Synced", olText
.UserProperties.Item("Synced").Value = strRun
.Save
End With
excWks.Cells(lngRow, EXC_EID) = olkTsk.EntryID
Case Else
Set olkTsk = olkSes.GetItemFromID(excWks.Cells(lngRow, EXC_EID))
End Select
With olkTsk
.Subject = excWks.Cells(lngRow, EXC_CLIENT) & "/" & excWks.Cells(lngRow, EXC_SUBJECT)
If IsDate(excWks.Cells(lngRow, EXC_START)) Then .StartDate = excWks.Cells(lngRow, EXC_START)
If IsDate(excWks.Cells(lngRow, EXC_DUE)) Then .DueDate = excWks.Cells(lngRow, EXC_DUE)
Select Case excWks.Cells(lngRow, EXC_STATUS)
Case "Complete"
.Status = olTaskComplete
Case "Deferred"
.Status = olTaskDeferred
Case "In Progress"
.Status = olTaskInProgress
Case "Not Started"
.Status = olTaskNotStarted
Case "Waiting"
.Status = olTaskWaiting
End Select
olkTsk.UserProperties.Item("Synced").Value = strRun
.Save
End With
lngRow = lngRow + 1
Loop
For lngRow = olkFld.Items.Count To 1 Step -1
Set olkTsk = olkFld.Items(lngRow)
Set olkPrp = olkTsk.UserProperties.Find("ExcelTaskList", True)
If TypeName(olkPrp) <> "Nothing" Then
If olkTsk.UserProperties.Item("Synced").Value < strRun Then
olkTsk.Delete
End If
End If
Next
End If
End If
End Sub
Private Sub Outlook2Excel()
Dim excRng As Excel.Range, arrTmp As Variant, intCnt As Integer
If Not bolSkp Then
If MsgBox("Should I sync tasks from Outlook?", vbQuestion + vbYesNo, PROC_NAME) = vbYes Then
For intCnt = olkFld.Items.Count To 1 Step -1
Set olkTsk = olkFld.Items(intCnt)
Set olkPrp = olkTsk.UserProperties.Find("ExcelTaskList", True)
If TypeName(olkPrp) = "Nothing" Then
'The task does not exist in the spreadsheet. Add it.
lngRow = excWks.UsedRange.Rows.Count + 1
With olkTsk
If InStr(1, .Subject, "/") > 0 Then
arrTmp = Split(.Subject, "/")
excWks.Cells(lngRow, EXC_CLIENT) = arrTmp(0)
excWks.Cells(lngRow, EXC_SUBJECT) = arrTmp(1)
Else
excWks.Cells(lngRow, EXC_CLIENT) = "Select Client"
excWks.Cells(lngRow, EXC_SUBJECT) = .Subject
End If
If .StartDate <> #1/1/4501# Then
excWks.Cells(lngRow, EXC_START) = .StartDate
excWks.Cells(lngRow, EXC_START).NumberFormat = "[$-409]d-mmm;@"
End If
Select Case .Status
Case olTaskComplete
excWks.Cells(lngRow, EXC_STATUS) = "Complete"
Case olTaskDeferred
excWks.Cells(lngRow, EXC_STATUS) = "Deferred"
Case olTaskInProgress
excWks.Cells(lngRow, EXC_STATUS) = "In Progress"
Case olTaskNotStarted
excWks.Cells(lngRow, EXC_STATUS) = "Not Started"
Case olTaskWaiting
excWks.Cells(lngRow, EXC_STATUS) = "Waiting"
End Select
If .DueDate <> #1/1/4501# Then
excWks.Cells(lngRow, EXC_DUE) = .DueDate
excWks.Cells(lngRow, EXC_DUE).NumberFormat = "[$-409]ddd, mmm. d;@"
End If
excWks.Cells(lngRow, EXC_EID) = .EntryID
.UserProperties.Add "ExcelTaskList", olYesNo, True
.UserProperties.Item("ExcelTaskList").Value = True
.UserProperties.Add "Synced", olText
.UserProperties.Item("Synced").Value = strRun
.Save
End With
Else
If olkTsk.UserProperties.Item("Synced").Value > olkTsk.LastModificationTime Then
For lngRow = 2 To excWks.UsedRange.Rows.Count
If excWks.Cells(lngRow, EXC_EID) = olkTsk.EntryID Then Exit For
Next
If lngRow >= 2 And lngRow <= excWks.UsedRange.Rows.Count Then
With olkTsk
If InStr(1, .Subject, "/") > 0 Then
arrTmp = Split(.Subject, "/")
excWks.Cells(lngRow, EXC_CLIENT) = arrTmp(0)
excWks.Cells(lngRow, EXC_SUBJECT) = arrTmp(1)
Else
excWks.Cells(lngRow, EXC_CLIENT) = "Select Client"
excWks.Cells(lngRow, EXC_SUBJECT) = .Subject
End If
If .StartDate <> #1/1/4501# Then excWks.Cells(lngRow, EXC_START) = .StartDate
Select Case .Status
Case olTaskComplete
excWks.Cells(lngRow, EXC_STATUS) = "Complete"
Case olTaskDeferred
excWks.Cells(lngRow, EXC_STATUS) = "Deferred"
Case olTaskInProgress
excWks.Cells(lngRow, EXC_STATUS) = "In Progress"
Case olTaskNotStarted
excWks.Cells(lngRow, EXC_STATUS) = "Not Started"
Case olTaskWaiting
excWks.Cells(lngRow, EXC_STATUS) = "Waiting"
End Select
If .DueDate <> #1/1/4501# Then excWks.Cells(lngRow, EXC_DUE) = .DueDate
.UserProperties.Item("Synced").Value = strRun
.Save
End With
Else
MsgBox "Critical problem. There was no match in the spreadsheet for the task" & vbCrLf & vbTab & olkTsk.Subject, vbCritical + vbOKOnly, PROC_NAME
End If
End If
End If
Next
On Error Resume Next
For lngRow = excWks.UsedRange.Rows.Count To 2 Step -1
If excWks.Cells(lngRow, EXC_EID) <> "" Then
Set olkTsk = olkSes.GetItemFromID(excWks.Cells(lngRow, EXC_EID))
Debug.Print excWks.Cells(lngRow, EXC_SUBJECT)
If (TypeName(olkTsk) = "Nothing") Or (olkTsk.Parent.Name = "Deleted Items") Then
Set excRng = excWks.Range("A" & lngRow, "Z" & lngRow)
excRng.Delete xlShiftUp
End If
End If
Set olkTsk = Nothing
Next
On Error GoTo 0
End If
End If
End Sub
Public Sub ForceExcel2Close()
Dim varDesktop As Variant
varDesktop = OpenInputDesktop(0, False, DESKTOP_READOBJECTS)
'varDesktop will be 0 if the screen is locked, non-zero if it is not.
If varDesktop = 0 Then
bolSkp = True
ThisWorkbook.Save
CreateScriptFile
RunScriptFile
End If
End Sub
Sub CreateScriptFile()
Dim objFSO As Object, objFil As Object
Set objFSO = CreateObject("Scripting.FileSystemobject")
Set objFil = objFSO.CreateTextFile(Environ("TMP") & "\CloseExcel.vbs", True)
With objFil
.WriteLine "WScript.Sleep 5000"
.WriteLine "Set excApp = GetObject(,""Excel.Application"")"
.WriteLine "excApp.Quit"
.WriteLine "Set excApp = Nothing"
.Close
End With
Set objFSO = Nothing
Set objFil = Nothing
End Sub
Sub RunScriptFile()
Dim objShl As Object
Set objShl = CreateObject("WScript.Shell")
objShl.Run Environ("TMP") & "\CloseExcel.vbs", 0, False
Set objShl = Nothing
End Sub