sf_flash.pas

smartflash ,delphi vcl组件 ,可以实现透明flash窗体

  TsfOleControl = class(TGraphicControl, IUnknown, IOleClientSite_Flash,
    IOleControlSite, IOleWindow, IOleInPlaceSite, IOleInPlaceSiteWindowless,
    IOleInPlaceFrame, IDispatch, IOleInPlaceUIWindow,
    IPropertyNotifySink, IParseDisplayName)
  private
    FGrabProcess: boolean;
    FInLoading: Boolean;
    FResizing: boolean;
    FRefCount: Longint;
    FControlData: PControlData;
    FEventDispatch: TEventDispatch;
    FObjectData: HGlobal;
    FOleObject: IOleObject_Flash;
    FPersistStream: IPersistStreamInit;
    FControlDispatch: IDispatch;
    FPropBrowsing: IPerPropertyBrowsing;
    FViewObject: IViewObject;
    FPropConnection: Longint;
    FEventsConnection: Longint;
    FMiscStatus: Longint;
    FFonts: TList;
    FPictures: TList;
    FUpdatingPictures: Boolean;
    FUpdatingColor: Boolean;
    FUpdatingFont: Boolean;
    FUpdatingEnabled: Boolean;
    FTransparent: boolean;
    FDisableFlashPopup: boolean;
    FDisableFlashCursor: boolean;
    { paint }
    FBackBuffer, FBuffer, FBuffer2: TsfBitmap;
    FPaintRect: PRect;
    FNeedUpdate: boolean;
    { TsfOleControl }
    procedure CreateControl;
    procedure CreateEnumPropDescs;
    procedure CreateInstance;
    procedure CreateStorage;
    procedure DesignModified;
    procedure DestroyControl;
    procedure DestroyEnumPropDescs;
    procedure DestroyStorage;
    procedure GetEventMethod(DispID: TDispID; var Method: TMethod);
    function GetMainMenu: TMainMenu;
    function GetOleObject: Variant;
    function GetDefaultDispatch: IDispatch;
    procedure HookControlWndProc;
    procedure ReadData(Stream: TStream);
    procedure SetUIActive(Active: Boolean);
    procedure WriteData(Stream: TStream);
    procedure CMDocWindowActivate(var Message: TMessage); message CM_DOCWINDOWACTIVATE;
    procedure CMColorChanged(var Message: TMessage); message CM_COLORCHANGED;
    procedure CMEnabledChanged(var Message: TMessage); message CM_ENABLEDCHANGED;
    procedure CMFontChanged(var Message: TMessage); message CM_FONTCHANGED;
    procedure CMDialogKey(var Message: TMessage); message CM_DIALOGKEY;
    procedure CMUIActivate(var Message: TMessage); message CM_UIACTIVATE;
    procedure CMUIDeactivate(var Message: TMessage); message CM_UIDEACTIVATE;
    procedure D2InvokeEvent(DispID: TDispID; var Params: TDispParams);

    function GetParentHandle: HWnd;
    procedure SetTransparent(const Value: boolean);
    procedure SetDisableFlashPopup(const Value: boolean);
  protected
    FOleControl: IOleControl;
    FOleInPlaceObject: IOleInPlaceObject;
    FOleInPlaceActiveObject: IOleInPlaceActiveObject;
    FFlashNotExists: boolean;
    FPaintBackground: boolean;
    FOnPaint: TNotifyEvent;
    FCaptured: boolean;
    FFocused: boolean;
    FNeedHandle: boolean;
    procedure StandardEvent(DispID: TDispID; var Params: TDispParams); virtual;
    procedure InvokeEvent(DispID: TDispID; var Params: TDispParams); virtual;
    { TControl }
    procedure AdjustSize; override;
    { IUnknown }
    function QueryInterface(const IID: TGUID; out Obj): HResult; override;
    function _AddRef: Integer; stdcall;
    function _Release: Integer; stdcall;
    { IParseDysplayName }
    function ParseDisplayName(const bc: IBindCtx; pszDisplayName: POleStr;
      out chEaten: Longint; out mkOut: IMoniker_Flash): HResult; stdcall;
    { IOleClientSite_Flash }
    function SaveObject: HResult; stdcall;
    function GetMoniker(dwAssign: Longint; dwWhichMoniker: Longint;
      out mk: IMoniker_Flash): HResult; stdcall;
    function GetContainer(out container: IOleContainer_Flash): HResult; stdcall;
    function ShowObject: HResult; stdcall;
    function OnShowWindow(fShow: BOOL): HResult; stdcall;
    function RequestNewObjectLayout: HResult; stdcall;
    { IOleControlSite }
    function OnControlInfoChanged: HResult; stdcall;
    function LockInPlaceActive(fLock: BOOL): HResult; stdcall;
    function GetExtendedControl(out disp: IDispatch): HResult; stdcall;
    function TransformCoords(var ptlHimetric: TPoint; var ptfContainer: TPointF;
      flags: Longint): HResult; stdcall;
    function IOleControlSite.TranslateAccelerator = OleControlSite_TranslateAccelerator;
    function OleControlSite_TranslateAccelerator(msg: PMsg;
      grfModifiers: Longint): HResult; stdcall;
    function OnFocus(fGotFocus: BOOL): HResult; stdcall;
    function ShowPropertyFrame: HResult; stdcall;
    { IOleWindow }
    function GetWindow(out WindowHandle: HWnd): HResult; stdcall;
    function ContextSensitiveHelp(fEnterMode: BOOL): HResult; stdcall;
    { IOleInPlaceSite }
    function IOleInPlaceSiteWindowless.GetWindow = OleInPlaceSite_GetWindow;
    function OleInPlaceSite_GetWindow(out wnd: HWnd): HResult; stdcall;
    function CanInPlaceActivate: HResult; stdcall;
    function OnInPlaceActivate: HResult; stdcall;
    function OnUIActivate: HResult; stdcall;
    function GetWindowContext(out frame: IOleInPlaceFrame;
      out doc: IOleInPlaceUIWindow; out rcPosRect: TRect;
      out rcClipRect: TRect; out frameInfo: TOleInPlaceFrameInfo): HResult;
      stdcall;
    function Scroll(scrollExtent: TPoint): HResult; stdcall;
    function OnUIDeactivate(fUndoable: BOOL): HResult; stdcall;
    function OnInPlaceDeactivate: HResult; stdcall;
    function DiscardUndoState: HResult; stdcall;
    function DeactivateAndUndo: HResult; stdcall;
    function OnPosRectChange(const rcPosRect: TRect): HResult; stdcall;
    { IOleInPlaceSiteEx }
    function OnInPlaceActivateEx(fNoRedraw: PBOOL; dwFlags: DWORD): HResult; stdcall;
    function OnInPlaceDeActivateEx(fNoRedraw: BOOL): HResult; stdcall;
    function RequestUIActivate: HResult; stdcall;
    { IOleInPlaceSiteWindowless }
    function CanWindowlessActivate: HResult; stdcall;
    function GetCapture: HResult; stdcall;
    function SetCapture(ACapture: BOOL): HResult; stdcall;
    function GetFocus: HResult; stdcall;
    function SetFocus(fFocus: BOOL): HResult; stdcall;
    function GetDC(var rc: TRect; qrfFlags: DWORD; var hDC: HDC): HResult; stdcall;
    function ReleaseDC(hDC: HDC): HResult; stdcall;
    function InvalidateRect(Rect: PRect; fErase: BOOL): HResult; stdcall;
    function InvalidateRgn(hRGN: HRGN; fErase: BOOL): HResult; stdcall;
    function ScrollRect(dx, dy: Integer; var RectScroll: TRect; var RectClip: TRect): HResult; stdcall;
    function AdjustRect(var rc: TRect): HResult; stdcall;
    function OnDefWindowMessage(msg: LongWord; wParam: WPARAM; lParam: LPARAM; var LResult: LRESULT): HResult; stdcall;
    { IOleInPlaceUIWindow }
    function GetBorder(out rectBorder: TRect): HResult; stdcall;
    function RequestBorderSpace(const borderwidths: TRect): HResult; stdcall;
    function SetBorderSpace(pborderwidths: PRect): HResult; stdcall;
    function SetActiveObject(const activeObject: IOleInPlaceActiveObject;
      pszObjName: POleStr): HResult; stdcall;
    { IOleInPlaceFrame }
    function IOleInPlaceFrame.GetWindow = OleInPlaceFrame_GetWindow;
    function OleInPlaceFrame_GetWindow(out wnd: HWnd): HResult; stdcall;
    function InsertMenus(hmenuShared: HMenu;
      var menuWidths: TOleMenuGroupWidths): HResult; stdcall;
    function SetMenu(hmenuShared: HMenu; holemenu: HMenu;
      hwndActiveObject: HWnd): HResult; stdcall;
    function RemoveMenus(hmenuShared: HMenu): HResult; stdcall;
    function SetStatusText(pszStatusText: POleStr): HResult; stdcall;
    function EnableModeless(fEnable: BOOL): HResult; stdcall;
    function IOleInPlaceFrame.TranslateAccelerator = OleInPlaceFrame_TranslateAccelerator;
    function OleInPlaceFrame_TranslateAccelerator(var msg: TMsg;
      wID: Word): HResult; stdcall;
    { IDispatch }
    function GetTypeInfoCount(out Count: Integer): HResult; stdcall;
    function GetTypeInfo(Index, LocaleID: Integer; out TypeInfo): HResult; stdcall;
    function GetIDsOfNames(const IID: TGUID; Names: Pointer;
      NameCount, LocaleID: Integer; DispIDs: Pointer): HResult; stdcall;
    function Invoke(DispID: Integer; const IID: TGUID; LocaleID: Integer;
      Flags: Word; var Params; VarResult, ExcepInfo, ArgErr: Pointer): HResult; stdcall;
    { ISimpleFrameSite }
    function PreMessageFilter(wnd: HWnd; msg, wp, lp: Integer;
      out res: Integer; out Cookie: Longint): HResult; stdcall;
    function PostMessageFilter(wnd: HWnd; msg, wp, lp: Integer;
      out res: Integer; Cookie: Longint): HResult; stdcall;
    { TsfOleControl }
    procedure CreateWnd; //override;
    procedure DefineProperties(Filer: TFiler); override;
    procedure DestroyWindowHandle; //override;
    function GetByteProp(Index: Integer): Byte;
    function GetColorProp(Index: Integer): TColor;
    function GetTColorProp(Index: Integer): TColor;
    function GetCompProp(Index: Integer): Comp;
    function GetCurrencyProp(Index: Integer): Currency;
    function GetDoubleProp(Index: Integer): Double;
    function GetIDispatchProp(Index: Integer): IDispatch;
    function GetIntegerProp(Index: Integer): Integer;
    function GetIUnknownProp(Index: Integer): IUnknown;
    function GetWordBoolProp(Index: Integer): WordBool;
    function GetTDateTimeProp(Index: Integer): TDateTime;
    function GetTFontProp(Index: Integer): TFont;
    function GetOleBoolProp(Index: Integer): TOleBool;
    function GetOleDateProp(Index: Integer): TOleDate;
    function GetOleEnumProp(Index: Integer): TOleEnum;
    function GetTOleEnumProp(Index: Integer): TOleEnum;
    function GetOleVariantProp(Index: Integer): OleVariant;
    function GetTPictureProp(Index: Integer): TPicture;
    procedure GetProperty(Index: Integer; var Value: TVarData);
    function GetShortIntProp(Index: Integer): ShortInt;
    function GetSingleProp(Index: Integer): Single;
    function GetSmallintProp(Index: Integer): Smallint;
    function GetStringProp(Index: Integer): string;
    function GetVariantProp(Index: Integer): Variant;
    function GetWideStringProp(Index: Integer): WideString;
    function GetWordProp(Index: Integer): Word;
    procedure InitControlData; virtual; abstract;
    procedure InitControlInterface(const Obj: IUnknown); virtual;
    procedure InvokeMethod(const DispInfo; Result: Pointer);
    function PaletteChanged(Foreground: Boolean): Boolean; override;
    procedure PictureChanged(Sender: TObject);
    procedure SetByteProp(Index: Integer; Value: Byte);
    procedure SetColorProp(Index: Integer; Value: TColor);
    procedure SetTColorProp(Index: Integer; Value: TColor);
    procedure SetCompProp(Index: Integer; const Value: Comp);
    procedure SetCurrencyProp(Index: Integer; const Value: Currency);
    procedure SetDoubleProp(Index: Integer; const Value: Double);
    procedure SetIDispatchProp(Index: Integer; const Value: IDispatch);
    procedure SetIntegerProp(Index: Integer; Value: Integer);
    procedure SetIUnknownProp(Index: Integer; const Value: IUnknown);
    procedure SetName(const Value: TComponentName); override;
    procedure SetWordBoolProp(Index: Integer; Value: WordBool);
    procedure SetTDateTimeProp(Index: Integer; const Value: TDateTime);
    procedure SetTFontProp(Index: Integer; Value: TFont);
    procedure SetOleBoolProp(Index: Integer; Value: TOleBool);
    procedure SetOleDateProp(Index: Integer; const Value: TOleDate);
    procedure SetOleEnumProp(Index: Integer; Value: TOleEnum);
    procedure SetTOleEnumProp(Index: Integer; Value: TOleEnum);
    procedure SetOleVariantProp(Index: Integer; const Value: OleVariant);
    procedure SetParent(AParent: TWinControl); override;
    procedure SetTPictureProp(Index: Integer;  Value: TPicture);
    procedure SetProperty(Index: Integer; const Value: TVarData);
    procedure SetShortIntProp(Index: Integer; Value: Shortint);
    procedure SetSingleProp(Index: Integer; const Value: Single);
    procedure SetSmallintProp(Index: Integer; Value: Smallint);
    procedure SetStringProp(Index: Integer; const Value: string);
    procedure SetVariantProp(Index: Integer; const Value: Variant);
    procedure SetWideStringProp(Index: Integer; const Value: WideString);
    procedure SetWordProp(Index: Integer; Value: Word);
    procedure _SetColorProp(Index: Integer; Value: TColor);
    procedure _SetTColorProp(Index: Integer; Value: TColor);
    procedure _SetTOleEnumProp(Index: Integer; Value: TOleEnum);
    procedure _SetTFontProp(Index: Integer; Value: TFont);
    procedure _SetTPictureProp(Index: Integer; Value: TPicture);
    procedure WndProc(var Message: TMessage); override;
    function SuppressException(E : Exception): Boolean; virtual;
    property ControlData: PControlData read FControlData write FControlData;
    { IPropertyNotifySink }
    function OnChanged(dispid: TDispID): HResult; virtual; stdcall;
    function OnRequestEdit(dispid: TDispID): HResult; virtual; stdcall;
    procedure PaintBackground;
    procedure Paint; override;
    procedure Loaded; override;
  public
    FOleInPlaceObjectWindowless: IOleInPlaceObjectWindowless;
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure BrowseProperties;
    procedure DefaultHandler(var Message); override;
    procedure DoObjectVerb(Verb: Integer);
    function GetEnumPropDesc(DispID: Integer): TEnumPropDesc;
    function GetHelpContext(Member: string; var HelpCtx: Integer;
      var HelpFile: string): Boolean;
    procedure GetObjectVerbs(List: TStrings);
    function GetPropDisplayString(DispID: Integer): string;
    procedure GetPropDisplayStrings(DispID: Integer; List: TStrings);
    function IsCustomProperty(DispID: Integer): Boolean;
    function IsPropPageProperty(DispID: Integer): Boolean;
    procedure SetBounds(ALeft, ATop, AWidth, AHeight: Integer); override;
    procedure SetPropDisplayString(DispID: Integer; const Value: string);
    procedure ShowAboutBox;

    function GrabCurrentFrame: TBitmap;
    function GrabCurrentFrame2: TsfBitmap;
    procedure GrabFrame(ACanvas: TCanvas);

    property OleObject: Variant read GetOleObject;
    property PerPropBrowsing: IPerPropertyBrowsing read FPropBrowsing;
    property DefaultDispatch: IDispatch read GetDefaultDispatch;
    property Anchors;
    property GrabProcess: boolean read FGrabProcess write FGrabProcess;
  published
    property Color;
    property ParentColor;
    property Transparent: boolean read FTransparent write SetTransparent default true;
    property DisableFlashPopup: boolean read FDisableFlashPopup write SetDisableFlashPopup default false;
    property DisableFlashCursor: boolean read FDisableFlashCursor write FDisableFlashCursor default false;
    property OnPaint: TNotifyEvent read FOnPaint write FOnPaint;
    property OnClick;
  end;

  TsfFlashCollection = class;
  TsfFlashList = class;

{ TsfFlashStream }

  TsfFlashStream = class(TCollectionItem)
  private
    FFlash: TMemoryStream;
    FTag: integer;
    FOnChanged: TNotifyEvent;
    function GetFlashStore: string;
    procedure SetFlashStore(const Value: string);
  protected
    function GetDisplayName: string; override;
    procedure ReadData(Stream: TStream);
    procedure WriteData(Stream: TStream);
    procedure DefineProperties(Filer: TFiler); override;
  public
    FFlashStore: string;
    constructor Create(Collection: TCollection); override;
    procedure Assign(Source: TPersistent); override;
    destructor Destroy; override;
    property Flash: TMemoryStream read FFlash;
  published
    property FlashStore: string read GetFlashStore write SetFlashStore;
    property Tag: integer read FTag write FTag;
  end;

{ TsfFlashCollection }

  TsfFlashCollection = class(TCollection)
  private
    FFlashList: TsfFlashList;
    function GetItem(Index: Integer): TsfFlashStream;
    procedure SetItem(Index: Integer; Value: TsfFlashStream);
  protected
    function GetOwner: TPersistent; override;
  public
    constructor Create(AOwner: TsfFlashList);
    function Add: TsfFlashStream;
    property Items[Index: Integer]: TsfFlashStream read GetItem write SetItem; default;
    destructor Destroy; override;
  published
  end;

{ TsfFlashList class }

  TsfFlashList = class(TComponent)
  private
    FFlashs: TsfFlashCollection;
  protected
    procedure Loaded; override;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
  published
    property Flashs: TsfFlashCollection read FFlashs write FFlashs;
  end;


implementation

uses OleConst;

const
  OCM_BASE = $2000;

{ Control flags }

const
  cfBackColor = $00000001;
  cfForeColor = $00000002;
  cfFont      = $00000004;
  cfEnabled   = $00000008;
  cfCaption   = $00000010;
  cfText      = $00000020;

const
  MaxDispArgs = 32;

type

  PDispInfo = ^TDispInfo;
  TDispInfo = packed record
    DispID: TDispID;
    ResType: Byte;
    CallDesc: TCallDesc;
  end;

  TArgKind = (akDWord, akSingle, akDouble);

  PEventArg = ^TEventArg;
  TEventArg = record
    Kind: TArgKind;
    Data: array[0..1] of Integer;
  end;

  TEventInfo = record
    Method: TMethod;
    Sender: TObject;
    ArgCount: Integer;
    Args: array[0..MaxDispArgs - 1] of TEventArg;
  end;