Dr. Karl Haller, kha-Makrocode AM6, Teil 1
'----------------------------------------------------------------------------
Option Explicit
Option Base 1 'Indizierung hier praktischer ab 1 und nicht ab 0
'
Public TB1 As Variant 'Aktive mit eMail in TextBox1, später in Textbox8
Public TB2 As Variant 'eMail
Public TB3 As Variant 'Verstorben
Public TB6 As Variant 'BOSS
Public TB7 As Variant 'Aktive ohne Mail
Public BOSS_Eintrag As Variant
Public email As Variant
Public NameAllgemein As Variant
Public eMailListe As Variant
Public SammelNamenVerstorben As Variant
Public SammelNamenUnbekannt As Variant
Public MsgBoxTitel As Variant
Public aktiveAnzahlMitEMail As Long
Public aktiveAnzahlOhneEMail As Long
Public verstorbenAnzahl As Long
Public eMailAnzahl As Long
Public unbekanntAnzahl As Long
Public Anzahl_BOSS_Eintraege As Long
Public i As Long
Sub eMail_Liste_Erzeugen() 'Aufrufen VBA-Projekt "Tabelle1", macht aber nicht nur eMail-Liste!
'Karl Haller, Herbst 2023. Nach längerer VBA-Enthaltung wegen "Python" dieses VBA-Makro weitgehend
'mit "Künstlicher Intelligenz (KI)" realisiert, genauer mit "Bing CHAT". Ein "Dreifach-hoch" auf die KI !!!
Const iMaximaleStudentenZahl = 59
Const eMail_Trennzeichen = ";" 'Das eMail-Trennzeichen ist das Semikolon, später noch 1 Leerzeichen dazu
Const khaNamenskuerzel = "kha"
Dim Nachname As String
Dim Vorname As String
Dim Ort As String
Dim LaengeSemesterListe As Long
Dim Sterbejahr As Variant
Dim semesterListe As Worksheet: Set semesterListe = ThisWorkbook.Sheets("Tabelle1")
Dim AktuellerBOSS As String
Dim ZeNr As Long
Dim SammelNamenAktivMitEMail As String
Dim SammelNamenAktivOhneEMail As String
Dim iBoss As Long
'-------------------------------------------------
LaengeSemesterListe = semesterListe.Range("Nachname").Rows.Count 'Liefert 59, OK
Anzahl_BOSS_Eintraege = 0 'Beginn Plausbilität "BOSS"
For i = 1 To LaengeSemesterListe
ZeNr = i + 1
BOSS_Eintrag = UCase(Range("N" & ZeNr).Text) 'Spalte O=Sonstiges, Zeile i + 1
If InStr(BOSS_Eintrag, "BOSS") <> 0 Then
iBoss = i
Anzahl_BOSS_Eintraege = Anzahl_BOSS_Eintraege + 1
AktuellerBOSS = Range("C" & ZeNr).Text & " " & Range("D" & ZeNr).Text & "', eMail " & "'" & Range("E" & ZeNr).Text & "'"
End If
Next i
'
If (Anzahl_BOSS_Eintraege = 0) Then
MsgBox "Kein BOSS-Eintrag in der Spalte 'BOSS+Sonstiges'. Abbruch!", , MsgBoxTitel
End '>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> Abbruch, Ende
End If
If (Anzahl_BOSS_Eintraege > 1) Then
MsgBox "Fehler: " & Str(Anzahl_BOSS_Eintraege) & " BOSS-Einträge in der Spalte 'BOSS+Sonstiges'. " & _
"Mehr als 1 BOSS-Eintrag in dieser Spalte darf nicht sein! Abbruch!", , MsgBoxTitel
End '>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> Abbruch, Ende
End If
'------------------------------
eMailListe = "": eMailAnzahl = 0
SammelNamenAktivMitEMail = "": aktiveAnzahlMitEMail = 0
SammelNamenAktivOhneEMail = "": aktiveAnzahlOhneEMail = 0
SammelNamenVerstorben = "": verstorbenAnzahl = 0
SammelNamenUnbekannt = "": unbekanntAnzahl = 0
If email <> "" And InStr(email, "@") = 0 Then
MsgBox "Fehler: Kein Zeichen '@' in der eMail-Adresse von: " & vbCrLf & _
"'" & NameAllgemein & "'. Abbruch!", , MsgBoxTitel
End '>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> Abbruch, Ende
End If
'
For i = 1 To iMaximaleStudentenZahl
email = semesterListe.Range("eMail").Cells(i - 0).Value
Sterbejahr = Range("B" & i + 1).Text 'Es muss so die originale Spalte "B" angesprochen werden
Sterbejahr = Trim(Sterbejahr)
Sterbejahr = UCase(Sterbejahr)
'If Status = " " Then Status = ""
If Trim(email) <> "" And Sterbejahr = "" Then
eMailListe = eMailListe & email & "; " '!!!!!! Mit 1 nachstehendem Leerzeichen !!!!!!!!!!!!!
eMailAnzahl = eMailAnzahl + 1
End If
Nachname = semesterListe.Range("Nachname").Cells(i + 1).Value
Nachname = Range("C" & i + 1).Text
Vorname = semesterListe.Range("Vorname").Cells(i + 0).Value
Ort = semesterListe.Range("Ort").Cells(i).Value
NameAllgemein = Str(i) & " " & Nachname & " " & Vorname
If email <> "" And InStr(email, "@") = 0 Then
MsgBox "Fehler: Kein Zeichen '@' in der eMail-Adresse von: " & vbCrLf & _
"'" & NameAllgemein & "'. Abbruch!", , MsgBoxTitel
End '>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> Abbruch, Ende
End If
If (Anzahl_BOSS_Eintraege > 1) Then
MsgBox "Fehler: " & Str(Anzahl_BOSS_Eintraege) & " BOSS-Einträge in der Spalte 'O=Sonstiges'. " & _
"Mehr als 1 BOSS-Eintrag in dieser Spalte darf nicht sein! Abbruch!", , MsgBoxTitel
End '>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> Abbruch, Ende
End If
If Sterbejahr = "" Then
If email <> "" Then
SammelNamenAktivMitEMail = SammelNamenAktivMitEMail & NameAllgemein & ", " & Ort & Chr(10) 'vbNewLine
aktiveAnzahlMitEMail = aktiveAnzahlMitEMail + 1
Else
SammelNamenAktivOhneEMail = SammelNamenAktivOhneEMail & NameAllgemein & ", " & Ort & Chr(10) 'vbNewLine
aktiveAnzahlOhneEMail = aktiveAnzahlOhneEMail + 1
End If
End If
If Sterbejahr <> "" Then
SammelNamenVerstorben = SammelNamenVerstorben & NameAllgemein & ", " & Range("B" & i + 1).Text & vbCrLf
verstorbenAnzahl = verstorbenAnzahl + 1
End If
Next i
'--------------------------------------------------------------------
TB1 = SammelNamenAktivMitEMail
TB2 = eMailListe
TB3 = SammelNamenVerstorben
AktuellerBOSS = "?????? ???"
TB6 = "Vom BOSS: '" & AktuellerBOSS & "':" & vbCr & _
"Das ist die dank eines Excel-Makro-Programms etwas modernisierte Verwaltung unserer Semesterliste " & _
"AM6 vom Balthasar-Neumann-Polytechnikum Würzburg, mit Abschluß im Jahre 1961. " & _
"Herzlichen Dank an Helbring Schültz für die jahrzehntelange Pflege der bisherigen Listen. " & vbCr & _
"Das Makro-Programm wurde von kha mit Unterstützung durch die 'Künstliche Intelligenz (KI)' generiert. Bitte sorgfältig prüfen " & _
"und Unstimmigkeiten an den BOSS melden."
TB7 = SammelNamenAktivOhneEMail
eMailListe = Left(eMailListe, Len(eMailListe) - 2) '1 Leerzeichen und 1 Semikolon am Ende entfernen
'----------------------------------------------------------------------------
Dim objCP As Object 'Den String "emailListe" in die Zwischenablage kopieren
Set objCP = CreateObject("HtmlFile")
objCP.ParentWindow.ClipboardData.SetData "text", eMailListe
End Sub 'von "Sub eMail_Liste_Erzeugen()"
Dr. Karl Haller, kha-Makrocode AM6, Teil 2
Private Sub Workbook_Open()
Application.ScreenUpdating = False
'Tabelle1.Visible = xlSheetHidden
Call kha_Start
End Sub
Private Sub kha_Start()
Call Tabelle1.eMail_Liste_Erzeugen
'
UserForm1_AM6.Caption = "Semesterliste AM6-1961, Balthasar-Neumann Polytechnikum, Würzburg" & String(60, " ") & "Druck-Datum " & Date & ", kha"
UserForm1_AM6.TextBox8.Text = Tabelle1.TB1 'MsgBox_3a 'Aktiv mit eMail'
'MsgBox "In Arbeitsmappe, Zeil 13: " & vbCrLf & Tabelle1.TB1
UserForm1_AM6.TextBox2.Text = Tabelle1.TB2 'MsgBox_2a 'eMails
UserForm1_AM6.TextBox3.Text = Tabelle1.TB3 'MsgBox_4a 'Verstorben
'UserForm1_AM6.TextBox4.Text = Tabelle1.TB4 'MsgBox_5a '"Daten fehlen", gelöscht, da durch neue Organisation überflüssig. kha, 01.12.2023
UserForm1_AM6.TextBox6.Text = Tabelle1.TB6 'MsgBox_6a 'BOSS
UserForm1_AM6.TextBox7.Text = Tabelle1.TB7 'MsgBox_7a 'Aktiv ohne eMail
'
UserForm1_AM6.Label4 = "Verstorben: " & Tabelle1.verstorbenAnzahl
UserForm1_AM6.Label5 = "Daten fehlen: " & Tabelle1.unbekanntAnzahl
UserForm1_AM6.Label8 = "Alle Ausgaben auf dieser Seite sind Auszüge aus der aktuellen Excel-Makro-Datei '" & ActiveWorkbook.Name & _
"', Druck-Datum siehe oben rechts. Diese Datei enthält in Form einer Tabelle mit 14 Spalten alle Informationen der " & _
"aktuellen Semesterliste, die in kompresser Form auf einer einzigen DIN-A4-Seite darstellbar ist und " & _
"ersetzt die neun Seiten des Adressverzeichnisses vom 25.10.2021." & _
vbCrLf & vbCrLf & "Die folgende automatisch generierte eMail-Sammelliste mit " & _
Str(Tabelle1.eMailAnzahl) & " eMail-Adressen steht bereits in der Windows-Zwischenablage und kann mit 'Strg+V' direkt in das 'An'-Feld des eMail-Programms eingefügt werden. Man störe sich nicht an " & _
"den Zeilenumbrüchen; im 'An'-Feld des eMail-Programms ist alles OK."
UserForm1_AM6.Label9 = "Mit eMail: " & Tabelle1.aktiveAnzahlMitEMail
UserForm1_AM6.Label10 = "Die Nummern vor den Namen sind die Zeilennummern in der aktuellen Excel-Datei '" & ActiveWorkbook.Name & "'"
UserForm1_AM6.Label12 = "Ohne eMail: " & Tabelle1.aktiveAnzahlOhneEMail
UserForm1_AM6.Label9 = "Mit eMail: " & Tabelle1.aktiveAnzahlMitEMail
'UserForm1_AM6.Label13 = "Vergößerung mit Klick in das Bild"
UserForm1_AM6.Show
End Sub
Dr. Karl Haller, kha-Makrocode AM6, Teil 3, Formulare
private Sub CommandButton6_Click()
UserForm5.Caption = "Semesterliste AM6-1961, Balthasar-Neumann Polytechnikum, Würzburg" & String(5, " ") & _
"Druck-Datum " & Date & ", kha"
UserForm5.Show 'Das gute alte Poly...
End Sub
Private Sub CommandButton7_Click()
MsgBox "Noch frei"
End Sub
Private Sub CommandButton8_Click() 'Tom, Dr. Thomas Treml
UserForm3.Caption = "Semesterliste AM6-1961, Balthasar-Neumann Polytechnikum, Würzburg" & String(5, " ") & _
"Druck-Datum " & Date & ", kha" '
UserForm3.Show 'Der legendäre Tom, OK, bis auf die zwangsweise abgekürzte Caption
End Sub
Private Sub CommandButton9_Click()
UserForm4.Caption = "Semesterliste AM6-1961, Balthasar-Neumann Polytechnikum, Würzburg" & String(15, " ") & _
"Druck-Datum " & Date & ", kha"
UserForm4.Show 'Unser gutes alte Poly .....
End Sub
Private Sub Image1_BeforeDragOver(ByVal Cancel As MSForms.ReturnBoolean, _
ByVal Data As MSForms.DataObject, ByVal X As Single, ByVal Y As Single, ByVal DragState As MSForms.fmDragState, ByVal Effect As MSForms.ReturnEffect, ByVal Shift As Integer)
'Me.Image1.Picture = "AM6-Semesterfoto-groß.jpg"
UserForm2.Image1.Picture = LoadPicture(ThisWorkbook.Path & "\AM4-Semesterfoto 1960 mit Nummern und Vierfach-Liste.jpg")
UserForm2.Show
End Sub
Private Sub Image1_Click() 'Dss große Semesterfoto in der Userform2, nach Mausklick auf das kleine Bild im Hauptmenü
UserForm2.Caption = "Semesterliste AM6-1961, Balthasar-Neumann Polytechnikum, Würzburg" & String(18, " ") & _
String(18, " ") & _
"Druck-Datum " & Date & ", kha" 'Erst nach Freigabe "???" durch "kha" ersetzen
UserForm2.Show
End Sub
kha: UserForm2 enthält unser Semesterfoto mit Klick auf Vergrößerung
kha: UserForm3 enthält das Bild vom Dr. Thomas Treml
kha: UserForm4 enthält die Liste unserer Dozenten
kha: UserForm5 enthält das Bild vom Eingang zu unserem Poly