我运行了一个Excel宏,它从电子表格中获取活动名称,日期和时间,并将它们放入Outlook日历中。这在Outlook运行时可以正常工作,但是当它不运行时,宏不会进行约会。
我已经制作了一个错误检查部分,用于检查正在运行的Outlook实例是否正在运行,如果没有正在运行,但它仍然只能在Outlook运行时运行。
任何想法为什么?
Sub SetAppt()
' Dim olApp As Outlook.Application
Dim olApt As AppointmentItem
Dim olApp As Object
'if an instance of outlook is not open then create an instance of the application
On Error Resume Next
Set olApp = GetObject(, "Outlook.Application")
If er.Number = 429 Then
Set olApp = CreateObject("Outlook.Application.14")
End If
On Error GoTo 0
Set olApp = CreateObject("Outlook.Application")
' Set olApp = New Outlook.Application
'declare an index for all the variables
Dim i As Integer
i = 2
'declare the variables that will hold the data and set their initial value
Dim occ, actName, srtTime, duration As String
occ = "A" & i
actName = "B" & i
srtTime = "F" & i
duration = "G" & i
'for holding different parts of the dates/times that will be split
Dim splitStr() As String
Dim splitDrtion() As String
'loop until there is no more items
While Range(occ).Value <> ""
'create a new appointment
Set olApt = olApp.CreateItem(olAppointmentItem)
'we must split the start time and date
splitStr = Split(Range(srtTime).Value, " ")
Dim oDate As Date
oDate = splitStr(0)
'we must also spilt the duration (number/hour)
splitDrtion = Split(Range(duration).Value, " ")
'with is used to acces the appointment items properties
With olApt
.Start = oDate + TimeValue(splitStr(1))
'if the duration is in hours then multiply number else leave it
If splitDrtion(1) = "Hour" Then
.duration = 60 * splitDrtion(0)
Else
.duration = splitDrtion(0)
End If
.Subject = Range(occ).Value
.Body = Range(actName).Value
.Save
End With
'increment i and reset all the variables with the new number
i = i + 1
occ = "A" & i
actName = "B" & i
srtTime = "F" & i
duration = "G" & i
Set olApt = Nothing
Wend
Set olApp = Nothing
End Sub
答案 0 :(得分:0)
而不是
On Error Resume Next
Set olApp = GetObject(, "Outlook.Application")
If er.Number = 429 Then
Set olApp = CreateObject("Outlook.Application.14")
End If
On Error GoTo 0
Set olApp = CreateObject("Outlook.Application")
试试这个
On Error Resume Next
Set olApp = GetObject(, "Outlook.Application")
'~~> If not found then create new instance
If Err.Number <> 0 Then
Set olApp = CreateObject("Outlook.Application")
End If
Err.Clear
On Error GoTo 0
由于我无法测试,因此这里是您的代码,其中包含必要的更新。请试试这个。
Sub SetAppt()
Dim olApt As Object, olApp As Object
Dim i As Integer
Dim occ As String, actName As String, srtTime As String, duration As String
Dim splitStr() As String, splitDrtion() As String
Dim oDate As Date
On Error Resume Next
Set olApp = GetObject(, "Outlook.Application")
'~~> If not found then create new instance
If Err.Number <> 0 Then
Set olApp = CreateObject("Outlook.Application")
End If
Err.Clear
On Error GoTo 0
'declare an index for all the variables
i = 2
'declare the variables that will hold the data and set their initial value
occ = "A" & i
actName = "B" & i
srtTime = "F" & i
duration = "G" & i
'loop until there is no more items
While Range(occ).Value <> ""
'create a new appointment
Set olApt = olApp.CreateItem(1)
'we must split the start time and date
splitStr = Split(Range(srtTime).Value, " ")
oDate = splitStr(0)
'we must also spilt the duration (number/hour)
splitDrtion = Split(Range(duration).Value, " ")
'with is used to acces the appointment items properties
With olApt
.Start = oDate + TimeValue(splitStr(1))
'if the duration is in hours then multiply number else leave it
If splitDrtion(1) = "Hour" Then
.duration = 60 * splitDrtion(0)
Else
.duration = splitDrtion(0)
End If
.Subject = Range(occ).Value
.Body = Range(actName).Value
.Save
End With
'increment i and reset all the variables with the new number
i = i + 1
occ = "A" & i
actName = "B" & i
srtTime = "F" & i
duration = "G" & i
Set olApt = Nothing
Wend
Set olApp = Nothing
End Sub
答案 1 :(得分:0)
在Siddharth示例的基础上,这是您的代码的重构版本。
Sub SetAppt()
Dim olApt As Object ' Outlook.AppointmentItem
Dim olApp As Object ' Outlook.Application
Dim i As Long
Dim apptRange As Variant
Const olAppointmentItem As Long = 1
' create outlook
Set olApp = GetOutlookApp
If olApp Is Nothing Then
MsgBox "Could not start Outlook"
Exit Sub
End If
' read appts into array
apptRange = Range(Cells(2, 1), Cells(Rows.Count, 7).End(xlUp)).value
For i = LBound(apptRange) To UBound(apptRange)
Set olApt = olApp.CreateItem(olAppointmentItem)
With olApt
.Start = apptRange(i, 6)
If InStr(apptRange(i, 7), "Hour") > 0 Then
' numeric portion cell is delimited by space
.Duration = 60 * Split(apptRange(i, 7), " ")(0)
Else
.Duration = apptRange(i, 7)
End If
.Subject = apptRange(i, 1)
.Body = apptRange(i, 2)
.Save
End With
Next i
End Sub
Function GetOutlookApp() As Object
On Error Resume Next
Set GetOutlookApp = CreateObject("Outlook.Application")
End Function
此代码将您的工作表数据读入数组。这避免了VBA和Excel之间的COM交互带来的时间损失。
我们遍历数组并为每一行创建一个新约会。
使用以下示例数据,无论Outlook是否打开(Outlook被关闭使其明显变慢),它都能正常工作。