Planet Source Code Jumbo …e CD Visual Basic 1 to 7/6_2008-2009.ISO/data/zips/EliteXp®_P21651610152009.psc/PE.cls

Text File | 2009-10-15 | 9KB | 272 lines

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "PE"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Private Type Props
    hMapFile As Long
    hFile As Long
    dwFileSize As Long
    FileName As String
    FileLoaded As Boolean
End Type

Private Type Objects
    DosHeader As DosHeader
    NtHeader As NtHeader
    Sections As Sections
    BoundImports As BoundImports
End Type

Dim Mem As Props    'Properties For this Class
Dim nFile As Props  'Properties For New File
Dim Obj As Objects

Property Get FileName() As String
FileName = Mem.FileName
End Property
Property Get Base() As Long
Base = Mem.hMapFile
End Property

Function LoadFile(ByVal FileName As String) As Boolean
On Error Resume Next
Mem.FileLoaded = False
Mem.hFile = CreateFile(FileName, GENERIC_READ, FILE_SHARE_READ, ByVal 0, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, 0)
If Mem.hFile = -1 Then
    SetError "Error Opening File. Check if the File exists and is not locked."
    Exit Function
End If
Mem.FileName = FileName
Mem.dwFileSize = GetFileSize(Mem.hFile, 0)
If Mem.dwFileSize = 0 Then
    SetError "FileSize Error. Check if the file is locked by other applications"
    Exit Function
End If
Mem.hMapFile = GlobalAlloc(GMEM_FIXED Or GMEM_ZEROINIT, Mem.dwFileSize)
If Mem.hMapFile = 0 Then
    SetError "Error Allocating Memory Space."
    Exit Function
End If
If ReadFile(Mem.hFile, ByVal Mem.hMapFile, Mem.dwFileSize, 0, ByVal 0) = 0 Then
    SetError "Error in Reading File"
    Exit Function
End If
'***********Close the File Handle
DosHeader.Fill Mem.hMapFile
If DosHeader.Magic <> IMAGE_DOS_SIGNATURE Then
    CloseFile
    SetError "Not a Valid PE File.Magic Number not Found."
    Exit Function
End If
NtHeader.Fill Base + DosHeader.lFaNew
If NtHeader.Signature <> IMAGE_NT_SIGNATURE Then
    CloseFile
    SetError "Not a Valid PE File.PE Signature not Found."
    Exit Function
End If
Dim idx As Long, Bytes() As Byte, dwBytes As Long
Dim tmpSection As Section
Dim dwFirstSecOffset As Long
dwFirstSecOffset = DosHeader.lFaNew + NtHeader.Length 'First Section Occurs After NtHeader
For idx = 0 To NtHeader.FileHeader.NumberOfSections - 1
    Set tmpSection = New Section
    tmpSection.Fill Base + dwFirstSecOffset + idx * tmpSection.Length
    tmpSection.FillCode Base + tmpSection.PointerToRawData, tmpSection.SizeOfRawData
    Sections.Add tmpSection
Next
Dim dwBIoffset As Long
dwBIoffset = dwFirstSecOffset + Sections.Count * tmpSection.Length
Dim tmpBi As BoundImport, tmpStr As String
OffSet = 0
Do
    Set tmpBi = New BoundImport
    tmpBi.Fill Base + dwBIoffset + OffSet
    dwBytes = StrLenPtr(Base + tmpBi.ModuleNameOffSet + dwBIoffset)
    If dwBytes <> 0 And tmpBi.ModuleNameOffSet <> 0 Then
        tmpStr = String(dwBytes, 0)
        StrCpyPtrToStr tmpStr, Base + tmpBi.ModuleNameOffSet + dwBIoffset
        tmpBi.ModuleName = tmpStr
        BoundImports.Add tmpBi
    End If
    OffSet = OffSet + tmpBi.Length
Loop While tmpBi.TimeStamp <> 0
Mem.FileLoaded = True
CloseFile
LoadFile = True
End Function
Function SaveFile(ByVal FileName As String) As Boolean
Dim tMem As Props
Dim Bytes() As Byte, idx As Long, OffSet As Long, dwFirstOffSet As Long
If Mem.FileLoaded = False Then
    SetError "Source PE not loaded. Make sure the input was a valid PE File."
    Exit Function
End If
nFile = tMem

nFile.dwFileSize = DosHeader.Length + NtHeader.Length + LenBytes(DosStub)
nFile.dwFileSize = nFile.dwFileSize + Sections.Count * Sections(1).Length
Dim fPtr As Long, tmp As Long
For idx = 1 To Sections.Count
    tmp = Sections(idx).PointerToRawData + Sections(idx).SizeOfRawData
    If tmp > fPtr Then fPtr = tmp
Next
nFile.dwFileSize = nFile.dwFileSize + fPtr
nFile.hFile = CreateFile(FileName, GENERIC_WRITE, FILE_SHARE_WRITE Or FILE_SHARE_READ, ByVal 0, CREATE_ALWAYS, 0, 0)
If nFile.hFile = -1 Then
    SetError "Error Creating File on Disk! Make sure the disk is ready."
    Exit Function
End If
nFile.hMapFile = GlobalAlloc(GMEM_FIXED Or GMEM_ZEROINIT, nFile.dwFileSize)
If nFile.hMapFile = 0 Then
    SetError "Error Allocating Memory! Try closing some applications."
    CloseNewFile
    Exit Function
End If
If DosHeader.CopyTo(nFile.hMapFile) = False Then
    SetError "Error Setting Dos Header!"
    CloseNewFile
    Exit Function
End If
'************Copy The Dos Stub**************

Bytes = DosStub
idx = UBound(Bytes)
CopyMemory ByVal NewBase + DosHeader.Length, Bytes(0), idx
'***********Modify Number of Sections
Dim fh  As IMAGE_FILE_HEADER
fh = NtHeader.FileHeader.Struct
fh.NumberOfSections = Sections.Count
NtHeader.FileHeader.Struct = fh
'*********************************************************
Dim hdr As IMAGE_OPTIONAL_HEADER
hdr = NtHeader.OptionalHeader.Struct
hdr.DataDirectory(11).VirtualAddress = 0
hdr.DataDirectory(11).Size = 0
NtHeader.OptionalHeader.Struct = hdr

If NtHeader.CopyTo(NewBase + DosHeader.lFaNew) = False Then
    SetError "Error Setting NT Header!"
    CloseNewFile
    Exit Function
End If
If Sections.Count < 1 Then
    SetError "PE File must contain at-least 1 section"
    CloseNewFile
    Exit Function
End If



Dim tmpBi As BoundImport
dwFirstOffSet = DosHeader.lFaNew + NtHeader.Length + Sections.Count * Sections(1).Length
OffSet = 0
For Each tmpBi In BoundImports
    tmpBi.CopyTo NewBase + dwFirstOffSet + OffSet
    Bytes = StrConv(tmpBi.ModuleName, vbFromUnicode)
    dwBytes = UBound(Bytes) + 1
    CopyMemory ByVal NewBase + dwFirstOffSet + tmpBi.ModuleNameOffSet, Bytes(0), dwBytes
    OffSet = OffSet + tmpBi.Length
Next
'*************Section***************
Dim tmpSection As Section
dwFirstOffSet = DosHeader.lFaNew + NtHeader.Length

For idx = 1 To Sections.Count
    Set tmpSection = Sections(idx)  'Collection is 1 Based
    OffSet = NewBase + dwFirstOffSet + (idx - 1) * tmpSection.Length
    If tmpSection.CopyTo(OffSet) = False Then
        SetError "Error Setting Section: " & tmpSection.Name
        CloseNewFile
        Exit Function
    End If
    OffSet = NewBase + tmpSection.PointerToRawData
    If tmpSection.CopyCodeTo(OffSet) = False Then
        SetError "Error Setting Section Code: " & tmpSection.Name
        CloseNewFile
        Exit Function
    End If

Next

WriteFile nFile.hFile, ByVal NewBase, nFile.dwFileSize, 0, ByVal 0
GlobalFree NewBase
CloseNewFile
End Function




'***************************Private Procedures************
'***********************************************************

Private Sub SetError(ByVal Desc As String)
Err.Description = Desc
End Sub
Private Sub CloseFile()
CloseHandle Mem.hFile
End Sub
Private Sub CloseNewFile()

CloseHandle nFile.hFile
End Sub
Private Function PEAlign(ByVal dwTarNum As Long, ByVal dwAlignTo As Long) As Long
PEAlign = (((dwTarNum + dwAlignTo - 1) / dwAlignTo) * dwAlignTo)
End Function
Private Sub Class_Terminate()
If Mem.hMapFile <> 0 Then
    If IsBadCodePtr(Mem.hMapFile) = False Then Exit Sub
    GlobalFree Mem.hMapFile
End If
End Sub
Private Property Get NewBase() As Long
NewBase = nFile.hMapFile
End Property

'****************************Dependent Properties****************
'****************************************************************
Property Get DosStub() As Byte()
Dim dwSize As Long
dwSize = DosHeader.lFaNew - DosHeader.Length
Dim ret() As Byte
ReDim ret(dwSize - 1)
CopyMemory ret(0), ByVal Base + DosHeader.Length, dwSize
DosStub = ret
End Property
Property Get DosHeader() As DosHeader
If Obj.DosHeader Is Nothing Then
    Set Obj.DosHeader = New DosHeader
    Obj.DosHeader.SetOwner Me
End If
Set DosHeader = Obj.DosHeader
End Property
Property Get NtHeader() As NtHeader
If Obj.NtHeader Is Nothing Then
    Set Obj.NtHeader = New NtHeader
    Obj.NtHeader.SetOwner Me
End If
Set NtHeader = Obj.NtHeader
End Property
Property Get Sections() As Sections
If Obj.Sections Is Nothing Then
    Set Obj.Sections = New Sections
    Obj.Sections.SetOwner Me
End If
Set Sections = Obj.Sections
End Property
Property Get BoundImports() As BoundImports
If Obj.BoundImports Is Nothing Then
    Set Obj.BoundImports = New BoundImports
    Obj.BoundImports.SetOwner Me
End If
Set BoundImports = Obj.BoundImports
End Property