pctools.bas

一个修改二进制文件的小程序,不过在打开大于1M的文件时耗时较长

Attribute VB_Name = "Tools"
Option Explicit
Global MyStr As String, FindStr As String, ReplaceStr As String
Global IsNum As Boolean, al As Boolean
Global Const ThisKey = "RecentFiles"
Global Const Total = 3
Global OpenName As String
Global CompName1 As String
Global CompName2 As String
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
Global Const freq As Double = 1193180
Global Start As Long
Global HexVal(15) As Byte, HexValA(255) As Byte, HexValB(255) As Byte
Declare Function QueryPerformanceCounter Lib "kernel32" (lpPerformanceCount As LARGE_INTEGER) As Long
Type LARGE_INTEGER
    lowpart As Long
    highpart As Long
End Type

Function GetTime() As Long
Dim result As LARGE_INTEGER
Dim a As Long
a = QueryPerformanceCounter(result)
GetTime = result.lowpart
End Function

Function st(n As Byte) As String
st = Hex$(n) & " "
If n < 16 Then st = "0" & st
End Function

Function mst(n) As String
Do
    mst = st(n Mod 256) & mst
    n = n \ 256
Loop Until n = 0
End Function

Function de(n) As Byte
de = pl(Left$(n, 1)) * 16 + pl(Right$(n, 1))
End Function

Function pl(n As String) As Byte
Select Case n
Case "1" To "9"
    pl = Val(n)
Case "A"
    pl = 10
Case "B"
    pl = 11
Case "C"
    pl = 12
Case "D"
    pl = 13
Case "E"
    pl = 14
Case "F"
    pl = 15
End Select
End Function

Sub OpenHex(FileName As String)
Dim a() As Byte, HCode() As Byte
Dim Pos As Long, Length As Long, BuffSize As Long
Dim i As Long, j As Long
Open FileName For Binary As #1
Length = LOF(1)
BuffSize = 1024: ReDim a(1 To BuffSize)
If Length = 0 Then Exit Sub
ReDim HCode(Length * 6 - 1)
Form1.Refresh
For i = 1 To Length \ BuffSize
    Get #1, , a()
    For j = 1 To BuffSize
        HCode(Pos) = HexValA(a(j))
        HCode(Pos + 2) = HexValB(a(j))
        HCode(Pos + 4) = 32
        Pos = Pos + 6
    Next j
Next i
Get #1, , a()
For i = 1 To Length Mod BuffSize
    HCode(Pos) = HexValA(a(i))
    HCode(Pos + 2) = HexValB(a(i))
    HCode(Pos + 4) = 32
    Pos = Pos + 6
Next i
Form1.rdata.Text = HCode
Form1.Caption = App.Title & "-" & FileName
Close #1
Erase HCode
End Sub

Sub GetRecentFiles()
Dim i As Integer, j As Integer
Dim FileName As String
FileName = GetSetting(App.Title, ThisKey, "RecentFile1")
If FileName = "" Then Exit Sub
With Form1
    .mnuMRU(0).Visible = True
    For i = 1 To Total
        .mnuMRU(i).Caption = "&" & i & " " & FileName
        .mnuMRU(i).Visible = True
        FileName = GetSetting(App.Title, ThisKey, "RecentFile" & i + 1)
        If FileName = "" Then Exit Sub
    Next i
End With
End Sub

Function FindRecentFile(FileName As String) As Integer
Dim i As Integer
For i = 1 To Total
    If Form1.mnuMRU(i).Caption = "&" & i & " " & FileName Then
        FindRecentFile = i
        Exit Function
    End If
Next i
FindRecentFile = -1
End Function

Sub Update(FileName As String)
Dim intRet As Integer
intRet = FindRecentFile(FileName)
If intRet = -1 Then
    WriteRecentFile FileName
Else
    WriteRecentFile FileName, intRet
End If
GetRecentFiles
End Sub

Sub WriteRecentFile(FileName As String, Optional Index)
Dim i As Integer, j As Integer
Dim strFile As String, key As String
If IsMissing(Index) Then j = Total - 1 Else j = Index - 1
For i = j To 1 Step -1
    key = "RecentFile" & i
    strFile = GetSetting(App.Title, ThisKey, key)
    If strFile <> "" Then
        key = "RecentFile" & i + 1
        SaveSetting App.Title, ThisKey, key, strFile
    End If
Next i
SaveSetting App.Title, ThisKey, "RecentFile1", FileName
End Sub

Function GetFileTitle(FileName As String) As String
Dim Pos As Long, a As Long
Do
Pos = a
a = InStr(Pos + 1, FileName, "\")
Loop Until a = 0
GetFileTitle = Mid$(FileName, Pos + 1)
End Function