Private Sub cmdSplitFile_Click()
Dim sFile As String
With CommonDialog1
.DialogTitle = "打開文件"
.Filter = "TXT文件(.txt)|*.txt|所有文件(*.*)|*.*"
.ShowOpen
.CancelError = False
End With
If Trim(CommonDialog1.FileName) = "" Then
MsgBox "請選擇文件", vbInformation
Exit Sub
End If
sFile = ReadFile(CommonDialog1.FileName)
end sub
模塊
Option Explicit
Declare Function FindFirstFile Lib "kernel32" Alias "FindFirstFileA" _
(ByVal lpFileName As String, _
lpFindFileData As WIN32_FIND_DATA _
) As Long
Declare Function FindClose Lib "kernel32" _
(ByVal hFindFile As Long _
) As Long
Declare Function FileTimeToSystemTime Lib "kernel32" _
(lpFileTime As FILETIME, _
lpSystemTime As SYSTEMTIME _
) As Long
'
Public Const FILE_ATTRIBUTE_READONLY = &H1
Public Const FILE_ATTRIBUTE_HIDDEN = &H2
Public Const FILE_ATTRIBUTE_SYSTEM = &H4
Public Const FILE_ATTRIBUTE_DIRECTORY = &H10
Public Const FILE_ATTRIBUTE_ARCHIVE = &H20
Public Const FILE_ATTRIBUTE_NORMAL = &H80
Public Const FILE_ATTRIBUTE_TEMPORARY = &H100
Public Const FILE_ATTRIBUTE_COMPRESSED = &H800
'
Type FILETIME
LowDateTime As Long
HighDateTime As Long
End Type
Type WIN32_FIND_DATA
dwFileAttributes As Long
ftCreationTime As FILETIME
ftLastAccessTime As FILETIME
ftLastWriteTime As FILETIME
nFileSizeHigh As Long
nFileSizeLow As Long
dwReserved0 As Long
dwReserved1 As Long
cFileName As String * 260 'MUST be set to 260
cAlternate As String * 14
End Type
Type SYSTEMTIME
wYear As Integer
wMonth As Integer
wDayOfWeek As Integer
wDay As Integer
wHour As Integer
wMinute As Integer
wSecond As Integer
wMilliseconds As Integer
End Type
'
Public Function Findfile(ByVal xstrfilename As String) As WIN32_FIND_DATA
On Error GoTo ErrorHandler
Dim Win32Data As WIN32_FIND_DATA
Dim plngFirstFileHwnd As Long
Dim plngRtn As Long
plngFirstFileHwnd = FindFirstFile(xstrfilename, Win32Data) ' Get information of file using API call
If plngFirstFileHwnd = 0 Then
Findfile.cFileName = "Error" ' If file was not found, return error as name
Else
Findfile = Win32Data ' Else return results
End If
plngRtn = FindClose(plngFirstFileHwnd) ' It is important that you close the handle for FindFirstFile
Exit Function 'Sub
ErrorHandler: ' 'On Error GoTo ErrorHandler
Dim funName
funName = "Findfile"
' Call WriteRunErrInfo(funName, Err.Number, Err.Description)
End Function
Public Function ReadFile(ByVal FileAllPath As String) As String
' Dim i As Long
'FileAllPath = "d:\sb$\test.txt"
'get file size
Dim filedata As WIN32_FIND_DATA
Dim nFileSize As Long
filedata = Findfile(FileAllPath) ' Get file information
If filedata.nFileSizeHigh = 0 Then '
nFileSize = filedata.nFileSizeLow '& " Bytes"
Else
nFileSize = filedata.nFileSizeHigh '& "Bytes"
End If
If nFileSize <= 0 Then '(error 61)
Exit Function
End If
'read file:
Dim bytBuffer() As Byte
ReDim bytBuffer(nFileSize - 1)
Dim nFileNum As Integer
nFileNum = FreeFile
Open FileAllPath For Binary As #nFileNum
Get #nFileNum, , bytBuffer()
Close #nFileNum
Dim sTeleText As String
sTeleText = StrConv(bytBuffer(), vbUnicode)
Private cfb1 As CFileBuff
Private cfb2 As CFileBuff
Private fh1 As Long
Private fh2 As Long
Private Sub Command1_Click()
Dim fn1 As String
Dim fn2 As String
Dim fn3 As String
Dim ch As Byte
Dim i As Long
Dim st1 As Single, et1 As Single
Dim st2 As Single, et2 As Single
st1 = Timer
Set cfb1 = New CFileBuff
Set cfb2 = New CFileBuff
If cfb1.Create(fn1) = True Then
cfb2.Create (fn2)
Do
If cfb1.GetByte(ch) = 1 Then
cfb2.PutByte ch
Else
Exit Do
End If
Loop While cfb1.FEof = False
Else
Debug.Print "Error Open File!"
End If
Set cfb1 = Nothing
Set cfb2 = Nothing
et1 = Timer
' MsgBox CStr(et1 - st1)
st2 = Timer
fh1 = FreeFile(0)
Open fn1 For Binary As fh1
fh2 = FreeFile(0)
Open fn3 For Binary As fh2
Do
Get fh1, , ch
Put fh2, , ch
Loop While EOF(fh1) = False
Close fh1
Close fh2
et2 = Timer
MsgBox CStr(et1 - st1) & " " & CStr(et2 - st2)
Debug.Print "Success!"
End Sub
Private Declare Function ReadFile Lib "kernel32" (ByVal hFile As Long, _
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 WriteFile Lib "kernel32" ( _
ByVal hFile As Long, lpBuffer As Any, _
ByVal nNumberOfBytesToWrite As Long, _
lpNumberOfBytesWritten As Long, ByVal lpOverlapped As _
Long) As Long
Private Declare Function CreateFile Lib "kernel32" _
Alias "CreateFileA" (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 SetFilePointer Lib "kernel32" ( _
ByVal hFile As Long, ByVal loWord As Long, ByVal hiWord As Long, ByVal MoveMethod As Long) As Long
Public Enum enumFileSeek
FS_BEGIN
FS_CURRENT
FS_END
End Enum
Private Const MAX_FILE_BUFF As Long = 512 '定义最大的缓冲区,正好一个扇区
Private Const EOF_CHAR As Byte = 0
Private m_fb(MAX_FILE_BUFF - 1) As Byte
Private m_NeedCloseFile As Boolean '是否需要
Private m_Handle As Long
Private m_OffSet As Long
Private m_DirtyFlag As Boolean
Private m_LastBuff As Boolean
Private m_MaxBytes As Long
Private m_FileName As String
'按标志创建文件
Public Function Create(FileName As String) As Boolean
m_Handle = CreateFile(FileName, GENERIC_WRITE Or GENERIC_READ, 0, 0, OPEN_ALWAYS, FILE_ATTRIBUTE_NORMAL, 0)
If m_Handle <> INVALID_HANDLE_VALUE Then '看是否正确创建了文件
m_FileName = FileName
ReadFileToBuff
Create = True
Else
Create = False
End If
End Function
'关闭文件
Public Sub CloseFile()
WriteBuffToFile
CloseHandle m_Handle
End Sub
'移动文件指针,不支持超过2 ^ 31 的位移
Public Function FSeek(Pos As Long, FS As enumFileSeek) As Boolean
Dim iPos As Long
If m_DirtyFlag = True Then WriteBuffToFile
Select Case FS
Case FS_BEGIN
If Pos < 0 Then FSeek = False
If SetFilePointer(m_Handle, Pos, 0, 0) = &HFFFFFFFF Then
FSeek = False
Else
If ReadFileToBuff = -1 Then
FSeek = False
Else
FSeek = True
End If
End If
Case FS_END
If Pos > 0 Then FSeek = False
If SetFilePointer(m_Handle, Pos, 0, 2) = &HFFFFFFFF Then
FSeek = False
Else
If ReadFileToBuff = -1 Then
FSeek = False
Else
FSeek = True
End If
End If
Case FS_CURRENT
iPos = Pos - (m_MaxBytes - m_OffSet) '计算实际的偏移位置
If SetFilePointer(m_Handle, iPos, 0, 1) = &HFFFFFFFF Then
FSeek = False
Else
If ReadFileToBuff = -1 Then
FSeek = False
Else
FSeek = True
End If
End If
End Select
End Function
'取一个字节
'返回 1 表示正确取到字符
'返回 0 表示已到文件尾,并且ch= EOF_CHAR
'返回 -1 表示取字符错误。
Public Function GetByte(ByRef ch As Byte) As Long
Dim fl As Long
If m_LastBuff = False Then
If m_OffSet = MAX_FILE_BUFF Then
fl = ReadFileToBuff
Select Case fl
Case 0
GetByte = 0
Case -1
GetByte = -1
Case Else
ch = m_fb(0)
m_OffSet = 1
GetByte = 1
End Select
Else
ch = m_fb(m_OffSet)
m_OffSet = m_OffSet + 1
GetByte = 1
End If
Else
If m_OffSet < m_MaxBytes Then
ch = m_fb(m_OffSet)
m_OffSet = m_OffSet + 1
GetByte = 1
Else
ch = EOF_CHAR
GetByte = 0
End If
End If
End Function
'写一个字节,如果正确表示1,错误为-1
Public Function PutByte(by As Byte) As Long
If m_OffSet < MAX_FILE_BUFF Then
WriteBuffToFile
m_fb(0) = by
m_OffSet = 1
m_DirtyFlag = True
End If
End Function
'看当前指针是否到达文件最尾端
Public Function FEof() As Boolean
If m_LastBuff = False Then
FEof = False
Else
If m_OffSet = m_MaxBytes Then
FEof = True
Else
FEof = False
End If
End If
End Function
'///////////////////////////////////////////////////////////////////////////////////////
'预读字节到缓冲区,并返回实际读到的字节,如果返回-1,则表示出错了。
Private Function ReadFileToBuff() As Long
Dim dwReadNum As Long
If ReadFile(m_Handle, m_fb(0), MAX_FILE_BUFF, dwReadNum, 0) = 0 Then
ReadFileToBuff = -1
Else
If dwReadNum <> MAX_FILE_BUFF Then
'最后一个缓冲区
End If
End Function
'写缓冲区到文件,并返回实际写的字节数
Private Function WriteBuffToFile() As Long
Dim dwWriteNum As Long
If m_OffSet = 0 Or m_DirtyFlag = False Then '如果写入数为0或者写入标志错则不写入
WriteBuffToFile = 0
Else
If WriteFile(m_Handle, m_fb(0), m_OffSet, dwWriteNum, 0) Then
WriteBuffToFile = dwWriteNum
Else
WriteBuffToFile = -1 '出错
End If
End If