Brauchen Sie Hilfe?
Web:     Online-Formular
E-Mail:  
Diese E-Mail-Adresse ist vor Spambots geschützt! Zur Anzeige muss JavaScript eingeschaltet sein!
Tel:       +49(0)151 / 164 55 914

Nutzen Sie für Ihre Anfrage unser Online-Formular oder senden Sie uns eine E-Mail an Diese E-Mail-Adresse ist vor Spambots geschützt! Zur Anzeige muss JavaScript eingeschaltet sein!. Gerne können Sie aber auch direkt telefonisch Kontakt aufnehmen.

   
     Referenzen
 Bosch 
  T-Systems
  Hagebau
  Siemens
 Areva  VW
 Haufe-Lexware  British American Tobacco
  nagel group farbe
   

Makro kann nur von einem bestimmten USB-Stick aus gestartet werden

In diesem Beitrag zeige ich Ihnen einen Möglichkeit, wie sichergestellt werden kann, dass ein Makro nur von einem bestimmten USB-Stick aus gestartet werden kann.

Dazu wird die Seriennummer des USB-Sticks ausgelesen und mit der im VBA-Code hinterlegten Seriennummer verglichen. Der eigentliche Programmcode wird entsprechend nur ausgeführt, wenn die im Code hinterlegte Seriennummer mit der aktuell  ausgelesenen Seriennummer übereinstimmt. In alllen anderen Fällen wird das Programm mit einer Hinweismeldung beendet.

Kopieren Sie bitte den folgenden VBA-Code in ein Modulblatt und starten Sie die Prozedur USB_ID_auslesen.

'** Berechtigte Seriennummer festlegen
Const id = 682590861

Sub USB_ID_auslesen()
'** Dimensionierung der Variablen
Dim objFSO, objLaufwerk, strLaufwerk As String, USB_ID$

'** Vorgaben festlegen
Set objFSO = CreateObject("Scripting.FileSystemObject")

'** Errorhandling
On Error GoTo ende

'** Seriennumemr auslesen
For Each objLaufwerk In objFSO.Drives
  If objLaufwerk.IsReady Then
    If objLaufwerk.DriveType = "1" Then USB_ID = objLaufwerk.SerialNumber
  End If
Next objLaufwerk
   
If USB_ID = id Then
  '** Wenn Seriennummer übereinstimmt - weitere Prozeduren ausführen
  Weiterer_Code
Else
  '** Wenn Seriennummer nicht übereinstimmt - Abbrechen
  MsgBox "Das Programm wird nicht weiter ausgeführt, da es sich um keinen gültigen USB-Stick handelt.", _
    vbCritical, "Hinweis"
End If

'** Programmende
ende:
   Set objFSO = Nothing
End Sub

In der ersten Programmzeile "Const id = 682590861" befindet sich die Seriennummer, die für eine gültige Programmausführung erwartet wird. Nur wenn die später im Programm ausgelesene USB_ID mit der angegebenen id übereinstimmt, wird das eigentliche VBA-Programm ausgeführt.

Der folgende VBA-Code enthält dann das eigentliche Makro, welches nur dann ausgeführt wird, wenn die Seriennummern übereinstimmen.

Sub Weiterer_Code()

'** Dieser Code wird nur dann ausgeführt, wenn die Seriennummer des USB-Sticks
'** mit der angegebenen Seriennummer übereinstimmt
MsgBox "Der Code wird ausgeführt!"

End Sub

Damit die Seriennummer im Programm hinterlegt werden kann, muss diese zuerst einmal ausgelesen werden. Dazu gibt es verschiedene kostenlose Tools wie beispielsweise das Programm List USB Drives. Alternativ kann aber auch der leicht abgewandelte VBA-Code verwendet werden, der die Seriennummer in einer Message-Box ausgibt, siehe Listing:

Sub USB_ID_einmalig_auslesen()
'** Dimensionierung der Variablen
Dim objFSO, objLaufwerk, strLaufwerk As String, USB_ID$

'** Vorgaben festlegen
Set objFSO = CreateObject("Scripting.FileSystemObject")

'** Errorhandling
On Error GoTo ende

'** Seriennumemr auslesen
For Each objLaufwerk In objFSO.Drives
  If objLaufwerk.IsReady Then
    If objLaufwerk.DriveType = "1" Then USB_ID = objLaufwerk.SerialNumber
  End If
Next objLaufwerk
   
'** Seriennummer auslesen
MsgBox "Die Seriennummer des USB-Sticks lautet wie folgt: " & USB_ID

'** Programmende
ende:
   Set objFSO = Nothing
End Sub

Die Beispieldatei können Sie über den folgenden Link herunterladen.

   

Relevante Artikel

  • Funktion zur gleichzeitigen Addition und Multiplikation

    112017 Diese Funktion addiert die beiden angegebenen Wert und multipliziert sie in diesem Fall mit 2! In der Tabelle ist einfach folgendes einzugeben:=summemult(a1;a3)Public Function summemult(Wert1, Wert2)    summemult = (CDbl(Wert1) + CDbl(Wert2)) * 2End FunctionDieser Code ist...

  • Diagramm-Skalierung per VBA ändern

    Excel skaliert die Größenachse (Y-Achse) bei einem Diagramm standardmäßig automatisch. Natürlich kann der Maxi- und Min-Wert auch manuell für das Diagramm vorgegeben werden. Dieses Beispiel zeigt,...

  • VBA Passwort über ein VBA-Makro automatisch aufheben

    In diesem Beitrag erfahren Sie, wie per VBA-Makro ein mit Passwort gesichertes VBA-Makro automatisch entsperrt werden kann. Es geht nicht darum, den VBA-Schutz zu haken. Bei der vorgestellten...

  • Online-Status prüfen

    Dieses Beispiel zeigt, wie sich der Online-Status per VBA überprüfen lässt. Mit Hilfe des Codes wird geprüft, ob der Computer mit dem Internet verbunden ist oder nicht und gibt eine entsprechende...

  • IBAN in Excel ermitteln - Neue Funktion

    Am 01.02.2014 tritt SEPA für alle Euro-Mitgliedsstaaten endgültig in Krafft. Zu diesem Zeitpunkt müssen alle bargeldlosen Zahlungen im EURO-Raum im SEPA-Format durchgeführt werden. SEPA steht für Single...

   

Excel-Inside auf Facebook Excel-Live News blog Excel-Inside RSS-Feed Twitter Account für Excel-Inside Mail an Excel-Inside 

Programmierung
Excel Auftragsprogrammierung Access Auftragsprogrammierung
Word Auftragsprogrammierung Outlook Auftragsprogrammierung
   
Unsere Produkte
Office Schulungen VBA, Excel, Access
E-Book Formeln und Funktionen Excel 2013