Будут конструктивные замечания, пишите, буду благодарен
- Код: Выделить всё
Attribute VB_Name = "mod_GetSecFile"
Option Explicit
'------------------------------------------------------------------------------------
' VB6
' Копирование файла методом чтения секторов с диска
' В основном данный метод предназначен для копирования фалов блокированных системой:
' %WinDir%\system32\config\SAM, %WinDir%\system32\config\System и так далее.
' Копирование больших файлов этим методом не рационально по времени.
'------------------------------------------------------------------------------------
' CopyFileCL(File, ToFile) - Основная функция
' File - Читаемый файл с полным маршрутом
' ToFile - Файл назначения с полным маршрутом
'------------------------------------------------------------------------------------
Private Const FSCTL_GET_RETRIEVAL_POINTERS = 589939
Private Enum eGenFile
GENERIC_ALL = &H10000000
GENERIC_EXECUTE = &H20000000
GENERIC_WRITE = &H40000000
GENERIC_READ = &H80000000
End Enum
Private Const CREATE_NEW As Long = 1
Private Const CREATE_ALWAYS As Long = 2
Private Const OPEN_EXISTING As Long = 3
Private Const OPEN_ALWAYS As Long = 4
Private Const TRUNCATE_EXISTING As Long = 5
Private Const FILE_SHARE_READ As Long = 1
Private Const FILE_SHARE_WRITE As Long = 2
Private Const FILE_SHARE_DELETE As Long = 4
Private Const FILE_READ_ATTRIBUTES As Long = &H80
Private Const FILE_BEGIN As Long = 0
Private Const FILE_CURRENT As Long = 1
Private Type STARTING_VCN_INPUT_BUFFER
StartingVcnH As Long ' Large_Integer
StartingVcnL As Long
End Type
Private Type tExtents
NextVcnH As Long ' Large_Integer
NextVcnL As Long ' количество кластеров в цепочке
LcnH As Long ' Large_Integer
LcnL As Long ' номер первого кластера цепочки
End Type
Private Type RETRIEVAL_POINTERS_BUFFER
dwExtentCount As Long
StartVcnH As Long ' Large_Integer
StartVcnL As Long ' номер первой цепочки кластеров файла
'NL() As tExtents
End Type
Private Type SECURITY_ATTRIBUTES3
nLength As Long
lpSecurityDescriptor As Long
bInheritHandle As Long
End Type
Private Type OVERLAPPED3
Internal As Long
InternalHigh As Long
Offset As Long
OffsetHigh As Long
hEvent As Long
End Type
Private Type FILETIME3
dwLowDateTime As Long
dwHighDateTime As Long
End Type
Private Type WIN32_FIND_DATA3
dwFileAttributes As Long
ftCreationTime As FILETIME3
ftLastAccessTime As FILETIME3
ftLastWriteTime As FILETIME3
nFileSizeHigh As Long
nFileSizeLow As Long
dwReserved0 As Long
dwReserved1 As Long
cFileName As String * 260
cAlternate As String * 14
End Type
Private Declare Function GetDiskFreeSpaceA Lib "kernel32" (ByVal lpRootPathName As String, lpSectorsPerCluster As Long, lpBytesPerSector As Long, lpNumberOfFreeClusters As Long, lpTotalNumberOfClusters As Long) As Long
Private Declare Function DeviceIoControl Lib "kernel32" (ByVal hDevice As Long, ByVal dwIoControlCode As Long, ByVal lpInBuffer As Long, ByVal nInBufferSize As Long, ByVal lpOutBuffer As Long, ByVal nOutBufferSize As Long, lpBytesReturned As Long, ByVal lpOverlapped As Long) As Long
Private Declare Function CreateDirectoryA Lib "kernel32" (ByVal lpPathName As String, lpSecurityAttributes As SECURITY_ATTRIBUTES3) As Long
Private Declare Sub RtlMoveMemory Lib "kernel32" (ByVal pDst As Long, ByVal pSrc As Long, ByVal ByteLen As Long)
Private Declare Function CreateFileA Lib "kernel32" (ByVal lpFileName As String, ByVal dwDesiredAccess As Long, ByVal dwShareMode As Long, ByVal lpSecurityAttributes As Long, ByVal dwCreationDisposition As Long, ByVal dwFlagsAndAttributes As Long, ByVal hTemplateFile As Long) As Long
Private Declare Function FindFirstFileA Lib "kernel32" (ByVal lpFileName As String, lpFindFileData As WIN32_FIND_DATA3) As Long
Private Declare Function FindNextFileA Lib "kernel32" (ByVal hFindFile As Long, lpFindFileData As WIN32_FIND_DATA3) As Long
Private Declare Function FindClose Lib "kernel32" (ByVal hFindFile As Long) As Long
Private Declare Function WriteFile Lib "kernel32" (ByVal hFile As Long, ByVal lpBuffer As Any, ByVal nNumberOfBytesToWrite As Long, lpNumberOfBytesWritten As Long, ByVal lpOverlapped As Long) As Long
Private Declare Function ReadFile Lib "kernel32" (ByVal hFile As Long, ByVal lpBuffer As Any, ByVal nNumberOfBytesToRead As Long, lpNumberOfBytesRead As Long, ByVal lpOverlapped As Long) As Long
Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
Private Declare Function GetFileSize Lib "kernel32" (ByVal hFile As Long, lpFileSizeHigh As Long) As Long
Private StartVcn As RETRIEVAL_POINTERS_BUFFER, lClusters() As tExtents
Private fSize As Double, ClusterSize As Long, sDrv As String
Private Function FileCreateT(ByVal sFile As String) As Long
' Создать Файл
FileCreateT = CreateFileA(sFile, GENERIC_WRITE, FILE_SHARE_READ, ByVal 0&, OPEN_ALWAYS, 0&, ByVal 0&)
End Function
Private Function FileRW(GlobAdr As Double, hFile As Long, buf() As Byte, nBuf As Long, bWrite As Boolean) As Long
' Прочесть Блок по адресу GlobBlockAdr
Dim OL As OVERLAPPED3, AdrLow As Long, AdrHigh As Long
AdrLow = DoubleTo2Long(GlobAdr, AdrHigh)
OL.Offset = AdrLow: OL.OffsetHigh = AdrHigh
If bWrite Then
WriteFile hFile, VarPtr(buf(0)), nBuf, FileRW, VarPtr(OL)
Else
ReadFile hFile, VarPtr(buf(0)), nBuf, FileRW, VarPtr(OL)
End If
End Function
Private Function FileSizeT(hFileT As Long) As Double
' Определить Размер Файла по открытому идентификатору файла
Dim BegAdrLow As Long, BegAdrHigh As Long
BegAdrLow = GetFileSize(hFileT, BegAdrHigh)
FileSizeT = Unit2Long(BegAdrHigh, BegAdrLow)
End Function
Private Function GetFileClusters(ByVal sFile As String) As Long
' Получаем список кластеров файла в виде массива lClusters() со структурами tExtents
Dim hFile As Long, lBytes As Long, lCount As Long, LenSV As Long, s As String
Dim OutBuf() As Byte, OutSize As Long, InBuf As STARTING_VCN_INPUT_BUFFER
Erase lClusters(): LenSV = Len(StartVcn)
sDrv = GetCharDrv(sFile) ' Получаем букву диска из полного имени файла (C:)
If Len(sDrv) <> 2 Then Exit Function
ClusterSize = GetClusterSize(sDrv) ' Узнаём размер кластера диска
If ClusterSize <= 0 Then Exit Function
' Открываем файл в режиме чтения
hFile = CreateFileA(sFile, FILE_READ_ATTRIBUTES, FILE_SHARE_READ Or FILE_SHARE_WRITE Or FILE_SHARE_DELETE, ByVal 0&, OPEN_EXISTING, &HFFF&, ByVal 0&)
If hFile <> -1 Then
fSize = FileSizeT(hFile) ' Узнаём размер файла
If fSize > 0 Then
OutSize = (fSize \ ClusterSize) * 16 + 32 ' Размер буфера с информацией о кластерах занимаемых файлом
ReDim OutBuf(OutSize - 1) ' Установить размер буфера
' Чтение информации о кластерах файла в буфер -> OutBuf()
If DeviceIoControl(hFile, FSCTL_GET_RETRIEVAL_POINTERS, ByVal VarPtr(InBuf), Len(InBuf), ByVal VarPtr(OutBuf(0)), OutSize, lBytes, ByVal 0&) Then
If lBytes >= LenSV Then
' Читаем кол-во элементов (tExtents)
Call RtlMoveMemory(ByVal VarPtr(StartVcn), ByVal VarPtr(OutBuf(0)), LenSV)
If lBytes > LenSV Then
' Кол-во элементов (tExtents)
GetFileClusters = StartVcn.dwExtentCount ' (lBytes - LenSV) \ 16
ReDim lClusters(GetFileClusters) ' Установить размер матрицы (tExtents)
' Копируем информацию о кластерах в матрицу со структурами (tExtents)
Call RtlMoveMemory(ByVal VarPtr(lClusters(0)), ByVal VarPtr(OutBuf(LenSV)), lBytes - LenSV)
' lClusters().Lcn - номер первого кластера цепочки
' lClusters().NextVcnL - количество кластеров в цепочке
End If
End If
End If
End If
Call CloseHandle(hFile)
End If
Erase OutBuf()
End Function
Private Function GetClusterSize(sDrv As String) As Long
Dim Sec1 As Long, Byte1 As Long, FreeClas1 As Long, NumClas1 As Long
GetDiskFreeSpaceA sDrv, Sec1, Byte1, FreeClas1, NumClas1
GetClusterSize = Sec1 * Byte1
End Function
Private Function GetCharDrv(sFile As String) As String
If InStr(vbNull, sFile, ":") = 2 Then
GetCharDrv = Left$(sFile, 2)
End If
End Function
Private Function LeftNameFile(PathA As String) As String
' Выделение пути к файлу - из полного пути
Dim iT As Integer
iT = InStrRev(PathA, "\")
If (iT > 0) Then LeftNameFile = Left$(PathA, iT)
End Function
Public Function UboundS(s() As String) As Long
On Local Error Resume Next
UboundS = UBound(s())
If Err.Number <> 0 Then
UboundS = -1: Err.Clear
End If
End Function
Private Function PathDelK(PathK As String) As String
' Удалить последнии "\" в строке
Dim s1 As String
s1 = Trim$(PathK)
While Right$(s1, 1) = "\"
s1 = Left$(s1, Len(s1) - 1)
Wend
PathDelK = s1
End Function
Private Function PathPlusK(PathK As String) As String
' Добавить к маршруту каталога "\
If Len(PathK) > 0 Then
If Right$(PathK, 1) = "\" Then
PathPlusK = PathK
Else
PathPlusK = PathK & "\"
End If
End If
End Function
Private Function NewDir(ByVal sPath As String) As Boolean
' Создать новый каталог
Dim sa1 As SECURITY_ATTRIBUTES3, sTmp As String, i As Integer, s() As String
sPath = PathDelK(sPath)
If IsFile(sPath, True) Then
NewDir = True
Else
If Len(sPath) > 0 Then
s() = Split(sPath, "\")
sTmp = s(0)
For i = 1 To UboundS(s())
sTmp = sTmp & "\" & s(i)
Call CreateDirectoryA(sTmp, sa1)
Next i
NewDir = IsFile(sPath, True)
End If
End If
End Function
Private Function LongToDouble(MinusLong As Long) As Double
' Переводит Отрицательное LONG число в Положительное Double
If MinusLong < 0 Then
LongToDouble = 4294967296# + MinusLong
Else
LongToDouble = MinusLong
End If
End Function
Private Function Unit2Long(High As Long, Low As Long) As Double
' Объединение Двух Long чисел в одно Double
Unit2Long = High * 4294967296# + LongToDouble(Low)
End Function
Private Function DoubleToLong(ByVal FDouble As Double) As Long
' Перевод Числа в формате Double в Long
If (FDouble <= 2147483647) Then
DoubleToLong = FDouble
Else
DoubleToLong = FDouble - 4294967296#
End If
End Function
Private Function DoubleTo2Long(FDouble As Double, High As Long) As Long
' Делит Double на два LONG числа
If FDouble = 0 Then High = 0: Exit Function
High = DoubleToLong(Fix(FDouble / 4294967296#))
DoubleTo2Long = DoubleToLong(FDouble - (High * 4294967296#))
End Function
Private Function IsDrv(sDrv As String) As Boolean
' Проверить существование логического диска
If Len(sDrv) = 2 Then
If Right$(sDrv, 1) = ":" Then IsDrv = True
End If
End Function
Public Function IsFile(ByVal sFile As String, Optional ByVal bPath As Boolean = False) As Boolean
' Проверить существование файла или каталога
Dim FFD As WIN32_FIND_DATA3, hFind As Long
sFile = PathDelK(sFile)
hFind = FindFirstFileA(sFile, FFD)
If hFind <> -1 Then
If (FFD.dwFileAttributes And vbDirectory) > 0 Then
IsFile = bPath
Else
IsFile = Not bPath
End If
FindClose hFind
Else
If bPath Then
IsFile = IsDrv(sFile)
End If
End If
End Function
Public Function CopyFileCL(ByVal sFile As String, ByVal sToFile As String) As Boolean
' Копирование файла методом чтения секторов
Dim hFile1 As Long, hFile2 As Long, buf() As Byte, d As Double
Dim ret As Long, FileSize As Double
Dim i As Long, j As Long, lCount As Long ' , F As Integer
If Not NewDir(LeftNameFile(sToFile)) Then Exit Function
If GetFileClusters(sFile) > 0 Then ' Получаем список кластеров файла
' Открываем диск в режиме чтения
hFile1 = CreateFileA("\\.\" & sDrv, GENERIC_READ, FILE_SHARE_READ Or FILE_SHARE_WRITE, ByVal 0&, OPEN_EXISTING, &HFFF&, ByVal 0&)
If hFile1 <> -1 Then
' Создаём файл назначения и открываем его на запись
'hFile2 = CreateFileA(sToFile, GENERIC_WRITE, FILE_SHARE_READ Or FILE_SHARE_WRITE, ByVal 0&, CREATE_NEW, FILE_ATTRIBUTE_NORMAL, ByVal 0&)
hFile2 = FileCreateT(sToFile)
' Установить размер буфера для обмена информацией
If (hFile2 <> -1) Then
ReDim buf(ClusterSize - 1)
' StartVcn.StartVcnL - номер первой цепочки кластеров файла
For i = 0 To StartVcn.dwExtentCount - 1 ' количество элементов tExtents
' В структуре (tExtents) -> lClusters(i).NextVcnL на самом деле указывается
' не кол-во кластеров в цепочке, а порядковый номер кластера относительно файла,
' с которого начинается цепочка, поэтому делаем так...
If i = 0 Then
lCount = lClusters(i).NextVcnL - 1
Else
lCount = lClusters(i).NextVcnL - lClusters(i - 1).NextVcnL - 1
End If
For j = 0 To lCount ' Кол-во кластеров в цепочке(Уже точное)
d = Unit2Long(lClusters(i).LcnH, lClusters(i).LcnL)
d = (d * ClusterSize) + (j * ClusterSize) ' Приращение адреса
' Читаем кластер с диска по адресу D
ret = FileRW(d, hFile1, buf(), ClusterSize, False)
' Следующая строка нужна для того, что бы в конец записываемого файла не попал мусор
If (FileSize + ClusterSize) > fSize Then ClusterSize = (fSize - FileSize)
' Записываем кластер в файл назначения
If ClusterSize > 0 Then
Call FileRW(FileSize, hFile2, buf(), ClusterSize, True)
FileSize = FileSize + ClusterSize
Else
Exit For
End If
'Call ControlPause(CDbl(ClusterSize)) ' Контроль паузы и вывод информации
'If BeginProcess = False Then Exit For
Next j
Next i
If fSize <= FileSize Then CopyFileCL = True
' Осторожно двери закрываются
Call CloseHandle(hFile2)
End If
Call CloseHandle(hFile1)
End If
Else
If fSize = 0 Then
' Создаём файл нулевой длины, так как функция не вернула кол-во кластеров
hFile2 = FileCreateT(sToFile)
Call CloseHandle(hFile2)
CopyFileCL = True
End If
End If
End Function
