发信人: lzzzl(lzzzl)
整理人: gzwsh(2002-11-05 22:59:39), 站内信件
|
我不想发MAIL了，而是在这里发布十六进制串，你可以把这些串反向转换成文件（恢复成原来的数据），知道它的好处吗？可以把一个小目录压缩到一个文件中，然后用它编码，再粘贴到这里，大家就可以共享了！当然，我有朋友们有先有这段代码，请粘贴到一个空白项目中并编译成bytes2base16.exe，并复制成base162bytes.exe（主要是图个方便）
，有兴趣的朋友用它把后面的代码解开：一个封装好的COM！当然，这个COM我只在我的系统下测试，可不能做商品用啊。这是我近日在做的练习，你说有没有用！
'----------------------------------------------------------------------
' 编码小工具
'----------------------------------------------------------------------
' 周仲俐创建于2001.12.22
' 周仲俐修改于2001.12.22
'----------------------------------------------------------------------
Option Explicit
Public Const LEN_OF_BYTE = 2 '为了放在一个模块中，在这里声明了
Public Sub Main()
Dim pisToBase16 As Boolean
Dim psFile As String
Dim psOutput As String
Dim psSwitch As String
Dim pisDebug As Boolean
psFile = Trim(Command$)
DeleteSwith psFile, UCase("-byte")
DeleteSwith psFile, UCase("/byte")
DeleteSwith psFile, UCase("-base16")
DeleteSwith psFile, UCase("/base16")
DeleteSwith psFile, UCase("-debug")
DeleteSwith psFile, UCase("/debug")
pisToBase16 = True
psFile = Trim(psFile)
'判断要做什么动作有三重判断，为了方便控制，后面的判断优先级最高，可以覆盖前面的判断
'程序名（昏招，但实用，可在资源管理器中不做任何设置就中拖放式操作）
If UCase(App.EXEName) = UCase("base162bytes") Then
pisToBase16 = False
ElseIf UCase(App.EXEName) = UCase("bytes2base16") Then
pisToBase16 = True
End If
'扩展名
If psFile = "" Then
ElseIf UCase(Right(psFile, 6)) = UCase(".byte") Then
pisToBase16 = True
ElseIf UCase(Right(psFile, 7)) = UCase(".base16") Then
pisToBase16 = False
End If
'开关
If InStr(1, UCase(Trim(Command$)), UCase("-byte"), vbBinaryCompare) > 0 Then
pisToBase16 = False
ElseIf InStr(1, UCase(Trim(Command$)), UCase("/byte"), vbBinaryCompare) > 0 Then
pisToBase16 = False
End If
If psFile = "" Then
ElseIf pisToBase16 Then
psOutput = "output.base16"
Else
psOutput = "output.byte"
End If
If Right(App.Path, 1) <> "\" Then
psOutput = "\" & psOutput
End If
psOutput = App.Path & psOutput
If psFile <> "" Then
File2File psFile, psOutput, pisToBase16
Beep
MsgBox "ok"
End If
pisDebug = False
If InStr(1, UCase(Trim(Command$)), UCase("-debug"), vbBinaryCompare) > 0 Then
pisDebug = True
ElseIf InStr(1, UCase(Trim(Command$)), UCase("/debug"), vbBinaryCompare) > 0 Then
pisDebug = True
End If
If pisDebug Then
Beep
MsgBox "command=" & Command$ & ",input=" & psFile & ",output=" & psOutput
End If
End Sub
Public Sub File2File(ByVal sSrc As String, Optional ByVal sDest As String, Optional ByVal isToBase16 As Boolean)
Dim piSrcFile As Integer
Dim piDestFile As Integer
Dim s As String
Dim plLen As Long
Dim piNextSize As Integer
Dim plPos As Long
Dim BUF_SIZE
Dim buf As String
Dim psDest As String
Dim BASE_TMP_FILE As String
Dim pBytes() As Byte
Dim pArr() As Byte
s = ""
BASE_TMP_FILE = "basekit.tmp"
'可能不指定目标文件，表示输出与输入是同一文件
psDest = sDest
If psDest = "" Or UCase(sSrc) = UCase(sDest) Then
psDest = BASE_TMP_FILE
End If
If Dir(psDest) <> "" Then
Kill psDest
End If
BUF_SIZE = 512
piSrcFile = FreeFile
Open sSrc For Binary As #piSrcFile
piDestFile = FreeFile
Open psDest For Binary As #piDestFile
plLen = LOF(piSrcFile)
piNextSize = BUF_SIZE
For plPos = 1 To plLen Step BUF_SIZE
DoEvents
If plPos + BUF_SIZE > plLen Then
piNextSize = plLen - plPos + 1
End If
'buf = Input(piNextSize, piSrcFile)
'Input #piSrcFile, pByte
ReDim pBytes(piNextSize - 1) '因为要写盘，所以下标从0开始
Get #piSrcFile, , pBytes
If isToBase16 Then
s = Byte2Base16(pBytes) 'StrConv(pBytes, vbUnicode)
Put #piDestFile, , s
Else
pArr = Base162Byte(pBytes) 'StrConv(pBytes, vbUnicode)
Put #piDestFile, , pArr
Debug.Print Format$(plPos, "00000000") & " | " & Format$(UBound(pArr), "0000") & " | " & Format(LOF(piDestFile), "0000000000")
'If (plPos - 1) / 2 + piNextSize / 2 <> LOF(piDestFile) Then Stop
End If
Next
Close #piSrcFile
Close #piDestFile
'可能需要处理临时文件
If psDest = BASE_TMP_FILE Then
FileCopy psDest, sSrc
Kill psDest
End If
End Sub
Private Function Byte2Base16(byteArr() As Byte) As String
'bytes－＞十六进制串。用于把二进制文件转换成方便传输的十六进制串
Dim i As Long
Dim pl As Long
Dim s As String
Dim piAsc As Integer
Dim tmp As String
s = ""
pl = UBound(byteArr)
For i = 0 To pl '因为要写盘，所以下标从0开始
DoEvents
piAsc = byteArr(i)
tmp = Hex$(piAsc)
If Len(tmp) < LEN_OF_BYTE Then
tmp = String(LEN_OF_BYTE - Len(tmp), "0") & tmp
End If
s = s & tmp
'If Len(s) <> i * LEN_OF_BYTE Then Stop
Next
Byte2Base16 = s
End Function
Private Function Base162Byte(byteArr() As Byte) As Byte()
'十六进制串－＞bytes。用于把接收到的十六进制串恢复成二进制文件以方便保存和使用
'错误处理 不处理，抛出2005号错误
Dim s As String
Dim i As Long
Dim pl As Long
Dim piRtrn As Integer
Dim pArr() As Byte
Dim psTmp As String
pl = UBound(byteArr)
If (pl + 1) Mod LEN_OF_BYTE <> 0 Then
Err.Raise 2005, App.EXEName & ".mBasekit.Base162Byte()", "十六进制串长度要是" & CStr(LEN_OF_BYTE) & "的整数倍"
End If
ReDim pArr((pl + 1) / LEN_OF_BYTE - 1)
s = ""
For i = 0 To pl Step LEN_OF_BYTE '注意，因为要写盘，所以下标从0开始
DoEvents
If byteArr(i) = 0 Then
psTmp = "0"
Else
psTmp = Chr$(byteArr(i))
End If
If byteArr(i + 1) = 0 Then
psTmp = psTmp & "0"
Else
psTmp = psTmp & Chr$(byteArr(i + 1))
End If
piRtrn = OneByte(psTmp)
pArr(Int(i / LEN_OF_BYTE)) = piRtrn
Next
Base162Byte = pArr
End Function
Private Function OneByte(ByVal s2Char As String) As Long
'转换2个十六进制数据成一个Byte
'错误处理 不处理，抛出2004号错误
Dim plRtrn As Long
Dim i As Long
Dim plTmp As Long
Dim pChar As String
plRtrn = 0
For i = 1 To 2
DoEvents
plTmp = 0
pChar = Mid(s2Char, i, 1)
Select Case UCase(pChar)
Case "A" To "F"
plTmp = Asc(pChar) - Asc("A") + 10
Case "0" To "9"
plTmp = Asc(pChar) - Asc("0")
Case Else
Err.Raise 2004, App.EXEName & ".mBasekit.OneByte()", "十六进制串中只能是{0123456789ABCDEF}中的字符组合"
End Select
plRtrn = plRtrn * 16 + plTmp
Next
OneByte = plRtrn
End Function
Public Sub DeleteSwith(ByRef sData As String, ByVal sFactor As String)
'过滤指定串中的指定内容
'参数 sData 数据串(值传递)
' sFactor 过滤因子串
Dim piIndex As Integer
Dim s As String
Dim piL As Integer
s = sData '化简
piL = Len(sFactor)
Do
DoEvents
piIndex = InStr(1, UCase(s), UCase(sFactor), vbBinaryCompare)
If s = "" Or piIndex = 0 Then
Exit Do
End If
s = Left(s, piIndex - 1) & Mid(s, piIndex + piL)
Loop
sData = s
End Sub
----
不想计较得失，却总在计较得失 |
|