delphi内存调用OCX
本来想做一个内存运行SWF的程序 在网上大肆搜索一番发现这类的代码很少VC的记得有一个不过不提供源代码的,delphi的几乎是没有的,借鉴网络上的不注册直接调用OCX 对以下程序 小幅度的修改实现内存调用OCX 函数 实验证明 效果还好，下面贴出代码
//修改后的微软自带的脚本msscript.ocx控件接口
const
Class_MSScriptControl:TGUID='{0E59F1D5-1FBE-11D0-8FF2-00A0D10038BC}';
Initialized = 0;
Connected = 1;
type
ScriptControlStates = TOleEnum;
IScriptControl = interface(IDispatch)
['{0E59F1D3-1FBE-11D0-8FF2-00A0D10038BC}']
function Get_Language: WideString; safecall;
procedure Set_Language(const Value: WideString); safecall;
function Get_State: ScriptControlStates; safecall;
procedure Set_State(Value: ScriptControlStates); safecall;
procedure Set_SitehWnd(Value: Integer); safecall;
function Get_SitehWnd: Integer; safecall;
function Get_Timeout: Integer; safecall;
procedure Set_Timeout(Value: Integer); safecall;
function Get_AllowUI: WordBool; safecall;
procedure Set_AllowUI(Value: WordBool); safecall;
function Get_UseSafeSubset: WordBool; safecall;
procedure Set_UseSafeSubset(Value: WordBool); safecall;
function Get_Modules: IInterface; safecall;
function Get_Error: IInterface; safecall;
function Get_CodeObject: IDispatch; safecall;
function Get_Procedures: IInterface; safecall;
procedure AboutBox; safecall;
procedure AddObject(const Name: WideString; Object_: IDispatch; AddMembers: WordBool); safecall;
procedure Reset; safecall;
procedure AddCode(const Code: WideString); safecall;
function Eval(const Expression: WideString): OleVariant; safecall;
procedure ExecuteStatement(const Statement: WideString); safecall;
function Run(const ProcedureName: WideString; var Parameters: PSafeArray): OleVariant; safecall;
property Language: WideString read Get_Language write Set_Language;
property State: ScriptControlStates read Get_State write Set_State;
property SitehWnd: Integer read Get_SitehWnd write Set_SitehWnd;
property Timeout: Integer read Get_Timeout write Set_Timeout;
property AllowUI: WordBool read Get_AllowUI write Set_AllowUI;
property UseSafeSubset: WordBool read Get_UseSafeSubset write Set_UseSafeSubset;
property Modules: IInterface read Get_Modules;
property Error: IInterface read Get_Error;
property CodeObject: IDispatch read Get_CodeObject;
property Procedures: IInterface read Get_Procedures;
end;
//主要实现内容 也比较简单
procedure TForm1.Button1Click(Sender: TObject);
var
MemoryFile:TMemoryStream;
hMemDll:TMemDll;
xDllGetClassObject:function(const CLSID,IID:TGUID; var Obj):HResult;stdcall;
vClassFactory: IClassFactory;
vScriptControl: IScriptControl;
begin
MemoryFile:=TMemoryStream.Create;
try
MemoryFile.LoadFromFile('myscript.ocx');
hMemDll:=xLoadLibrary(MemoryFile.Memory);
@xDllGetClassObject:=xGetProcAddress(hMemDll,'DllGetClassObject');
xDllGetClassObject(Class_MSScriptControl, IClassFactory, vClassFactory);
if Assigned(vClassFactory) then
begin
vClassFactory.CreateInstance(nil, IScriptControl, vScriptControl);
if Assigned(vScriptControl) then
begin
vScriptControl.AboutBox;
vScriptControl := nil;
end;
vClassFactory := nil;
end;
finally
MemoryFile.Free;
end;
end;
//内存运行DLL单元
unit untMemDll;
{$DEFINE DEBUG}
interface
uses
Windows;
type
TMemDll = record
Headers: PImageNtHeaders;
lpCodebase: Pointer;
Modules: Pointer;
NumModules: integer;
initialized: boolean;
end;
function xLoadLibrary(ModuleAddress: Pointer): TMemDll;
function xGetProcAddress(MemDll: TMemDll; lpstrName: PChar): Pointer;
procedure xFreeLibrary(var MemDll: TMemDll);
implementation
uses SysUtils;
procedure DebugOutput(S: string);
begin
{$IFDEF DEBUG}
MessageBox(0, PChar(S), 'Error', 0);
{$ENDIF}
end;
function FieldOffset(const Struc; const Field): Cardinal;
begin
Result := Cardinal(@Field) - Cardinal(@Struc);
end;
// replacement of IMAGE_FIRST_SECTION macro
function GetImageFirstSection(NtHeader: PImageNtHeaders): PImageSectionHeader;
begin
Result := PImageSectionHeader(Cardinal(NtHeader) +
FieldOffset(NtHeader^, NtHeader^.OptionalHeader) +
NtHeader^.FileHeader.SizeOfOptionalHeader);
end;
// replacement of GET_HEADER_DICTIONARY macro
function GetHeaderDictionary(MemDll: TMemDll; idx: DWORD):
PImageDataDirectory;
begin
Result := @MemDll.Headers.OptionalHeader.DataDirectory[idx];
end;
// replacement of IMAGE_ORDINAL macro
function GetImageOrdinal(Ordinal: DWORD): Word;
begin
Result := Ordinal and $FFFF;
end;
// replacement of IMAGE_SNAP_BY_ORDINAL macro
function GetImageSnapByOrdinal(Ordinal: DWORD): Boolean;
begin
Result := (Ordinal and $80000000) <> 0;
end;
function GetSectionProtection(SC: DWORD): DWORD;
//SC ? ImageSectionHeader.Characteristics
begin
result := 0;
if (SC and IMAGE_SCN_MEM_NOT_CACHED) <> 0 then
result := result or PAGE_NOCACHE;
// E - Execute, R ? Read , W ? Write
if (SC and IMAGE_SCN_MEM_EXECUTE) <> 0 //E ?
then if (SC and IMAGE_SCN_MEM_READ) <> 0 //ER ?
then if (SC and IMAGE_SCN_MEM_WRITE) <> 0 //ERW ?
then result := result or PAGE_EXECUTE_READWRITE
else result := result or PAGE_EXECUTE_READ
else if (SC and IMAGE_SCN_MEM_WRITE) <> 0 //EW?
then result := result or PAGE_EXECUTE_WRITECOPY
else result := result or PAGE_EXECUTE
else if (SC and IMAGE_SCN_MEM_READ) <> 0 // R?
then if (SC and IMAGE_SCN_MEM_WRITE) <> 0 //RW?
then result := result or PAGE_READWRITE
else result := result or PAGE_READONLY
else if (SC and IMAGE_SCN_MEM_WRITE) <> 0 //W?
then result := result or PAGE_WRITECOPY
else result := result or PAGE_NOACCESS;
end;
procedure FinalizeSections(MemDll: TMemDll);
var
Section: PImageSectionHeader;
i: integer;
dwProtect, dwOldProtect, dwSize: DWORD;
begin
Section := GetImageFirstSection(MemDll.Headers);
for i:=0 to MemDll.Headers.FileHeader.NumberOfSections-1 do
begin
if (Section.Characteristics and IMAGE_SCN_MEM_DISCARDABLE) <> 0 then
begin
VirtualFree(Pointer(Section.Misc.PhysicalAddress), Section.SizeOfRawData,
MEM_DECOMMIT);
inc(DWORD(Section), SizeOf(TImageSectionHeader));
continue;
end;
dwProtect := GetSectionProtection(Section.Characteristics);
if (Section.Characteristics and IMAGE_SCN_MEM_NOT_CACHED) <> 0 then
dwProtect := (dwProtect or PAGE_NOCACHE);
dwSize := Section.SizeOfRawData;
if dwSize = 0 then
begin
if (Section.Characteristics and IMAGE_SCN_CNT_INITIALIZED_DATA) <> 0 then
dwSize := MemDll.Headers.OptionalHeader.SizeOfInitializedData
else
if (Section.Characteristics and IMAGE_SCN_CNT_INITIALIZED_DATA) <> 0 then
dwSize := MemDll.Headers.OptionalHeader.SizeOfUninitializedData;
end;
if dwSize > 0 then
begin
if not VirtualProtect(Pointer(Section.Misc.PhysicalAddress), Section.SizeOfRawData, dwProtect, @dwOldProtect) then
begin
DebugOutput('VirtualProtect failed');
exit;
end;
end;
inc(DWORD(Section), SizeOf(TImageSectionHeader));
end;
end;
function BuildImportTable(MemDll: TMemDll): boolean;
type
PImageImportDescriptor = ^TImageImportDescriptor;
TImageImportDescriptor = packed record
OriginalFirstThunk: dword;
TimeDateStamp: dword;
ForwarderChain: dword;
Name: dword;
FirstThunk: dword;
end;
PImageImportByName = ^TImageImportByName;
TImageImportByName = packed record
Hint: Word;
Name: array[0..255] of Byte;
end;
var
lpCodeBase: Pointer;
directory: PImageDataDirectory;
ImportDesc: PImageImportDescriptor;
Handle: HMODULE;
dwTemp: DWORD;
ThunkRef, FuncRef: ^DWORD;
ThunkData: TImageImportByName;
begin
Result := False;
lpCodeBase := MemDll.lpCodebase;
directory := GetHeaderDictionary(MemDll, IMAGE_DIRECTORY_ENTRY_IMPORT);
if directory.Size > 0 then
begin
ImportDesc := Pointer(DWORD(lpCodeBase) + directory.VirtualAddress);
while (not IsBadReadPtr(ImportDesc, sizeof(TImageImportDescriptor)))
and (ImportDesc.Name <> 0) do
begin
Handle := LoadLibrary(Pointer(DWORD(lpCodeBase) + ImportDesc.Name));
if Handle = INVALID_HANDLE_VALUE then
begin
DebugOutput('Cannot load library '+String(Pointer(DWORD(lpCodeBase) + ImportDesc.Name)));
exit;
end;
if MemDll.Modules = nil then
MemDll.Modules := AllocMem(1);
MemDll.Modules := ReallocMemory(MemDll.Modules,
((MemDll.NumModules + 1) * (SizeOf(HMODULE))));
if MemDll.Modules = nil then
begin
DebugOutput('ReallocMemory failed');
exit;
end;
dwTemp := SizeOf(Cardinal) * (MemDll.NumModules);
inc(Cardinal(MemDll.Modules), dwTemp);
cardinal(MemDll.Modules^) := Handle;
dec(Cardinal(MemDll.Modules), dwTemp);
inc(MemDll.NumModules);
If ImportDesc.OriginalFirstThunk <> 0 then
begin
ThunkRef := Pointer(DWORD(lpCodeBase) + ImportDesc.OriginalFirstThunk);
FuncRef := Pointer(DWORD(lpCodeBase) + ImportDesc.FirstThunk);
end
else
begin
ThunkRef := Pointer(DWORD(lpCodeBase) + ImportDesc.FirstThunk);
FuncRef := Pointer(DWORD(lpCodeBase) + ImportDesc.FirstThunk);
end;
while ThunkRef^ <> 0 do
begin
if GetImageSnapByOrdinal(ThunkRef^) then
begin
FuncRef^ := DWORD(GetProcAddress(Handle, PChar(GetImageOrdinal(ThunkRef^))))
end
else
begin
CopyMemory(@ThunkData, Pointer(DWORD(lpCodeBase) + ThunkRef^), SizeOf(TImageImportByName));
FuncRef^ := DWORD(GetProcAddress(Handle, PChar(@(ThunkData.Name))));
end;
if FuncRef^ = 0 then
begin
DebugOutput('GetProcAddres failed');
exit;
end;
inc(FuncRef);
inc(ThunkRef);
end;
inc(DWORD(ImportDesc), sizeof(TImageImportDescriptor));
end;
end;
Result:=True;
end;
procedure PerformBaseRelocation(f_module: TMemDll; f_delta: Cardinal); stdcall;
const
IMAGE_SIZEOF_BASE_RELOCATION = 8;
IMAGE_REL_BASED_HIGHLOW = 3;
IMAGE_ORDINAL_FLAG32 = DWORD($80000000);
type
PImageBaseRelocation = ^TImageBaseRelocation;
TImageBaseRelocation = packed record
VirtualAddress:cardinal;
SizeOfBlock:cardinal;
end;
var
l_i: Cardinal;
l_codebase: Pointer;
l_directory: PImageDataDirectory;
l_relocation: PImageBaseRelocation;
l_dest: Pointer;
l_relInfo: ^Word;
l_patchAddrHL: ^DWord;
l_type, l_offset: integer;
begin
l_codebase := f_module.lpcodeBase;
l_directory := GetHeaderDictionary(f_module, IMAGE_DIRECTORY_ENTRY_BASERELOC);
if l_directory.Size > 0 then begin
l_relocation := PImageBaseRelocation(Cardinal(l_codebase) + l_directory.VirtualAddress);
while l_relocation.VirtualAddress > 0 do begin
l_dest := Pointer((Cardinal(l_codebase) + l_relocation.VirtualAddress));
l_relInfo := Pointer(Cardinal(l_relocation) + IMAGE_SIZEOF_BASE_RELOCATION);
for l_i := 0 to (trunc(((l_relocation.SizeOfBlock - IMAGE_SIZEOF_BASE_RELOCATION) / 2)) - 1) do begin
// the upper 4 bits define the type of relocation
l_type := (l_relInfo^ shr 12);
// the lower 12 bits define the offset
l_offset := l_relInfo^ and $FFF;
//showmessage(inttostr(l_relInfo^));
if l_type = IMAGE_REL_BASED_HIGHLOW then begin
// change complete 32 bit address
l_patchAddrHL := Pointer(Cardinal(l_dest) + Cardinal(l_offset));
l_patchAddrHL^ := l_patchAddrHL^ + f_delta;
end;
inc(l_relInfo);
end;
l_relocation := Pointer(cardinal(l_relocation) + l_relocation.SizeOfBlock);
end;
end;
end;
{procedure PerformBaseRelocation(MemDll: TMemDll; dwDelta: dword);
type
PImageBaseRelocation = ^TImageBaseRelocation;
TImageBaseRelocation = packed record
VirtualAddress:cardinal;
SizeOfBlock:cardinal;
end;
var
i: integer;
lpCodeBase, lpDest: pointer;
lpRelInfo: ^Word;
directory: PImageDataDirectory;
relocation: PImageBaseRelocation;
dwType, dwOffset: DWORD;
lpPatchAddrHL: ^DWORD;
begin
lpCodeBase := MemDll.lpCodebase;
directory := GetHeaderDictionary(MemDll, IMAGE_DIRECTORY_ENTRY_BASERELOC);
if directory.Size > 0 then
begin
relocation :=
PImageBaseRelocation(Pointer(dword(lpCodeBase) + directory.VirtualAddress)^);
while relocation.VirtualAddress > 0 do
begin
lpDest := Pointer(DWORD(lpCodeBase) + relocation.VirtualAddress);
lpRelInfo := Pointer(DWORD(relocation) + 8);
for i := 0 to Trunc((relocation.SizeOfBlock - 8) / 2) - 1 do
begin
dwType := (lpRelInfo^ shr 12);
dwOffset := lpRelInfo^ and $FFF;
if dwType = 3 then
begin
lpPatchAddrHL := Pointer(DWORD(lpDest) + DWORD(dwOffset));
lpPatchAddrHL^ := lpPatchAddrHL^ + dwDelta;
end;
inc(lpRelInfo);
end;
relocation := Pointer(DWORD(relocation) + relocation.SizeOfBlock);
end;
end;
end; }
procedure CopySections(ModuleAddress: Pointer; ImageNTHeader: PImageNTHeaders;
MemDll: TMemDll);
var
i, dwSize: dword;
lpCodeBase, lpDest: pointer;
Section: PImageSectionHeader;
begin
lpCodeBase := MemDll.lpCodebase;
Section := GetImageFirstSection(MemDll.Headers);
for i:=1 to MemDll.Headers.FileHeader.NumberOfSections do
begin
if Section.SizeOfRawData = 0 then
begin
// Section doesn't contain data in the dll itself, but may define
// uninitialized data
dwSize := ImageNTHeader.OptionalHeader.SectionAlignment;
If dwSize > 0 then
begin
lpDest := VirtualAlloc(Pointer(dword(lpCodeBase) + Section.VirtualAddress),
dwSize, MEM_COMMIT, PAGE_READWRITE);
Section.Misc.PhysicalAddress := dword(lpDest);
ZeroMemory(lpDest, dwSize);
end;
// else section is empty
inc(DWORD(Section), SizeOf(TImageSectionHeader));
Continue;
end;
// commit memory block and copy data from dll
lpDest := VirtualAlloc(Pointer(dword(lpCodeBase) + Section.VirtualAddress),
Section.SizeOfRawData, MEM_COMMIT, PAGE_READWRITE);
CopyMemory(lpDest, Pointer(dword(ModuleAddress) + Section.PointerToRawData),
Section.SizeOfRawData);
Section.Misc.PhysicalAddress := dword(lpDest);
inc(DWORD(Section), SizeOf(TImageSectionHeader));
end;
end;
function xLoadLibrary(ModuleAddress: Pointer): TMemDll;
type
TDllEntryProc = function(hinstdll: THandle; fdwReason: DWORD; lpReserved: Pointer): BOOL; stdcall;
var
ImageDosHeader: PImageDosHeader;
ImageNTHeader: PImageNtHeaders;
lpCodeBase, lpHeaders: Pointer;
dwLocationDelta: DWORD;
DllEntry: TDllEntryProc;
begin
// check if Dos header is not corrupt
ImageDosHeader := PImageDosHeader(ModuleAddress);
If ImageDosHeader.e_magic <> IMAGE_DOS_SIGNATURE then
begin
DebugOutput('Invalid MZ header');
exit;
end;
// check if PE header is not corrupt
ImageNTHeader := PImageNtHeaders(Pointer(LongWord(ModuleAddress) +
ImageDosHeader._lfanew));
If ImageNTHeader.Signature <> IMAGE_NT_SIGNATURE then
begin
DebugOutput('Invalid PE header');
exit;
end;
// try to allocate memory at orignal library imagebse
lpCodeBase := VirtualAlloc(Pointer(ImageNTHeader.OptionalHeader.ImageBase),
ImageNTHeader.OptionalHeader.SizeOfImage,MEM_RESERVE, PAGE_READWRITE);
// if fails, try to allocate at arbitrary position
If lpCodeBase = nil then
begin
lpCodebase := VirtualAlloc(nil, ImageNTHeader.OptionalHeader.SizeOfImage,
MEM_RESERVE, PAGE_READWRITE);
If lpCodeBase = nil then
begin
DebugOutput('Cannot allocate memory');
exit;
end;
end;
// initialize TMemDll Structure
Result.lpCodeBase:=lpCodeBase;
Result.NumModules:=0;
Result.Modules:=nil;
Result.initialized:=false;
// commit memory for module image
VirtualAlloc(lpCodeBase, ImageNTHeader.OptionalHeader.SizeOfImage, MEM_COMMIT,
PAGE_READWRITE);
// commit memory for headers
lpHeaders := VirtualAlloc(lpCodeBase, ImageNTHeader.OptionalHeader.SizeOfHeaders,
MEM_COMMIT, PAGE_READWRITE);
If lpHeaders = nil then
begin
DebugOutput('Cannot commit memory for headers');
exit;
end;
// copy PE header to code
CopyMemory(lpHeaders, {ImageDosHeader,}ModuleAddress,
ImageDOsHeader._lfanew+ImageNTHeader.OptionalHeader.SizeOfHeaders);
Result.Headers := Pointer(DWORD(lpHeaders) + ImageDosHeader._lfanew);
// update position
Result.Headers.OptionalHeader.ImageBase:=dword(lpCodeBase);
// copy sections from DLL file block to new memory location
CopySections(ModuleAddress, ImageNTHeader, Result);
// adjust base address of imported data
dwLocationDelta := DWORD(lpCodeBase) - ImageNTHeader.OptionalHeader.ImageBase;
if dwLocationDelta <> 0 then
PerformBaseRelocation(Result, dwLocationDelta);
// load required dlls and adjust function table of imports
if not BuildImportTable(Result) then
begin
DebugOutput('Cannot build import table!');
exit;
end;
// mark memory pages depending on section headers and release
// sections that are marked as "discardable"
FinalizeSections(Result);
// execute entrypoint
if Result.Headers.OptionalHeader.AddressOfEntryPoint <> 0 then
begin
DllEntry := Pointer(DWORD(lpCodeBase) +
Result.Headers.OptionalHeader.AddressOfEntryPoint);
if @DllEntry = nil then
begin
DebugOutput('Dll has no entrypoint');
exit;
end;
if not DllEntry(DWORD(lpCodeBase), DLL_PROCESS_ATTACH, nil) then
begin
DebugOutput('Dll attach unsuccessfull');
exit;
end;
end;
Result.Initialized:=True;
end;
function xGetProcAddress(MemDll: TMemDll; lpstrName: PChar): Pointer;
var
lpCodeBase: Pointer;
idx, i: integer;
lpNameRef, lpTemp: ^DWORD;
lpOrdinal: ^WORD;
lpExports: PImageExportDirectory;
lpDirectory: PImageDataDirectory;
begin
Result := nil;
lpCodeBase := MemDll.lpCodeBase;
idx := -1;
lpDirectory := GetHeaderDictionary(MemDll, IMAGE_DIRECTORY_ENTRY_EXPORT);
if lpDirectory.Size = 0 then
begin
DebugOutput('No export table found');
exit;
end;
lpExports := PImageExportDirectory(DWORD(lpCodeBase) + lpDirectory.VirtualAddress);
if (lpExports.NumberOfNames = 0) or (lpExports.NumberOfFunctions = 0) then
begin
DebugOutput('Dll doesn''t export anything');
exit;
end;
// search function name in list of exported names
lpNameRef := Pointer(DWORD(lpCodeBase) + DWORD(lpExports.AddressOfNames));
lpOrdinal := Pointer(DWORD(lpCodeBase) + DWORD(lpExports.AddressOfNameOrdinals));
for i := 0 to lpExports.NumberOfNames - 1 do
begin
if StrComp(lpstrName, PChar(DWORD(lpCodeBase) + lpNameRef^)) = 0 then
begin
idx := lpOrdinal^;
break;
end;
inc(lpNameRef);
inc(lpOrdinal);
end;
if (idx = -1) then
begin
DebugOutput('Export symbol not found');
exit;
end;
if (DWORD(idx) > lpExports.NumberOfFunctions - 1) then
begin
DebugOutput('Name and ordinal number don''t match');
exit;
end;
// AddressOfFunctions contains the RVAs to the "real" functions
lpTemp := Pointer(DWORD(lpCodeBase) + DWORD(lpExports.AddressOfFunctions) + DWORD(idx * 4));
Result := Pointer(DWORD(lpCodeBase) + lpTemp^);
end;
procedure xFreeLibrary(var MemDll: TMemDll);
type
TDllEntryProc = function(hinstdll: THandle; fdwReason: DWORD; lpReserved: Pointer): BOOL; stdcall;
var
lpModule: ^TMemDll;
i: integer;
dwTemp: DWORD;
lpDllEntry: TDllEntryProc;
begin
lpModule := @MemDll;
if lpModule <> nil then
begin
if lpModule.Initialized then
begin
@lpDllEntry := Pointer(DWORD(lpModule.lpCodeBase) + lpModule.Headers.OptionalHeader.AddressOfEntryPoint);
lpDllEntry(DWORD(lpModule.lpCodeBase), DLL_PROCESS_DETACH, nil);
lpModule.Initialized := False;
// free previously opened libraries
for i := 0 to lpModule.numModules - 1 do
begin
dwTemp := SizeOf(Cardinal) * i;
inc(DWORD(lpModule.Modules), dwTemp);
if DWORD(MemDll.Modules^) <> INVALID_HANDLE_VALUE then
FreeLibrary(Cardinal(MemDll.Modules^));
dec(DWORD(lpModule.Modules), dwTemp);
end;
FreeMemory(lpModule.Modules);
if lpModule.lpCodeBase <> nil then
// release memory of library
VirtualFree(lpModule.lpCodeBase, 0, MEM_RELEASE);
// Pointer(MemDll) := nil;
end;
end;
end;
end.
