精华区 [关闭][返回]

当前位置:网易精华区>>讨论区精华>>编程开发>>● VB和Basic>>〓〓....周边技巧....〓〓>>以后要和我交流源码的朋友需要的解码程序在这里

主题:以后要和我交流源码的朋友需要的解码程序在这里
发信人: 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





----
不想计较得失,却总在计较得失   

[关闭][返回]