Gedruckt von, Erweiterung?

Informationen und Beispiele zu den hier genannten Dialog-Elementen:
MsgBox
Bild

Betrifft: Gedruckt von, Erweiterung?
von: Bernd
Geschrieben am: 16.11.2015 06:42:37

Wunderschönen guten Morgen!
Ich habe da mal zwei Fragen, ob nachstehender Code veränderbar ist.
Hier mein jetziger Code, welchen ich auch hier erhalten habe:

Private Sub Workbook_BeforePrint(Cancel As Boolean)
Dim PZ As Range
Dim UserN$, UserId$, UserPc$
On Error GoTo Fehler
UserN = Application.UserName
UserId = Environ("Username")
UserPc = Environ("Computername")
Set PZ = ActiveSheet.Range("A51") 'Zielzelle
With PZ
 If TypeName(ActiveSheet) = "Worksheet" Then
  If InStr(.Value, "gedruckt von: ") > 0 Then
   If MsgBox("Das aktuelle Tabelleblatt wurde bereits " & vbCrLf & .Value _
& " ," & vbCrLf & vbCrLf & "soll es noch einmal gedruckt werden?", vbYesNo Or vbExclamation Or  _
vbDefaultButton1, "Bereits gedruckt") = vbNo Then
    Cancel = True
   Else
    .Value = "gedruckt von: " & UserN & " / " & UserId & " am PC " & UserPc
   End If
  Else
   Application.EnableEvents = False 'unterbindet das ChangeEvent
   'ActiveSheet.Unprotect Password:="abc" 'wenn Passwort verwendet wurde
   .Value = "gedruckt von: " & UserN & " / " & UserId & " am PC " & UserPc
   'ActiveSheet.Protect Password:="abc"
   Application.EnableEvents = True ' Events wieder einschalten
  End If
 End If
End With
Err.Clear
Fehler:
If Err.Number <> 0 Then MsgBox "Fehler: " & Err.Number & vbLf & Err.Description: Err.Clear
End Sub
Meine Fragen wären, wenn das Blatt gedruckt wurde, wird dies ja am Blatt, in Zelle A51 vermerkt (wer das Blatt von wo aus gedruckt hat).
Wenn es erneut gedruckt wird, wird die Zelle A51 überschrieben.
Ist es möglich, nach jedem erneuten Drucken, dies fortlaufend einzutragen?
Also nach dem ersten Druck in Zelle A51, nach dem zweiten Druck in Zelle A52 usw.
Meine zweite Frage, ist es möglich zuzüglich zu den Informationen wer gedruckt hat, auch das Datum und die Uhrzeit mit einzutragen?
Da meine VBA Kenntnisse nur begrenzt sind, würde ich um dementsprechende Änderung meines o.a. Codes bitten, falls dies machbar ist.
Ich Danke schon mal im Voraus und wünsche jeden einen schönen Wochenstart,
mfg Bernd

Bild

Betrifft: AW: Gedruckt von, Erweiterung?
von: fcs
Geschrieben am: 16.11.2015 11:13:46
Hallo Bernd,
mit folgenden Anpassungen sollte es funktionieren. Das Format von Datum/Uhrzeit kannst du noch anpassen.

Private Sub Workbook_BeforePrint(Cancel As Boolean)
    Dim PZ As Range
    Dim UserN$, UserId$, UserPc$
    Dim bolPrint As Boolean
    On Error GoTo Fehler
    UserN = Application.UserName
    UserId = Environ("Username")
    UserPc = Environ("Computername")
    Set PZ = ActiveSheet.Range("A51") 'Zielzelle
        
    If TypeName(ActiveSheet) = "Worksheet" Then
        bolPrint = True
        If InStr(PZ.Value, "gedruckt von: ") > 0 Then
            Do Until PZ.Offset(1, 0) = ""
                Set PZ = PZ.Offset(1, 0)
            Loop
            If MsgBox("Das aktuelle Tabelleblatt wurde bereits " & vbCrLf & PZ.Value _
                & " ," & vbCrLf & vbCrLf & "soll es noch einmal gedruckt werden?", _
                vbYesNo + vbExclamation + vbDefaultButton1, _
                "Bereits gedruckt") = vbNo Then
                    bolPrint = False
            Else
                Set PZ = PZ.Offset(1, 0)
            End If
        End If
        If bolPrint = True Then
            Application.EnableEvents = False 'unterbindet das ChangeEvent
            'ActiveSheet.Unprotect Password:="abc" 'wenn Passwort verwendet wurde
            PZ.Value = "gedruckt von: " & UserN & " / " & UserId & " am PC " _
                & UserPc & Format(Now, " YYYY-MM-DD hh:mm:ss")
            'ActiveSheet.Protect Password:="abc"
            Application.EnableEvents = True ' Events wieder einschalten
        Else
            Cancel = True
        End If
    End If
    Err.Clear
Fehler:
    If Err.Number <> 0 Then MsgBox "Fehler: " & Err.Number & vbLf & Err.Description: Err.Clear
End Sub
Gruß
Franz

Bild

Betrifft: AW: Gedruckt von, Erweiterung?
von: Bernd
Geschrieben am: 16.11.2015 11:20:18
Hallo Franz!
recht herzlichen Dank für Deine Mühe, es funktioniert Einwandfrei wie gewünscht.
Alles Gute weiterhin und liebe Grüße,
Bernd

Bild

Betrifft: prüfzelle möglich?
von: Thomas
Geschrieben am: 16.11.2015 13:43:04
Hallo Franz,
würdest Du noch zusätzlich die Zelle B51 als Prüfzelle mit einarbeiten?
So das die abfrage ob es nochmal gedruckt werden soll, nur dann kommt wenn die Prüfzelle sich
nicht verändert hat?
Ich weiss einfach noch nicht wo ich dies einarbeiten müsste.
hab schon mal recht vielen dank dafür
liebe grüsse thomas

Bild

Betrifft: AW: prüfzelle möglich?
von: fcs
Geschrieben am: 17.11.2015 16:54:25
Hallo Thomas alias Bernd
nach folgend ein angepasstes Makro.
Damit der Prüfwert verglichen werden Kann muss er in eine andere Zelle geschrieben werdenm, wenn gedruckt wird. Ich hab dafür die Zelle unterhalb von B51 gewählt (B52).
Gruß
Franz

Private Sub Workbook_BeforePrint(Cancel As Boolean)
    Dim PZ As Range, PZ2 As Range
    Dim UserN$, UserId$, UserPc$
    Dim bolPrint As Boolean
    On Error GoTo Fehler
    UserN = Application.UserName
    UserId = Environ("Username")
    UserPc = Environ("Computername")
    Set PZ = ActiveSheet.Range("A51") 'Zielzelle
    Set PZ2 = ActiveSheet.Range("B51") 'Prüfzelle
    If TypeName(ActiveSheet) = "Worksheet" Then
        bolPrint = True
        If InStr(PZ.Value, "gedruckt von: ") > 0 Then
            Do Until PZ.Offset(1, 0) = ""
                Set PZ = PZ.Offset(1, 0)
            Loop
            If PZ2.Value = PZ2.Offset(1, 0).Value Then
                If MsgBox("Das aktuelle Tabelleblatt wurde bereits " & vbCrLf & PZ.Value _
                    & " ," & vbCrLf & vbCrLf & "soll es noch einmal gedruckt werden?", _
                    vbYesNo + vbExclamation + vbDefaultButton1, _
                    "Bereits gedruckt") = vbNo Then
                        bolPrint = False
                Else
                    Set PZ = PZ.Offset(1, 0)
                End If
            Else
                Set PZ = PZ.Offset(1, 0)
            End If
        End If
        If bolPrint = True Then
            Application.EnableEvents = False 'unterbindet das ChangeEvent
            'ActiveSheet.Unprotect Password:="abc" 'wenn Passwort verwendet wurde
            PZ.Value = "gedruckt von: " & UserN & " / " & UserId & " am PC " _
                & UserPc & Format(Now, " YYYY-MM-DD hh:mm:ss")
            PZ2.Offset(1, 0).Value = PZ2.Value
            'ActiveSheet.Protect Password:="abc"
            Application.EnableEvents = True ' Events wieder einschalten
        Else
            Cancel = True
        End If
    End If
    Err.Clear
Fehler:
    If Err.Number <> 0 Then MsgBox "Fehler: " & Err.Number & vbLf & Err.Description: Err.Clear
End Sub


Bild

Betrifft: super besten dank an fcs
von: Thomas
Geschrieben am: 17.11.2015 19:04:01
Hallo Franz,
vielen vielen dank dafür damit komme ich super klar.
liebe grüsse thomas

Bild

Betrifft: @ fcs --> also da hat sich....
von: Bernd
Geschrieben am: 18.11.2015 05:51:46
Guten Morgen Franz,
doch jemand sehr stark geirrt! Denn dieser Beitrag bzw. die Frage dazu kam von mir, und ich bin Bernd aus dem wunderschönen Kärnten am Wörthersee! Bin auch seit Jahren hier als User angemeldet, helfe wo ich kann, Frage aber auch gerne ma, wenn ich nicht weiter komme.
Ergo, Thomas hat anscheinend diesen Thread mitgelesen und sich den Code für sich runterkopiert.
Dann wünsche ich noch einen schönen Tag und liebe Grüße,
B E R N D

Bild

Betrifft: AW: @ fcs --> also da hat sich....
von: Thomas
Geschrieben am: 18.11.2015 18:41:59
Hallo,
der Strolch war ich. Ich hoffe das ich nichts falsch gemacht habe.
Ich konnte das gerade gut für meine Datei gebrauchen.
sorry wenn ich Verwirrung gestiftet habe.
liebe grüsse thomas

Bild

Betrifft: AW: @ fcs --> also da hat sich....
von: fcs
Geschrieben am: 18.11.2015 21:02:26
Hallo Thomas,
der Strolch war ich. Ich hoffe das ich nichts falsch gemacht habe.

Du hast halt nur nicht angedeutet, dass du Zweit-Nutzer meiner Anwort bist, dann hätte auf das "alias Bernd" verzichtet.
Manche User sind hier -aus welchen Gründen auch immer- mit mehreren Usernamen unterwegs. Da kann ich mir das "alias" nicht immer verkneifen.
Gruß
Franz

 Bild

Beiträge aus den Excel-Beispielen zum Thema "Gedruckt von, Erweiterung?"