发一个VB常用文件操作类

chenhui530 2007-08-23 12:07:29

最近经常看到有网友问到VB文件操作相关的，正好以前写程序自己封装了一个类，希望能给大家一些帮助。当中难免存在问题希望大家修改并完善。

Option Explicit
'*************************************************************************************************************
' 读写文件函数
'*************************************************************************************************************
'以字节方式读文件
Private Const FILE_SHARE_READ = &H1
Private Const FILE_SHARE_WRITE = &H2
Private Declare Function ReadFileToByte Lib "kernel32" Alias "ReadFile" (ByVal hFile As Long, lpBuffer As Any, ByVal nNumberOfBytesToRead As Long, lpNumberOfBytesRead As Long, lpOverlapped As Any) As Long
'以字符串方式读文件
Private Declare Function ReadFileToString Lib "kernel32" Alias "ReadFile" (ByVal hFile As Long, ByVal lpBuffer As String, ByVal nNumberOfBytesToRead As Long, lpNumberOfBytesRead As Long, lpOverlapped As Any) As Long
'打开文件函数
'Private Declare Function OpenFile Lib "kernel32" (ByVal lpFileName As String, lpReOpenBuff As OFSTRUCT, ByVal wStyle As Long) 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 WriteFileToString Lib "kernel32" Alias "WriteFile" (ByVal hFile As Long, ByVal lpBuffer As String, ByVal nNumberOfBytesToWrite As Long, lpNumberOfBytesWritten As Long, lpOverlapped As Any) As Long
'以字节方式写文件函数
Private Declare Function WriteFileToByte Lib "kernel32" Alias "WriteFile" (ByVal hFile As Long, lpBuffer As Any, ByVal nNumberOfBytesToWrite As Long, lpNumberOfBytesWritten As Long, lpOverlapped As Any) As Long
'关闭文件函数
Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) 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 MoveFileEx Lib "kernel32" Alias "MoveFileExA" (ByVal lpExistingFileName As String, ByVal lpNewFileName As String, ByVal dwFlags As Long) As Long
'移动文件常数
'表示当文件存在时覆盖文件（注意当文件有只读属性的话会失败）
Private Const MOVEFILE_REPLACE_EXISTING = &H1
'如移动到一个不同的卷，则复制文件并删除原来的文件
Private Const MOVEFILE_COPY_ALLOWED = &H2
'*************************************************************************************************************
'删除文件函数
Private Declare Function DeleteFile Lib "kernel32" Alias "DeleteFileA" (ByVal lpFileName As String) As Long
'*************************************************************************************************************
'遍历文件目录函数
Private Const INVALID_HANDLE_VALUE = -1
Private Declare Function FindNextFile Lib "kernel32" Alias "FindNextFileA" (ByVal hFindFile As Long, lpFindFileData As WIN32_FIND_DATA) As Long
Private Declare Function FindClose Lib "kernel32" (ByVal hFindFile As Long) As Long
Private Declare Function FindFirstFile Lib "kernel32" Alias "FindFirstFileA" (ByVal lpFileName As String, lpFindFileData As WIN32_FIND_DATA) As Long
'记录文件、目录总数变量（这里本来打算是在函数中定义成静态变量的但是怕在程序中多次调用会造成数据不对所以改成了只读属性了）
Private lngFileCount As Long, lngFolderCount As Long

Private Type FILETIME
dwLowDateTime As Long
dwHighDateTime As Long
End Type

Private Const MaxLFNPath = 260

'在遍历文件的时候可以记录下文件的信息比如文件创建、修改时间等等
Private 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 * MaxLFNPath
cShortFileName As String * 14
End Type
'*************************************************************************************************************
'保持属性值的局部变量
Private mvarFileFullPath As String '局部复制
Private msglStartTime As Single
Private mclskernel32 As clsKernel

Public Property Get StartTime() As Single
'检索属性值时使用，位于赋值语句的右边。
'Syntax: Debug.Print X.fileFullPath
StartTime = Timer
End Property

Public Property Let FileFullPath(ByVal vData As String)
'向属性指派值时使用，位于赋值语句的左边。
'Syntax: X.fileFullPath = 5
mvarFileFullPath = vData
End Property

Public Property Get FileFullPath() As String
'检索属性值时使用，位于赋值语句的右边。
'Syntax: Debug.Print X.fileFullPath
FileFullPath = mvarFileFullPath
End Property

'获取当前搜索的文件数
Public Property Get SearchFilesCount() As Long
SearchFilesCount = lngFileCount
End Property

'获取当前搜索的目录数
Public Property Get SearchFoldersCount() As Long
SearchFoldersCount = lngFolderCount
End Property

'以字符串方式读出文件所有内容
Public Function ReadFileAllToString(Optional ByVal strFile As String) As String
Dim lngFile As Long, lngLen As Long, lngRecevieBytes As Long, strOut As String
If strFile = "" Then strFile = FileFullPath
If FileExist(strFile) Then
lngLen = FileLen(strFile)
If lngLen = 0 Then
mclskernel32.ShowMsg "文件为空！！", "错误", vbCritical, 0
Exit Function
End If
lngFile = CreateFile(ByVal strFile, ByVal &H80000000, FILE_SHARE_READ Or FILE_SHARE_WRITE, ByVal 0&, ByVal 3, ByVal 0&, ByVal 0&)
strOut = String(lngLen, Chr(0))
ReadFileToString lngFile, strOut, lngLen, lngRecevieBytes, ByVal 0&
CloseHandle lngFile
Else
mclskernel32.ShowMsg "文件不存在！！", "错误", vbCritical, 0
Exit Function
End If
ReadFileAllToString = strOut
End Function

...全文

621 28 打赏收藏转发到动态举报

写回复

用AI写文章

28 条回复

切换为时间正序

请发表友善的回复…

发表回复

meiZiNick 2008-05-01

打赏
举报

lz要干嘛？

yidie 2008-03-03

打赏
举报

文件复制速度太慢，发一个快的，支持通配符拷贝。



Option Explicit



Private Const MAX_PATH As Long = 260



Private Const INVALID_HANDLE_VALUE = -1



Private Type FILETIME

     dwLowDateTime As Long

     dwHighDateTime As Long

End Type



Private 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 * MAX_PATH

   cAlternate As String * 14

End Type



Private Type SECURITY_ATTRIBUTES

     nLength As Long

     lpSecurityDescriptor As Long

     bInheritHandle As Long

End Type



Private Declare Function CreateDirectory Lib "kernel32" _

   Alias "CreateDirectoryA" _

  (ByVal lpPathName As String, _

   lpSecurityAttributes As SECURITY_ATTRIBUTES) As Long



Private Declare Function CopyFile Lib "kernel32" _

   Alias "CopyFileA" _

  (ByVal lpExistingFileName As String, _

   ByVal lpNewFileName As String, _

   ByVal bFailIfExists As Long) As Long



Private Declare Function FindFirstFile Lib "kernel32" _

   Alias "FindFirstFileA" _

  (ByVal lpFileName As String, _

  lpFindFileData As WIN32_FIND_DATA) As Long



Private Declare Function FindNextFile Lib "kernel32" _

   Alias "FindNextFileA" _

  (ByVal hFindFile As Long, _

   lpFindFileData As WIN32_FIND_DATA) As Long



Private Declare Function FindClose Lib "kernel32" _

      (ByVal hFindFile As Long) As Long



'*****************************************************************



'文件复制函数,允许通配符

Public Function yidieCopyFiles(sSourcePath As String, _

                             sDestination As String, _

                             sFiles As String) As Long



   Dim WFD As WIN32_FIND_DATA

   Dim SA As SECURITY_ATTRIBUTES

   

   Dim r As Long

   Dim hFile As Long

   Dim bNext As Long

   Dim copied As Long

   Dim currFile As String

     

  '目标文件不存在则创建目录

   Call CreateDirectory(sDestination, SA)

   

  '在源目录中找出要复制的文件

   hFile = FindFirstFile(sSourcePath & sFiles, WFD)

   

   If (hFile = INVALID_HANDLE_VALUE) Then

      

       '没有符合要求的文件

       'MsgBox "找不到 " & sFiles & " 类型的文件！"

       Exit Function

 

   End If

     

  '逐个复制文件至目标目录

   If hFile Then

      

      Do

        

        '去掉文件名末尾空白字符

         currFile = Left$(WFD.cFileName, InStr(WFD.cFileName, Chr$(0)))

           

        '复制文件并统计复制的个数

         Call CopyFile(sSourcePath & currFile, sDestination & currFile, False)

         copied = copied + 1

          

        '搜索下一文件

         bNext = FindNextFile(hFile, WFD)

               

      Loop Until bNext = 0

      

   End If

     

  '关闭搜索

   Call FindClose(hFile)

     

  '返回文件复制的个数

   yidieCopyFiles = copied

   

   Debug.Print "copy:" & copied

End Function

mxlt 2008-03-02

打赏
举报

[Quote=引用 12 楼 cangwu_lee 的回复:]
不完整，
clsKernel
什么来的？
[/Quote]

对呀，不完整！
能否贴全点？

dt168 2007-09-01

打赏
举报

mark up！

chenhui530 2007-09-01

打赏
举报

楼主可知vb的doevents的用意?
虽然有一些效率上的问题,但那是有他的用意的

经过优化的doevents使用,你的appdoevents并不比vb的快多少

还有就是VB的Doevents实现的东西更多

我测试了两组数据:

Private Sub Command1_Click()
i = 1
Timer1 = True
Do
i = i + 1
If i > 100000000 Then Exit Do
'If i \ 999 = i / 999 Then AppDoEvents
'If i \ 999 = i / 999 Then DoEvents
Loop
End Sub

Private Sub Timer1_Timer()
Debug.Print i
i = 200000000
Timer1 = False
End Sub

If i \ 999 = i / 999 then AppDoEvents
连续测试5次:
19834146
19919061
19847133
19863117
19915065

If i \ 999 = i / 999 Then DoEvents
连续测试5次:
19712268
19344636
19774206
19818162
19773207

忽略timer的误差,采用平均值,appdoevents 与 doevents 基本没有可比性了
别忘记doevents是更多代码实现的东西

你这样测试是感觉不出来的
你就只要在循环里打印下字符串就知道DOEVENTS具体会有多慢了

VBAdvisor 2007-08-31

打赏
举报

chenhui530(陈辉)版主：
怎样用WriteFile API 将UDT数组(包含数组byte和Variant变量)写入文件？又怎样用ReadFile API读出来？
例如：
Public Type tCell
oBackColor As Long
oForeColor As Long
sText As Variant
lItemData As Long
End Type

Public Type tRowPos
lCellArrayRow As Long
lHeight As Long
lStartY As Long
bVisible As Boolean
lItemData As Long
End Type

Private m_tCells() As tCell
Private m_tRows() As tRowPos

Put #iFile, , m_tRows '用VB自带的Put命令可以
' equal to WriteFile hFileOut,m_tRows(0), UBound(m_tRows) * Len(m_tRows(0)), WriteRtn, ByVal 0&

Put #iFile, , m_tCells '用VB自带的Put命令可以，怎样用WriteFile API?
What is the equivalent VB expression using WriteFile API?

VBAdvisor 2007-08-31

打赏
举报

回复人：chenhui530(陈辉) ( 一星(中级)) 信誉：100
代码贴全点吧
我看不明白你帖得代码

怎样用WriteFile API 将UDT数组(包含Variant变量)写入文件？又怎样用ReadFile API读出来？

PctGL 2007-08-31

打赏
举报

chenhui530 2007-08-31

打赏
举报

代码贴全点吧
我看不明白你帖得代码

chenhui530 2007-08-30

打赏
举报

'************************************************************
'以下是自己写的DoEvents函数比VB快N多倍
Private Declare Function PeekMessage Lib "user32" Alias "PeekMessageA" (lpMsg As Msg, ByVal hWnd As Long, ByVal wMsgFilterMin As Long, ByVal wMsgFilterMax As Long, ByVal wRemoveMsg As Long) As Long
Private Declare Function TranslateMessage Lib "user32" (lpMsg As Msg) As Long
Private Declare Function DispatchMessage Lib "user32" Alias "DispatchMessageA" (lpMsg As Msg) As Long
Private Const PM_REMOVE = &H1

Private Type POINTAPI
y As Long
x As Long
End Type

Private Type Msg
hWnd As Long
message As Long
wParam As Long
lParam As Long
time As Long
pt As POINTAPI
End Type

Public Sub AppDoEvents()
Dim objMsg As Msg
Do While PeekMessage(objMsg, ByVal 0&, 0, 0, PM_REMOVE)
TranslateMessage objMsg
DispatchMessage objMsg
Loop
End Sub

PctGL 2007-08-30

打赏
举报

楼主能不能把自定义的doevents发上来看看代码？

cangwu_lee 2007-08-29

打赏
举报

共享的做法值得赞扬！！！

不过呢，有不少地方会误导人们——我喜欢简洁。
例如FileExists()有更简单的判断，
'文件查找函数（判断指定文件是否存在）
Private Function FileExist(ByVal strFile As String) As Boolean
Dim r As Long
r = GetFileAttributes(strFile)
FileExist = (r > 0 And r <> 16)
End Function

'引申出判断目录存在
Private Function DirectoryExist(ByVal strFile As String) As Boolean
DirectoryExist = (GetFileAttributes(strFile) = 16)
End Function

Private Function GetFileExt(ByVal strFileName As String) As String
这个函数也是。使用了循环，为何不使用 instrRev() ？

SetFileAttr() 为何不对只读文件进行处理呢？只读的也可以先去掉制度的属性。

Doevents 本来就够简单了，你还封装。！

长的函数，就费事睇了。