Yes, it is slow. But i think a performance increase is not possible.
It was hard to get a Browser-Bitmap to a GS-Bitmap.
@adoado: Unfortunately i can not use the paintto-Method. Wicht did this with the 3dgs-Flash-Plugin. But with a TWebBrowser-Object it's not possible.
There are two main operations:
1. From TWebBrowser to TBitmap
2. From TBitmap to PBMAP.
The second step is very easy and very fast. (BitmapToTexture(PBMAP, TBitmap). The bottle neck is step one.
Here is the complete Code:
Code:
unit Unit_Main;
interface
uses ComObj, ActiveX, Windows,Graphics,Sysutils,A6DLLLib, A6DLL, DLL_DEBUG, Classes, messages, OleCtrls,SHDocVW,MSHTML_TLB,Controls,JPEG,Direct3D9,Dialogs,Clipbrd,ExtCtrls,Variants,StdCtrls,ComCtrls;
function dsg_WebCreate():VAR_; cdecl; exports dsg_WebCreate;
function dsg_WebNavigate(url:PString):VAR_; cdecl; exports dsg_WebNavigate;
function dsg_WebPaint(bmap:PBMAP):VAR_; cdecl; exports dsg_WebPaint;
function BitmapToTexture(tex: PBMAP; var B: TBitmap): Integer;
implementation
const Username_real:string = 'put your GS username here';
var WB:TWebBrowser;
H:THandle;
sourceBitmap: TBitmap;
targetBitmap: TBitmap;
B:TBitmap;
UserValid:boolean = false;
function dsg_WebCreate():VAR_;
var Username_p:PChar;
Username_s:String;
Begin
Username_p:=ev.User_name.char;
Username_s:=StrPas(Username_p);
if Username_s = Username_real then
UserValid:=true else
UserValid:=false;
if UserValid = true then
Begin
Coinitialize(nil);
H:=ev.hWndMain;
WB:=TWebBrowser.CreateParented(H);
WB.Left:=1400;
WB.Top:=0;
WB.Width:=1024;
WB.Height:=1024;
WB.Visible:=true;
WB.DoubleBuffered:=true;
End else
ShowMessage('Sorry... Wrong User');
End;
function dsg_WebNavigate(url:PString):VAR_;
var url_p:PChar;
url_s:string;
Begin
if UserValid = true then
Begin
url_p:=_CHR(url);
url_s:=StrPas(url_p);
WB.Navigate(url_s);
end;
End;
function generateBitmapfromBrowser(browser: iWebBrowser2;
srcHeight: Integer; srcWidth: Integer; tarHeight: Integer; tarWidth: Integer):TBitmap;
var
sourceDrawRect: TRect;
targetDrawRect: TRect;
viewObject: IViewObject;
begin
if sourceBitmap=nil then
sourceBitmap := TBitmap.Create;
if targetBitmap=nil then
Begin
targetBitmap := TBitmap.Create;
targetBitmap.PixelFormat:=pf16bit;
End;
try
try
sourceDrawRect := Rect(0, 0, srcWidth, srcHeight);
sourceBitmap.Width := srcWidth;
sourceBitmap.Height := srcHeight;
viewObject := browser as IViewObject;
if viewObject = nil then
Exit;
// this operation is the bottle neck !!!!!!!!!!!!!!
OleCheck(viewObject.Draw(DVASPECT_CONTENT, 1, nil, nil, H,
sourceBitmap.Canvas.Handle, @sourceDrawRect, nil, nil, 0));
// Resize the src bitmap to the target bitmap
targetDrawRect := Rect(0, 0, tarWidth, tarHeight);
targetBitmap.Height := tarHeight;
targetBitmap.Width := tarWidth;
targetBitmap.Canvas.StretchDraw(targetDrawRect, sourceBitmap);
result:=targetBitmap;
finally
end;
except
// Error Code
end;
end;
function dsg_WebPaint(bmap:PBMAP):VAR_;
var
IDoc1: IHTMLDocument2;
Web:IWebBrowser2;
viewObject: IViewObject;
dx9tex : IDIRECT3DTEXTURE9;
ddsd : TD3DSURFACE_DESC;
tex:PBMAP;
Begin
if UserValid = true then
Begin
CoInitialize(nil);
try
if B=nil then
Begin
B:=TBitmap.Create;
B.PixelFormat:=pf16bit;
end;
tex:=bmap;
with WB do
begin
Document.QueryInterface(IHTMLDocument2, iDoc1);
Web := WB.ControlInterface;
TControl(WB).Visible := Boolean(0);
Height:=1024;
Width:=1024;
B:=generateBitmapfromBrowser(Web,1024, 1024, 1024, 1024);
TControl(WB).Visible := Boolean(1);
end;
dx9tex := IDIRECT3DTEXTURE9(tex.d3dtex);
if (dx9tex <> nil) then
begin
if (not FAILED(dx9tex.GetLevelDesc(0,ddsd))) then
begin
B.Width := ddsd.Width;
B.Height := ddsd.Height;
end;
end;
BitmapToTexture(tex,B);
SourceBitmap.FreeImage;
TargetBitmap.FreeImage;
except
on E:Exception do
begin
if Assigned(B) then B.Free;
// if Verbose then a5dll_errormessage(PChar(E.Message));
//ShowMessage(PChar(E.Message));
end;
end;
end;
result:=_VAR(1);
End;
function BitmapToTexture(tex: PBMAP; var B: TBitmap): Integer;
type
TRGBQuadArray = ARRAY[WORD] OF INTEGER;
pRGBQuadArray = ^TRGBQuadArray;
PWORD = ^WORD;
var
// tex : PA4_TEX;
dx9tex : IDIRECT3DTEXTURE9;
ddsd : TD3DSURFACE_DESC;
d3dlr : TD3DLOCKED_RECT;
pixels : PByte;
row : pRGBQuadArray;
Row16 : pWordArray;
y : longword;
x : longword;
target : Plongword;
Error: Integer;
//OldT: Integer;
begin
Error := 0;
// oldt := gettickcount;
{ we can not be sure that the entity texture exists - it could be purged }
// tex := bmap^.tex;
if (tex <> NIL) then
begin
dx9tex := IDIRECT3DTEXTURE9(tex.d3dtex);
if (dx9tex <> nil) then
begin
// a5dll_errormessage(pchar('got to bitmap create'));
// B := TBitmap.Create;
{ check the texture format }
if (not FAILED(dx9tex.GetLevelDesc(0,ddsd))) then
begin
//B.Width := ddsd.Width;
//B.Height := ddsd.Height;
{ lock the texture and retrieve a pointer to the surface }
if (not FAILED(dx9tex.LockRect(0,d3dlr,nil,0))) then
begin
try
pixels := PByte(d3dlr.pBits);
// a5dll_errormessage(pchar('pixels assigned'));
{ do we have a 16 bit or 32 bit format? All 4 formats are possible: }
if (ddsd.Format = D3DFMT_A8R8G8B8) then
begin
// a5dll_errormessage(pchar('32bit'));
B.PixelFormat := pf32Bit;
y := 0;
while (y < ddsd.Height) do
begin
target := pointer(longword(pixels) + (y * d3dlr.Pitch));
row := B.Scanline[y];
x := 0;
while (x < ddsd.Width) do
begin
//target^ := $FFFF0000; { that's red in 8888 }
target^ := row[x];//x*y;
target := pointer(longword(target) + 4);
x := x + 1;
end;
y := y + 1;
end;
end
else if (ddsd.Format = D3DFMT_A4R4G4B4) then
begin
// a5dll_errormessage(pchar('16bit1'));
B.PixelFormat := pf16Bit;
y := 0;
while (y < ddsd.Height) do
begin
target := pointer(longword(pixels) + (y * d3dlr.Pitch));
row16 := B.Scanline[y];
x := 0;
while (x < ddsd.Width) do
begin
//PWord(target)^ := $FF00; { that's red in 4444 }
PWord(target)^ := row16[x];//x*y;
target := pointer(longword(target) + 2);
x := x + 1;
end;
y := y + 1;
end
end
else if (ddsd.Format = D3DFMT_A1R5G5B5) then
begin
// a5dll_errormessage(pchar('16bit2'));
B.PixelFormat := pf16Bit;
y := 0;
while (y < ddsd.Height) do
begin
target := pointer(longword(pixels) + (y * d3dlr.Pitch));
row16 := B.Scanline[y];
x := 0;
while (x < ddsd.Width) do
begin
//PWord(target)^ := $FC00; { that's red in 1555 }
PWord(target)^ := row16[x];//x*y;
target := pointer(longword(target) + 2);
x := x + 1;
end;
y := y + 1;
end;
end
else if (ddsd.Format = D3DFMT_R5G6B5) then
begin
// a5dll_errormessage(pchar('16bit3'));
B.PixelFormat := pf16Bit;
y := 0;
while (y < ddsd.Height) do
begin
target := pointer(longword(pixels) + (y * d3dlr.Pitch));
row16 := B.Scanline[y];
x := 0;
while (x < ddsd.Width) do
begin
PWord(target)^ := row16[x];//x*y;
//PWord(target)^ := $F800; { that's red in 565 }
target := pointer(longword(target) + 2);
x := x + 1;
end;
y := y + 1;
end;
end;
// a5dll_errormessage(pchar('got to save file'));
// fn := StrPas(filename^.chars);
// B.SaveToFile(fn);
// a5dll_errormessage(pchar('saved'));
{ Unlock the surface again }
except
Error := 1;
end;
dx9tex.UnlockRect(0);
end;
end;
// B.Free;
end;
end;
// oldt := gettickcount-oldt;
// a5dll_errormessage(pchar(inttostr(oldt)));
result := Error;
end;
end.
