foxtools.frm

一款反编译VFP程序的代码的工具

'Dim fieldnamel As String
'Dim fieldvaluel As String
'fieldsnuml = (FirstRecPos - 296) / 32
'Dim Item As ListItem
'Dim clmAdd As ColumnHeader
'Dim itmAdd As ListItem

''ListView2.View = lvwReport
'Dim lStyle As Long
'lStyle = SendMessage('ListView2.hWnd, LVM_GETEXTENDEDLISTVIEWSTYLE, 0, 0)
'lStyle = lStyle Or LVS_EX_FULLROWSELECT
'Call SendMessage(ListView2.hWnd, LVM_SETEXTENDEDLISTVIEWSTYLE, 0, ByVal lStyle)

'Dim Fieldtypel As String

'ListView2.ColumnHeaders.Clear

'For jl = 1 To fieldsnuml
   'fieldnamel = ""
   'fieldnamel = GetFieldName(jl)
   'Set clmAdd = ListView2.ColumnHeaders.Add(Text:=fieldnamel)
'Next

'For rel = 1 To RecNum
 '  For jl = 1 To fieldsnuml
  '    fieldvaluel = ""
   '   Fieldtypel = GetFieldType(jl)
    '
     ' If Fieldtypel <> "M" Then
     '    fieldvaluel = GetFieldValue(rel, jl)
      'End If
      
      'If jl = 1 Then
'         Set itmAdd = ListView2.ListItems.Add(Text:=fieldvaluel)
 '     Else
  '      If Fieldtypel = "M" Then
   '        If GetMemoOffset(rel, jl) = 0 Then
    '          itmAdd.SubItems(jl - 1) = "memo"
     '      Else
      '        itmAdd.SubItems(jl - 1) = "MEMO"
       '    End If
        'Else
         '  itmAdd.SubItems(jl - 1) = fieldvaluel
'        End If
 '     End If
  ' Next
'Next

'Close #1
'On Error GoTo Error
 '
  '         RichTextBox1.Visible = False
   '        Image3.Visible = False
    '      ListView2.Visible = True
            ' OpenAndLoad3 filenamea, FILENAMET
     '       On Error GoTo Error
            ''''''''''''''''''''''''''表结构结束
            ''''''''''''''''''''
          ' Case ".DBF" ''dbf表
          
            
            
            
            
            
            
            
            
            
           '''''''''''''''新代码结束
            Case Else
           On Error GoTo Error
             'List2.Clear
             RichTextBox1.Text = ""
           RichTextBox1.Visible = True
'           Image3.Visible = False
        'ListView2.ColumnHeaders.Clear
           'ListView2.Visible = False
          
           On Error GoTo Error
            End Select
            
Exit Sub

Error:
 'List2.Clear
             RichTextBox1.Text = ""
           RichTextBox1.Visible = True
'           Image3.Visible = False
        'ListView2.ColumnHeaders.Clear
           'ListView2.Visible = False
          
MsgBox "打开文件时发生错误", , "提示"
Exit Sub
End Sub
Private Sub File1_DblClick()

RichTextBox1.Text = ""
Dim filenamea As String, lx As String, tt As String, efile As String, selfile As String
tt = File1.path
If Len(tt) = 0 Then
tt = Drive1.Drive
End If
If Right(tt, 1) <> "\" Then
tt = tt + "\"
End If
filenamea = tt + File1.FileName
lx = Right(filenamea, 4)
   Select Case UCase(lx)
        
       Case ".FXP", ".FOX", ".SPX", ".QPX", ".MPX"

''''''''''''''''''''

selfile = filenamea

If selfile = "" Then
    Exit Sub
Else

Dim filelen1 As Long
filelen1 = FileLen(selfile)
If filelen1 = 0 Then
Exit Sub
End If
       
        Dim fname As String
   
        Select Case UCase(Right(selfile, 4))
        Case ".FXP", ".FOX"
             fname = strleft(selfile, strlen(selfile) - 4) + ".prg"
        Case ".MPX"
             fname = strleft(selfile, strlen(selfile) - 4) + ".mpr"
        Case ".QPX"
             fname = strleft(selfile, strlen(selfile) - 4) + ".qpr"
        Case ".SPX"
             fname = strleft(selfile, strlen(selfile) - 4) + ".spr"
        End Select
    
         RichTextBox1.Visible = True
'           Image3.Visible = False
           On Error GoTo Error
        If dir(fname) <> "" Then
        RichTextBox1.LoadFile fname, rtfText
        End If
        
         On Error GoTo Error
    End If

Case ".SCX", ".VCX"
         Dim filename2 As String
         Dim filename1 As String
         filename1 = filenamea
         filename2 = strleft(filenamea, strlen(filenamea) - 1) + "t"
          On Error GoTo Error
          ErrNum = 0
          
sctvct:
           
Dim fl As Long
Dim f2 As Long
fl = FileLen(filename1)
If fl = 0 Then
   Exit Sub
End If

f2 = FileLen(filename2)
If f2 = 0 Then
   Exit Sub
End If

filelen1 = fl
filelen2 = f2

ReDim FileDataScx(1 To fl) As Byte

Open filename1 For Binary As #10
Open filename2 For Binary As #20

' 读入 scx
Get #10, , FileDataScx()

' 检查文件类型
If FileDataScx(1) <> 48 Then
   Close #10
   Close #20
   MsgBox "文件类型错误", , "错误"
   Exit Sub
End If

' 检查备注字段标志
If FileDataScx(29) <> 2 Then
   Close #10
   Close #20
   MsgBox "无备注字段错误!", , "错误"
   Exit Sub
End If

ReDim FileDataSct(1 To f2) As Byte
Get #20, , FileDataSct()

ErrNum = 0
' 记录长度
FirstRecPos = FileDataScx(10)
FirstRecPos = FileDataScx(9) + FirstRecPos * 256
reclen = FileDataScx(12)
reclen = reclen * 256 + FileDataScx(11)

' 记录数
CopyMemory RecNum, FileDataScx(5), 4
CopyMemory FirstRecOffset, FileDataScx(9), 2


If RecNum = 0 Then
   Close #20
   Close #10
   MsgBox "无记录供处理", , "错误"
   Exit Sub
End If

Dim ByteLong(0 To 3) As Byte
Dim ByteArr(0 To 1) As Byte
Dim reallen As Long
Dim reallen2 As Long
Dim fd2() As Byte
Dim p As Long
Dim I As Integer

CopyMemory FirstRecPos, FileDataScx(9), 2
CopyMemory reclen, FileDataScx(11), 2

Seek #20, 5
Get #20, , ByteLong()
ReserveByte ByteLong
CopyMemory BlockSize, ByteLong(0), 2

If BlockSize = 0 Then
    Exit Sub
End If

LastBlock = BlockNum(f2)
FirstBlock = BlockNum(512)

Seek #20, 1
Get #20, , ByteLong()
ReserveByte ByteLong

'下一个自由块的块号
CopyMemory NextFreeBlockNum, ByteLong(0), 4

If NextFreeBlockNum > FileLen(filename2) Then
   NextFreeBlockNum = FileLen(filename2) + 1
End If

' 下一个自由块的偏移
NextFreeBlockOffset = NextFreeBlockNum * BlockSize

reallen = LOF(20)

' 修正 sct 文件长度
If BlockSize = 1 Then
     CopyMemory ByteLong(0), reallen, 4
Else
     reallen2 = reallen / BlockSize
     If reallen2 <> Int(reallen2) Then
        reallen2 = reallen2 + 1
     End If
     CopyMemory ByteLong(0), reallen2, 4
End If

ReDim fd2(1 To reallen) As Byte
Seek #20, 1
Get #20, , fd2()
Close #20
DeleteFile filename2

' 修正第一个自由块位置
ReserveByte ByteLong
CopyMemory fd2(1), ByteLong(0), 4
Open filename2 For Binary As #20
Put #20, , fd2()
   
NextFreeBlockOffset = reallen + 1

p = NextFreeBlockOffset / BlockSize
If p <> Int(NextFreeBlockOffset / BlockSize) Then
    p = Int(p) + 1
End If

NextFreeBlockNum = p

Dim j As Integer
Dim re As Integer
Dim fieldsnum As Integer
Dim fieldname As String
Dim fieldvalue As String
Dim Fieldtype As String
Dim MemoOffset As Long
Dim mLength As Long
Dim HasObjcode As Boolean
Dim fxpflag As Long
Dim fxplen As Long
Dim scxcodext() As String  '局部数组保存代码
Dim scxlmt() As String     '局部数组保存控件名
fieldsnum = (FirstRecPos - 296) / 32

Dim IsComment As String

For re = 1 To RecNum ''此处是不是处理SCX。VCX记录数？？
   IsComment = GetFieldValue(re, 1)
   
   For j = 1 To fieldsnum
      fieldname = ""
      fieldvalue = ""
      fieldname = GetFieldName(j) ''字段名
      Fieldtype = GetFieldType(j) ''字段类型
      
      If Fieldtype <> "M" Then
         fieldvalue = GetFieldValue(re, j)
      End If
      
      If Fieldtype = "M" Then
         
         mLength = GetMemoLength(re, j)
         MemoOffset = GetMemoOffset(re, j)
         If MemoOffset <> 0 Then
         
         If (MemoOffset < FirstBlock Or MemoOffset > LastBlock) Then
            '字段指向不正确位置
            ClearInvalidMemo re, j
            ErrNum = ErrNum + 1
            GoTo here9
         Else
         
         
            ' 对于 methods 字段,直接清除
            If LCase(fieldname) = "methods" Then
               ClearInvalidMemo re, j
               ErrNum = ErrNum + 1
            End If
         
            If (mLength <= 0 Or mLength > (f2 - MemoOffset)) Then
               '备注块长度错误
               If LCase(fieldname) <> "objcode" Then
                  ClearInvalidMemo re, j
               End If
               ErrNum = ErrNum + 1
            End If
            
            If LCase(fieldname) <> "reserved1" And re = 1 And mLength <> 0 And mLength <> -1 Then
               '字段出现在不正确的位置
               ClearInvalidMemo re, j
               ErrNum = ErrNum + 1
               GoTo here9
            End If
         
            If (Trim(LCase(IsComment)) = "comment" And LCase(fieldname) = "objcode" And re <> 1) Or _
               (LCase(fieldname) = "objcode" And re = 1) Then
               '字段出现在不正确的位置
               ClearInvalidMemo re, j
               ErrNum = ErrNum + 1
               GoTo here9
            End If
         
            If LCase(fieldname) = "methods" And mLength <> 0 And GetMemoLength(re, 12) = 0 Then
            '字段中有垃圾内容
               ClearInvalidMemo re, j
               ErrNum = ErrNum + 1
            End If
         
            If LCase(fieldname) = "objcode" Then
               fxpflag = GetMemoLong(re, j)
               If Hex(fxpflag) <> "20FFF2FE" Then
                  ' Objcode 标志被修改
                  'WriteFxpHeader re, j
                  ErrNum = ErrNum + 1
               End If
            
               fxplen = GetFxpLen(re, j)
               If mLength <> fxplen Then
                  ' Objcode 长度被修改
                  WriteFxpLen re, j, fxplen '+ 10240
                  ErrNum = ErrNum + 1
               End If
            End If
here9:
         End If
         End If
      End If
   Next
Next

Seek #10, 1
Put #10, , FileDataScx()
Close #10
Seek #20, 1
Put #20, , FileDataSct()
Close #20

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' 反编译 objcode 中的代码
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Dim sct_methods_length2 As String
Dim CodeLen As Long
Dim ObjNane As String
Dim CodeStartPos As Long
Dim methodtext As String
Dim MethodLen As Long
Dim CurrentRecodNo As Long

Open filename1 For Binary As #10
Open filename2 For Binary As #20
If RecNum > 0 Then
'ReDim scxcodext(1 To RecNum) '重新定义数据将生成的代码放到scxcodext数据中
'ReDim scxlmt(1 To RecNum)
End If
For I = 1 To RecNum
    
    
    CodeLen = GetMemoLength(I, 12)