Makro zum automatischen speichern auf USB

[Atlan]

Erstmal Danke, Ihr seit fantastisch.

      
 Folgendes:
eine Mappe wird, beim Abspeichern immer auf einem Server abgelegt.
Nun, versuche ich, einen 'button' einzubauen, (kleines Backup) der folgendes kann.


1)   Abfrage, welches USB-Laufwerk, Stick usw. auf diesem PC, angeschlossen und beschreibbar ist.
2)   Ausgabe in einem Fenster das dieses(e) Laufwerk(e) auswählbar macht um die offene Datei (Mappe) zu speichern.
3)   Möglichkeit den Namen, Datum mit Uhrzeit zu ändern.
Das Einzige was ich habe ist folgendes:

ActiveWorkbook.SaveAs "d:\Excel\termine " & Format(Now, "yyyy.mm.dd") & ".xlsm"

Wer kann mir einen Tipp geben oder wer hat schon mal so ein Makro geschrieben und kann mir aushelfen?

[schauan]

Hallöchen,

USB-Laufwerke könntest Du im Prinzip so ausgeben. Kann aber auch SD-Kartenleser erwischen

Code:

Sub ShowDriveList
    Dim objFSO as Object, objDrive as Object, objDrives as Object
    Dim strAll$
    'Objektzuweisung
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    Set objDrives = objFSO.Drives
    'Schleife ueber alle Laufwerke
     For Each objDrive in objDrives
       'Wenn es ein Wechseldatentraeger ist, dann
       If objDrive.DriveType = 2 Then
           'LaufwerksName  zum Ausgabestring hinzufuegen
           strAll = strAll & objDrive.DriveLetter & vblf
       'Ende Wenn es ein Wechseldatentraeger ist, dann
        End If
    'Ende Schleife ueber alle Laufwerke
    Next
    MsgBox strAll
End Sub

---

... Edit: SSD's werden auch als Wechseldatenträger erkannt.

[Atlan]

Hallo,
im Bild (Anhang) werden alle HD's aufgelistet die im PC vorhanden sind.
Mein Wunsch währe dass nur die USB Lwerke angezeigt, die Partionen-Namen erscheinen,
anwählbar sind um darauf dann die Mappe, mit Name,als xls oder xlsm und Datum mit Uhrzeit, durch einen OK klicke zu speichern sind.
Das Problem ist dass die Benutzer der Mappe, von Computer weniger verstehen als ich   und deswegen die Sache so einfach wie möglich zu gestalten ist.
Merci

[snb]

Verwende das serialnumber

Code:

Sub M_snb()
  With CreateObject("scripting.filesystemobject")
    For Each it In .drives
      If it.SerialNumber = 12345 Then Exit For
    Next
  End With
 
  MsgBox it
End Sub

[schauan]

Hallöchen,

nimm mal den DriveType 1 ...

[Atlan]

Danke Leute,
aber ich komme nicht klar.
Ich gebs auf.

[schauan]

Hallöchen,

also, 2 durch 1 zu ersetzen sollte doch nicht so schwer sein.

Code:

Sub ShowDriveList()
    Dim objFSO As Object, objDrive As Object, objDrives As Object
    Dim strAll$
    'Objektzuweisung
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    Set objDrives = objFSO.Drives
    'Schleife ueber alle Laufwerke
     For Each objDrive In objDrives
       'Wenn es ein Wechseldatentraeger ist, dann
       If objDrive.DriveType = 1 Then
           'LaufwerksName  zum Ausgabestring hinzufuegen
           strAll = strAll & objDrive.DriveLetter & " " & objDrive.rootfolder.Type & " " & objDrive.volumename & vbLf
       'Ende Wenn es ein Wechseldatentraeger ist, dann
        End If
    'Ende Schleife ueber alle Laufwerke
    Next
    MsgBox strAll
End Sub

Wenn das passt, kann man weitermachen ...

[snb]

Lass mal laufen und zeige mal das Ergebnis:

Code:

Sub M_snb()
  With CreateObject("scripting.filesystemobject")
    For Each it In .drives
      c00=c00 & vblf & it & vbtab & it.SerialNumber
    Next
  End With

  msgbox c00 
End Sub

[schauan]

@snb,

Dein Code zeigt alle Drives, mein letzter nur die Wechseldatenträger - z.B. USB-Drives, die als solche erkannt werden, also ggf. keine HD / SSD am USB-Port.
   
E ist eine SSD an USB, D und F zwei Sticks.

[snb]

@Schau

Ich berücksichtige das Serialnumber; Der TS kann uns dann sagen welche Driveletterder USB hat.

Basiert auf das Ergebnis kann man wählen welche USB benützt werden soll.
z. B D:\

Code:

Sub M_snb()
  With CreateObject("scripting.filesystemobject")
    For Each it In .drives
      If it.SerialNumber = 785958618 Then Exit For
    Next
  End With

  activeworkbook.saveas it  &  "Beispiel.xlsb",50
End Sub