Solved: Drive letters for Devices with Removable Storage

[mdmackillop]

Hi all,
In My Computer, "Hard Drives" and "Devices with Removable Storage" are listed in separate sections. Is it possible to return only the drive letters for the latter using VBA?
Regards
MD

[johnske]

[VBA]Option Explicit
'
Sub ShowDriveLetter()
'
Dim Drive As Object, MyDrives As String
'
For Each Drive In CreateObject("Scripting.FileSystemObject").Drives
If Drive.DriveType <> 2 Then '< DriveType 2 is the hard drive
MyDrives = Drive & vbNewLine & MyDrives
End If
Next
'
MsgBox MyDrives
'
End Sub[/VBA]

[malik641]

That's awesome.


Is there a way to get the device name?

[johnske]

That's awesome.


Is there a way to get the device name?

[vba]Sub ShowInfo()
ShowDriveInfo ("D:")
End Sub
'
Sub ShowDriveInfo(DrivePath As String)
'
Dim FSO As Object, Drive As Object, Info As String, DriveType As String
'
Set FSO = CreateObject("Scripting.FileSystemObject")
Set Drive = FSO.GetDrive(DrivePath)
'
Select Case Drive.DriveType
Case 0: DriveType = "Unknown"
Case 1: DriveType = "Removable"
Case 2: DriveType = "Fixed"
Case 3: DriveType = "Network"
Case 4: DriveType = "CD-ROM"
Case 5: DriveType = "RAM Disk"
End Select
'
Info = "Drive " & Drive.DriveLetter & ": " & DriveType & vbNewLine & _
"Name: " & Drive.VolumeName
'
If Drive.IsReady Then
Info = Info & vbNewLine & "Drive is Ready."
Else
Info = Info & vbNewLine & "Drive is not Ready."
End If
'
MsgBox Info
'
End Sub[/vba]

[malik641]

Wicked.

You should make that a KB. Great job

[Ivan F Moala]

The problem with that code is that, now a days you can get Removable drives connected via USB ports, so the function will report it as a 'Fixed' Drive. The type of drive is correct BUT it is also a removable drive. You can get this via WMI.

[mdmackillop]

Thanks John,
And I agree with Malik, definitely a KB submission
Regards
Malcolm

[Justinlabenne]

This line crashes for me if I don't have a cd in the drive

[VBA] Info = "Drive " & Drive.DriveLetter & ": " & DriveType & vbNewLine & _
"Name: " & Drive.VolumeName[/VBA]


Ivan may have a different method, but this is the version I use with WMI:

[VBA]Option Explicit

Public Sub ListDriveInformation()
Dim oWMIService As Object
Dim oItem As Object
Dim oQuery As Object
Dim sComputer As String
Dim sDriveType As String
Dim sDiskSize As String
Dim sDisk As String

sComputer = "."
On Error Resume Next
Set oWMIService = GetObject("winmgmts:\\" & sComputer & "\root\cimv2")
Set oQuery = oWMIService.ExecQuery("Select * from Win32_LogicalDisk")

For Each oItem In oQuery
Select Case oItem.DriveType
Case 1
sDriveType = "Drive could not be determined."
Case 2
sDriveType = "Removable Drive"
Case 3
sDriveType = "Local hard disk."
Case 4
sDriveType = "Network disk."
Case 5
sDriveType = "Compact disk (CD)"
Case 6
sDriveType = "RAM disk."
Case Else
sDriveType = "Drive type Problem."
End Select

If oItem.DriveType = 2 Then
sDiskSize = Int(oItem.Size / 1048576) & " Mega Bytes"
Else
sDiskSize = Int(oItem.Size / 1073741824) & " GB"
End If

sDisk = sDisk & vbCrLf & "Drive Letter: " & oItem.Name & vbCrLf & _
"Drive Type : " & sDriveType & vbCrLf & _
"Disk Size : " & sDiskSize & vbCrLf & "Free Space : " _
& Int(oItem.FreeSpace / 1073741824) & " GB" & vbCrLf & _
"- - - - - - - - - - - - -"
Next oItem

Set oQuery = Nothing
Set oWMIService = Nothing

MsgBox sDisk
End Sub[/VBA]

[johnske]

This line crashes for me if I don't have a cd in the drive

[vba] Info = "Drive " & Drive.DriveLetter & ": " & DriveType & vbNewLine & _
"Name: " & Drive.VolumeName[/vba]

Easily fixed...
[vba]Option Explicit
'
Sub ShowMoreDriveInfo()
'
On Error GoTo ErrMsg
ShowAllDriveInfo ("D:")
'
Exit Sub
'
ErrMsg:
MsgBox Err.Description
End Sub
'
'
Sub ShowAllDriveInfo(DriveName As String)
'
Dim Drive As Object, Info As String, DriveTypeIs As String
'
Set Drive = CreateObject("Scripting.FileSystemObject").GetDrive(DriveName)
'
Select Case Drive.DriveType
Case 0: DriveTypeIs = "Unknown"
Case 1: DriveTypeIs = "Removable"
Case 2: DriveTypeIs = "Fixed"
Case 3: DriveTypeIs = "Network"
Case 4: DriveTypeIs = "CD-ROM"
Case 5: DriveTypeIs = "RAM Disc"
End Select
'
If Drive.VolumeName = Empty Then Drive.VolumeName = "(None)"
Info = "Drive " & Drive.DriveLetter & ": " & vbnewline & _
"Drive Type: " & DriveTypeIs & vbnewline & _
"Drive Name: " & Drive.VolumeName & vbnewline & _
"Total Size: " & FormatNumber(Drive.TotalSize / 1024, 0) & " Kbytes" & vbnewline & _
"Available Space: " & FormatNumber(Drive.AvailableSpace / 1024, 0) & " Kbytes"
'
If Drive.IsReady Then Info = Info & vbnewline & "Drive " & Drive.DriveLetter & " is Ready."
'
MsgBox Info
'
Set Drive = Nothing
'
End Sub
[/vba]

[Frederic]

Hi VBAexpress community,

This is my first post here as I'm getting more in depth with VBA in Excel.
I'm currently trying to develop a model that manages daily downloaded spreadsheets extracted from a database.
I would need to find a similar VBA to the one below this post, which could let any user plugin the USB drive, launch the worksheet with a macro to open the zip_depository and extract the .zip in inside the file_depository, and create a new workbook containing all unzipped workbook inside the patched_depository

Since the key will be used by different people, they will therefore not share the same USB port, so at first I would need to have a VBA which looks for the drive based on the name of the drive named (e:\W\) and where the master .xlsm is located, and the depository folders are located, such as: (e:\W\zip_depository\)

Has anyone came across a similar outcome ? Does this sounds feasible ?

Thank you in advance for the help that you can give me.

Fred

Easily fixed...
[vba]Option Explicit
'
Sub ShowMoreDriveInfo()
'
On Error GoTo ErrMsg
ShowAllDriveInfo ("D:")
'
Exit Sub
'
ErrMsg:
MsgBox Err.Description
End Sub
'
'
Sub ShowAllDriveInfo(DriveName As String)
'
Dim Drive As Object, Info As String, DriveTypeIs As String
'
Set Drive = CreateObject("Scripting.FileSystemObject").GetDrive(DriveName)
'
Select Case Drive.DriveType
Case 0: DriveTypeIs = "Unknown"
Case 1: DriveTypeIs = "Removable"
Case 2: DriveTypeIs = "Fixed"
Case 3: DriveTypeIs = "Network"
Case 4: DriveTypeIs = "CD-ROM"
Case 5: DriveTypeIs = "RAM Disc"
End Select
'
If Drive.VolumeName = Empty Then Drive.VolumeName = "(None)"
Info = "Drive " & Drive.DriveLetter & ": " & vbnewline & _
"Drive Type: " & DriveTypeIs & vbnewline & _
"Drive Name: " & Drive.VolumeName & vbnewline & _
"Total Size: " & FormatNumber(Drive.TotalSize / 1024, 0) & " Kbytes" & vbnewline & _
"Available Space: " & FormatNumber(Drive.AvailableSpace / 1024, 0) & " Kbytes"
'
If Drive.IsReady Then Info = Info & vbnewline & "Drive " & Drive.DriveLetter & " is Ready."
'
MsgBox Info
'
Set Drive = Nothing
'
End Sub
[/vba]

[mdmackillop]

launch the worksheet with a macro to open the zip_depository and extract the .zip in inside the file_depository, and create a new workbook containing all unzipped workbook inside the patched_depository

This is confusing.
How many zip files are in the depository? One or more?
Create one workbook? Containing all sheets from all books?

For the USB part, give this a try

Option Explicit

Sub ShowDriveLetter()
    Dim Drive As Object, Dr As String
    Dim dict
    Set dict = CreateObject("Scripting.Dictionary")
    For Each Drive In CreateObject("Scripting.FileSystemObject").Drives
        dict.Add Drive, vbNullString
    Next
    MsgBox "Insert USB.  OK when done."
    For Each Drive In CreateObject("Scripting.FileSystemObject").Drives
        If Not dict.Exists(Drive) Then
            Dr = Drive
            Exit For
        End If
    Next
    Call DoStuff(Dr)
End Sub


Sub DoStuff(Dr As String)
    MsgBox Dr
End Sub

[Frederic]

This is confusing.
How many zip files are in the depository? One or more?
Create one workbook? Containing all sheets from all books?

Thank you for your prompt response mdmackillop.

So here is the idea:

You plug in the usb drive and open the master excel (e:\W\data_extractor.xlsm)

The user will then drop off the desired .zip in the the e:\W\zip_depository. (There could be one, or could be many and depends how many zip does the user need to extract.)
Each .zip will contain contains 4 .CSV worksheet.
i.e.
- YYYYMM_NAME_contracts.CSV
- YYYYMM_NAME_ident.CSV
- YYYYMM_NAME_indexPub.CSV
- YYYYMM_NAME_transactions.CSV

I would need a vba command that allows the user to open the e:\W\zip_depository and select the .zip desired for data extraction.

Code: Ron de Bruin's code

Sub Unzip1()
    Dim FSO As Object
    Dim oApp As Object
    Dim Fname As Variant
    Dim FileNameFolder As Variant
    Dim DefPath As String
    Dim strDate As String


    Fname = Application.GetOpenFilename(filefilter:="Zip Files (*.zip), *.zip", _
                                        MultiSelect:=true)
    If Fname = False Then
 
    Else
        DefPath = "e:\files_depository"
        If Right( DefPath, 1) <> "\" Then
            DefPath = DefPath & "\"
        End If


        'I still have issue changing the name of the folder according to the name of the extraction file
        strDate = Format(Now, " yyyy-mm ")
        FileNameFolder = DefPath & "Name " & strDate & "\"


        MkDir FileNameFolder


        Set oApp = CreateObject("Shell.Application")


        oApp.Namespace(FileNameFolder).CopyHere oApp.Namespace(Fname).items


        MsgBox "You find the files here: " & FileNameFolder


        On Error Resume Next
        Set FSO = CreateObject("scripting.filesystemobject")
        FSO.deletefolder Environ("Temp") & "e:\zip_depository", True
    End If
End Sub

Once the zip is extracted in the e:\W\files_depository under a folder name based on the YYYYMM_NAME.

Then I would need a following command that binds these 4 .CSV into one workbook inside the e:\W\patched_depository\YYYYMM_NAME\YYYYMM_NAME.xlsx

I hope this gives you a clear overview of the structure.

So this is why I ultimately need the to have the master excel to look for a drive named "W" instead looking for USB port "e" as not every user will have the usb port under "e"

For the USB part, give this a try
Option Explicit

Sub ShowDriveLetter()
Dim Drive As Object, Dr As String
Dim dict
Set dict = CreateObject("Scripting.Dictionary")
For Each Drive In CreateObject("Scripting.FileSystemObject").Drives
dict.Add Drive, vbNullString
Next
MsgBox "Insert USB. OK when done."
For Each Drive In CreateObject("Scripting.FileSystemObject").Drives
If Not dict.Exists(Drive) Then
Dr = Drive
Exit For
End If
Next
Call DoStuff(Dr)
End Sub


Sub DoStuff(Dr As String)
MsgBox Dr
End Sub

So i'm not really sure the USB part really apply in this case as the master excel is already inside the USB drive.

[mdmackillop]

Option Explicit

Sub Unzip1()
    'Modified from https://www.rondebruin.nl/win/s7/win002.htm
    Dim FSO As Object
    Dim oApp As Object
    Dim Fname As Variant
    Dim FileNameFolder As Variant
    Dim DefPath As String
    Dim strDate As String
    Dim Pth As String
    Dim f As Variant
    Dim fld As String
    Dim TgtNameFolder As String
    
    Fname = Application.GetOpenFilename(filefilter:="Zip Files (*.zip), *.zip", _
    MultiSelect:=False)
    Application.ScreenUpdating = False
    Pth = Left(Fname, InStr(4, Fname, "\"))
    If Fname = False Then
        'Do nothing
    Else
        'Root folder for the new folder.
        DefPath = Pth
        If Right(DefPath, 1) <> "\" Then
            DefPath = DefPath & "\"
        End If
        
        'Create the folder name
        FileNameFolder = DefPath & "tmp" & "\"
        'Make the normal folder in DefPath
        On Error Resume Next
        MkDir FileNameFolder
        On Error GoTo 0
        
        'Create the targetfolder name
        TgtNameFolder = DefPath & "patched_depository" & "\"
        'Make the normal folder in DefPath
        On Error Resume Next
        MkDir TgtNameFolder
        On Error GoTo 0
        
        'Extract the files into the newly created tmp folder
        Set oApp = CreateObject("Shell.Application")
        oApp.Namespace(FileNameFolder).CopyHere oApp.Namespace(Fname).items
        
        'Create folder based on filename
        f = Split(Dir(DefPath & "tmp" & "\*.csv"), "_")
        fld = f(0) & "_" & f(1)


        'Make the target folder in DefPath
        On Error Resume Next
        MkDir TgtNameFolder & fld
        On Error GoTo 0
        Call DoStuff(fld, DefPath & "tmp", TgtNameFolder & fld)
        
        
        On Error Resume Next
        Set FSO = CreateObject("scripting.filesystemobject")
        FSO.deletefolder Left(FileNameFolder, Len(FileNameFolder) - 1), True
    End If
    
    Application.ScreenUpdating = True
    Shell "Explorer.exe " & TgtNameFolder, vbNormalFocus
End Sub




Sub DoStuff(fld, tmp, Pth)
    Dim wb As Workbook, csv As Workbook, f
    Set wb = Workbooks.Add
    wb.SaveAs Filename:=Pth & "\" & fld & ".xlsx", FileFormat:=xlOpenXMLWorkbook
    
    f = Dir(tmp & "\*.csv")
    Do
        Set csv = Workbooks.Open(Filename:=tmp & "\" & f)
        csv.Sheets(1).Copy after:=wb.Sheets(wb.Sheets.Count)
        csv.Close False
        Kill tmp & "\" & f 'CSV
        ActiveSheet.Name = Split(Split(f, "_")(2), ".")(0)
        f = Dir
    Loop Until f = ""
    
    Application.DisplayAlerts = False
    wb.Sheets(1).Delete
    wb.Close True
    Application.DisplayAlerts = False
End Sub

[SamT]

@ Frederic,
Since this thread is now marked SOLVED, I am closing it because of it's age, (2006.) If you need it reopened, please contact any Moderator by PM.