sf_flash.pas

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

                if FuncDesc^.lprgelemdescParam[FuncDesc.cParams - 1].tdesc.vt = VT_PTR then
                  CreateEnum(FuncDesc^.lprgelemdescParam[FuncDesc.cParams - 1].tdesc.ptdesc^,
                    TypeInfo, FuncDesc^.memid);
            end;
        finally
          TypeInfo.ReleaseFuncDesc(FuncDesc);
        end;
      end;
    finally
      TypeInfo.ReleaseTypeAttr(TypeAttr);
    end;
  end;

var
  TypeInfo: ITypeInfo;
begin
  CreateControl;
  FControlData^.EnumPropDescs := TList.Create;
  try
    OleCheck(FControlDispatch.GetTypeInfo(0, 0, TypeInfo));
    ProcessTypeInfo(TypeInfo);
  except
    DestroyEnumPropDescs;
    raise;
  end;
end;

procedure TsfOleControl.CreateInstance;
var
  ClassFactory2: IClassFactory2;
  LicKeyStr: WideString;

  procedure LicenseCheck(Status: HResult; const Ident: string);
  begin
    if Status = CLASS_E_NOTLICENSED then
      raise EOleError.CreateFmt(Ident, [ClassName]);
    OleCheck(Status);
  end;

begin
  try
    if not (csDesigning in ComponentState) and
      (FControlData^.LicenseKey <> nil) then
    begin
      OleCheck(CoGetClassObject(FControlData^.ClassID, CLSCTX_INPROC_SERVER or
        CLSCTX_LOCAL_SERVER, nil, IClassFactory2, ClassFactory2));
      LicKeyStr := PWideChar(FControlData^.LicenseKey);
      LicenseCheck(ClassFactory2.CreateInstanceLic(nil, nil, IOleObject_Flash,
        LicKeyStr, FOleObject), SInvalidLicense);
    end
    else
      LicenseCheck(CoCreateInstance(FControlData^.ClassID, nil,
        CLSCTX_INPROC_SERVER or CLSCTX_LOCAL_SERVER, IOleObject_Flash,
        FOleObject), SNotLicensed);
  except
    FFlashNotExists := true;
  end;
end;

procedure TsfOleControl.CreateStorage;
var
  Stream: IStream;
begin
  DestroyStorage;
  FObjectData := GlobalAlloc(GMEM_MOVEABLE, 0);
  if FObjectData = 0 then OutOfMemoryError;
  try
    OleCheck(CreateStreamOnHGlobal(FObjectData, False, Stream));
    OleCheck(FPersistStream.Save(Stream, True));
  except
     DestroyStorage;
     raise;
  end;

end;

procedure TsfOleControl.CreateWnd;
var
  Result: LResult;
  H: HWnd;
begin
  if FFlashNotExists then Exit;
  
  CreateControl;
  if FMiscStatus and OLEMISC_INVISIBLEATRUNTIME = 0 then
  begin
    FOleObject.DoVerb(OLEIVERB_INPLACEACTIVATE, nil, Self, 0,
      0, BoundsRect);
    if FOleInPlaceObject = nil then
      raise EOleError.CreateRes(@SCannotActivate);

    if FOleInPlaceObjectWindowless <> nil then
      FOleInPlaceObjectWindowless.OnWindowMessage(WM_SETFOCUS, 0, 0, Result);
    HookControlWndProc;
  end;
end;

procedure TsfOleControl.DefaultHandler(var Message);
begin
  try
{    if HandleAllocated then
      with TMessage(Message) do
      begin
        if (Msg >= CN_BASE) and (Msg < CN_BASE + WM_USER) then
          Msg := Msg - (CN_BASE - OCM_BASE);
        if FMiscStatus and OLEMISC_SIMPLEFRAME = 0 then
        begin
          Result := CallWindowProc(DefWndProc, Handle, Msg, WParam, LParam);
          Exit;
        end;
      end;}
    inherited DefaultHandler(Message);
  except
  end;
end;

function TsfOleControl.SuppressException(E : Exception): boolean;
{ Unhandled control generated exceptions created when Delphi is streaming a
  form can cause errant behavior of the IDE.  SuppressException is meant to
  allow misbehaving hosted ActiveX Controls to fail in some fashion and still not
  have the Delphi IDE fail along with them.
  If you need to see all control generated exceptions, override this function
  in your TOLEControl descendent and return FALSE.
}
begin
  if (E is EOleSysError) then
    Result := (csDesigning in ComponentState)
      else Result := False;
end;

procedure TsfOleControl.DefineProperties(Filer: TFiler);
begin
  try
    inherited DefineProperties(Filer);
    Filer.DefineBinaryProperty('ControlData', ReadData, WriteData, FOleObject <> nil);
  except
    on E: Exception do
      if not SuppressException(E) then
        raise;
  end;
end;

procedure TsfOleControl.DesignModified;
var
  Form: TCustomForm;
begin
  Form := GetParentForm(Self);
  if (Form <> nil) and (Form.Designer <> nil) then Form.Designer.Modified;
end;

procedure TsfOleControl.DestroyControl;
begin
  DestroyWindowHandle;
  InterfaceDisconnect(FOleObject, FControlData^.EventIID, FEventsConnection);
  InterfaceDisconnect(FOleObject, IPropertyNotifySink, FPropConnection);
  FPropBrowsing := nil;
  FControlDispatch := nil;
  FOleControl := nil;
end;

procedure TsfOleControl.DestroyEnumPropDescs;
var
  I: Integer;
begin
  with FControlData^ do
    if EnumPropDescs <> nil then
    begin
      for I := 0 to EnumPropDescs.Count - 1 do
        TEnumPropDesc(EnumPropDescs[I]).Free;
      EnumPropDescs.Free;
      EnumPropDescs := nil;
    end;
end;

procedure TsfOleControl.DestroyStorage;
begin
  if FObjectData <> 0 then
  begin
    GlobalFree(FObjectData);
    FObjectData := 0;
  end;
end;

procedure TsfOleControl.DestroyWindowHandle;
begin
  if FMiscStatus and OLEMISC_INVISIBLEATRUNTIME = 0 then
  begin
//    SetWindowLong(WindowHandle, GWL_WNDPROC, Longint(DefWndProc));
    if FOleObject <> nil then FOleObject.Close(OLECLOSE_NOSAVE);
//    WindowHandle := 0;
  end
  else
//    inherited DestroyWindowHandle;
end;

procedure TsfOleControl.DoObjectVerb(Verb: Integer);
var
  ActiveWindow: HWnd;
  WindowList: Pointer;
begin
  CreateControl;
  ActiveWindow := GetActiveWindow;
  WindowList := DisableTaskWindows(0);
  try
{    OleCheck(FOleObject.DoVerb(Verb, nil, Self, 0,
      GetParentHandle, BoundsRect));}
  finally
    EnableTaskWindows(WindowList);
    SetActiveWindow(ActiveWindow);
    Windows.SetFocus(ActiveWindow);
  end;
  if FPersistStream.IsDirty <> S_FALSE then DesignModified;
end;

function TsfOleControl.GetByteProp(Index: Integer): Byte;
begin
  Result := GetIntegerProp(Index);
end;

function TsfOleControl.GetColorProp(Index: Integer): TColor;
begin
  Result := GetIntegerProp(Index);
end;

function TsfOleControl.GetTColorProp(Index: Integer): TColor;
begin
  Result := GetIntegerProp(Index);
end;

function TsfOleControl.GetCompProp(Index: Integer): Comp;
begin
  Result := GetDoubleProp(Index);
end;

function TsfOleControl.GetCurrencyProp(Index: Integer): Currency;
var
  Temp: TVarData;
begin
  GetProperty(Index, Temp);
  Result := Temp.VCurrency;
end;

function TsfOleControl.GetDoubleProp(Index: Integer): Double;
var
  Temp: TVarData;
begin
  GetProperty(Index, Temp);
  Result := Temp.VDouble;
end;

function TsfOleControl.GetEnumPropDesc(DispID: Integer): TEnumPropDesc;
var
  I: Integer;
begin
  with FControlData^ do
  begin
    if EnumPropDescs = nil then CreateEnumPropDescs;
    for I := 0 to EnumPropDescs.Count - 1 do
    begin
      Result := EnumPropDescs[I];
      if Result.FDispID = DispID then Exit;
    end;
    Result := nil;
  end;
end;

procedure TsfOleControl.GetEventMethod(DispID: TDispID; var Method: TMethod);
asm
        PUSH    EBX
        PUSH    ESI
        PUSH    EDI
        PUSH    ECX
        MOV     EBX,EAX
        MOV     ECX,[EBX].TsfOleControl.FControlData
        MOV     EDI,[ECX].TControlData.EventCount
        MOV     ESI,[ECX].TControlData.EventDispIDs
        XOR     EAX,EAX
        JMP     @@1
@@0:    CMP     EDX,[ESI].Integer[EAX*4]
        JE      @@2
        INC     EAX
@@1:    CMP     EAX,EDI
        JNE     @@0
        XOR     EAX,EAX
        XOR     EDX,EDX
        JMP     @@3
@@2:    PUSH    EAX
        CMP     [ECX].TControlData.Version, 401
        JB      @@2a
        MOV     EAX, [ECX].TControlData2.FirstEventOfs
        TEST    EAX, EAX
        JNE     @@2b
@@2a:   MOV     EAX, [EBX]
        CALL    TObject.ClassParent
        CALL    TObject.InstanceSize
        ADD     EAX, 7
        AND     EAX, not 7  // 8 byte alignment
@@2b:   ADD     EBX, EAX
        POP     EAX
        MOV     EDX,[EBX][EAX*8].TMethod.Data
        MOV     EAX,[EBX][EAX*8].TMethod.Code
@@3:    POP     ECX
        MOV     [ECX].TMethod.Code,EAX
        MOV     [ECX].TMethod.Data,EDX
        POP     EDI
        POP     ESI
        POP     EBX
end;

procedure Exchange(var A,B); register;
asm
  MOV   ECX, [EDX]
  XCHG  ECX, [EAX]
  MOV   [EDX], ECX
end;

{ TsfOleControl.GetHelpContext:  Fetch the help file name and help context
  id of the given member (property, event, or method) of the Ole Control from
  the control's ITypeInfo interfaces.  GetHelpContext returns False if
  the member name is not found in the control's ITypeInfo.
  To obtain a help context for the entire control class, pass an empty
  string as the Member name.  }

function TsfOleControl.GetHelpContext(Member: string;
  var HelpCtx: Integer; var HelpFile: string): Boolean;
var
  TypeInfo: ITypeInfo;
  HlpFile: TBStr;
  ImplTypes, MemberID: Integer;
  TypeAttr: PTypeAttr;

  function Find(const MemberStr: string; var TypeInfo: ITypeInfo): Boolean;
  var
    Code: HResult;
    I, Flags: Integer;
    RefType: HRefType;
    Name: TBStr;
    Temp: ITypeInfo;
  begin
    Result := False;
    Name := StringToOleStr(Member);
    try
      I := 0;
      while (I < ImplTypes) do
      begin
        OleCheck(TypeInfo.GetImplTypeFlags(I, Flags));
        if Flags and (IMPLTYPEFLAG_FDEFAULT or IMPLTYPEFLAG_FSOURCE) <> 0 then
        begin
          OleCheck(TypeInfo.GetRefTypeOfImplType(I, RefType));
          OleCheck(TypeInfo.GetRefTypeInfo(RefType, Temp));
          Code := Temp.GetIDsOfNames(@Name, 1, @MemberID);
          if Code <> DISP_E_UNKNOWNNAME then
          begin
            OleCheck(Code);
            Exchange(TypeInfo, Temp);
            Result := True;
            Break;
          end;
        end;
        Inc(I);
      end;
    finally
      SysFreeString(Name);
    end;
  end;

begin
  HelpCtx := 0;
  HelpFile := '';
  CreateControl;
  OleCheck((FOleObject as IProvideClassInfo).GetClassInfo(TypeInfo));
  MemberID := MEMBERID_NIL;
  if Length(Member) > 0 then
  begin
    OleCheck(TypeInfo.GetTypeAttr(TypeAttr));
    ImplTypes := TypeAttr.cImplTypes;
    TypeInfo.ReleaseTypeAttr(TypeAttr);
    Result := Find(Member, TypeInfo);
    if (not Result) and (Member[Length(Member)] = '_') then
    begin
      Delete(Member, Length(Member)-1, 1);
      Result := Find(Member, TypeInfo);
    end;
    if (not Result) and (Pos('On', Member) = 1) then
    begin
      Delete(Member, 1, 2);
      Result := Find(Member, TypeInfo);
    end;