Liebes Forum!
Ich sitze schon länger an einem VBA- Projekt und möchte es teilweise verbessern!
Nur leider bin ich auch noch ein bisschen ein Anfänger! Den Code hab ich aus einem Forum bekommen und hab ihn etwas angepasst und verändert. Nur leider funktioniert manches nicht so! z.B dass er mir im E-Mail Text einfach die ersten paar Zeilen nicht schreibt.
Könnt ihr mal kurz darüber schauen, ob ich etwas falsch mache?
Hier der Code:
Option Explicit
Option Compare Text
Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" ( _
ByVal lpClassName As String, ByVal lpWindowName As String) As LongPtr
Private Declare PtrSafe Function PostMessage Lib "user32" Alias "PostMessageA" ( _
ByVal hwnd As LongPtr, ByVal wMsg As Long, ByVal wParam As LongPtr, _
ByVal lParam As LongPtr) As Long
Private Declare PtrSafe Function GetWindow Lib "user32" (ByVal hwnd As LongPtr, ByVal wCmd As Long) As LongPtr
Private Declare PtrSafe Function GetWindowTextLength Lib "user32" Alias "GetWindowTextLengthA" ( _
ByVal hwnd As LongPtr) As Long
Private Declare PtrSafe Function GetWindowText Lib "user32" Alias "GetWindowTextA" ( _
ByVal hwnd As LongPtr, ByVal lpString As String, _
ByVal cch As Long) As Long
Private Declare PtrSafe Function GetForegroundWindow Lib "user32" () As LongPtr
Private Const WM_CLOSE = &H10
Dim hwnd As LongPtr
Private Const GW_HWNDFIRST = 0
Private Const GW_HWNDNEXT = 2
Sub SendeMail()
'Sendet Monatlich eine E-Mail mit einem Textinhalt über den aktuellen Notenstand
Dim WSh As Worksheet
Dim sText As String, L As Long, sClass As String * 128
Dim Mailtext_2 As String
Dim Mailtext_1 As String
Dim objOutlook As Object
Dim objEmail As Object
Dim Mail As Object
Dim Kontrolle_0 As Date
Dim Kontrolle_1 As Date
Dim Kontrolle_2 As Date
Dim Kontrolle_3 As Date
Dim Kontrolle_4 As Date
Dim Kontrolle_5 As Date
Dim Kontrolle_6 As Date
Dim Kontrolle_7 As Date
Dim Kontrolle_8 As Date
Dim Kontrolle_9 As Date
Calculate
Set WSh = ThisWorkbook.Sheets("3AHET") 'Blatt mit Maildaten
Set objOutlook = CreateObject("Outlook.Application") 'E-Mail-Erstellung
Set objEmail = objOutlook.CreateItem(0) 'Neue E-Mail öffnen
Set Mail = objEmail
Kontrolle_0 = DateSerial(2020, 9, 30) 'Kontrollen(Datume) definieren
Kontrolle_1 = DateSerial(2020, 10, 12)
Kontrolle_2 = DateSerial(2020, 11, 18)
Kontrolle_3 = DateSerial(2020, 12, 31)
Kontrolle_4 = DateSerial(2021, 1, 31)
Kontrolle_5 = DateSerial(2021, 2, 28)
Kontrolle_6 = DateSerial(2021, 3, 31)
Kontrolle_7 = DateSerial(2021, 4, 30)
Kontrolle_8 = DateSerial(2021, 5, 31)
Kontrolle_9 = DateSerial(2021, 6, 30)
If Date = Kontrolle_0 Then 'Datum kontrollieren
GoTo Weiter
End If
If Date = Kontrolle_1 Then 'Datum kontrollieren
GoTo Weiter
End If
If Date = Kontrolle_2 Then 'Datum kontrollieren
GoTo Weiter
End If
If Date = Kontrolle_3 Then 'Datum kontrollieren
GoTo Weiter
End If
If Date = Kontrolle_4 Then 'Datum kontrollieren
GoTo Weiter
End If
If Date = Kontrolle_5 Then 'Datum kontrollieren
GoTo Weiter
End If
If Date = Kontrolle_6 Then 'Datum kontrollieren
GoTo Weiter
End If
If Date = Kontrolle_7 Then 'Datum kontrollieren
GoTo Weiter
End If
If Date = Kontrolle_8 Then 'Datum kontrollieren
GoTo Weiter
End If
If Date = Kontrolle_9 Then 'Datum kontrollieren
GoTo Weiter
End If
Exit Sub
'Weiter zur den E-Mail-Versendung
Weiter:
Shell "C:\Program Files\Microsoft Office\root\Office16\OUTLOOK" 'Outlook öffnen
'Schreibe die E-Mail Texte (max. 25 Zeilenumbrüche - &Chr(13)& or &Chr(10)& - Für nächste Zeile: Abstand _ )
Mailtext_2 = "Mathematik: " & Chr(13) & _
"Prozentstand: " & WSh.Range("AK14").Value & Chr(13) & _
"Note: " & WSh.Range("AN14").Value & Chr(13) & _
Chr(13) & _
"Energiesysteme: " & Chr(13) & _
"Prozentstand: " & WSh.Range("AK16").Value & Chr(13) & _
"Note: " & WSh.Range("AN16").Value & Chr(13) & _
Chr(13) & _
"Automatisierungstechnik: " & Chr(13) & _
"Prozentstand: " & WSh.Range("AK18").Value & Chr(13) & _
"Note: " & WSh.Range("AN18").Value & Chr(13) & _
Chr(13) & _
"Antriebtechnik: " & Chr(13) & _
"Punktestand: " & WSh.Range("AJ20").Value & Chr(13) & _
"Note: " & WSh.Range("AN20").Value & Chr(13) & _
Chr(13) & _
"CPE: " & Chr(13) & _
"Prozentstand: " & WSh.Range("AK22").Value & Chr(13) & _
"Note: " & WSh.Range("AN22").Value
Mailtext_1 = "Geografie: " & Chr(13) & _
"Prozentstand: " & WSh.Range("AK24").Value & Chr(13) & _
"Note: " & WSh.Range("AN24").Value & Chr(13) & _
Chr(13) & _
"Geschichte: " & Chr(13) & _
"Prozentstand: " & WSh.Range("AK26").Value & Chr(13) & _
"Note: " & WSh.Range("AN26").Value & Chr(13) & _
Chr(13) & _
"Industrieelektronik: " & Chr(13) & _
"Prozentstand: " & WSh.Range("AK28").Value & Chr(13) & _
"Note: " & WSh.Range("AN28").Value & Chr(13) & _
Chr(13) & _
"Naturwissenschaften: " & Chr(13) & _
"Punktestand: " & WSh.Range("AJ32").Value & Chr(13) & _
"Note: " & WSh.Range("AN32").Value & Chr(13) & _
Chr(13) & _
"Informatik: " & Chr(13) & _
"Prozentstand: " & WSh.Range("AK40").Value & Chr(13) & _
"Note: " & WSh.Range("AN40").Value
'E-Mail schreiben
With objEmail
Mail.To = "180178@studierende.htl-donaustadt.at"
Mail.Subject = "Noteninfo"
Mail.Body = "Aktueller Notenstand HTBLA22" & Chr(13) & _
Mailtext_2 & Mailtext_1
Mail.Display
Mail.send
End With
'Warteschleife um E-Mail zu senden
Application.Wait Now + TimeSerial(0, 0, 15) 'wartet 15 Sekunden
'E-Mail versendet!!!
'Alle Fenster durchscannen, um Outlook zu finden
hwnd = GetWindow(GetForegroundWindow(), GW_HWNDFIRST)
Do While hwnd <> 0
L = GetWindowTextLength(hwnd) + 1
sText = Space$(L)
L = GetWindowText(hwnd, sText, L)
If sText Like "Post*Outlook*" Then
PostMessage hwnd, WM_CLOSE, 0&, 0& 'Outlook schließen
Exit Sub
End If
DoEvents
hwnd = GetWindow(hwnd, GW_HWNDNEXT) 'Handle des nächsten Fensters
Loop
End Sub
Wäre echt super wenn ihr mi helfen könnt!
Vielen Dank im Voraus!
Ich sitze schon länger an einem VBA- Projekt und möchte es teilweise verbessern!
Nur leider bin ich auch noch ein bisschen ein Anfänger! Den Code hab ich aus einem Forum bekommen und hab ihn etwas angepasst und verändert. Nur leider funktioniert manches nicht so! z.B dass er mir im E-Mail Text einfach die ersten paar Zeilen nicht schreibt.
Könnt ihr mal kurz darüber schauen, ob ich etwas falsch mache?
Hier der Code:
Option Explicit
Option Compare Text
Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" ( _
ByVal lpClassName As String, ByVal lpWindowName As String) As LongPtr
Private Declare PtrSafe Function PostMessage Lib "user32" Alias "PostMessageA" ( _
ByVal hwnd As LongPtr, ByVal wMsg As Long, ByVal wParam As LongPtr, _
ByVal lParam As LongPtr) As Long
Private Declare PtrSafe Function GetWindow Lib "user32" (ByVal hwnd As LongPtr, ByVal wCmd As Long) As LongPtr
Private Declare PtrSafe Function GetWindowTextLength Lib "user32" Alias "GetWindowTextLengthA" ( _
ByVal hwnd As LongPtr) As Long
Private Declare PtrSafe Function GetWindowText Lib "user32" Alias "GetWindowTextA" ( _
ByVal hwnd As LongPtr, ByVal lpString As String, _
ByVal cch As Long) As Long
Private Declare PtrSafe Function GetForegroundWindow Lib "user32" () As LongPtr
Private Const WM_CLOSE = &H10
Dim hwnd As LongPtr
Private Const GW_HWNDFIRST = 0
Private Const GW_HWNDNEXT = 2
Sub SendeMail()
'Sendet Monatlich eine E-Mail mit einem Textinhalt über den aktuellen Notenstand
Dim WSh As Worksheet
Dim sText As String, L As Long, sClass As String * 128
Dim Mailtext_2 As String
Dim Mailtext_1 As String
Dim objOutlook As Object
Dim objEmail As Object
Dim Mail As Object
Dim Kontrolle_0 As Date
Dim Kontrolle_1 As Date
Dim Kontrolle_2 As Date
Dim Kontrolle_3 As Date
Dim Kontrolle_4 As Date
Dim Kontrolle_5 As Date
Dim Kontrolle_6 As Date
Dim Kontrolle_7 As Date
Dim Kontrolle_8 As Date
Dim Kontrolle_9 As Date
Calculate
Set WSh = ThisWorkbook.Sheets("3AHET") 'Blatt mit Maildaten
Set objOutlook = CreateObject("Outlook.Application") 'E-Mail-Erstellung
Set objEmail = objOutlook.CreateItem(0) 'Neue E-Mail öffnen
Set Mail = objEmail
Kontrolle_0 = DateSerial(2020, 9, 30) 'Kontrollen(Datume) definieren
Kontrolle_1 = DateSerial(2020, 10, 12)
Kontrolle_2 = DateSerial(2020, 11, 18)
Kontrolle_3 = DateSerial(2020, 12, 31)
Kontrolle_4 = DateSerial(2021, 1, 31)
Kontrolle_5 = DateSerial(2021, 2, 28)
Kontrolle_6 = DateSerial(2021, 3, 31)
Kontrolle_7 = DateSerial(2021, 4, 30)
Kontrolle_8 = DateSerial(2021, 5, 31)
Kontrolle_9 = DateSerial(2021, 6, 30)
If Date = Kontrolle_0 Then 'Datum kontrollieren
GoTo Weiter
End If
If Date = Kontrolle_1 Then 'Datum kontrollieren
GoTo Weiter
End If
If Date = Kontrolle_2 Then 'Datum kontrollieren
GoTo Weiter
End If
If Date = Kontrolle_3 Then 'Datum kontrollieren
GoTo Weiter
End If
If Date = Kontrolle_4 Then 'Datum kontrollieren
GoTo Weiter
End If
If Date = Kontrolle_5 Then 'Datum kontrollieren
GoTo Weiter
End If
If Date = Kontrolle_6 Then 'Datum kontrollieren
GoTo Weiter
End If
If Date = Kontrolle_7 Then 'Datum kontrollieren
GoTo Weiter
End If
If Date = Kontrolle_8 Then 'Datum kontrollieren
GoTo Weiter
End If
If Date = Kontrolle_9 Then 'Datum kontrollieren
GoTo Weiter
End If
Exit Sub
'Weiter zur den E-Mail-Versendung
Weiter:
Shell "C:\Program Files\Microsoft Office\root\Office16\OUTLOOK" 'Outlook öffnen
'Schreibe die E-Mail Texte (max. 25 Zeilenumbrüche - &Chr(13)& or &Chr(10)& - Für nächste Zeile: Abstand _ )
Mailtext_2 = "Mathematik: " & Chr(13) & _
"Prozentstand: " & WSh.Range("AK14").Value & Chr(13) & _
"Note: " & WSh.Range("AN14").Value & Chr(13) & _
Chr(13) & _
"Energiesysteme: " & Chr(13) & _
"Prozentstand: " & WSh.Range("AK16").Value & Chr(13) & _
"Note: " & WSh.Range("AN16").Value & Chr(13) & _
Chr(13) & _
"Automatisierungstechnik: " & Chr(13) & _
"Prozentstand: " & WSh.Range("AK18").Value & Chr(13) & _
"Note: " & WSh.Range("AN18").Value & Chr(13) & _
Chr(13) & _
"Antriebtechnik: " & Chr(13) & _
"Punktestand: " & WSh.Range("AJ20").Value & Chr(13) & _
"Note: " & WSh.Range("AN20").Value & Chr(13) & _
Chr(13) & _
"CPE: " & Chr(13) & _
"Prozentstand: " & WSh.Range("AK22").Value & Chr(13) & _
"Note: " & WSh.Range("AN22").Value
Mailtext_1 = "Geografie: " & Chr(13) & _
"Prozentstand: " & WSh.Range("AK24").Value & Chr(13) & _
"Note: " & WSh.Range("AN24").Value & Chr(13) & _
Chr(13) & _
"Geschichte: " & Chr(13) & _
"Prozentstand: " & WSh.Range("AK26").Value & Chr(13) & _
"Note: " & WSh.Range("AN26").Value & Chr(13) & _
Chr(13) & _
"Industrieelektronik: " & Chr(13) & _
"Prozentstand: " & WSh.Range("AK28").Value & Chr(13) & _
"Note: " & WSh.Range("AN28").Value & Chr(13) & _
Chr(13) & _
"Naturwissenschaften: " & Chr(13) & _
"Punktestand: " & WSh.Range("AJ32").Value & Chr(13) & _
"Note: " & WSh.Range("AN32").Value & Chr(13) & _
Chr(13) & _
"Informatik: " & Chr(13) & _
"Prozentstand: " & WSh.Range("AK40").Value & Chr(13) & _
"Note: " & WSh.Range("AN40").Value
'E-Mail schreiben
With objEmail
Mail.To = "180178@studierende.htl-donaustadt.at"
Mail.Subject = "Noteninfo"
Mail.Body = "Aktueller Notenstand HTBLA22" & Chr(13) & _
Mailtext_2 & Mailtext_1
Mail.Display
Mail.send
End With
'Warteschleife um E-Mail zu senden
Application.Wait Now + TimeSerial(0, 0, 15) 'wartet 15 Sekunden
'E-Mail versendet!!!
'Alle Fenster durchscannen, um Outlook zu finden
hwnd = GetWindow(GetForegroundWindow(), GW_HWNDFIRST)
Do While hwnd <> 0
L = GetWindowTextLength(hwnd) + 1
sText = Space$(L)
L = GetWindowText(hwnd, sText, L)
If sText Like "Post*Outlook*" Then
PostMessage hwnd, WM_CLOSE, 0&, 0& 'Outlook schließen
Exit Sub
End If
DoEvents
hwnd = GetWindow(hwnd, GW_HWNDNEXT) 'Handle des nächsten Fensters
Loop
End Sub
Wäre echt super wenn ihr mi helfen könnt!
Vielen Dank im Voraus!