readfile.bas

对文件的一系列操作

Attribute VB_Name = "ReadFile"

Option Explicit

Public Const ChunkSize = 4096 '4096
Declare Function SetWindowPos Lib "user32" (ByVal hwnd As Long, ByVal hWndInsertAfter As Long, ByVal x As Long, ByVal y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long

Type OPENFILENAME
lStructSize As Long
hwndOwner As Long
hInstance As Long
lpstrFilter As String
lpstrCustomFilter As String
nMaxCustFilter As Long
nFilterIndex As Long
lpstrFile As String
nMaxFile As Long
lpstrFileTitle As String
nMaxFileTitle As Long
lpstrInitialDir As String
lpstrTitle As String
flags As Long
nFileOffset As Integer
nFileExtension As Integer
lpstrDefExt As String
lCustData As Long
lpfnHook As Long
lpTemplateName As String
End Type

Declare Function GetOpenFileName Lib "comdlg32.dll" Alias "GetOpenFileNameA" (pOpenfilename As OPENFILENAME) As Long

Declare Function GetSaveFileName Lib "comdlg32.dll" Alias "GetSaveFileNameA" (pOpenfilename As OPENFILENAME) As Long

Public Type SHITEMID
mkidcb As Long
abID As Byte
End Type

Public Type ITEMIDLIST
idlmkid As SHITEMID
End Type

Public Type BROWSEINFO
hOwner As Long
pidlRoot As Long
pszDisplayName As String
lpszTitle As String
ulFlags As Long
lpfn As Long
lParam As Long
iImage As Long
End Type

Public Declare Function SHGetPathFromIDList Lib "shell32.dll" Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) As Long

Public Declare Function SHBrowseForFolder Lib "shell32.dll" Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long

Public Const BIF_RETURNONLYFSDIRS = &H1

Function GetOpenFileNameDLG(Filter As String, Title As String, DefaultExt As String, WindowHnd As Long) As String

    On Error GoTo handelopenfile
    Dim OpenFile As OPENFILENAME, Tempstr As String
    Dim Success As Long, FileTitleLength%
    Filter = Find_And_Replace(Filter, "|", Chr(0))
    If Right$(Filter, 1) <> Chr(0) Then Filter = Filter & Chr(0)
    OpenFile.lStructSize = Len(OpenFile)
    OpenFile.hwndOwner = WindowHnd
    OpenFile.hInstance = App.hInstance
    OpenFile.lpstrFilter = Filter
    OpenFile.nFilterIndex = 1
    OpenFile.lpstrFile = String(257, 0)
    OpenFile.nMaxFile = Len(OpenFile.lpstrFile) - 1
    OpenFile.lpstrFileTitle = OpenFile.lpstrFile
    OpenFile.nMaxFileTitle = OpenFile.nMaxFile
    OpenFile.lpstrTitle = Title
    OpenFile.lpstrDefExt = DefaultExt
    OpenFile.flags = 0
    Success = GetOpenFileName(OpenFile)

    If Success = 0 Then
    GetOpenFileNameDLG = ""
    Else
    Tempstr = OpenFile.lpstrFile
    GetOpenFileNameDLG = Trim(Tempstr)
    End If

    Exit Function
    
handelopenfile:        MsgBox Err.Description, 16, "Error " & Err.Number
    Exit Function
    End Function



Function Find_And_Replace(ByRef TextLine As String, ByRef SourceStr As String, ByRef ReplaceStr As String) As String

    On Error GoTo handelfindandreplace
    Dim DoAnother As Boolean, PosFound As Integer, ReturnStr As String

    DoAnother = True
    ReturnStr = TextLine

        While DoAnother
        PosFound = InStr(1, ReturnStr, SourceStr)

            If PosFound > 0 Then
            ReturnStr = Mid$(ReturnStr, 1, PosFound - 1) & ReplaceStr & Mid$(ReturnStr, PosFound + Len(SourceStr))
            Else

                DoAnother = False
                End If

            Wend

            Find_And_Replace = ReturnStr
handelfindandreplace:
Exit Function
End Function
'-------------------------上面打开文件结束。-----------------------------



Public Sub ChangeFile(FName$, IDString$, NString$)

  Dim PosString, WhereString
  Dim FileNumber, A$, NewString$
  Dim FileNumber2 As Integer
  Dim AString As String * ChunkSize
  Dim IsChanged As Boolean
  Dim BlockIsChanged As Boolean
  Dim NumChanges As Integer
  Dim tempstring As String
   IsChanged = False
   BlockIsChanged = False
   On Error GoTo Problems
   FileNumber = FreeFile
   PosString = 1
   WhereString = 0
   AString = Space$(ChunkSize)

'    If Len(IDString$) > Len(NString$) Then
'       NewString$ = NString$ + Space$(Len(IDString$) - Len(NString$))
'    Else
'       NewString$ = Left$(NString$, Len(IDString$))
'    End If
    NewString$ = NString$

    Open FName$ For Binary As FileNumber
    FileNumber2 = FreeFile
    Open FName + ".tmp" For Binary As FileNumber2
    NumChanges = 0

    If LOF(FileNumber) < ChunkSize Then
       A$ = Space$(LOF(FileNumber))
       Get #FileNumber, 1, A$
       WhereString = FindInString(1, A$, IDString$)
    Else
       A$ = Space$(ChunkSize)
       Get #FileNumber, 1, A$
       WhereString = FindInString(1, A$, IDString$)
    End If



    Do

        While WhereString <> 0
         tempstring = Left$(A$, WhereString - 1) & NewString$ & Mid$(A$, WhereString + Len(IDString$))
         A$ = tempstring
         NumChanges = NumChanges + 1
         IsChanged = True
'         BlockIsChanged = True
         WhereString = FindInString(WhereString + 1, A$, IDString$)
        Wend


'        If BlockIsChanged Then
           Put #FileNumber2, PosString, A$
'           BlockIsChanged = False
'        End If

        PosString = ChunkSize + PosString - Len(IDString$)        '完成之后退出


        If EOF(FileNumber) Or PosString > LOF(FileNumber) Then
        Exit Do
        End If

        ' 给出下一块

        If PosString + ChunkSize > LOF(FileNumber) Then
           A$ = Space$(LOF(FileNumber) - PosString + 1)
           Get #FileNumber, PosString, A$
           WhereString = FindInString(1, A$, IDString$)
        Else: A$ = Space$(ChunkSize)
           Get #FileNumber, PosString, A$
           WhereString = FindInString(1, A$, IDString$)
        End If

    Loop Until EOF(FileNumber) Or PosString > LOF(FileNumber)

    ' 关闭所有文件
    Close
    
    Beep
    Dim Msg As String
    If IsChanged = True Then
       Msg = Chr$(34) & FName$ & Chr$(34) & " 已经修改:       " & vbCrLf
       Msg = Msg & NumChanges & " 个部分,已经将: " & Chr$(34) & IDString$ & _
       Chr$(34) & " 替换为: " & Chr$(34) & _
       Left$(NString$, Len(IDString$)) & Chr$(34) & "          "
       MsgBox Msg, vbInformation, "文件修改完成!"
       Kill FName
       Name FName + ".tmp" As FName
    Else
       MsgBox "文件不能修改,请检查文件的正确性.", vbInformation, "不能找到搜索的字符或文件不存在"
    End If

    Exit Sub
Problems:
    Close
       MsgBox "一个错误发生." & vbCrLf & Err.Description, _
              vbExclamation, "Error number " & Err.Number
    End Sub
'________________________________________________________________________
Public Function FindInString(StartPos As Integer, StrToSearch As String, _
                             StrToFind As String) As Integer

    If Form1.Check1.Value = 0 Then
       FindInString = InStr(StartPos, UCase(StrToSearch), UCase(StrToFind))
    Else: FindInString = InStr(StartPos, StrToSearch, StrToFind)
    End If

End Function