Num-Lock wird deaktiviert
04.02.2020 04:01:56
Thomas
Ich habe folgenden Code im Forum gefunden.
Diesen habe ich etwas angepasst und funktioniert bis auf eine Kleinigkeit ganz gut.
Wenn ich das Makro starte, wird Num-Lock deaktiviert. Wie kann ich das wieder aktivieren per Makro?
Hier der Code:
Sub zurück()
' zurück Makro
' Makro am 6.12.2007 von Dirk Ehrhardt aufgezeichnet
Sheets("Terminübersicht").Select
ActiveWindow.LargeScroll Down:=-1
End Sub
Sub Excel_Control_Termin_nach_Outlook()
'E 2000
'Dim OutApp As Outlook.Application
Dim OutApp As Object, apptOutApp As Object
'Hier beginnen die Termine
Dim BlattName As String
Dim Zeile As Integer
Dim EmailNamen As String
BlattName = "Terminübersicht"
EmailNamen = "" 'hier können auch Termin an Emailempfänger versendet werden, Adressen mit _
Semikolon trennen
For Zeile = 2 To Sheets(BlattName).UsedRange.Rows.Count
Set OutApp = CreateObject("Outlook.Application")
Set apptOutApp = OutApp.CreateItem(1) 'olAppointmentItem
If Sheets(BlattName).Cells(Zeile, 8) > 0 Then 'Datum vorhanden
If IsEmpty(Sheets(BlattName).Cells(Zeile, 9)) = True Then 'Status ohne Wert
With apptOutApp
'Datum wird die Termine aus der Zelle genommen
.Start = Format(Sheets(BlattName).Cells(Zeile, 8), "dd.mm.yyyy") & " 08:00"
'Termininfo
.Subject = "" & Sheets(BlattName).Cells(Zeile, 7) 'Betreff
'Zusätzlicher Text
Nachricht = Sheets(BlattName).Cells(Zeile, 2) & Chr(10) 'Text aus Nachrichtenfeld
'Nachricht = Nachricht & "weiterer Text möglich"
.Body = Nachricht
'Anzeige
.display
'ort
.Location = "Ort: " & Sheets(BlattName).Cells(Zeile, 3)
'Dauer. Angabe ist jeweils in ganzen Minuten zu setzen von 8:00 bis ...
.Duration = "5"
'Erinnerung
.ReminderMinutesBeforeStart = 10
'mit Sound :-)
.ReminderPlaySound = True
'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, 9) = "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