Rambler's Top100
Форум: MS ACCESSVBVBA MS OfficeMS SQL server
Новые сообщения: 0000

Форум: MS ACCESS

Вопросы связанные с MS ACCESS

Обновить визитку
Участники «Online»
Все участники

 
 

Доброго времени суток, Посетитель!

вид форума:
Линейный форум Структурный форум

тема: Как определить флэшку
 
 автор: час   (31.10.2011 в 09:14)   личное сообщение
 
 


Dim D
Dim Dc As Object
Dim s As String
On Error Resume Next
Dim fs As New FileSystemObject
Set Dc = fs.Drives
For Each D In Dc
's = D.DriveType & "  " & D
'MsgBox s

If D.DriveType <> 3 And D.DriveType <> 4 And D.DriveType <> 1 Then

End If
Next


D.DriveType - на разных компах выдаёт разные номера для накопителей.
То 1 - это дисковод дискеток, а если его нет - тада это флэшка.
Можэ есть другия способы?

  Ответить  
 
 автор: Силblч   (31.10.2011 в 09:38)   личное сообщение
 
 

хз, но сетевой или нет я так определял :)

Public Function fnDriveType(strDrive As String) As String
    Dim objFSO As Object, drive As Object
    On Error GoTo err123
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    Set drive = objFSO.GetDrive(strDrive)
    fnDriveType = drive.RootFolder.Type
err123:
    Set objFSO = Nothing
End Function



    dt = LCase(fnDriveType(Left(CurrentDb.Properties(0), 3)))
    If Not dt Like "*локальный*" And Not dt Like "*local*" Then '-- если запускается не с локального диска
        MsgBox "Запуск приложения возможен только с локального диска" & vbNewLine & iDevelop, , "Ошибка"
        Cancel = -1
        Exit Sub
    End If



может и тебя натолкнет? :)

  Ответить  
 
 автор: час   (31.10.2011 в 09:43)   личное сообщение
 
 

пока не натолкнуло..

  Ответить  
 
 автор: час   (31.10.2011 в 09:44)   личное сообщение
 
 

есть такой вариант


Dim obj, objs

Set objs = GetObject("winmgmts:").InstancesOf("Win32_DiskDrive")
For Each obj In objs
      If obj.InterfaceType = "USB" Then

' тока не  понятно как теперь определить имя\путь к этому накоплятелю
      End If
Next

  Ответить  
 
 автор: час   (31.10.2011 в 09:51)   личное сообщение
 
 

ещё вот чё нашёл, но синтаксис какой то не понятный......
Кто нибудь может перевести?


var
  Drive: Char;
  DriveLetter: String[4];
begin
  for Drive := 'A' to 'Z' do
  begin
    DriveLetter := Drive + ':\';
    case GetDriveType(PChar(Drive + ':\')) of
      DRIVE_REMOVABLE:
        Memo1.Lines.Add(DriveLetter + '     Флеш');
      DRIVE_FIXED:
        Memo1.Lines.Add(DriveLetter + '     Локальный');
      DRIVE_REMOTE:
        Memo1.Lines.Add(DriveLetter + '     Сетевой');
      DRIVE_CDROM:
        Memo1.Lines.Add(DriveLetter + '     CD-ROM ');
    end;
  end;
end;

  Ответить  
 
 автор: Силblч   (31.10.2011 в 09:58)   личное сообщение
 
 

это паскаль

практически то, что я тебе дал :)

  Ответить  
 
 автор: час   (31.10.2011 в 10:00)   личное сообщение
 
 

Паскаль, я его за ... таскаль.
Ничё не понятно.


Private Sub Form_Load()
  Me.AutoRedraw = True
  Set objSWbemService = GetObject("winmgmts:\\.\ROOT\CIMV2")
  Set wmiDiskDrives = objSWbemService.ExecQuery("SELECT * FROM Win32_DiskDrive")
  For Each wmiDiskDrive In wmiDiskDrives
   If wmiDiskDrive.InterfaceType = "USB" Then 'IDE
    Print "USB диск:", wmiDiskDrive.Model
    Print "Size:", wmiDiskDrive.Size & " Байт"
    PnPID = wmiDiskDrive.PnPDeviceID
    Print "Заводской номер:", Replace(Mid(PnPID, InStrRev(PnPID, "\") + 1), "&0", "")
    strEscapedDeviceID = Replace(wmiDiskDrive.DeviceID, "\", "\\", 1, -1, vbTextCompare)
    Set wmiDiskPartitions = objSWbemService.ExecQuery _
                       ("ASSOCIATORS OF {Win32_DiskDrive.DeviceID=""" & _
                       strEscapedDeviceID & """} WHERE AssocClass = " & _
                       "Win32_DiskDriveToDiskPartition")
    For Each wmiDiskPartition In wmiDiskPartitions
    Set wmiLogicalDisks = objSWbemService.ExecQuery _
                       ("ASSOCIATORS OF {Win32_DiskPartition.DeviceID=""" & _
                       wmiDiskPartition.DeviceID & """} WHERE AssocClass = " & _
                       "Win32_LogicalDiskToPartition")
    For Each wmiLogicalDisk In wmiLogicalDisks
     Print "Логический диск:", wmiLogicalDisk.DeviceID
    Next
   Next
   End If
  Next
End Sub

  Ответить  
 
 автор: час   (31.10.2011 в 10:39)   личное сообщение
 
 

Определить флэшку - самый простой способ

Dim obj, objs, s

Set objs = GetObject("winmgmts:").InstancesOf("Win32_DiskDrive")
For Each obj In objs
      If obj.InterfaceType = "USB" Then
     s = obj.InterfaceType & "   " & obj.PnPDeviceID & "   " & obj.Name & "   " & obj.Type
MsgBox s
      End If
Next


А как в этом коде определить имя тома илли букву флэшки?

  Ответить  
 
 автор: Дядя Федор   (31.10.2011 в 12:04)   личное сообщение
 
 

http://bit.pirit.info/forum/viewtopic.php?t=18150 вот тут поройся -= там есть и ф-я GetDriveLetter

  Ответить  
 
 автор: час   (31.10.2011 в 16:34)   личное сообщение
 
 

  Ответить  
 
 автор: ial52   (02.11.2011 в 22:32)   личное сообщение
 
 

Взял самое просте из хелпа:

Sub ShowDriveType(drvpath)
Dim fs, d, s, t
Set fs = CreateObject("Scripting.FileSystemObject")
Set d = fs.GetDrive(drvpath)
Select Case d.DriveType
Case 0: t = "Unknown"
Case 1: t = "Removable"
Case 2: t = "Fixed"
Case 3: t = "Network"
Case 4: t = "CD-ROM"
Case 5: t = "RAM Disk"
End Select
s = "Drive " & d.DriveLetter & ": - " & t
MsgBox s
End Sub

Все работает. Стало быть дело за малым - либо прописать устройство жестко, либо посмотреть устройство, на котором расположена программулина - CurrentProject.Path (естественно выделив только буковку, которую заключаем в кавычки. "c:\" )

  Ответить  
 
 автор: час   (03.11.2011 в 11:09)   личное сообщение
 
 

Спасибо!
Программулина на компе на диске "D:\"
А как определить букву флэшки?

  Ответить  
 
 автор: ial52   (03.11.2011 в 11:41)   личное сообщение
 
 

Вы ведь заранее знаете куда будете обращаться, поэтому надо ввести переменную, или еще что-то.
У меня, например при работе клиента, предусмотрена работа как с диска, так и с флешки (база малюсенькая и применяется в данном случае только для вспомогательных расчетов). Проблема в файловой структуре - на флешке нет директорий, там все у него в куче, а обращается программка к разным файлам. Поэтому, чтобы не прописывать всякий раз пути, я просто определяю место, откуда стартует программка. Left(CurrentProject.Path,3)

  Ответить  
 
 автор: час   (03.11.2011 в 22:30)   личное сообщение
 
 

Спасибо!
==================
Программа у меня на компе на жёстком диске с буквой "D"
=============================
никакой куррентпатч тут не поможет.
=========================================
мне надо выгрузку файла на флэшку делать и загруку с флэшки, потому мне надо знать букву флэшки, сто бы найти место, куда файл кинуть

  Ответить  
 
 автор: ial52   (04.11.2011 в 09:40)   личное сообщение
 
 

Ясно. У меня была другая задача.

  Ответить  
 
 автор: час   (04.11.2011 в 16:26)   личное сообщение
 
 


Эти разные задачи
В интересной позе нас
Так меня, тебя иначе
А ещё мудрёней ВАС

  Ответить  
 
 автор: Волшебник   (05.11.2011 в 10:15)   личное сообщение
 
 

Может это поможет.

Перечисление локальных и сетевых дисков.
'
************ Code Start **************
'This code was originally written by Terry Kreft
'and Dev Ashish.
'It is not to be altered or distributed,
'except as part of an application.
'You are free to use it in any application,
'provided the copyright notice is left unchanged.
'
' Original Code by Terry Kreft
' Modified by Dev Ashish
'
'Drive Types
Private Const DRIVE_UNKNOWN = 0
Private Const DRIVE_ABSENT = 1
Private Const DRIVE_REMOVABLE = 2
Private Const DRIVE_FIXED = 3
Private Const DRIVE_REMOTE = 4
Private Const DRIVE_CDROM = 5
Private Const DRIVE_RAMDISK = 6
' returns errors for UNC Path
Private Const ERROR_BAD_DEVICE = 1200&
Private Const ERROR_CONNECTION_UNAVAIL = 1201&
Private Const ERROR_EXTENDED_ERROR = 1208&
Private Const ERROR_MORE_DATA = 234
Private Const ERROR_NOT_SUPPORTED = 50&
Private Const ERROR_NO_NET_OR_BAD_PATH = 1203&
Private Const ERROR_NO_NETWORK = 1222&
Private Const ERROR_NOT_CONNECTED = 2250&
Private Const NO_ERROR = 0

Private Declare Function WNetGetConnection Lib "mpr.dll" Alias _
"WNetGetConnectionA" (ByVal lpszLocalName As String, _
ByVal lpszRemoteName As String, cbRemoteName As Long) As Long
Private Declare Function GetLogicalDriveStrings Lib "kernel32" Alias _
"GetLogicalDriveStringsA" (ByVal nBufferLength As Long, _
ByVal lpBuffer As String) As Long
Private Declare Function GetDriveType Lib "kernel32" Alias "GetDriveTypeA" _
(ByVal nDrive As String) As Long

Private Function fGetDrives() As String
'Returns all mapped drives
Dim lngRet As Long
Dim strDrives As String * 255
Dim lngTmp As Long
lngTmp = Len(strDrives)
lngRet = GetLogicalDriveStrings(lngTmp, strDrives)
fGetDrives = Left(strDrives, lngRet)
End Function

Private Function fGetUNCPath(strDriveLetter As String) As String
On Local Error GoTo fGetUNCPath_Err

Dim Msg As String, lngReturn As Long
Dim lpszLocalName As String
Dim lpszRemoteName As String
Dim cbRemoteName As Long
lpszLocalName = strDriveLetter
lpszRemoteName = String$(255, Chr$(32))
cbRemoteName = Len(lpszRemoteName)
lngReturn = WNetGetConnection(lpszLocalName, lpszRemoteName, _
cbRemoteName)
Select Case lngReturn
Case ERROR_BAD_DEVICE
Msg = "Error: Bad Device"
Case ERROR_CONNECTION_UNAVAIL
Msg = "Error: Connection Un-Available"
Case ERROR_EXTENDED_ERROR
Msg = "Error: Extended Error"
Case ERROR_MORE_DATA
Msg = "Error: More Data"
Case ERROR_NOT_SUPPORTED
Msg = "Error: Feature not Supported"
Case ERROR_NO_NET_OR_BAD_PATH
Msg = "Error: No Network Available or Bad Path"

Case ERROR_NO_NETWORK
Msg = "Error: No Network Available"
Case ERROR_NOT_CONNECTED
Msg = "Error: Not Connected"
Case NO_ERROR
' all is successful...
End Select
If Len(Msg) Then
MsgBox Msg, vbInformation
Else
fGetUNCPath = Left$(lpszRemoteName, cbRemoteName)
End If
fGetUNCPath_End:
Exit Function
fGetUNCPath_Err:
MsgBox Err.Description, vbInformation
Resume fGetUNCPath_End
End Function

Private Function fDriveType(strDriveName As String) As String
Dim lngRet As Long
Dim strDrive As String
lngRet = GetDriveType(strDriveName)
Select Case lngRet
Case DRIVE_UNKNOWN 'The drive type cannot be determined.
strDrive = "Unknown Drive Type"
Case DRIVE_ABSENT 'The root directory does not exist.
strDrive = "Drive does not exist"
Case DRIVE_REMOVABLE 'The drive can be removed from the drive.
strDrive = "Removable Media"
Case DRIVE_FIXED 'The disk cannot be removed from the drive.
strDrive = "Fixed Drive"
Case DRIVE_REMOTE 'The drive is a remote (network) drive.
strDrive = "Network Drive"
Case DRIVE_CDROM 'The drive is a CD-ROM drive.
strDrive = "CD Rom"
Case DRIVE_RAMDISK 'The drive is a RAM disk.
strDrive = "Ram Disk"
End Select
fDriveType = strDrive
End Function

Sub sListAllDrives()
Dim strAllDrives As String
Dim strTmp As String

strAllDrives = fGetDrives
If strAllDrives <> "" Then
Do
strTmp = Mid$(strAllDrives, 1, InStr(strAllDrives, vbNullChar) - 1)
strAllDrives = Mid$(strAllDrives, InStr(strAllDrives, vbNullChar) + 1)
Select Case fDriveType(strTmp)
Case "Removable Media":
Debug.Print "Removable drive : " & strTmp
Case "CD ROM":
Debug.Print " CD Rom drive : " & strTmp
Case "Fixed Drive":
Debug.Print " Local drive : " & strTmp
Case "Network Drive":
Debug.Print " Network drive : " & strTmp
Debug.Print " UNC Path : " & _
fGetUNCPath(Left$(strTmp, Len(strTmp) - 1))
End Select
Loop While strAllDrives <> ""
End If
End Sub
'**************** Code End ******************

  Ответить  
 
 автор: час   (05.11.2011 в 14:36)   личное сообщение
 
 

Спасибо!
щас - попробую

====================
Помогло!
=======================
Надо же как всё засекречено - не так то просто букву флэшки найти.

  Ответить  
 
 автор: ddi   (05.11.2011 в 15:56)   личное сообщение
 
 


Option Compare Database
Option Explicit
Function r() As String 'by David Zakaryan (ddi)
Dim f As New FileSystemObject
Dim drv As Drive
'drv может иметь значения
'drv.AvailableSpace
'drv.DriveLetter
'drv.DriveType
'drv.FileSystem
'drv.FreeSpace
'drv.IsReady
'drv.Path
'drv.RootFolder
'drv.SerialNumber
'drv.ShareName
'drv.TotalSize
'drv.VolumeName так скозать что душе угодно
Dim i As Integer
For Each drv In f.Drives
If drv.DriveType = Removable Then
If fe(drv & "\1.txt") = True Then
r = drv & "\1.txt"
MsgBox (r)
Else
End If
End If
Next
If r = "" Then
MsgBox ("Нет флешки")
End If
End Function
Function fe(Path As String) As Boolean
       Dim i As Integer
    On Error Resume Next
    i = GetAttr(Path)
    Select Case Err.Number
    Case Is = 0
        fe = True
    Case Else
        fe = False
    End Select
    On Error GoTo 0
End Function

  Ответить  
 
 автор: ddi   (05.11.2011 в 16:02)   личное сообщение
 
 


Option Compare Database
Option Explicit
Function r(filename As String) As String  'by David Zakaryan (ddi)
Dim f As New FileSystemObject
Dim drv As Drive
'drv может иметь значения
'drv.AvailableSpace
'drv.DriveLetter
'drv.DriveType
'drv.FileSystem
'drv.FreeSpace
'drv.IsReady
'drv.Path
'drv.RootFolder
'drv.SerialNumber
'drv.ShareName
'drv.TotalSize
'drv.VolumeName так скозать что душе угодно
For Each drv In f.Drives
If drv.DriveType = Removable Then
If fe(drv & "\" & filename) = True Then
r = drv & "\" & filename
Else
End If
End If
Next
If r = "" Then
MsgBox ("Нет флешки")
End If
End Function
Function fe(Path As String) As Boolean
       Dim i As Integer
    On Error Resume Next
    i = GetAttr(Path)
    Select Case Err.Number
    Case Is = 0
        fe = True
    Case Else
        fe = False
    End Select
    On Error GoTo 0
End Function

  Ответить  
 
 автор: ddi   (05.11.2011 в 16:06)   личное сообщение
 
 

Тестил на 4 компах win 7 win xp работает

  Ответить  
 
 автор: час   (05.11.2011 в 19:51)   личное сообщение
 
 

Спасибо!

  Ответить  
 
 автор: ddi   (06.11.2011 в 12:39)   личное сообщение
 
 

У тебя работает?

  Ответить  
 
 автор: час   (06.11.2011 в 21:08)   личное сообщение
 
 

Мне надо определять букву флэшки.
Этот код не делает задачу.

  Ответить  
 
 автор: snipe   (07.11.2011 в 03:19)   личное сообщение
 
 

А если это не флешка, а винт-потаскун
или будет установлен картридер или воткнуто 2 флешки
Что-то автоматическое определение при таких раскладах меня настораживает

может предложить последовательность действий по указанию носителя
типа вставьте носитель в гнездо и нажмите кнопку далее
укажите носитель или папку куда сохранить (откуда читать данные)
и радуйтесь прелестями проги

  Ответить  
 
 автор: ddi   (07.11.2011 в 09:26)   личное сообщение
 
 


'drv.DriveLetter 

А ЧТО ЭТО?

  Ответить  
 
 автор: ddi   (07.11.2011 в 09:50)   личное сообщение
 
 


А если это не флешка, а винт-потаскун
или будет установлен картридер или воткнуто 2 флешки
Что-то автоматическое определение при таких раскладах меня настораживает
может предложить последовательность действий по указанию носителя
типа вставьте носитель в гнездо и нажмите кнопку далее
укажите носитель или папку куда сохранить (откуда читать данные)
и радуйтесь прелестями проги


Я исползывал такой код у меня во флешке лежал ключ к проге не зовисемо что компу потклёчено 1 2 ... 8 флешек он искал в них мой файл в котором найдёт там же и останавливолся
а для винды не имеет значения как флешка потключена главное что бы вида знала что это флешка

  Ответить  
 
 автор: ddi   (07.11.2011 в 09:52)   личное сообщение
 
 

а винт-потаскун для винды HDD

  Ответить  
 
 автор: час   (07.11.2011 в 11:15)   личное сообщение
 
 


Ест над чем подумати!
==========================
А с другой сторона - всё равно какой носитель воткнули - туда файл и сбрасываем.
Надо думать - чё делаешь.

  Ответить  
 
 автор: ddi   (07.11.2011 в 13:10)   личное сообщение
 
 

  Ответить  
 
 автор: ddi   (09.11.2011 в 10:43)   личное сообщение
 
 

http://msdn.microsoft.com/en-us/library/ebkhfaaz(v=vs.85).aspx

  Ответить  
 
 автор: час   (11.11.2011 в 00:03)   личное сообщение
 
 

ай нот спик инглишь

  Ответить  
 
 автор: ddi   (11.11.2011 в 09:32)   личное сообщение
 
 


Пример кода, описанные в этом разделе содержится реальный пример, который демонстрирует многие возможности, доступные в FileSystemObject объектной модели. Этот код показывает, как все возможности объектной модели работают вместе, и как использовать эти функции эффективно в вашем собственном коде.

Как использовать кодекс
Обратите внимание, что поскольку этот код достаточно общий характер, дополнительный код и небольшой настройки необходимы, чтобы сделать этот код на самом деле работает на вашей машине. Эти изменения необходимы из-за различных способов вход и выход для пользователя обрабатывается между страницы Active Server Pages и хост Windows Scripting.

Для выполнения этого кода на активной серверной страницы, выполните следующие действия:

Создайте стандартные веб-страницы с расширением. Жерех.

Скопируйте следующий код в этот файл между <BODY> BODY ...</> теги.

Заключите весь код в <%...%> теги.

Перемещение Option Explicit заявление от текущей позиции в коде, чтобы самой верхней части HTML-страницы, позиционирование его еще до открытия <HTML> тега.

Место <%...%> теги Option Explicit заявление, чтобы это работает на стороне сервера.

Добавьте следующий код в конец пример кода:

VBScript
Sub печати (х) 
   Response.Write "<PRE> & ltFONT FACE =" "Courier New" "SIZE =" "1" ">" 
   Response.Write х 
   Response.Write "</ FONT> </ PRE>" 
End Sub 
Главная
Предыдущий код добавляет печати процедура, которая будет работать на стороне сервера, но отображать результаты на стороне клиента.

Для выполнения этого кода на хост Windows Scripting, используйте следующие шаги:

Закомментируйте все <A теги привязки name=""> </ A>

Добавьте следующий код в конец пример кода:

VBScript
Sub печати (х) 
   WScript.Echo х 
End Sub 
Главная
Код содержится в следующем разделе:

VBScript
'''''''''''''''''''''''''''''''''''''''''''''''''' '''''''''''''''''''' 
"FileSystemObject Пример кода 
Copyright '1998 Microsoft Corporation. Все права защищены. 
'''''''''''''''''''''''''''''''''''''''''''''' '''''''''''''''''''''''' 

Option Explicit 

'''''''''''''''''''''''' '''''''''''''''''''''''''''''''''''''''''''''' 
Что касается кода "качества : 
"1) Следующий код делает много работы со строками на 
"объединения коротких строк вместе с" & "оператора. 
" Так как объединение строк стоит дорого, это очень 
"неэффективный способ написания кода. Тем не менее, это очень 
"в сопровождении способ написания кода, и используется здесь, потому что это 
"программа выполняет обширные операции диска, и из-за 
"диска намного медленнее, чем операции с памятью, необходимые для 
«объединения строк. Имейте в виду, что это демонстрация 
"код, а не рабочий код. 

'2) "Option Explicit" используется, потому что объявленная переменная доступа 
"немного быстрее, чем необъявленная переменная доступа. Оно также предотвращает 
"ошибок от ползучего в код, например, когда вы опечатки 
"DriveTypeCDROM как DriveTypeCDORM. 

'3) обработка ошибок отсутствует этот код, чтобы сделать код более 
читабельным. Хотя меры предосторожности были приняты для того, чтобы 
"код не будет ошибки в общих случаях, файловые системы могут быть 
"непредсказуемыми. В рабочем коде, использование On Error Resume Next и 
"Err объекта в ловушку возможно 
Некоторые удобные глобальные переменные 
'''''''''''''''''''''''''''''''''''''''''''''' '''''''''''''''''''''''' 
Dim TabStop 
Dim NewLine 
Const TestDrive = "C" 
Const TestFilePath = "C: \ Test" 
''''''' '''''''''''''''''''''''''''''''''''''''''''''''''' ''''''''''''' 
Константы "возвращается Drive.DriveType 
'''''''''''''''''''''''''''''' '''''''''''''''''''''''''''''''''''''''' 
Const DriveTypeRemovable = 1 
Const DriveTypeFixed = 2 
Const DriveTypeNetwork = 3 
Const DriveTypeCDROM = 4 
Const DriveTypeRAMDisk = 5 
'''''''''''''''''''''''''''''''''''''''' '''''''''''''''''''''''''''''' 
Константы "возвращается File.Attributes 
''''''''''''' '''''''''''''''''''''''''''''''''''''''''''''''''' ''''''' 
Const FileAttrNormal = 0 
Const FileAttrReadOnly = 1 
Const FileAttrHidden = 2 
Const FileAttrSystem = 4 
Const FileAttrVolume = 8 
Const FileAttrDirectory = 16 
Const FileAttrArchive = 32 
Const FileAttrAlias &#8203;&#8203;= 1024 
Const FileAttrCompressed = 2048 
''''''' '''''''''''''''''''''''''''''''''''''''''''''''''' ''''''''''''' 
'Константы для открытия файлов 
'''''''''''''''''''''''''''''''' '''''''''''''''''''''''''''''''''''''' 
Const OpenFileForReading = 1 
Const OpenFileForWriting = 2 
Const OpenFileForAppending = 8 
'''''''''''''''''''''''''''''''''''''''''''''''''' '''''''''''''''''''' 
"ShowDriveType 
Цель ': 
'Создает строку, описывающую типом привода данного диска объекта. 
" Демонстрирует следующие 
'- Drive.DriveType 
'''''''''''''''''''''''''''''''''''''''''' '''''''''''''''''''''''''''' 
Функция ShowDriveType (Drive) 
   Dim S 
   Select Case Drive.DriveType 
   Дело DriveTypeRemovable 
      S = "Съемный" 
   Дело DriveTypeFixed 
      S = "Фиксированный" 
   Дело DriveTypeNetwork 
      S = "Сеть" 
   Дело DriveTypeCDROM 
      S = "CD-ROM" 
   Дело DriveTypeRAMDisk 
      S = "RAM Disk" 
   Case Else 
      S = "Неизвестный" 
   End Select 
   ShowDriveType = S 
End Function 
'''''''' '''''''''''''''''''''''''''''''''''''''''''''''''' '''''''''''' 
"ShowFileAttr 
Цель ': 
'генерирует строку с описанием атрибутов файла или папки. 
" Демонстрирует следующие 
'- File.Attributes 
'- Folder.Attributes 
''''''''''''''''''''''''''''''''''''' ''''''''''''''''''''''''''''''''' 
файла Функция ShowFileAttr (File) 'может быть файл или папку, 
   Dim S 
   Dim Attr 
   Attr = File.Attributes 
   Если Attr = 0 Then 
      ShowFileAttr = "Обычный" 
      Exit Function 
   End If 
   Если Attr И FileAttrDirectory Тогда S = S & "Справочник" 
   Если Attr И FileAttrReadOnly Тогда S = S & "только для чтения" 
   Если Attr И тогда FileAttrHidden S = S & "Hidden" 
   Если Attr И FileAttrSystem Тогда S = S & "Система" 
   Если Attr И FileAttrVolume Тогда S = S & "Volume" 
   Если Attr И FileAttrArchive Тогда S = S & "Архив" 
   Если Attr И FileAttrAlias &#8203;&#8203;Тогда S = S & "Alias" 
   Если Attr И FileAttrCompressed Тогда S = S & "Сжатый" 
   ShowFileAttr = S 
End Function 
'''''''''''''''''''''''''''' '''''''''''''''''''''''''''''''''''''''''' 
"GenerateDriveInformation 
Цель ': 
'Генерирует строки, описывающей текущее состояние 
"доступных дисков. 
" Демонстрирует следующие 
'- FileSystemObject.Drives 
'- Итерация диски коллекции 
'- Drives.Count 
'- Drive.AvailableSpace 
'- Drive.DriveLetter 
'- Drive.DriveType 
'- Drive.FileSystem 
'- Drive.FreeSpace 
'- Drive.IsReady 
" - Drive.Path 
'- Drive.SerialNumber 
'- Drive.ShareName 
'- Drive.TotalSize 
'- Drive.VolumeName 
'''''''''''''''''''''''''' '''''''''''''''''''''''''''''''''''''''''''' 
Функция GenerateDriveInformation (FSO) 
   Dim Диски 
   Диск Dim 
   Dim S 
   Диски комплект = FSO.Drives 
   S = "Количество дисков:" & & TabStop Drives.Count & & NewLine NewLine 
   'Построить первую линию отчета. 
   S = S & String (2, TabStop) и "Драйв" 
   S = S & String (3, TabStop) и "Файл" 
   S = S & TabStop и "Total" 
   S = S & TabStop и "Свободный" 
   S = S & TabStop и "Доступный" 
   S = S & TabStop и "Сериал" & NewLine 
   'Построить вторую линию отчета. 
   S = S & "Письмо" 
   S = S & TabStop и «Путь» 
   S = S & TabStop и "Тип" 
   S = S & TabStop и "Готов?" 
   S = S & TabStop & "Имя" 
   S = S & TabStop и "Система" 
   S = S & TabStop и "Космос" 
   S = S & TabStop и "Космос" 
   S = S & TabStop и "Космос" 
   S = S & TabStop и "Количество" и NewLine    
   "Разделительная линия. 
   S = S & String (105, "-") & NewLine 
   для каждого диска в приводах 
      S = S & Drive.DriveLetter 
      S = S & TabStop & Drive.Path 
      S = S & TabStop & ShowDriveType (Drive), 
      S = S & TabStop & Drive.IsReady 
      Если Drive.IsReady Затем 
         Если DriveTypeNetwork = Drive.DriveType Тогда 
            S = S & TabStop & Drive.ShareName 
         остальное 
            S = S & TabStop & Drive.VolumeName 
         End If 
         S = S & TabStop & Drive.FileSystem 
         S = S & TabStop & Drive.TotalSize 
         S = S & TabStop & Drive.FreeSpace 
         S = S & TabStop & Drive.AvailableSpace 
         S = S & TabStop & Hex (Drive.SerialNumber) 
      End If 
      S = S & NewLine 
   Следующая 
   GenerateDriveInformation = S 
End Function 
'''''''''''''''''''''''''''''''''''''''''''''''' '''''''''''''''''''''' 
"GenerateFileInformation 
Цель ': 
'Создает строку, описывающую текущее состояние файла. 
" Демонстрирует следующие 
'- File.Path 
'- File.Name 
'- File.Type 
'- File.DateCreated 
'- File.DateLastAccessed 
'- File.DateLastModified 
'- File.Size 
'''''''''''' '''''''''''''''''''''''''''''''''''''''''''''''''' '''''''' 
Функция GenerateFileInformation (Файл) 
   Dim S 
   = S & NewLine "Путь:" & & TabStop File.Path 
   S = S & NewLine и "Name:" & & TabStop File.Name 
   S = S & NewLine и "Тип:" & & TabStop File.Type 
   S = S & NewLine и "Attribs:" & & TabStop ShowFileAttr (Файл) 
   S = S & NewLine и "Создано:" & & TabStop File.DateCreated 
   S = S & NewLine & "доступ:" & & TabStop File.DateLastAccessed 
   S = S & NewLine и "изменения:" & & TabStop File.DateLastModified 
   S = S & NewLine и "Размер" & & TabStop File.Size & NewLine 
   GenerateFileInformation = S 
End Function 
'' '''''''''''''''''''''''''''''''''''''''''''''''''' '''''''''''''''''' 
"GenerateFolderInformation 
Цель ': 
'Создает строку, описывающую текущее состояние папки. 
" Демонстрирует следующие 
'- Folder.Path 
'- Folder.Name 
'- Folder.DateCreated 
'- Folder.DateLastAccessed 
'- Folder.DateLastModified 
'- Folder.Size 
''''''''''''''''' '''''''''''''''''''''''''''''''''''''''''''''''''' ''' 
Функция GenerateFolderInformation (Folder) 
   Dim S 
   S = "Путь:" & & TabStop Folder.Path 
   S = S & NewLine и "Name:" & & TabStop Folder.Name 
   S = S & NewLine и "Attribs:" & TabStop И ShowFileAttr (Папка) 
   S = S & NewLine и "Создано:" & & TabStop Folder.DateCreated 
   S = S & NewLine и "доступ:" & & TabStop Folder.DateLastAccessed 
   S = S & NewLine и "изменения:" & & TabStop Folder.DateLastModified 
   S = S & NewLine и "Размер:" & & TabStop Folder.Size & NewLine 
   GenerateFolderInformation = S 
End Function 
'''''''''''''''''''''''' '''''''''''''''''''''''''''''''''''''''''''''' 
"GenerateAllFolderInformation 
"Цель : 
'генерирует строку, описывающую текущее состояние 
"папку и все файлы и подпапки. 
' Демонстрирует следующие 
'- Folder.Path 
'- Folder.SubFolders 
'- Folders.Count 
'''''''''''''''''''''''''''''''' '''''''''''''''''''''''''''''''''''''' 
Функция GenerateAllFolderInformation (Folder) 
   Dim S 
   Dim вложенные 
   подпапки Dim 
   Dim Файлы 
   Dim файла 
   S = "Папка:" & & TabStop Folder.Path & & NewLine NewLine 
   Установить Files = Folder.Files 
   Если 1 = Files.Count Тогда 
      S = S & "Существует один файл" & NewLine 
   остальное 
      S = S & " Есть "& & Files.Count" файлы "& NewLine 
   End If 
   Если Files.Count <> 0 Then 
      для каждого файла в файлы 
         S = S & GenerateFileInformation (Файл) 
      Следующая 
   End If 
   Установить Вложенные = Folder.SubFolders 
   Если 1 = подпапки. Затем граф 
      S = S & NewLine & "Существует 1 подпапку" & & NewLine NewLine 
   остальное 
      S = S & NewLine и "Есть" и SubFolders.Count и "подпапки" & & NewLine NewLine 
   End If 
   Если SubFolders.Count < > 0 Then 
      для каждой вложенной папки в подпапках 
         S = S & GenerateFolderInformation (подпапки) 
      Следующая 
      S = S & NewLine 
      для каждой вложенной папки в подпапках 
         S = S & GenerateAllFolderInformation (подпапки) 
      Следующая 
   End If 
   GenerateAllFolderInformation = S 
End Function 
''''''' '''''''''''''''''''''''''''''''''''''''''''''''''' ''''''''''''' 
"GenerateTestInformation 
Цель ': 
'Создает строку, описывающую текущее состояние C: \ Test 
. папку и все файлы и подпапки 
" Демонстрирует следующие 
'- FileSystemObject.DriveExists 
'- FileSystemObject.FolderExists 
'- 
GenerateTestInformation (FSO) 
   Dim TestFolder 
   Dim S 
   Если не FSO.DriveExists (TestDrive) Затем Exit Function 
   If Not FSO.FolderExists (TestFilePath) Затем Exit Function 
   TestFolder комплект = FSO.GetFolder (TestFilePath) 
   GenerateTestInformation = GenerateAllFolderInformation (TestFolder) 
End Function 
''' '''''''''''''''''''''''''''''''''''''''''''''''''' ''''''''''''''''' 
"DeleteTestDirectory 
'Цель: 
'Очищает тест каталог. 
" Демонстрирует следующие 
'- FileSystemObject.GetFolder 
'- FileSystemObject.DeleteFile 
'- FileSystemObject.DeleteFolder 
'- Folder.Delete 
'- File.Delete 
'''''''''''''''''''''' '''''''''''''''''''''''''''''''''''''''''''''''' 
Sub DeleteTestDirectory (FSO) 
   Dim TestFolder 
   Dim подпапку 
   Dim файлов 
   <A NAME="driveinfo"> </ A> 
   "Два способа удаления файла: 
   FSO.DeleteFile (TestFilePath & "\ LoremIpsum \ Paragraph1.txt") 
   Установить Файл = FSO.GetFile (TestFilePath & "\ LoremIpsum \ Paragraph2.txt") 
   File.Delete    
   "Два способа удалить папку: 
   FSO.DeleteFolder (TestFilePath & "\ LoremIpsum") 
   FSO.DeleteFile (TestFilePath & "\ ReadMe.txt") 
   Установить TestFolder = FSO.GetFolder (TestFilePath) 
   TestFolder.Delete 
End Sub 
''''''''''''''''''''''''''''''''''''''' ''''''''''''''''''''''''''''''' 
"CreateLyrics 
Цель ': 
'строит пару текстовых файлов в папке. 
" Демонстрирует следующие 
'- FileSystemObject.CreateTextFile 
'- TextStream.WriteLine 
'- TextStream.Write 
'- TextStream.WriteBlankLines 
'- TextStream.Close 
'''''''''''''''''''''' '''''''''''''''''''''''''''''''''''''''''''''''' 
Sub CreateLyrics (Folder) 
   Dim TextStream 
   <A NAME="deletefile"> </ A> 
   Установить TextStream = Folder.CreateTextFile ("Paragraph1.txt") 
   <A NAME="createtextfilewritetofile"> </ A> 
   "Обратите внимание, что это не добавляет строки в файл. 
   TextStream.Write ("Lorem Ipsum - Пункт 1")     
   TextStream.WriteBlankLines (1) 
   TextStream.WriteLine (".. Lorem Ipsum боль сидеть Амет, consectetuer adipiscing элит Меценат сем") 
   TextStream.WriteLine ("Донец ... анте Nulla facilisi Phasellus interdum Nulla пипс Morbi laoreet пипс "). 
   TextStream.WriteBlankLines (2) 
   TextStream.Close 
   Установить TextStream = Folder.CreateTextFile ("Paragraph2.txt") 
   TextStream.WriteLine ("Lorem Ipsum - пункт 2" ) 
   TextStream.WriteBlankLines (1) 
   TextStream.WriteLine ("Nullam Nulla quam, sollicitudin ут, lobortis ornare, tristique, augue"). 
   TextStream.WriteLine ("преддверия сем Felis, fermentum ЕС, volutpat ЕС, vulputate eget, Элит". ) 
   TextStream.WriteBlankLines (2) 
   TextStream.Close 
Sub End 
'''''''''''''''''''''''''''''''''''''' '''''''''''''''''''''''''''''''' 
"GetLyrics 
Цель ': 
'Отображение содержимого песни файлы. 
' Демонстрирует следующие 
'- FileSystemObject.OpenTextFile 
'- FileSystemObject.GetFile 
'- TextStream.ReadAll 
'- TextStream.Close 
'- File.OpenAsTextStream 
'- TextStream.AtEndOfStream 
'- TextStream.ReadLine 
'''''''''''' '''''''''''''''''''''''''''''''''''''''''''''''''' '''''''' 
Функция GetLyrics (FSO) 
   Dim TextStream 
   Dim S 
   Dim Файл 
   "Есть несколько способов открыть текстовый файл, а несколько 
   "способов чтения данных из файла. Вот два пути 
   ", чтобы сделать каждый: 
   Установить TextStream = FSO.OpenTextFile (TestFilePath & "\ LoremIpsum \ Paragraph1.txt", OpenFileForReading) 
   <A NAME="closereadfromfile"> </ A> 
   S = TextStream.ReadAll & & NewLine NewLine 
   TextStream . Закрыть 
   Установить Файл = FSO.GetFile (TestFilePath & "\ LoremIpsum \ Paragraph2.txt") 
   Установить TextStream = File.OpenAsTextStream (OpenFileForReading) 
   Do While Not TextStream.AtEndOfStream 
      S = S & TextStream.ReadLine & NewLine 
   Loop 
   TextStream.Close 
   GetLyrics = S 
End Function 
''''''''''''''''''''''''''''''''''''''''''''''' ''''''''''''''''''''''' 
"BuildTestDirectory 
'Цель: 
'Построение иерархии каталогов для демонстрации FileSystemObject. 
' Мы будем строить иерархию в следующем порядке: 
'C: \ Test 
'C: \ Test \ ReadMe.txt 
'C: \ Test \ LoremIpsum 
'C: \ Test \ LoremIpsum \ Paragraph1.txt 
'C: \ Test \ LoremIpsum \ Paragraph2.txt 
'Демонстрирует следующие 
'- FileSystemObject.DriveExists 
'- FileSystemObject.FolderExists 
'- FileSystemObject.CreateFolder 
'- FileSystemObject.CreateTextFile 
'- Folders.Add 
'- Folder.CreateTextFile 
'- TextStream.WriteLine 
'- TextStream.Close 
''' '''''''''''''''''''''''''''''''''''''''''''''''''' ''''''''''''''''' 
Функция BuildTestDirectory (FSO) 
   Dim TestFolder 
   Dim вложенные 
   подпапки Dim 
   Dim TextStream 
   "выручить, если (а) диск не существует, или если (б) каталог строится 
   'уже существует. 
   Если не FSO.DriveExists (TestDrive) Затем 
      BuildTestDirectory = False 
      Exit Функция 
   End If 
   Если FSO.FolderExists (TestFilePath) Затем 
      BuildTestDirectory = False 
      Exit Функция 
   End If 
   Установить TestFolder = FSO.CreateFolder (TestFilePath) 
   Установить TextStream = FSO.CreateTextFile (TestFilePath & "\ ReadMe.txt") 
   TextStream.WriteLine ("Мой образец текста коллекция") 
   TextStream.Close 
   Установить Вложенные = TestFolder.SubFolders 
   Установить подпапку = SubFolders.Add ("LoremIpsum") 
   CreateLyrics подпапку    
   BuildTestDirectory = True 
End Функция 
''''''''''''''''''''''''''''''''''''''''''''''''' ''''''''''''''''''''' 
"основной программе 
на первом месте ", он создает тестовый каталог, а также некоторые вложенные папки 
и файлы. Затем, он сбрасывает информацию о доступных 
"дисков, так и о тесте каталог, а затем очищает 
"все снова. 
'''''''''''''''''''''''' '''''''''''''''''''''''''''''''''''''''''''''' 
Sub Main 
   Dim FSO 
   "Настройка глобальных данных. 
   TabStop = Chr (9) 
   NewLine = Chr (10) 
   <A NAME="folderinfo"> </ A> 
   Установить FSO = CreateObject ("Scripting.FileSystemObject") 
   If Not BuildTestDirectory (FSO) Затем 
      Печать " Испытание каталог уже существует или не может быть создан. продолжаться не может. " 
      Exit Sub 
   End If 
   печати GenerateDriveInformation (FSO) & NewLine & NewLine 
   печати GenerateTestInformation (FSO) & NewLine & NewLine 
   печати GetLyrics (FSO) & NewLine & NewLine 
   DeleteTestDirectory (FSO) 
End Sub

  Ответить  
 
 автор: Kagalar   (02.09.2017 в 09:55)   личное сообщение
 
 

Так же по флешкам, много полезной ингформации тут + есть проги по восстановлению накопителей.

  Ответить  
HiProg.com - Технологии программирования
Rambler's Top100 TopList