ActiveForm 的 bug？？？？，DFW 没有人能回答这问题吗？ 不敢相信！！！ ( 积分: 200 )

  • 主题发起人 主题发起人 xuxiaohan
  • 开始时间 开始时间
X

xuxiaohan

Unregistered / Unconfirmed
GUEST, unregistred user!
unit GifOleImpl;

{$WARN SYMBOL_PLATFORM OFF}

interface

uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
ActiveX, AxCtrls, GifOleProj_TLB, StdVcl, GifImage, ExtCtrls, StdCtrls;

const
cm_Animate = WM_USER+1;

type

TGifOle = Class;

TDrawThd = class(TThread)
private
Fimage: TGifImage;
FGifOle: TGifOle;
FrameIndex: integer;
procedure DrawImage;
public
Constructor Create(GifOle: TGifOle);
procedure Execute
override;
end;

TGifOle = class(TActiveForm, IGifOle, IpersistStorage)
Image1: TImage;
procedure ActiveFormCreate(Sender: TObject);
procedure ActiveFormDestroy(Sender: TObject);
private
{ Private declarations }
FimageIndex: integer;
DrawThd: TDrawThd;
procedure internalpaintGif;
procedure SetimageIndex(const Value: integer);
procedure WMEraseBkgnd(var Message: TWMEraseBkgnd)
message WM_ERASEBKGND;
procedure WakeMainThread(Sender: TObject);
procedure cmAnimate(var msg: TMessage)
message CM_ANIMATE;
protected
{ Protected declarations }
function IsDirty: HResult
stdcall;
function InitNew(const stg: IStorage): HResult
stdcall;
function Load(const stg: IStorage): HResult
stdcall;
function Save(const stgSave: IStorage
fSameAsLoad: BOOL): HResult;
stdcall;
function SaveCompleted(const stgNew: IStorage): HResult
stdcall;
function HandsOffStorage: HResult
stdcall;
function GetClassID(out classID: TCLSID): HResult
stdcall;
property imageIndex: integer read FimageIndex write SetimageIndex;
// procedure WndProc(var message: TMessage)
override;
// procedure WmPaint(var message: TwmPaint)
message WM_PAINT;
procedure Run;
public
{ Public declarations }
Gif: TGifImage;
procedure LoadFromFile(const FileName: WideString)
safecall;
procedure PaintGif
safeCall;
procedure paint
override;
end;

implementation

uses ComObj, ComServ;

{$R *.DFM}

{ TGifOle }
procedure TGifOle.LoadFromFile(const FileName: WideString);
var
i: integer;
msg: TMsg;
begin
Gif.LoadFromFile(FileName);
ClientWidth := Gif.Width;
ClientHeight := Gif.Height;
// Image1.Picture.Assign(Gif);
//imageIndex := 0;
DrawThd:=TDrawThd.Create(self);
// DrawThd.Resume;
end;


procedure TGifOle.PaintGif
safeCall;
begin
internalpaintGif;
end;


procedure TGifOle.ActiveFormCreate(Sender: TObject);
begin
Classes.WakeMainThread := WakeMainThread;
Gif := TGifImage.Create;

end;

procedure TGifOle.ActiveFormDestroy(Sender: TObject);
begin
if Gif <> nil then Gif.Free;
if self.DrawThd<>nil then
begin
DrawThd.Terminate;
DrawThd.Free;
end;
//Classes.WakeMainThread := nil;
end;


procedure TGifOle.paint;
begin
// inherited;
// PaintGif;
//gif.Draw(canvas, Rect(0, 0, gif.Width, gif.Height));
// beep;
end;

procedure TGifOle.internalpaintGif;
var
R: TRect;
DC: HDC;
cvs: TCanvas;
begin
R:=Rect(0, 0, gif.Width, gif.Height);
if gif.Empty then exit;
[blue]奇怪的是，无法在ActiveForm 的canvas, ActiveForm 中的panel的canvas都无法draw[/blue];
{ gif.Images.SubImages[Imageindex].Draw(canvas, R,
(goTransparent in gif.DrawOptions), (goTile in Gif.DrawOptions));
imageIndex := ImageIndex + 1;
}
[red]在桌面上画就可以，奇怪！！！！；[/red]
Dc:=getDC(0);
Try
cvs:=TCanvas.Create;
cvs.Handle:=Dc;
gif.Images.SubImages[Imageindex].Draw(cvs, R,
(goTransparent in gif.DrawOptions), (goTile in Gif.DrawOptions));
imageIndex := ImageIndex + 1;
finally
cvs.Free;
ReleaseDc(0, Dc);
end;
end;

procedure TGifOle.SetimageIndex(const Value: integer);
begin
if (value >= 0) and (value <> FimageIndex) then
begin
if value > gif.Images.Count - 1 then
FImageIndex := 0
else
FimageIndex := Value;
end;
end;

function TGifOle.HandsOffStorage: HResult;
begin
result := S_OK;
end;

function TGifOle.InitNew(const stg: IStorage): HResult;
begin
Result := S_OK;
end;

function TGifOle.IsDirty: HResult;
begin
Result := S_OK;
end;

function TGifOle.Load(const stg: IStorage): HResult;
var
stmData: IStream;
OS: TOleStream;
begin
if SUCCEEDED(stg.OpenStream('GifData', nil,
STGM_READWRITE or STGM_SHARE_EXCLUSIVE, 0, stmData)) then
begin
OS := TOleStream.Create(stmData);
try
Gif.LoadFromStream(os);
//image1.Picture.Assign(Gif);
finally
OS.Free;
end;
end;
Result := S_OK;
end;

function TGifOle.Save(const stgSave: IStorage
fSameAsLoad: BOOL): HResult;
var
stmData: IStream;
OS: TOleStream;
begin
OleCheck(stgSave.CreateStream('GifData',
STGM_CREATE or STGM_READWRITE or STGM_SHARE_EXCLUSIVE, 0, 0, stmData));
OS := TOleStream.Create(stmData);
try
Gif.SaveToStream(OS);
finally
OS.Free;
end;
Result := S_OK;
end;

function TGifOle.SaveCompleted(const stgNew: IStorage): HResult;
begin
result := S_Ok;
end;

function TGifOle.GetClassID(out classID: TCLSID): HResult;
begin
ClassId := CLASS_GifOle;
Result:=S_OK;
end;

procedure TGifOle.WMEraseBkgnd(var Message: TWMEraseBkgnd);
begin
message.Result:=1;
end;

{
procedure TGifOle.WndProc(var message: TMessage);
begin
// if message.Msg<>WM_PAINT THEN inherited WndProc(message);

if message.Msg = WM_NULL then
begin
CheckSynchronize;
//internalpaintGif;
end
else
inherited WndProc(message);

end;
}
procedure TGifOle.WakeMainThread(Sender: TObject);
begin
if PostMessage(handle, WM_NULL, 0, 0) then //beep;
end;

procedure TGifOle.Run;
var
msg: TMsg;
begin
while PeekMessage(Msg, handle, 0, 0, PM_REMOVE) do
if Msg.message = WM_NULL then
CheckSynchronize
else
begin
TranslateMessage(Msg);
DispatchMessage(Msg);
end;
end;

procedure TGifOle.cmAnimate(var msg: TMessage);
begin
PaintGif;
end;

{
procedure TGifOle.WmPaint(var message: TwmPaint);
begin
inherited;
PaintGif;
beep;
end;
}
{ TDrawThd }

constructor TDrawThd.Create(GifOle: TGifOle);
begin
FGifOle:=GifOle;
FImage:=GifOle.Gif;
FrameIndex:=0;
inherited create(false);
end;

procedure TDrawThd.DrawImage;
var
delay: integer;
R: TRect;
begin
{
R:=Rect(0, 0, Fimage.Width, Fimage.Height);
Fimage.Images.SubImages[Frameindex].Draw(FGifOle.Canvas, R, true, (goTile in Fimage.DrawOptions));
// Fgifole.Canvas.Draw(0, 0, Fimage.Images.SubImages[FrameIndex].Bitmap);
}
// postmessage(FGifole.Handle, CM_INVALIDATE, 0, 0);
// FGifole.Invalidate;
postMessage(FGifole.Handle, CM_ANIMATE, 0, 0);
// InvalidateRect(FHandle, nil, not (csOpaque in ControlStyle))
// self.FGifOle.Invalidate;
delay:=Fimage.Images.SubImages[FrameIndex].GraphicControlExtension.Delay;
if delay=0 then Delay:=10;
sleep(Delay*11);
inc(FrameIndex);
if FrameIndex>Fimage.Images.Count-1 then FrameIndex:=0;

// beep;
end;

procedure TDrawThd.Execute;
begin
while not Terminated do DrawImage;
end;

initialization
TActiveFormFactory.Create(
ComServer,
TActiveFormControl,
TGifOle,
Class_GifOle,
1,
'',
OLEMISC_SIMPLEFRAME or OLEMISC_ACTSLIKELABEL,
tmApartment);
end.
 
unit GifOleImpl;

{$WARN SYMBOL_PLATFORM OFF}

interface

uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
ActiveX, AxCtrls, GifOleProj_TLB, StdVcl, GifImage, ExtCtrls, StdCtrls;

const
cm_Animate = WM_USER+1;

type

TGifOle = Class;

TDrawThd = class(TThread)
private
Fimage: TGifImage;
FGifOle: TGifOle;
FrameIndex: integer;
procedure DrawImage;
public
Constructor Create(GifOle: TGifOle);
procedure Execute
override;
end;

TGifOle = class(TActiveForm, IGifOle, IpersistStorage)
Image1: TImage;
procedure ActiveFormCreate(Sender: TObject);
procedure ActiveFormDestroy(Sender: TObject);
private
{ Private declarations }
FimageIndex: integer;
DrawThd: TDrawThd;
procedure internalpaintGif;
procedure SetimageIndex(const Value: integer);
procedure WMEraseBkgnd(var Message: TWMEraseBkgnd)
message WM_ERASEBKGND;
procedure WakeMainThread(Sender: TObject);
procedure cmAnimate(var msg: TMessage)
message CM_ANIMATE;
protected
{ Protected declarations }
function IsDirty: HResult
stdcall;
function InitNew(const stg: IStorage): HResult
stdcall;
function Load(const stg: IStorage): HResult
stdcall;
function Save(const stgSave: IStorage
fSameAsLoad: BOOL): HResult;
stdcall;
function SaveCompleted(const stgNew: IStorage): HResult
stdcall;
function HandsOffStorage: HResult
stdcall;
function GetClassID(out classID: TCLSID): HResult
stdcall;
property imageIndex: integer read FimageIndex write SetimageIndex;
// procedure WndProc(var message: TMessage)
override;
// procedure WmPaint(var message: TwmPaint)
message WM_PAINT;
procedure Run;
public
{ Public declarations }
Gif: TGifImage;
procedure LoadFromFile(const FileName: WideString)
safecall;
procedure PaintGif
safeCall;
procedure paint
override;
end;

implementation

uses ComObj, ComServ;

{$R *.DFM}

{ TGifOle }
procedure TGifOle.LoadFromFile(const FileName: WideString);
var
i: integer;
msg: TMsg;
begin
Gif.LoadFromFile(FileName);
ClientWidth := Gif.Width;
ClientHeight := Gif.Height;
// Image1.Picture.Assign(Gif);
//imageIndex := 0;
DrawThd:=TDrawThd.Create(self);
// DrawThd.Resume;
end;


procedure TGifOle.PaintGif
safeCall;
begin
internalpaintGif;
end;


procedure TGifOle.ActiveFormCreate(Sender: TObject);
begin
Classes.WakeMainThread := WakeMainThread;
Gif := TGifImage.Create;

end;

procedure TGifOle.ActiveFormDestroy(Sender: TObject);
begin
if Gif <> nil then Gif.Free;
if self.DrawThd<>nil then
begin
DrawThd.Terminate;
DrawThd.Free;
end;
//Classes.WakeMainThread := nil;
end;


procedure TGifOle.paint;
begin
// inherited;
// PaintGif;
//gif.Draw(canvas, Rect(0, 0, gif.Width, gif.Height));
// beep;
end;

procedure TGifOle.internalpaintGif;
var
R: TRect;
DC: HDC;
cvs: TCanvas;
begin
R:=Rect(0, 0, gif.Width, gif.Height);
if gif.Empty then exit;
[blue]奇怪的是，无法在ActiveForm 的canvas, ActiveForm 中的panel的canvas都无法draw[/blue];
{ gif.Images.SubImages[Imageindex].Draw(canvas, R,
(goTransparent in gif.DrawOptions), (goTile in Gif.DrawOptions));
imageIndex := ImageIndex + 1;
}
[red]在桌面上画就可以，奇怪！！！！；[/red]
Dc:=getDC(0);
Try
cvs:=TCanvas.Create;
cvs.Handle:=Dc;
gif.Images.SubImages[Imageindex].Draw(cvs, R,
(goTransparent in gif.DrawOptions), (goTile in Gif.DrawOptions));
imageIndex := ImageIndex + 1;
finally
cvs.Free;
ReleaseDc(0, Dc);
end;
end;

procedure TGifOle.SetimageIndex(const Value: integer);
begin
if (value >= 0) and (value <> FimageIndex) then
begin
if value > gif.Images.Count - 1 then
FImageIndex := 0
else
FimageIndex := Value;
end;
end;

function TGifOle.HandsOffStorage: HResult;
begin
result := S_OK;
end;

function TGifOle.InitNew(const stg: IStorage): HResult;
begin
Result := S_OK;
end;

function TGifOle.IsDirty: HResult;
begin
Result := S_OK;
end;

function TGifOle.Load(const stg: IStorage): HResult;
var
stmData: IStream;
OS: TOleStream;
begin
if SUCCEEDED(stg.OpenStream('GifData', nil,
STGM_READWRITE or STGM_SHARE_EXCLUSIVE, 0, stmData)) then
begin
OS := TOleStream.Create(stmData);
try
Gif.LoadFromStream(os);
//image1.Picture.Assign(Gif);
finally
OS.Free;
end;
end;
Result := S_OK;
end;

function TGifOle.Save(const stgSave: IStorage
fSameAsLoad: BOOL): HResult;
var
stmData: IStream;
OS: TOleStream;
begin
OleCheck(stgSave.CreateStream('GifData',
STGM_CREATE or STGM_READWRITE or STGM_SHARE_EXCLUSIVE, 0, 0, stmData));
OS := TOleStream.Create(stmData);
try
Gif.SaveToStream(OS);
finally
OS.Free;
end;
Result := S_OK;
end;

function TGifOle.SaveCompleted(const stgNew: IStorage): HResult;
begin
result := S_Ok;
end;

function TGifOle.GetClassID(out classID: TCLSID): HResult;
begin
ClassId := CLASS_GifOle;
Result:=S_OK;
end;

procedure TGifOle.WMEraseBkgnd(var Message: TWMEraseBkgnd);
begin
message.Result:=1;
end;

{
procedure TGifOle.WndProc(var message: TMessage);
begin
// if message.Msg<>WM_PAINT THEN inherited WndProc(message);

if message.Msg = WM_NULL then
begin
CheckSynchronize;
//internalpaintGif;
end
else
inherited WndProc(message);

end;
}
procedure TGifOle.WakeMainThread(Sender: TObject);
begin
if PostMessage(handle, WM_NULL, 0, 0) then //beep;
end;

procedure TGifOle.Run;
var
msg: TMsg;
begin
while PeekMessage(Msg, handle, 0, 0, PM_REMOVE) do
if Msg.message = WM_NULL then
CheckSynchronize
else
begin
TranslateMessage(Msg);
DispatchMessage(Msg);
end;
end;

procedure TGifOle.cmAnimate(var msg: TMessage);
begin
PaintGif;
end;

{
procedure TGifOle.WmPaint(var message: TwmPaint);
begin
inherited;
PaintGif;
beep;
end;
}
{ TDrawThd }

constructor TDrawThd.Create(GifOle: TGifOle);
begin
FGifOle:=GifOle;
FImage:=GifOle.Gif;
FrameIndex:=0;
inherited create(false);
end;

procedure TDrawThd.DrawImage;
var
delay: integer;
R: TRect;
begin
{
R:=Rect(0, 0, Fimage.Width, Fimage.Height);
Fimage.Images.SubImages[Frameindex].Draw(FGifOle.Canvas, R, true, (goTile in Fimage.DrawOptions));
// Fgifole.Canvas.Draw(0, 0, Fimage.Images.SubImages[FrameIndex].Bitmap);
}
// postmessage(FGifole.Handle, CM_INVALIDATE, 0, 0);
// FGifole.Invalidate;
postMessage(FGifole.Handle, CM_ANIMATE, 0, 0);
// InvalidateRect(FHandle, nil, not (csOpaque in ControlStyle))
// self.FGifOle.Invalidate;
delay:=Fimage.Images.SubImages[FrameIndex].GraphicControlExtension.Delay;
if delay=0 then Delay:=10;
sleep(Delay*11);
inc(FrameIndex);
if FrameIndex>Fimage.Images.Count-1 then FrameIndex:=0;

// beep;
end;

procedure TDrawThd.Execute;
begin
while not Terminated do DrawImage;
end;

initialization
TActiveFormFactory.Create(
ComServer,
TActiveFormControl,
TGifOle,
Class_GifOle,
1,
'',
OLEMISC_SIMPLEFRAME or OLEMISC_ACTSLIKELABEL,
tmApartment);
end.
 
好,帮顶



--------签名档---------------------------

比肩国内顶尖源码下载站点 -> 源码我爱你

http://www.source520.com
http://www.source520.net

80G源码电子书免费免注册下载,大量精辟技术文档库随时更新
******************************************************************
附:为了站点持续发展,现有本站近年来收藏的大量大型商业源码低价出售,
详情请进入以下链接查看:
http://www.source520.com/building_delphi.htm

浏览商业代码请从如下URL进入查看实物:
1.商业源码库1: ftp://source520see3:browse@61.152.199.245/
2.商业源码库2: ftp://source520see2:browse@61.152.199.245/
 
你的procedure TGifOle.paint;事件都注释了啊.

下面是我测试的:
var
dc: HDC;
begin
dc := GetDC(pnl1.Handle);
MoveToEx(dc, 10, 0, nil);
LineTo(dc, 10, 100);
ReleaseDC(pnl1.Handle, dc);

其中:pnl1:TPanel;

是可以的!

还有:
http://www.delphibbs.com/delphibbs/dispq.asp?lid=2973982
这个是在ActiveForm中用到的!
 
不过ActiveForm确实有很多问题,比如下面的拷屏就不行:
var
TempCanvas: TCanvas;
Bitmap: TBitmap;
ARect: TRect;
begin
TempCanvas := TCanvas.Create;
TempCanvas.Handle := GetDC(ScrollBox.Handle);

ARect := Rect(0, 0, 100, 100);
Bitmap.Canvas.CopyRect(ARect, TempCanvas, ARect);

Bitmap.SaveToFile('C:/TEST.BMP');

FreeAndNil(Bitmap);
FreeAndNil(TempCanvas);
 
问题是，在 pain里面是可以的，但由于我是画 gif 动画，没有理由在 paint里面画的。我用线程发给ActiveForm 一个自定义消息，让它显示一个Gif 的 一个Frame，循环不断。
 
unit ActiveFormImpl1;

{$WARN SYMBOL_PLATFORM OFF}

interface

uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
ActiveX, AxCtrls, Project2_TLB, StdVcl, ExtCtrls, StdCtrls;

type
TActiveFormX = class(TActiveForm, IActiveFormX)
Image1: TImage;
Button1: TButton;
Timer1: TTimer;
procedure Button1Click(Sender: TObject);
procedure Timer1Timer(Sender: TObject);
private
{ Private declarations }
FEvents: IActiveFormXEvents;
procedure ActivateEvent(Sender: TObject);
procedure ClickEvent(Sender: TObject);
procedure CreateEvent(Sender: TObject);
procedure DblClickEvent(Sender: TObject);
procedure DeactivateEvent(Sender: TObject);
procedure DestroyEvent(Sender: TObject);
procedure KeyPressEvent(Sender: TObject
var Key: Char);
procedure PaintEvent(Sender: TObject);
protected
{ Protected declarations }
procedure DefinePropertyPages(DefinePropertyPage: TDefinePropertyPage)
override;
procedure EventSinkChanged(const EventSink: IUnknown)
override;
function Get_Active: WordBool
safecall;
function Get_AlignDisabled: WordBool
safecall;
function Get_AutoScroll: WordBool
safecall;
function Get_AutoSize: WordBool
safecall;
function Get_AxBorderStyle: TxActiveFormBorderStyle
safecall;
function Get_Caption: WideString
safecall;
function Get_Color: OLE_COLOR
safecall;
function Get_Cursor: Smallint
safecall;
function Get_DoubleBuffered: WordBool
safecall;
function Get_DropTarget: WordBool
safecall;
function Get_Enabled: WordBool
safecall;
function Get_Font: IFontDisp
safecall;
function Get_HelpFile: WideString
safecall;
function Get_HelpKeyword: WideString
safecall;
function Get_HelpType: TxHelpType
safecall;
function Get_KeyPreview: WordBool
safecall;
function Get_PixelsPerInch: Integer
safecall;
function Get_PrintScale: TxPrintScale
safecall;
function Get_Scaled: WordBool
safecall;
function Get_Visible: WordBool
safecall;
function Get_VisibleDockClientCount: Integer
safecall;
procedure _Set_Font(var Value: IFontDisp)
safecall;
procedure Set_AutoScroll(Value: WordBool)
safecall;
procedure Set_AutoSize(Value: WordBool)
safecall;
procedure Set_AxBorderStyle(Value: TxActiveFormBorderStyle)
safecall;
procedure Set_Caption(const Value: WideString)
safecall;
procedure Set_Color(Value: OLE_COLOR)
safecall;
procedure Set_Cursor(Value: Smallint)
safecall;
procedure Set_DoubleBuffered(Value: WordBool)
safecall;
procedure Set_DropTarget(Value: WordBool)
safecall;
procedure Set_Enabled(Value: WordBool)
safecall;
procedure Set_Font(const Value: IFontDisp)
safecall;
procedure Set_HelpFile(const Value: WideString)
safecall;
procedure Set_HelpKeyword(const Value: WideString)
safecall;
procedure Set_HelpType(Value: TxHelpType)
safecall;
procedure Set_KeyPreview(Value: WordBool)
safecall;
procedure Set_PixelsPerInch(Value: Integer)
safecall;
procedure Set_PrintScale(Value: TxPrintScale)
safecall;
procedure Set_Scaled(Value: WordBool)
safecall;
procedure Set_Visible(Value: WordBool)
safecall;
public
{ Public declarations }
procedure Initialize
override;
end;

implementation

uses ComObj, ComServ;

{$R *.DFM}

{ TActiveFormX }

procedure TActiveFormX.DefinePropertyPages(DefinePropertyPage: TDefinePropertyPage);
begin
{ Define property pages here. Property pages are defined by calling
DefinePropertyPage with the class id of the page. For example,
DefinePropertyPage(Class_ActiveFormXPage)
}
end;

procedure TActiveFormX.EventSinkChanged(const EventSink: IUnknown);
begin
FEvents := EventSink as IActiveFormXEvents;
inherited EventSinkChanged(EventSink);
end;

procedure TActiveFormX.Initialize;
begin
inherited Initialize;
OnActivate := ActivateEvent;
OnClick := ClickEvent;
OnCreate := CreateEvent;
OnDblClick := DblClickEvent;
OnDeactivate := DeactivateEvent;
OnDestroy := DestroyEvent;
OnKeyPress := KeyPressEvent;
OnPaint := PaintEvent;
end;

function TActiveFormX.Get_Active: WordBool;
begin
Result := Active;
end;

function TActiveFormX.Get_AlignDisabled: WordBool;
begin
Result := AlignDisabled;
end;

function TActiveFormX.Get_AutoScroll: WordBool;
begin
Result := AutoScroll;
end;

function TActiveFormX.Get_AutoSize: WordBool;
begin
Result := AutoSize;
end;

function TActiveFormX.Get_AxBorderStyle: TxActiveFormBorderStyle;
begin
Result := Ord(AxBorderStyle);
end;

function TActiveFormX.Get_Caption: WideString;
begin
Result := WideString(Caption);
end;

function TActiveFormX.Get_Color: OLE_COLOR;
begin
Result := OLE_COLOR(Color);
end;

function TActiveFormX.Get_Cursor: Smallint;
begin
Result := Smallint(Cursor);
end;

function TActiveFormX.Get_DoubleBuffered: WordBool;
begin
Result := DoubleBuffered;
end;

function TActiveFormX.Get_DropTarget: WordBool;
begin
Result := DropTarget;
end;

function TActiveFormX.Get_Enabled: WordBool;
begin
Result := Enabled;
end;

function TActiveFormX.Get_Font: IFontDisp;
begin
GetOleFont(Font, Result);
end;

function TActiveFormX.Get_HelpFile: WideString;
begin
Result := WideString(HelpFile);
end;

function TActiveFormX.Get_HelpKeyword: WideString;
begin
Result := WideString(HelpKeyword);
end;

function TActiveFormX.Get_HelpType: TxHelpType;
begin
Result := Ord(HelpType);
end;

function TActiveFormX.Get_KeyPreview: WordBool;
begin
Result := KeyPreview;
end;

function TActiveFormX.Get_PixelsPerInch: Integer;
begin
Result := PixelsPerInch;
end;

function TActiveFormX.Get_PrintScale: TxPrintScale;
begin
Result := Ord(PrintScale);
end;

function TActiveFormX.Get_Scaled: WordBool;
begin
Result := Scaled;
end;

function TActiveFormX.Get_Visible: WordBool;
begin
Result := Visible;
end;

function TActiveFormX.Get_VisibleDockClientCount: Integer;
begin
Result := VisibleDockClientCount;
end;

procedure TActiveFormX._Set_Font(var Value: IFontDisp);
begin
SetOleFont(Font, Value);
end;

procedure TActiveFormX.ActivateEvent(Sender: TObject);
begin
if FEvents <> nil then FEvents.OnActivate;
end;

procedure TActiveFormX.ClickEvent(Sender: TObject);
begin
if FEvents <> nil then FEvents.OnClick;
end;

procedure TActiveFormX.CreateEvent(Sender: TObject);
begin
if FEvents <> nil then FEvents.OnCreate;
end;

procedure TActiveFormX.DblClickEvent(Sender: TObject);
begin
if FEvents <> nil then FEvents.OnDblClick;
end;

procedure TActiveFormX.DeactivateEvent(Sender: TObject);
begin
if FEvents <> nil then FEvents.OnDeactivate;
end;

procedure TActiveFormX.DestroyEvent(Sender: TObject);
begin
if FEvents <> nil then FEvents.OnDestroy;
end;

procedure TActiveFormX.KeyPressEvent(Sender: TObject
var Key: Char);
var
TempKey: Smallint;
begin
TempKey := Smallint(Key);
if FEvents <> nil then FEvents.OnKeyPress(TempKey);
Key := Char(TempKey);
end;

procedure TActiveFormX.PaintEvent(Sender: TObject);
begin
//
Canvas.TextOut(1, 1, FormatDateTime('&quot;PaintEvent:&quot
YYYY-MM-DD HH:NN:SS', now));

if FEvents <> nil then FEvents.OnPaint;
end;

procedure TActiveFormX.Set_AutoScroll(Value: WordBool);
begin
AutoScroll := Value;
end;

procedure TActiveFormX.Set_AutoSize(Value: WordBool);
begin
AutoSize := Value;
end;

procedure TActiveFormX.Set_AxBorderStyle(Value: TxActiveFormBorderStyle);
begin
AxBorderStyle := TActiveFormBorderStyle(Value);
end;

procedure TActiveFormX.Set_Caption(const Value: WideString);
begin
Caption := TCaption(Value);
end;

procedure TActiveFormX.Set_Color(Value: OLE_COLOR);
begin
Color := TColor(Value);
end;

procedure TActiveFormX.Set_Cursor(Value: Smallint);
begin
Cursor := TCursor(Value);
end;

procedure TActiveFormX.Set_DoubleBuffered(Value: WordBool);
begin
DoubleBuffered := Value;
end;

procedure TActiveFormX.Set_DropTarget(Value: WordBool);
begin
DropTarget := Value;
end;

procedure TActiveFormX.Set_Enabled(Value: WordBool);
begin
Enabled := Value;
end;

procedure TActiveFormX.Set_Font(const Value: IFontDisp);
begin
SetOleFont(Font, Value);
end;

procedure TActiveFormX.Set_HelpFile(const Value: WideString);
begin
HelpFile := string(Value);
end;

procedure TActiveFormX.Set_HelpKeyword(const Value: WideString);
begin
HelpKeyword := string(Value);
end;

procedure TActiveFormX.Set_HelpType(Value: TxHelpType);
begin
HelpType := THelpType(Value);
end;

procedure TActiveFormX.Set_KeyPreview(Value: WordBool);
begin
KeyPreview := Value;
end;

procedure TActiveFormX.Set_PixelsPerInch(Value: Integer);
begin
PixelsPerInch := Value;
end;

procedure TActiveFormX.Set_PrintScale(Value: TxPrintScale);
begin
PrintScale := TPrintScale(Value);
end;

procedure TActiveFormX.Set_Scaled(Value: WordBool);
begin
Scaled := Value;
end;

procedure TActiveFormX.Set_Visible(Value: WordBool);
begin
Visible := Value;
end;

procedure TActiveFormX.Button1Click(Sender: TObject);
begin
Canvas.TextOut(1, 100, FormatDateTime('&quot;Button1Click:&quot
YYYY-MM-DD HH:NN:SS', now));
end;

procedure TActiveFormX.Timer1Timer(Sender: TObject);
begin
Canvas.TextOut(1, 300, FormatDateTime('&quot;Timer1Timer:&quot
YYYY-MM-DD HH:NN:SS', now));

end;

initialization
TActiveFormFactory.Create(
ComServer,
TActiveFormControl,
TActiveFormX,
Class_ActiveFormX,
1,
'',
OLEMISC_SIMPLEFRAME or OLEMISC_ACTSLIKELABEL,
tmApartment);
end.
 
我测试 了 ActiveForm.Canvas 是 可以 画的。（我用了 PaintEvent，Button1Click，Timer1Timer 三种 作了 测试 都没问题 ）
procedure TActiveFormX.PaintEvent(Sender: TObject);
begin
//
Canvas.TextOut(1, 1, FormatDateTime('&quot;PaintEvent:&quot
YYYY-MM-DD HH:NN:SS', now));

if FEvents <> nil then FEvents.OnPaint;
end;


procedure TActiveFormX.Button1Click(Sender: TObject);
begin
Canvas.TextOut(1, 100, FormatDateTime('&quot;Button1Click:&quot
YYYY-MM-DD HH:NN:SS', now));
end;

procedure TActiveFormX.Timer1Timer(Sender: TObject);
begin
Canvas.TextOut(1, 300, FormatDateTime('&quot;Timer1Timer:&quot
YYYY-MM-DD HH:NN:SS', now));

end;

怀疑 你 在其他的地方 可能 有问题。
 
太长了，看不下去了！
 
hfg：
你是在什么环境下测试的？
我将 这个ActiveForm 插入到 RxRichedit 中， 就是不行哦， 连Button 也不能响应鼠标的消息，Button1Click 无法执行。

在RxRiched 单元加了这个Function
function TRxCustomRichEdit.InsertGif(FileName: string): Variant
//add
var
Storage : IStorage;
OleObject : IOleObject;
OleSite : IOleClientSite;
ReObject : TReObject;
OleCache : IOLECache;
Data : TOleUIChangeIcon;
GifImg : TGifImage;
ClassID : TGuid;
ole : Variant;
begin
try
IRichEditOle(FRichEditOle).GetClientSite(OleSite);
CreateStorage(Storage);
// ClassID := ProgIDToClassID('ImageOle.GifAnimator')
这个时腾讯用的 imageOle.dll，可以显示动画。
// ClassID := ProgIDToClassID('GifOleProj.GifOle')
//这个是我原来的ActiveForm，不能在Canvas上Draw，除非在 procedure paint 里面。
ClassID := ProgIDToClassID('AnimateGif.AnimateGifOle')
这个是根据你的例子做的有Timer， button 的ActiveFoem，还是不行！
// ClassID := ProgIDToClassID('Dynamicgif.DynamicGif');
// ClassID := ProgIDToClassID('Gif89.Gif89a');
OleCheck(OleCreate(ClassID, IOleObject, OLERENDER_DRAW, nil, OleSite, Storage, OleObject));

FillChar(ReObject, SizeOf(TReObject), 0);
ReObject.cbStruct:=SizeOf(TReObject);
ReObject.cp:=SelStart;
ReObject.poleobj:=OleObject;
ReObject.clsid:=Data.clsid;
ReObject.pstg:=Storage;
ReObject.polesite:=OleSite;
// ReObject.sizel.cx:=0;
// ReObject.sizel.cy:=0;
ReObject.dwUser:=0;
ReObject.dwFlags:=REO_BELOWBASELINE or REO_DYNAMICSIZE{ or REO_RESIZABLE};
ReObject.dvaspect:=DVASPECT_CONTENT;
// ReObject.dwFlags:= ReObject.dwFlags or REO_BLANK;
result:=Variant(ReObject.poleobj as IDispatch);
// Result.loadFromFile(filename)

// IRichEditOle(FRichEditOle).SetHostNames(PChar(WideString(Application.Title)),
// PChar(WideString(Caption)));
Olecheck(IRichEditOle(FRichEditOle).InsertObject(ReObject));
except
raise;
end;
end;
 
您必须登录或注册才可回复。

Similar threads

A
大家帮我分析一下，对IE的控制为什么会导致错误？（在线等候）(20分)
回复
16
查看
345
白河愁
白
N
实现插入BMP图片到RichEdit中？ (100分)
回复
9
查看
642
shaga
S
沧
Dll 的参数传递问题。帮帮忙！(100分)
回复
14
查看
298
沧海
沧
H
急得不行：关于ActiveX组件属性页的问题(50分)
回复
0
查看
154
huxiaoyong
H
S
为什么我重载了控件的WindowProc过程，但截消息的时候就出问题了(200分)
回复
8
查看
231
spdavid
S
后退
顶部