AW: Excel in Outlook
24.02.2009 12:28:36
Renee
Hi Tom,
Ich hab's zwar nicht getestet und damit ohne Gewähr.
Ersetze die Subroutine xoExportCalendar() durch diesen Code:
Sub xoExportCalendar()
Dim olApp As Object
Dim olNS As Object
Dim olAI As Object
Dim olFolder As Object
Dim iRow As Long
Dim rC As Range
Set olApp = CreateObject("Outlook.Application")
Set olNS = olApp.GetNamespace("MAPI")
Set olFolder = olNS.GetDefaultFolder(9)
If Selection.Address = ActiveCell.Address Or _
Selection.Cells(1, 1).Column > 1 Then
MsgBox "Markieren Sie in Spalte A Zellen oder Zeilen!", _
vbOKOnly, "Termine Exportieren"
Exit Sub
End If
For Each rC In Selection.Rows(1)
iRow = rC.Row
If Cells(iRow, 1).Value > 0 And _
Cells(iRow, 2).Value > 0 And _
Cells(iRow, 2).Value > Cells(iRow, 1).Value Then
Set olAI = olApp.CreateItem(1)
With olAI
.Start = Cells(iRow, 1).Value
.End = Cells(iRow, 2).Value
.Location = Cells(iRow, 3).Value
.Subject = Cells(iRow, 4).Value
.Body = Cells(iRow, 5).Value
If Cells(iRow, 6).Value = "Ohne" Then
.ReminderSet = False
Else
.ReminderMinutesBeforeStart = _
WorksheetFunction.VLookup(Cells(iRow, 6).Value, wksData.Columns("A:B"), 2, 0)
End If
.Sensitivity = WorksheetFunction.VLookup(Cells(iRow, 7).Value, _
wksData.Columns("E:F"), 2, 0)
.Importance = WorksheetFunction.VLookup(Cells(iRow, 8).Value, _
wksData.Columns("C:D"), 2, 0)
.Save
End With
End If
Next rC
Set olAI = Nothing
Set olNS = Nothing
Set olApp = Nothing
End Sub
GreetZ Renée