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
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
MVP (Excel 2008-2010)
Post a workbook with sample data and layout if you want a quicker solution.
To help indent your macros try Smart Indent
Please remember to mark threads 'Solved'
[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]
You know you're really in trouble when the light at the end of the tunnel turns out to be the headlight of a train hurtling towards you
The major part of getting the right answer lies in asking the right question...
Made your code more readable, use VBA tags (this automatically inserts [vba] at the start of your code, and [/vba ] at the end of your code) | Help those helping you by marking your thread solved when it is.
That's awesome.
Is there a way to get the device name?
New to the forum? Check out our Introductions section to get to know some of the members here. Feel free to tell us a little about yourself as well.
[vba]Sub ShowInfo()Originally Posted by malik641
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]
You know you're really in trouble when the light at the end of the tunnel turns out to be the headlight of a train hurtling towards you
The major part of getting the right answer lies in asking the right question...
Made your code more readable, use VBA tags (this automatically inserts [vba] at the start of your code, and [/vba ] at the end of your code) | Help those helping you by marking your thread solved when it is.
Wicked.
You should make that a KB. Great job
New to the forum? Check out our Introductions section to get to know some of the members here. Feel free to tell us a little about yourself as well.
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.
Kind Regards,
Ivan F Moala From the City of Sails
Thanks John,
And I agree with Malik, definitely a KB submission
Regards
Malcolm
MVP (Excel 2008-2010)
Post a workbook with sample data and layout if you want a quicker solution.
To help indent your macros try Smart Indent
Please remember to mark threads 'Solved'
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]
Justin Labenne
Easily fixed...Originally Posted by Justinlabenne
[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]
You know you're really in trouble when the light at the end of the tunnel turns out to be the headlight of a train hurtling towards you
The major part of getting the right answer lies in asking the right question...
Made your code more readable, use VBA tags (this automatically inserts [vba] at the start of your code, and [/vba ] at the end of your code) | Help those helping you by marking your thread solved when it is.
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
This is confusing.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
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
MVP (Excel 2008-2010)
Post a workbook with sample data and layout if you want a quicker solution.
To help indent your macros try Smart Indent
Please remember to mark threads 'Solved'
Thank you for your prompt response mdmackillop.This is confusing.
How many zip files are in the depository? One or more?
Create one workbook? Containing all sheets from all books?
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
Once the zip is extracted in the e:\W\files_depository under a folder name based on the YYYYMM_NAME.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
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"
So i'm not really sure the USB part really apply in this case as the master excel is already inside the USB drive.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
Last edited by Frederic; 08-30-2017 at 07:23 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
MVP (Excel 2008-2010)
Post a workbook with sample data and layout if you want a quicker solution.
To help indent your macros try Smart Indent
Please remember to mark threads 'Solved'
@ 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.
I expect the student to do their homework and find all the errrors I leeve in.
Please take the time to read the Forum FAQ