Tabelle nur einmal speichern

Moin zusammen,
Weiß nicht ob der Betreff richtig ist, Ich habe diesen Code:
Option Explicit
Declare


Function GetVolumeInformationA Lib "kernel32" _
(ByVal lpRootPathName As String, _
ByVal lpVolumeNameBuffer As String, _
ByVal nVolumeNameSize As Long, _
lpVolumeSerialNumber As Long, _
lpMaximumComponentLength As Long, _
lpFileSystemFlags As Long, _
ByVal lpFileSystemNameBuffer As String, _
ByVal nFileSystemNameSize As Long) As Long

Sub Festplatte_und_UserName_speichern() 'speichern unter Workbook BeforeClose
Dim SerialNumber As Long
Dim Username As String
GetVolumeInformationA "C:\", vbNullString, 0, SerialNumber, _
0, 0, vbNullString, 0
Sheets("Daten").Range("B2") = SerialNumber 'ließt Festplattennummer aus
Sheets("Daten").Range("C2") = Application.Username   ' ließt Username aus
End Sub


 


Sub Festplatte_und_UserName_lesen() 'speichern unter Workbook Open
Dim SerialNumber As Long
Dim Username As String
Dim Text As String
Dim A As String
GetVolumeInformationA "C:\", vbNullString, 0, SerialNumber, _
0, 0, vbNullString, 0
Sheets("Daten").Range("D2") = SerialNumber 'ließt Festplattennummer aus
Sheets("Daten").Range("E2") = Application.Username   ' ließt Username aus
If Sheets("Daten").Range("B2") = Sheets("Daten").Range("D2") And Sheets("Daten").Range("C2") = Sheets("Daten").Range("E2") Then
Sheets("Daten").Range("D2,E2").Delete
Else
Text = "Du versuchst diese Tabelle auf einem anderen Rechner zu öffnen!!!"
Text = Text & vbCrLf & "Dieses geht NICHT!!!"
Text = Text & vbCrLf & ""
Text = Text & "Diese Tabelle kann nur da geöffnet werden wo sie das erste mal geöffnet wurde."
Text = Text & vbCrLf & vbCrLf & "Diese Tabelle wird nun geschlossen."
A = MsgBox(Text, vbOKOnly + vbExclamation)
'ThisWorkbook.Close
End If
End Sub


Nun wollte ich mit diesem Code erreichen das der Username und die Festplattennummer gespeichert wird dieses geht ja auch. Wenn mann nun die Tabelle schließt

(hier z.B. wird mein Name und meine Nummer) gespeichert,öffne ich nun die Tabelle auf einem anderen Rechner kommt natürlich die Fehlermeldung und die Tabelle wird geschlossen

(ist aber noch aus) so soll es ja auch sein.Öffnet man aber nun diese Tabelle ein zweites mal schreibt es natürlich die neue Nummer und den Namen rein und mann kann wieder mit arbeiten.

Wie bekomme ich das nun hin das man die Tabelle nur jeweils einmal öffnen kann (auf ca.15 Rechnern)? 

Der Username und Nummer schreibt sich dabei ein,kann es sein das man die Tabelle nur einmal speichern darf oder die Daten beim schließen wieder löschen muß?

Ich hoffe das ihr verstanden habt wie ich es meine.

Gruß Rene

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Function GetVolumeInformationA Lib "kernel32" _ (ByVal lpRootPathName As String, _ ByVal lpVolumeNameBuffer As String, _ ByVal nVolumeNameSize As Long, _ lpVolumeSerialNumber As Long, _ lpMaximumComponentLength As Long, _ lpFileSystemFlags As Long, _ ByVal lpFileSystemNameBuffer As String, _ ByVal nFileSystemNameSize As Long) As Long 'Der Code ist völlig unnötig Sub Festplatte_und_UserName_speichern() 'speichern unter Workbook BeforeClose Dim SerialNumber As Long Dim Username As String Dim chkWks As Worksheet Set chkWks = Worksheets("Daten") GetVolumeInformationA "C:\", vbNullString, 0, SerialNumber, 0, 0, vbNullString, 0 With chkWks If IsEmpty(.Range("B2")) And IsEmpty(.Range("D2")) Then .Range("B2") = SerialNumber 'Das taugt nix zur Prüfung 'weil es von jedem User unter "Extras - Optionen" geändert werden kann .Range("D2") = Application.Username End If End With End Sub 'Bis hier '******************************* Sub Festplatte_und_UserName_lesen() 'speichern unter Workbook Open Dim SerialNumber As Long Dim Username As String Dim Text As String Dim A As String Dim chkWks As Worksheet Set chkWks = Worksheets("Daten") GetVolumeInformationA "C:\", vbNullString, 0, SerialNumber, 0, 0, vbNullString, 0 With chkWks If IsEmpty(.Range("B2")) And IsEmpty(.Range("D2")) Then .Range("B2") = SerialNumber 'Das taugt nix zur Prüfung 'weil es von jedem User unter "Extras - Optionen" geändert werden kann .Range("D2") = Application.Username 'Gleich speichern ThisWorkbook.Save True Else If SerialNumber <> .Range("B2") Then Text = "Du versuchst diese Tabelle auf einem anderen Rechner zu öffnen!!!" Text = Text & vbCrLf & "Dieses geht NICHT!!!" Text = Text & vbCrLf & "" Text = Text & "Diese Tabelle kann nur da geöffnet werden wo sie das erste mal geöffnet wurde." Text = Text & vbCrLf & vbCrLf & "Diese Tabelle wird nun geschlossen." A = MsgBox(Text, vbOKOnly + vbExclamation) 'Aktivieren 'ThisWorkbook.Close End If End With End Sub Das Worksheet("Daten") muss natürlich mit VBA auf "xlVeryHidden" gesetzt werden und das VB-Projekt geschützt werden. Ein Zugriff auf die Tabelle ohne aktivierte Makros muss natürlich ebenso verhindert werden, ansonsten der ganze Code hier völlig sinnlos ist. "....Wie bekomme ich das nun hin das man die Tabelle nur jeweils einmal öffnen kann (auf ca.15 Rechnern)? ..." Schreib die Festplattennmummern in die Spalte B, prüfe bei jedem öffnen ob die Anzahl der eingetragenen Festplattennummern kleiner 16 ist und das wars dann. Gruss Rainer

Sub Festplatte_und_UserName_lesen() 'speichern unter Workbook Open Dim SerialNumber As Long Dim Username As String Dim Text As String Dim A As String Dim chkWks As Worksheet Set chkWks = Worksheets("Daten") GetVolumeInformationA "C:\", vbNullString, 0, SerialNumber, 0, 0, vbNullString, 0 With chkWks If IsEmpty(.Range("B2")) And IsEmpty(.Range("D2")) Then .Range("B2") = SerialNumber 'Das taugt nix zur Prüfung 'weil es von jedem User unter "Extras - Optionen" geändert werden kann .Range("D2") = Application.Username 'Gleich speichern ThisWorkbook.Save Else If SerialNumber <> .Range("B2") Then Text = "Du versuchst diese Tabelle auf einem anderen Rechner zu öffnen!!!" Text = Text & vbCrLf & "Dieses geht NICHT!!!" Text = Text & vbCrLf & "" Text = Text & "Diese Tabelle kann nur da geöffnet werden wo sie das erste mal geöffnet wurde." Text = Text & vbCrLf & vbCrLf & "Diese Tabelle wird nun geschlossen." A = MsgBox(Text, vbOKOnly + vbExclamation) 'Aktivieren 'ThisWorkbook.Close End If End If End With End Sub

Hi Rainer,
Konnte es doch nicht bis heute Abend abwarten,habe es probiert und so geht es prima.
Das mit dem Namen habe ich zwar erst nicht verstanden,habe es dann aber auch gefunden.
Das mit den Tabellen ist so: Ich gebe in meiner Firma die Tabelle(als Beispiel 15 mal)an verschiedene Benutzer weiter.Jeder öffnet nun diese Tabelle auf seinem Rechner das erstemal und nun tritt ja dein Code in Aktion mann kann also diese Tabelle auch nur noch auf dem Rechner öffnen wo man sie das erste mal geöffnet hat.(Wenn man sich denkt jetzt habe ich die Tabelle nun kann ich sie mir kopieren und auch auf einem anderen Rechner öffnen,geht aber nicht weil ja die Festplattennummer gespeichert ist.)Aber nun hätte ich doch nochmal eine Frage, wenn ich nun diese Tabelle als "halber" Programmierer auf meinem Rechner selber öffnen will(kann ja immer mal sein) würde dieses ja auch nicht gehen,da die Tabelle ja gleich wieder schließt wie könnte ich denn das damit einbauen das ich z.B. ein Kennwort eingebe und ich dann trotzdem die Tabelle öffnen kann? Hättest du da ein Idee?
Gruß Rene

Beliebteste Forumthreads (12 Monate)

8
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

309 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Tabelle nur einmal speichern

8 Beiträge zum Forumthread Beiträge zu diesem Forumthread

309 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

8
Beiträge zum Forumthread

Beiträge zu diesem Forumthread