Laufzeitfehler 440 und NumLock
30.08.2016 10:53:49
Rico
Ich benötige wieder einmal kompetente Hilfe zu einem für mich nicht lösbaren Problem:
Aus einer Excel-Tabelle sollen Termine nach Outlook übertragen werden. Im Forums-Archiv habe ich einige Beiträge dazu gefunden und auch etwas für mich zusammengestellt. Ich muss dazu anmerken, dass ich mich mit VBA nicht wirklich gut auskenne. Anweisungen, die ich vorerst nicht benötige, habe ich auskommentiert. Der Code sieht so aus und funktioniert fast perfekt:
Sub Excel_Control_Termin_nach_Outlook()
'Termine werden von einer Excel-Liste nach Outlook übertragen
Dim OutApp As Object, apptOutApp As Object
'Hier beginnen die Termine
Dim BlattName As String
Dim Zeile As Integer
Dim EmailNamen As String
BlattName = "Arbeitsauftragstracker"
'EmailNamen = "" 'hier können auch Termin an Emailempfänger versendet werden, Adressen mit _
Semikolon trennen
For Zeile = 4 To Sheets(BlattName).UsedRange.Rows.Count
Set OutApp = CreateObject("Outlook.Application")
Set apptOutApp = OutApp.CreateItem(1) 'olAppointmentItem
If Sheets(BlattName).Cells(Zeile, 6) > 0 Then 'Datum vorhanden
If IsEmpty(Sheets(BlattName).Cells(Zeile, 10)) = True Then 'Status ohne Wert
With apptOutApp
'Als Datum wird der Termin aus der Zelle genommen
.Start = Format(Sheets(BlattName).Cells(Zeile, 6), "dd.mm.yyyy") & " 08:00"
'Termininfo
.Subject = "Auftrag: " & Sheets(BlattName).Cells(Zeile, 3)
'Zusätzlicher Text
Nachricht = Sheets(BlattName).Cells(Zeile, 2) & Chr(10)
'Nachricht = Nachricht & "weiterer Text möglich"
.Body = Nachricht
'Anzeige
.display
'ort
' .Location = "Einsatzort: " & Sheets(BlattName).Cells(Zeile, 3)
'Dauer. Angabe ist jeweils in ganzen Minuten zu setzen
.Duration = "60"
'Erinnerung
.ReminderMinutesBeforeStart = 10
'mit Sound?
.ReminderPlaySound = False
'Erinnerung wiederholen
.ReminderSet = True
'Wichtigkeit
.Importance = olImportanceHigh
'Status
' .MeetingStatus = olMeeting
'Optionale Adressen
'.OptionalAttendees = EmailNamen
Application.DisplayAlerts = False
'Termin speichern
.Save
'Schließen ohne senden
Application.SendKeys "%DL"
'Senden an anderen EmailAdressen (Aktivierung: 1. Zeichen bei den nächsten 2 Zeilen _
entfernen)
'.OptionalAttendees = EmailNamen
' Application.SendKeys "%S" '*** automatisch ohne überprüfung senden ***
Application.DisplayAlerts = True
'Erledigt setzen
Sheets(BlattName).Cells(Zeile, 10) = "in Outlook übernommen"
End With
' ActiveCell.Offset(1, 0).Select
' Variablen leeren,
End If
End If
Set apptOutApp = Nothing
Set OutApp = Nothing
Next Zeile
MsgBox "Termine an Outlook übertragen!"
End Sub
Bei meiner Recherche bin ich u. a. darauf gestoßen, dass für das Ausschalten der NumLock-Taste der Befehl Application.SendKeys zuständig sein kann. Ich weiß aber leider nicht, wie ich das Problem beheben soll.
Kann mir bitte jemand verraten, was ich im Code anpassen muss, damit das Makro fehlerfrei läuft? Eine Beispieldatei habe ich hochgeladen.
Für Eure Hilfe bedanke ich mich schon einmal vorab!
Viele Grüße
Rico
https://www.herber.de/bbs/user/107893.xlsm