注：不保证可用性，可能有错误，且Partie变种极多，此工具只应对其中一种，默认认为文件的基地址就是00400000h，只是作为一个笔记的形式存在于此，不要把这个程序付诸实践……（Zblog的UBB模式缩进有问题）

Option Explicit
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (pDst As Any, pSrc As Any, ByVal ByteLen As Long)
Private Declare Function GetFileAttributes Lib "kernel32" Alias "GetFileAttributesA" (ByVal lpFileName As String) As Long
Dim PE() As Byte, e_lfanew As Long, NumberOfSections As Long
Dim SizeOfOptionalHeader As Long, AddressOfEntryPoint As Long, NumberOfRvaAndSizes As Long
Dim EncStart As Long, EncEnd As Long
Dim SectionTableOffset As Long, SectionTable() As SectionHeader, EntrySection As Long, PaddingArea As Long
Dim Tmp As Long

Private Type SectionHeader
Name As String * 8
RVA As Long
VirtualSize As Long
PhysicalSize As Long
Offset As Long
Flags As Long
End Type

Private Function PartieCheck(FileName As String) As String
On Error Resume Next
Dim i As Integer
ReDim PE(FileLen(FileName) - 1)
Open FileName For Binary As #1
Get #1, , PE
Close #1
If ReadWord(0) <> &H5A4D Then PartieCheck = "不是PE文件": Exit Function
e_lfanew = ReadDword(&H3C) '0x3C处地址指向'PE'字符
If ReadDword(e_lfanew) <> &H4550 Then PartieCheck = "不是PE文件": Exit Function
If ReadWord(e_lfanew + 4) <> &H14C Then PartieCheck = "不是PE文件": Exit Function
NumberOfSections = ReadWord(e_lfanew + 6)
If NumberOfSections <= 0 Or NumberOfSections >= &H100 Then PartieCheck = "不是PE文件": Exit Function
SizeOfOptionalHeader = ReadWord(e_lfanew + &H14)
If ReadWord(e_lfanew + &H18) <> &H10B Then PartieCheck = "不是PE文件": Exit Function
'＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝PECheck＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝
AddressOfEntryPoint = ReadWord(e_lfanew + &H28&)
If SizeOfOptionalHeader >= &H60 Then
NumberOfRvaAndSizes = ReadDword(e_lfanew + &H74&)
Else
NumberOfRvaAndSizes = 0
End If
If NumberOfRvaAndSizes > 16 Then NumberOfRvaAndSizes = 16
If NumberOfRvaAndSizes > (SizeOfOptionalHeader - &H60&) \ 8 Then _
NumberOfRvaAndSizes = (SizeOfOptionalHeader - &H60&) \ 8
NumberOfRvaAndSizes = NumberOfRvaAndSizes - 1
NumberOfSections = NumberOfSections - 1
If SizeOfOptionalHeader <> 224 Then Stop
SectionTableOffset = e_lfanew + &H18& + SizeOfOptionalHeader
EntrySection = -1
ReDim SectionTable(NumberOfSections)
With SectionTable(NumberOfSections)
.Name = ReadTDword(SectionTableOffset + NumberOfSections * &H28&)
.VirtualSize = ReadDword(SectionTableOffset + NumberOfSections * &H28& + &H8&)
.RVA = ReadDword(SectionTableOffset + NumberOfSections * &H28& + &HC&)
.PhysicalSize = ReadDword(SectionTableOffset + NumberOfSections * &H28& + &H10&)
.Offset = ReadDword(SectionTableOffset + NumberOfSections * &H28& + &H14&)
.Flags = ReadDword(SectionTableOffset + NumberOfSections * &H28& + &H24&)
'=======================================Partie Check=========================================
Dim Sign As String, Countar As Long, eax As Long, edi As Long, esi As Long, ImageBase As Long, EntryPoint As Long
Dim Xdiff As Long, FileSign As String, SizeOfImage As Long
Sign = "90 68 ?? ?? ?? ?? 58 90 90 68 ?? ?? ?? ?? 5F 90 68 ?? ?? ?? ?? 5E 90 90 31 04 3E 83 EE 03 4E 75 "
'第一种Partie的特征
'Sign = "B8 39 30 00 00 E8 00 00 00 00 33 C0 5B 81 EB E4 22 40 00 83 C0 01 8B C4"
' 另一种Partie的特征，暂时不用它
For Countar = 0 To &H1F
FileSign = FileSign & IIf(PE(.Offset + Countar) <= 15, "0", "") & Hex(PE(.Offset + Countar)) & " "
Next Countar
If (FileSign Like Sign) = False Then PartieCheck = "未被感染": Exit Function '特征不匹配
WriteWord e_lfanew + 6, NumberOfSections 'NOS 之前已减一，无需再减



eax = ReadDword(.Offset + 2)
edi = ReadDword(.Offset + 10)
esi = ReadDword(.Offset + 17)
ImageBase = ReadDword(e_lfanew + 52)
If ImageBase = 0 Then ImageBase = &H400000
edi = edi - ImageBase
edi = edi - .RVA + .Offset '还原常态
For Countar = esi To 0 Step -4
WriteDword edi + Countar, ReadDword(edi + Countar) Xor eax
Next Countar
'ImageBase = ReadDword(.Offset + &H2A)
SizeOfImage = ReadDword(e_lfanew + 80) - Xdiff
EntryPoint = ReadDword(.Offset + &H2E)
WriteDword e_lfanew + &H28&, EntryPoint
Xdiff = FileLen(FileName) - .Offset
SizeOfImage = SizeOfImage - .VirtualSize
WriteDword e_lfanew + 80, SizeOfImage '修正SizeOfImage
ReDim Preserve PE(.Offset - 1)
End With
Kill FileName
Open FileName For Binary As #1
Put #1, , PE()
Close #1
PartieCheck = "修复完毕"
'Debug.Print "done!"
End Function
Private Function ReadWord(ByVal Offset As Long) As Long
CopyMemory ReadWord, PE(Offset), 2
End Function
Private Function ReadDword(ByVal Offset As Long) As Long
CopyMemory ReadDword, PE(Offset), 4
End Function
Private Sub WriteWord(ByVal Offset As Long, ByVal Data As Long)
CopyMemory PE(Offset), Data, 2
End Sub
Private Sub WriteDword(ByVal Offset As Long, ByVal Data As Long)
CopyMemory PE(Offset), Data, 4
End Sub

Private Function Add0To8(ByVal InputStr As String) As String
Add0To8 = String(8 - Len(InputStr), "0") & InputStr
End Function

Private Function ReadTDword(ByVal Offset As Long) As String
Dim i As Long, c As Byte, s As String
For i = 0 To 7
c = PE(Offset + i): If c < 32 Or c > 127 Then c = 32: s = s & Chr(c)
Next i
ReadTDword = s
End Function

Private Sub cmdRepair_Click()
Dim RetnValue As String
If GetFileAttributes(txtFile.Text) = -1 Then
MsgBox "文件不存在!", vbCritical, "错误"
Else
RetnValue = PartieCheck(txtFile.Text)
If RetnValue <> "" Then MsgBox RetnValue, vbInformation, "结果"
End If
End Sub