USB Port prüfen und Dateiübertragung auf USB Stick

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Sub DriveTypeAndList() Dim objDrv As Object Dim strMsg As String For Each objDrv In CreateObject("Scripting.FileSystemObject").Drives Select Case objDrv.DriveType Case 0: strMsg = strMsg & vbNewLine & objDrv.DriveLetter & ": Unknown" Case 1: strMsg = strMsg & vbNewLine & objDrv.DriveLetter & ": Removable Drive" Case 2: strMsg = strMsg & vbNewLine & objDrv.DriveLetter & ": Hard Disk Drive" Case 3: strMsg = strMsg & vbNewLine & objDrv.DriveLetter & ": Network Drive" Case 4: strMsg = strMsg & vbNewLine & objDrv.DriveLetter & ": CDROM Drive" Case 5: strMsg = strMsg & vbNewLine & objDrv.DriveLetter & ": RAM Disk Drive" End Select Next Set objDrv = Nothing MsgBox strMsg, vbInformation, "Excel Experts Tip" End Sub

Option Explicit Private WithEvents EvtCls As SWbemSink Private o As WbemScripting.SWbemServices Private Sub EvtCls_OnObjectReady(ByVal objWbemObject As WbemScripting.ISWbemObject, ByVal _ objWbemAsyncContext As WbemScripting.ISWbemNamedValueSet) Dim sOut As String With objWbemObject Select Case .Path_.Class Case "__InstanceCreationEvent": Me.Text2 = .TargetInstance.Caption & " hinzugefügt _ am/um " & Now Case "__InstanceDeletionEvent": Me.Text2 = .TargetInstance.Caption & " entfernt am/ _ um " & Now End Select End With End Sub Private Sub Form_Load() If o Is Nothing Then Set o = CreateObject("winmgmts:{impersonationLevel=Impersonate}!\\" & "." & "\root\ _ CIMV2") Set EvtCls = New WbemScripting.SWbemSink o.ExecNotificationQueryAsync EvtCls, "SELECT * FROM __InstanceOperationEvent WITHIN 1 _ WHERE TargetInstance ISA 'Win32_LogicalDisk'" '" 'Win32_VolumeChangeEvent" End If End Sub

Hi Marvin,
ich habe vllt eine Lösung
hier gefunden: http://www.office-loesung.de/ftopic637137_0_0_asc.php
Dafür ist es aber erforderlich, dass dein USB-Stick eine Datei enthalten muss, die auf sonst keinem Laufwerk enthalten ist.
Enthält also dein Stick - immer - eine Datei mit - immer - dem gleichen Dateinamen, die nur auf dem Stick gespeichert ist? (das wäre die eindeutigste Lösung)
Wenn auf dem Stick immer unterschiedliche Dateien gespeichert sind, dann versuch es mal so:
1. Verbinde den Stick mit deinem Computer
2. Erstell auf dem Stick im Root-Verzeichnis eine neue Textdatei mit dem Namen USB_Stick_ist_hier.txt
Groß-/Kleinschreibung des Dateinamens ist egal.
Die Datei muss auch keinen Inhalt haben; Dateigröße = 0KB ist ok.
3. Lade meine Bsp-Datei runter https://www.herber.de/bbs/user/120324.xlsm
4. Starte das Makro mit dem Namen a
Wenn du von 1. - 4. alles richtig gemacht hast, erscheint eine MsgBox mit dem Text:
"Es wurde ein USB-Stick mit dem Laufwerksbuchstaben Laufwerk:\erkannt"
Anstelle von Laufwerk:\ erscheint natürlich der Buchstabe, der deinem Stick vom System zugewiesen wurde.
So, das alles ist nun erst mal "meine Vorrede" :-)
Wenn alles so funktioniert, wie von mir beschrieben (wie schon erwähnt, am besten wäre, der Stick enthält immer eine Datei mit dem gleichen Namen), dann werde ich in meiner nächsten Antwort eine Bsp-Datei erstellen, die, abhängig davon, ob der Stick angeschlossen ist oder nicht, einen CommandButton enthält, der dir schon vorm Anklicken anzeigt, ob der Stick angeschlossen ist oder nicht.
Ciao erst mal
Thorsten

Hallo Marvin,
so prüfst du, ob ein Stick eingesteckt wurde und kannst den entfernen lassen:

Code in Zwischenablage:

'UserForm mit Label1 und CommandButton1
Private Sub UserForm_Activate()
Dim objWMIService As Object, colMonitoredEvents As Object, objLatestEvent As Object
Set objWMIService = GetObject("winmgmts:{impersonationLevel=impersonate}!\\.\root\cimv2")
Set colMonitoredEvents = objWMIService.ExecNotificationQuery("Select * from Win32_VolumeChangeEvent")
With Me.CommandButton1
.Caption = "Stick auswerfen und Ende"
.Enabled = False
End With
With Me.Label1
.BackColor = vbRed
.Caption = "kein Stick"
'warten bis ein Stick eingesteckt wurde
Do
DoEvents
Set objLatestEvent = colMonitoredEvents.NextEvent
Loop Until objLatestEvent.EventType = 2
'Laufwerksbuchstabe vom Stick anzeigen
.Caption = objLatestEvent.DriveName
.BackColor = vbGreen
End With
Me.CommandButton1.Enabled = True
End Sub
Private Sub CommandButton1_Click()
Dim fso As Object, l As Object
'Stick auswerfen
CreateObject("Shell.Application").Namespace(17).ParseName(Me.Label1.Caption).InvokeVerb ("Eject")
Set fso = CreateObject("Scripting.FileSystemObject")
Set l = fso.GetDrive(Me.Label1.Caption)
Do: DoEvents: Loop Until Not l.IsReady
Set fso = Nothing
'Userform schließen
Unload Me
End Sub

Wie man die Dateien kopiert, kannst du hier nachschauen.
mfg Anton

Beliebteste Forumthreads (12 Monate)

USB Port prüfen und Dateiübertragung auf USB Stick

26
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

USB Port prüfen und Dateiübertragung auf USB Stick

26 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

26
Beiträge zum Forumthread

Beiträge zu diesem Forumthread