compile.bas

在vb中镶入汇编、VC

    'Get the proc address of the IAT entry to be changed
    If VarType(vCallNameOrAddress) = vbString Then
    
        sCallName = CStr(vCallNameOrAddress)    'user is hooking an import
    
        'Get handle (address) of exporting module
        lpExportingModuleHandle = GetModuleHandle(sExportingModuleName)
        If lpExportingModuleHandle = 0 Then sError = "Unable to obtain exporting module handle for """ & sExportingModuleName & """.": Exit Function
    
        'Get address of call
        lpProcAddress = GetProcAddress(lpExportingModuleHandle, sCallName)
        If lpProcAddress = 0 Then sError = "Unable to obtain proc address for """ & sCallName & """.": Exit Function
    
    Else
        lpProcAddress = CLng(vCallNameOrAddress) 'user is restoring a hooked import
    End If

    'Beginning of the IAT is located at offset 0x1000 in most PE modules
    vectorIAT = lpImportingModuleHandle + &H1000

    'Scan module to find PE header by looking for header signature
    lpPEHeader = lpImportingModuleHandle
    Do
        If lpPEHeader > vectorIAT Then  'this is not a PE module
            sError = "Module """ & sImportingModuleName & """ is not a PE module."
            Exit Function
        Else
            If Deref(lpPEHeader) = IMAGE_NT_SIGNATURE Then  'we have located the module's PE header
                Exit Do
            Else
                lpPEHeader = lpPEHeader + 1 'keep searching
            End If
        End If
    Loop
    
    'Determine and validate length of the IAT. The length is at offset 0xDC in the PE header.
    lenIAT = Deref(lpPEHeader + &HDC)
    If lenIAT = 0 Or lenIAT > &HFFFFF Then 'its too big or too small to be valid
        sError = "The calculated length of the Import Address Table in """ & sImportingModuleName & """ is not valid: " & lenIAT
        Exit Function
    End If

    'Scan Import Address Table for proc address
    lpEndIAT = lpImportingModuleHandle + &H1000 + lenIAT
    Do
        If vectorIAT > lpEndIAT Then 'we have reached the end of the table
            sError = "Proc address " & Hex(lpProcAddress) & " not found in Import Address Table of """ & sImportingModuleName & """."
            Exit Function
        Else
            lpIATCallAddress = Deref(vectorIAT)
            If lpIATCallAddress = lpProcAddress Then  'we have found the entry
                Exit Do
            Else
                vectorIAT = vectorIAT + 4   'try next entry in table
            End If
        End If
    Loop
    
    'Substitute hook for existing call address and return existing address by ref
    'We must make this memory writable to make the entry in the IAT
    If VirtualProtect(ByVal vectorIAT, 4, PAGE_EXECUTE_READWRITE, lpflOldProtect) = 0 Then
        sError = "Unable to change IAT memory to execute/read/write."
        Exit Function
    Else
        lpOriginalAddress = Deref(vectorIAT)    'save original address
        CopyMemory ByVal vectorIAT, lpHook, 4   'set the hook
        VirtualProtect ByVal vectorIAT, 4, lpflOldProtect, lpflOldProtect2  'restore memory protection
    End If

    HookDLLImport = True 'mission accomplished

    Exit Function
    
EH:
    sError = "Unexpected error: " & Err.Description

End Function

Function Deref(lngPointer As Long) As Long  'Equivalent of *lngPointer (returns the value pointed to)
    Dim lngValueAtPointer As Long
    CopyMemory lngValueAtPointer, ByVal lngPointer, 4
    Deref = lngValueAtPointer
End Function

Private Function ReturnProcedureAddress(lngAddress As Long) As Long
    ReturnProcedureAddress = lngAddress
End Function

'Declaration Re-Typing for VB

'ByVal lpApplicationName As String          =>  Long (pointer to lpstr)
'ByVal lpCommandLine As String              =>  Long (pointer to lpstr)
'lpProcessAttributes As SECURITY_ATTRIBUTES OK as is
'lpThreadAttributes As SECURITY_ATTRIBUTES  OK as is
'ByVal bInheritHandles As Long              OK as is
'ByVal dwCreationFlags As Long              OK as is
'lpEnvironment As Long                      OK as is
'ByVal lpCurrentDirectory As String         =>  Long (pointer to lpstr)
'lpStartupInfo As STARTUPINFO                   OK as is
'lpProcessInformation As PROCESS_INFORMATION    OK as is

Public Function CreateProcessFilter(lpApplicationName As Long, lpCommandLine As Long, lpProcessAttributes As SECURITY_ATTRIBUTES, lpThreadAttributes As SECURITY_ATTRIBUTES, ByVal bInheritHandles As Long, ByVal dwCreationFlags As Long, lpEnvironment As Long, ByVal lpCurrentDirectory As Long, lpStartupInfo As STARTUPINFO, lpProcessInformation As PROCESS_INFORMATION) As Long
    
    Static sInterceptMode As String
    Static bCheckModuleList As Boolean
    Dim bRefreshModuleList As Boolean
    Dim asModuleList() As String
    Dim idxModuleList As Long
    Dim sApplicationName As String, sCommandLine As String, sCurrentDirectory As String, lngCreateProcessReturnValue As Long, lngErrorCode As Long

    sApplicationName = CStringToVBString(lpApplicationName)
    sCommandLine = CStringToVBString(lpCommandLine)
    sCurrentDirectory = CStringToVBString(lpCurrentDirectory)

'#If bDEBUG Then
'    Static sDebugString As String
'    sDebugString = sDebugString & sCommandLine & vbNewLine
'    sDebugString = sDebugString & "intercept mode: " & sInterceptMode & vbNewLine
'    sDebugString = sDebugString & "bcheckmodlist: " & IIf(bCheckModuleList, "true", "false") & vbNewLine
'    MsgBox sDebugString
'#End If

    If mbCompileInProgress Then
        bRefreshModuleList = False  'the module should be current for this compile
    Else
        sInterceptMode = ""         'initialize UI mode settings
        bCheckModuleList = False
        bRefreshModuleList = True   'at the beginning of a compile cycle must refresh module list
        mbCompileInProgress = True  'the compile has started
    End If
    
    If bCheckModuleList Then
        asModuleList = Split(sInterceptMode, Chr(&HFF))
        For idxModuleList = 0 To UBound(asModuleList) - 1
'#If bDEBUG Then
'    sDebugString = sDebugString & "checking: " & """" & asModuleList(idxModuleList) & """" & vbNewLine
'#End If
            If InStr(sCommandLine, """" & asModuleList(idxModuleList) & """") > 0 Then 'module is there
                sInterceptMode = ShowControlPanel(sApplicationName, sCommandLine, bRefreshModuleList)
            End If
        Next
        If Left(sCommandLine, 4) = "LINK" Then
            sInterceptMode = ShowControlPanel(sApplicationName, sCommandLine, bRefreshModuleList)
        End If
    Else
      Select Case sInterceptMode
        Case "", "Next Module"
            sInterceptMode = ShowControlPanel(sApplicationName, sCommandLine, bRefreshModuleList)
        Case "Skip to Link"
            If Left(sCommandLine, 4) = "LINK" Then
                sInterceptMode = ShowControlPanel(sApplicationName, sCommandLine, bRefreshModuleList)
            Else
                'keep compiling
            End If
        Case "Finish Compile"
            'do nothing - just keep calling create process
        Case Else
      End Select
    End If

    If Right(sInterceptMode, 1) = Chr(&HFF) Then
        bCheckModuleList = True
    Else
        bCheckModuleList = False
    End If
    
'#If bDEBUG Then
'    sDebugString = sDebugString & "Executing: " & sCommandLine & vbNewLine
'    sDebugString = sDebugString & vbNewLine
'#End If
    
    'Check to see if ready to link, and if so, reset everything
    If Left(sCommandLine, 4) = "LINK" Then 'this is the end of the compile
        HideControlPanel 'always hide cp when ready to link
        sInterceptMode = "" 'reset intercept mode
        mbCompileInProgress = False
'#If bDEBUG Then
'        Dim hFile As Integer
'        hFile = FreeFile
'        Open "c:\temp\debugcc.tmp" For Output As hFile
'        Write #hFile, sDebugString
'        Close hFile
'#End If
    End If

    lngCreateProcessReturnValue = CreateProcess(sApplicationName, sCommandLine, lpProcessAttributes, lpThreadAttributes, bInheritHandles, dwCreationFlags, lpEnvironment, sCurrentDirectory, lpStartupInfo, lpProcessInformation)
    
    If lngCreateProcessReturnValue = 0 Then
        lngErrorCode = GetLastError
        Select Case lngErrorCode
            Case Else
                CreateError "Error creating process: " & lngErrorCode
        End Select
    End If
    CreateProcessFilter = lngCreateProcessReturnValue

End Function

Function CStringToVBString(lpCString As Long) As String
    Dim lenString As Long, sBuffer As String, lpBuffer As Long, lngStringPointer As Long, refStringPointer As Long
    If lpCString = 0 Then
        CStringToVBString = vbNullString
    Else
        lenString = lenCString(lpCString)
        sBuffer = String$(lenString + 1, 0) 'buffer has one extra byte for terminator
        lpBuffer = CopyCString(sBuffer, lpCString, lenString + 1)
        CStringToVBString = sBuffer
    End If
End Function