Определение доступного диска

[MoHoMaXFR]

Здраствуйте. Как задать VBA определение доступного диска? Так как на компе много разделов но админка например диск С для использование в профиле запуска программы соотвецтвенно мы не можем просто задать путь сохранения файла на определённый диск. а как научить вба находить исользующийся диск и выводить надпись о том что этот диск доступен

[MoHoMaXFR]

или как это обойти

[IgorGO]

а что надо?
найти все диски используемые системой?
найти первую свободную букву?

Sub bb()
  On Error Resume Next
  For i = 97 To 122
    ChDir Chr(i) & ":\"
    If Err.Number = 0 Then MsgBox Chr(i) Else Err.Clear
  Next
End Sub

[Alex_ST]

Попробуйте так:

Sub List_MyPC_Drives()   ' создать новую книгу и вывести на лист инфо о всех дисках компьютера
   Dim Arr(): Arr = Application.Transpose(Array("DriveLetter", "DriveType", "IsReady", "VolumeName", "TotalSize", "AvailableSpace", "SerialNumber"))  ' заголовки в первом столбце массива
   Dim DRVtype(): DRVtype = Array("UnKnown", "Removable", "HDD", "Network", "CD/DVD", "RAM")
   Dim DRV
   Dim i%: i = 2   ' начать заполнять массив со второго столбца (в первом - заголовки)
   On Error Resume Next
   For Each DRV In CreateObject("Scripting.FileSystemObject").Drives
      ReDim Preserve Arr(1 To 7, 1 To i)
      Arr(1, i) = DRV.DriveLetter
      Arr(2, i) = DRVtype(DRV.DriveType)
      Arr(3, i) = IIf(DRV.IsReady, "Ready", "Not Ready")
      If DRV.IsReady Then
         Arr(4, i) = DRV.VolumeName
         Arr(5, i) = DRV.TotalSize
         Arr(6, i) = DRV.AvailableSpace
         Arr(7, i) = Hex$(DRV.SerialNumber)
      End If
      i = i + 1
   Next DRV
   Application.Workbooks.Add
   Cells(1, 1).Resize(UBound(Arr, 2), UBound(Arr, 1)).ClearContents
   Cells(1, 1).Resize(UBound(Arr, 2), UBound(Arr, 1)).Value = Application.Transpose(Arr)
End Sub

[Alex_ST]

А если не нужен вывод в новую книгу, то можно короче:

Sub List_of_Drives()   ' инфо о жёстких дисках компьютера
   Dim DRV: Const DriveType = 2   '0-"UnKnown", 1-"Removable", 2-"HDD", 3-"Network", 4-"CD/DVD", 5-"RAM"
   On Error Resume Next
   For Each DRV In CreateObject("Scripting.FileSystemObject").Drives
      If DRV.DriveType = DriveType Then
Debug.Print "------------------------"
Debug.Print "DriveLetter = " & DRV.DriveLetter
Debug.Print "IsReady = " & DRV.IsReady
Debug.Print "VolumeName = " & DRV.VolumeName
Debug.Print "TotalSize = " & DRV.TotalSize
Debug.Print "AvailableSpace = " & DRV.AvailableSpace
Debug.Print "SerialNumber = " & Hex$(DRV.SerialNumber)
      End If
   Next
End Sub

[MoHoMaXFR]

мне надо чтобы он нашел раздел на котором может работать данный пользователь , нанем создал папку и сохранял туда файлы

[MoHoMaXFR]

Извините если не прально поставил свой вопрос.

[Alex_ST]

Сообщение от MoHoMaXFR

… как научить вба находить исользующийся диск и выводить надпись о том что этот диск доступен

Кем и для чего использующийся?
Я вам дал примеры получения информации о дисках компьютера.
А подпиливайте под свои нужды уже самостоятельно, т.к. толком объяснить не можете, что хотите получить

[IgorGO]

так?

Sub SaveAt1FreeDisk()
  Dim ps As String, pth As String, nm As String, cdr As String
  On Error Resume Next
  ps = Application.PathSeparator
  For i = 100 To 122
    pth = Chr(i) & ":" & ps & "Fold" & Format(Now, "YYYYMMDDhhmmss") & ps
    MkDir pth
    If Err.Number = 0 Then
      nm = "FL" & Format(Now, "YYYYMMDDhhmmss")
      ActiveWorkbook.SaveAs pth & nm
      MsgBox "File " & nm & " was saved at " & pth, vbOKOnly, "Congratulations!!!"
      Exit For
    Else
      Err.Clear
    End If
  Next
  If i = 123 Then MsgBox "Mission not possible", vbCritical + vbOKOnly, "Condolence..."
End Sub