PDA

View Full Version : Solved: Drive letters for Devices with Removable Storage



mdmackillop
06-06-2006, 03:11 PM
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
06-06-2006, 06:10 PM
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:)

malik641
06-06-2006, 06:20 PM
That's awesome.


Is there a way to get the device name?

johnske
06-06-2006, 07:06 PM
That's awesome.


Is there a way to get the device name?
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

malik641
06-06-2006, 07:15 PM
Wicked.

You should make that a KB. Great job :thumb

Ivan F Moala
06-06-2006, 10:44 PM
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
06-06-2006, 11:40 PM
Thanks John,
And I agree with Malik, definitely a KB submission
Regards
Malcolm

Justinlabenne
06-08-2006, 04:34 AM
This line crashes for me if I don't have a cd in the drive

Info = "Drive " & Drive.DriveLetter & ": " & DriveType & vbNewLine & _
"Name: " & Drive.VolumeName


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

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

johnske
06-08-2006, 06:20 AM
This line crashes for me if I don't have a cd in the drive

Info = "Drive " & Drive.DriveLetter & ": " & DriveType & vbNewLine & _
"Name: " & Drive.VolumeNameEasily fixed... :)
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

Frederic
08-30-2017, 03:13 AM
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... :)
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

mdmackillop
08-30-2017, 04:39 AM
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
08-30-2017, 05:14 AM
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
08-30-2017, 07:30 AM
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
08-30-2017, 08:17 AM
@ 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.