VERSION 5.00
Begin VB.Form frmMain
BorderStyle = 1 'Fixed Single
Caption = "磁盘文件复制"
ClientHeight = 2745
ClientLeft = 45
ClientTop = 435
ClientWidth = 5235
LinkTopic = "Form1"
LockControls = -1 'True
MaxButton = 0 'False
MinButton = 0 'False
ScaleHeight = 2745
ScaleWidth = 5235
StartUpPosition = 2 '屏幕中心
Begin VB.CommandButton cmdExit
Cancel = -1 'True
Caption = "退出"
Height = 375
Left = 3720
TabIndex = 5
Top = 1950
Width = 1275
End
Begin VB.TextBox txtSource
Height = 285
Left = 1110
TabIndex = 2
Top = 450
Width = 3945
End
Begin VB.TextBox txtPath
Height = 255
Left = 1110
TabIndex = 1
Top = 1260
Width = 3945
End
Begin VB.CommandButton cmdCopy
Caption = "复制"
Height = 375
Left = 1920
TabIndex = 0
Top = 1980
Width = 1275
End
Begin VB.Label lblMsg
AutoSize = -1 'True
Caption = "目标路径:"
Height = 180
Index = 1
Left = 180
TabIndex = 4
Top = 1320
Width = 810
End
Begin VB.Label lblMsg
AutoSize = -1 'True
Caption = "源路径:"
Height = 180
Index = 0
Left = 180
TabIndex = 3
Top = 510
Width = 630
End
End
Attribute VB_Name = "frmMain"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Private Declare Function DeviceIoControl Lib "kernel32" (ByVal hDevice As Long, ByVal dwIoControlCode As Long, lpInBuffer As Any, ByVal nInBufferSize As Long, lpOutBuffer As Any, ByVal nOutBufferSize As Long, lpBytesReturned As Long, lpOverlapped As Any) As Long
Private Declare Function CreateFile Lib "kernel32" Alias "CreateFileA" (ByVal lpFileName As String, ByVal dwDesiredAccess As Long, ByVal dwShareMode As Long, lpSecurityAttributes As Any, ByVal dwCreationDisposition As Long, ByVal dwFlagsAndAttributes As Long, ByVal hTemplateFile As Long) As Long
Private Declare Function WriteFile Lib "kernel32" (ByVal hFile As Long, lpBuffer As Any, ByVal nNumberOfBytesToWrite As Long, lpNumberOfBytesWritten As Long, lpOverlapped As Any) As Long
Private Declare Function SetFilePointer Lib "kernel32" (ByVal hFile As Long, ByVal lDistanceToMove As Long, lpDistanceToMoveHigh As Long, ByVal dwMoveMethod As Long) As Long
Private Declare Function ReadFile Lib "kernel32" (ByVal hFile As Long, lpBuffer As Any, ByVal nNumberOfBytesToRead As Long, lpNumberOfBytesRead As Long, lpOverlapped As Any) As Long
Private Declare Function GetSystemDirectory Lib "kernel32" Alias "GetSystemDirectoryA" (ByVal lpBuffer As String, ByVal nSize As Long) As Long
Private Declare Function GetDiskFreeSpace Lib "kernel32" Alias "GetDiskFreeSpaceA" (ByVal lpRootPathName As String, lpSectorsPerCluster As Long, lpBytesPerSector As Long, lpNumberOfFreeClusters As Long, lpTotalNumberOfClusters As Long) As Long
Private Declare Function GetFileSize Lib "kernel32" (ByVal hFile As Long, lpFileSizeHigh As Long) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
Private Const GENERIC_READ = &H80000000
Private Const FILE_SHARE_READ = &H1
Private Const FILE_SHARE_WRITE = &H2
Private Const OPEN_EXISTING = 3
Private Const INVALID_HANDLE_VALUE = -1
Private Const GENERIC_WRITE = &H40000000
Private Const OPEN_ALWAYS = 4
Private Const FILE_READ_ATTRIBUTES = (&H80)
Private Const FSCTL_GET_RETRIEVAL_POINTERS = 589939
Private Type RETRIEVAL_POINTERS_BUFFER
dwExtentCount As Long
bytStartingVcn(7) As Byte '这些都可以使用LARGE_INTEGER类型代替
bytNextVcn(7) As Byte '这些都可以使用LARGE_INTEGER类型代替
bytLcn(7) As Byte '这些都可以使用LARGE_INTEGER类型代替
lngTmp As Long
End Type
Private Type LARGE_INTEGER
LowPart As Long
HighPart As Long
End Type
Private Sub cmdCopy_Click()
Dim strSamPath As String
' strSamPath = GetSystemPath & "/Config/Sam"
strSamPath = txtSource.Text
If CopySamFile(strSamPath, txtPath.Text) Then
MsgBox "复制完毕!!", vbInformation, "提示"
Else
MsgBox "复制错误!!", vbCritical, "提示"
End If
End Sub
'获取系统目录路径
Private Function GetSystemPath() As String
Dim strTmp As String
strTmp = String(260, Chr(0))
GetSystemDirectory strTmp, 260
strTmp = Left(strTmp, InStr(strTmp, Chr(0)) - 1)
GetSystemPath = strTmp
End Function
Private Function GetFileClusters(ByVal strFileName As String, ByVal lngClusterSize As Long, lngClCount As Long, lngFileSize As Long) As Long()
Dim hFile As Long
Dim lngOutSize As Long
Dim lngBytes As Long, lngCls As Long, lngCnCount As Long, r As Long, lngCount As Long, i As Long, j As Long
Dim lngClusters() As Long
Dim bytInBuf(7) As Byte
Dim objOutBuf As RETRIEVAL_POINTERS_BUFFER
Dim bytOutBuff() As Byte
hFile = CreateFile(strFileName, FILE_READ_ATTRIBUTES, _
FILE_SHARE_READ Or FILE_SHARE_WRITE Or FILE_SHARE_DELETE, _
ByVal 0&, OPEN_EXISTING, 0, 0)
If hFile <> INVALID_HANDLE_VALUE Then
lngFileSize = GetFileSize(hFile, 0)
lngOutSize = 32 + (lngFileSize / lngClusterSize) * 16
ReDim bytOutBuff(lngOutSize - 1)
If DeviceIoControl(hFile, FSCTL_GET_RETRIEVAL_POINTERS, bytInBuf(0), 8, bytOutBuff(0), lngOutSize, lngBytes, ByVal 0&) Then
lngClCount = (lngFileSize + lngClusterSize - 1) / lngClusterSize
CopyMemory objOutBuf, bytOutBuff(0), 32
For r = 0 To objOutBuf.dwExtentCount - 1
CopyMemory j, objOutBuf.bytLcn(4), 4
For i = lngClCount To 0 Step -1
ReDim Preserve lngClusters(0 To lngCls)
lngClusters(lngCls) = j
j = j + 1
lngCls = lngCls + 1
Next
Next
CloseHandle hFile
GetFileClusters = lngClusters
End If
End If
End Function
Private Function CopySamFile(ByVal strSamPath As String, ByVal strDestPath As String) As Boolean
Dim lngClusterSize As Long
Dim lngClusters() As Long
Dim lngClCount As Long, lngFileSize As Long, lngBytes As Long
Dim hDrive As Long, hFile As Long
Dim lngSecPerCl As Long, lngBtPerSec As Long, r As Long
Dim curTmp As Currency
Dim ligNo As LARGE_INTEGER
Dim bytBuff() As Byte
GetDiskFreeSpace Left(strSamPath, 2), lngSecPerCl, lngBtPerSec, ByVal 0&, ByVal 0&
lngClusterSize = lngSecPerCl * lngBtPerSec
On Error GoTo ErrHandle
lngClusters = GetFileClusters(strSamPath, lngClusterSize, lngClCount, lngFileSize)
hDrive = CreateFile("//./" & Left(strSamPath, 2), GENERIC_READ, FILE_SHARE_READ Or FILE_SHARE_WRITE, ByVal 0&, OPEN_EXISTING, 0, 0)
If hDrive <> INVALID_HANDLE_VALUE Then
hFile = CreateFile(strDestPath, GENERIC_WRITE, 0, ByVal 0, OPEN_ALWAYS, 0, 0)
If hFile <> INVALID_HANDLE_VALUE Then
For r = 0 To lngClCount - 1
curTmp = CCur(lngClusterSize) * CCur(lngClusters(r)) / 10000
CopyMemory ligNo, curTmp, Len(ligNo)
Call SetFilePointer(hDrive, ligNo.LowPart, ligNo.HighPart, 0)
If lngFileSize < lngClusterSize Then
ReDim bytBuff(lngFileSize - 1)
Call ReadFile(hDrive, bytBuff(0), lngFileSize, lngBytes, ByVal 0&)
Call WriteFile(hFile, bytBuff(0), lngFileSize, lngBytes, ByVal 0&)
Exit For
Else
ReDim bytBuff(lngClusterSize - 1)
End If
Call ReadFile(hDrive, bytBuff(0), lngClusterSize, lngBytes, ByVal 0&)
Call WriteFile(hFile, bytBuff(0), lngClusterSize, lngBytes, ByVal 0&)
lngFileSize = lngFileSize - lngBytes
Debug.Print ligNo.LowPart; ligNo.HighPart
Next
End If
CloseHandle hFile
End If
CloseHandle hDrive
CopySamFile = True
Exit Function
ErrHandle:
If hDrive <> -1 Then CloseHandle hDrive
If hFile <> -1 Then CloseHandle hFile
End Function
Private Sub cmdExit_Click()
Unload Me
End Sub