From 864081102a5f252415f41950b3039a896b4ae9c5 Mon Sep 17 00:00:00 2001 From: Vadim Dashevskiy Date: Mon, 8 Oct 2012 18:43:29 +0000 Subject: Awkwars's plugins - welcome to our trunk git-svn-id: http://svn.miranda-ng.org/main/trunk@1822 1316c22d-e87f-b044-9b9b-93d7a3e3ba9c --- plugins/Libs/ActiveKOL.pas | 2649 ++ plugins/Libs/BASS_DSHOW.pas | 275 + plugins/Libs/Dynamic_Bass.pas | 1298 + plugins/Libs/FastMM4.pas | 11698 +++++++ plugins/Libs/FastMM4Messages.pas | 135 + plugins/Libs/FastMM4Options.inc | 426 + plugins/Libs/KOLCCtrls.pas | 1780 + plugins/Libs/KOLDEF.inc | 308 + plugins/Libs/KOL_ASM.inc | 15855 +++++++++ plugins/Libs/KOL_ASM_NOUNICODE.inc | 4351 +++ plugins/Libs/KOL_ansi.inc | 2316 ++ plugins/Libs/KOL_unicode.inc | 1277 + plugins/Libs/KolZLibBzip.pas | 1940 ++ plugins/Libs/MCKfakeClasses.inc | 79 + plugins/Libs/MCKfakeClasses200x.inc | 51 + plugins/Libs/MsgDecode.pas | 4957 +++ plugins/Libs/PsAPI.pas | 399 + plugins/Libs/bz2/BLOCKS~1.OBJ | Bin 0 -> 11771 bytes plugins/Libs/bz2/BZLIB.OBJ | Bin 0 -> 11596 bytes plugins/Libs/bz2/COMPRESS.OBJ | Bin 0 -> 14175 bytes plugins/Libs/bz2/DECOMP~1.OBJ | Bin 0 -> 15653 bytes plugins/Libs/bz2/HUFFMAN.OBJ | Bin 0 -> 6463 bytes plugins/Libs/delphicommctrl.inc | 1594 + plugins/Libs/dynbasswma.pas | 249 + plugins/Libs/err.pas | 1199 + plugins/Libs/kol.pas | 61873 ++++++++++++++++++++++++++++++++++ plugins/Libs/kolcomobj.pas | 2352 ++ plugins/Libs/kolmath.pas | 1845 + plugins/Libs/make.bat | 14 + plugins/Libs/visual_xp_styles.inc | 1448 + plugins/Libs/zlib/Infblock.obj | Bin 0 -> 5570 bytes plugins/Libs/zlib/Infcodes.obj | Bin 0 -> 3817 bytes plugins/Libs/zlib/Infutil.obj | Bin 0 -> 1554 bytes plugins/Libs/zlib/adler32.obj | Bin 0 -> 529 bytes plugins/Libs/zlib/compress.obj | Bin 0 -> 559 bytes plugins/Libs/zlib/crc32.obj | Bin 0 -> 11189 bytes plugins/Libs/zlib/deflate.obj | Bin 0 -> 8175 bytes plugins/Libs/zlib/infback.obj | Bin 0 -> 7736 bytes plugins/Libs/zlib/inffast.obj | Bin 0 -> 2394 bytes plugins/Libs/zlib/inflate.obj | Bin 0 -> 10775 bytes plugins/Libs/zlib/inftrees.obj | Bin 0 -> 2408 bytes plugins/Libs/zlib/trees.obj | Bin 0 -> 11757 bytes plugins/Libs/zlib/uncompr.obj | Bin 0 -> 496 bytes 43 files changed, 120368 insertions(+) create mode 100644 plugins/Libs/ActiveKOL.pas create mode 100644 plugins/Libs/BASS_DSHOW.pas create mode 100644 plugins/Libs/Dynamic_Bass.pas create mode 100644 plugins/Libs/FastMM4.pas create mode 100644 plugins/Libs/FastMM4Messages.pas create mode 100644 plugins/Libs/FastMM4Options.inc create mode 100644 plugins/Libs/KOLCCtrls.pas create mode 100644 plugins/Libs/KOLDEF.inc create mode 100644 plugins/Libs/KOL_ASM.inc create mode 100644 plugins/Libs/KOL_ASM_NOUNICODE.inc create mode 100644 plugins/Libs/KOL_ansi.inc create mode 100644 plugins/Libs/KOL_unicode.inc create mode 100644 plugins/Libs/KolZLibBzip.pas create mode 100644 plugins/Libs/MCKfakeClasses.inc create mode 100644 plugins/Libs/MCKfakeClasses200x.inc create mode 100644 plugins/Libs/MsgDecode.pas create mode 100644 plugins/Libs/PsAPI.pas create mode 100644 plugins/Libs/bz2/BLOCKS~1.OBJ create mode 100644 plugins/Libs/bz2/BZLIB.OBJ create mode 100644 plugins/Libs/bz2/COMPRESS.OBJ create mode 100644 plugins/Libs/bz2/DECOMP~1.OBJ create mode 100644 plugins/Libs/bz2/HUFFMAN.OBJ create mode 100644 plugins/Libs/delphicommctrl.inc create mode 100644 plugins/Libs/dynbasswma.pas create mode 100644 plugins/Libs/err.pas create mode 100644 plugins/Libs/kol.pas create mode 100644 plugins/Libs/kolcomobj.pas create mode 100644 plugins/Libs/kolmath.pas create mode 100644 plugins/Libs/make.bat create mode 100644 plugins/Libs/visual_xp_styles.inc create mode 100644 plugins/Libs/zlib/Infblock.obj create mode 100644 plugins/Libs/zlib/Infcodes.obj create mode 100644 plugins/Libs/zlib/Infutil.obj create mode 100644 plugins/Libs/zlib/adler32.obj create mode 100644 plugins/Libs/zlib/compress.obj create mode 100644 plugins/Libs/zlib/crc32.obj create mode 100644 plugins/Libs/zlib/deflate.obj create mode 100644 plugins/Libs/zlib/infback.obj create mode 100644 plugins/Libs/zlib/inffast.obj create mode 100644 plugins/Libs/zlib/inflate.obj create mode 100644 plugins/Libs/zlib/inftrees.obj create mode 100644 plugins/Libs/zlib/trees.obj create mode 100644 plugins/Libs/zlib/uncompr.obj (limited to 'plugins/Libs') diff --git a/plugins/Libs/ActiveKOL.pas b/plugins/Libs/ActiveKOL.pas new file mode 100644 index 0000000000..6f62f0c50d --- /dev/null +++ b/plugins/Libs/ActiveKOL.pas @@ -0,0 +1,2649 @@ +{This version is compatible with KOL 3.00+ -- VK} + +unit ActiveKOL; + +interface + +uses + windows, messages, KOL, ActiveX, KOLComObj, err; + +{$I KOLDEF.INC} +{$IFDEF _D6orHigher} + //{$WARN SYMBOL_DEPRECATED OFF} + {$WARN SYMBOL_PLATFORM OFF} + {$IFDEF _D7orHigher} + {$WARN UNSAFE_TYPE OFF} + {$WARN UNSAFE_CAST OFF} + {$WARN UNSAFE_CODE OFF} + {$ENDIF} +{$ENDIF} + +{$IFNDEF _D5orHigher} +const + sNoRunningObject = 'Unable to retrieve a pointer to a running object registered with OLE for %s/%s'; +{$ENDIF} + +type + POleCtl = ^TOleCtl; + + TEventDispatch = class(TObject, IUnknown, IDispatch) + private + FControl: POleCtl; + protected + { IUnknown } + function QueryInterface(const IID: TGUID; out Obj): HResult; stdcall; + function _AddRef: Integer; stdcall; + function _Release: Integer; 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; + property Control: POleCtl read FControl; + public + constructor Create(Control: POleCtl); + end; + + {$IFNDEF _D5orHigher} + TOleEnum = type Integer; + //{$NODEFINE TOleEnum} + {$ENDIF} + + TGetStrProc = procedure(const S: string) of object; + + TEnumValue = record + Value: Longint; + Ident: string; + end; + + PEnumValueList = ^TEnumValueList; + TEnumValueList = array[0..32767] of TEnumValue; + + PEnumPropDesc = ^TEnumPropDesc; + TEnumPropDesc = object(TObj) + private + FDispID: Integer; + FValueCount: Integer; + FValues: PEnumValueList; + public + constructor Create(DispID, ValueCount: Integer; + const TypeInfo: ITypeInfo); + destructor Destroy; virtual; + procedure GetStrings(Proc: TGetStrProc); + function StringToValue(const S: string): Integer; + function ValueToString(V: Integer): string; + end; + + PControlData = ^TControlData; + TControlData = record + ClassID: TGUID; + EventIID: TGUID; + EventCount: Longint; + EventDispIDs: Pointer; + LicenseKey: Pointer; + Flags: DWORD; + Version: Integer; + FontCount: Integer; + FontIDs: PDispIDList; + PictureCount: Integer; + PictureIDs: PDispIDList; + Reserved: Integer; + InstanceCount: Integer; + EnumPropDescs: PList; + end; + + PControlData2 = ^TControlData2; + TControlData2 = record + ClassID: TGUID; + EventIID: TGUID; + EventCount: Longint; + EventDispIDs: Pointer; + LicenseKey: Pointer; + Flags: DWORD; + Version: Integer; + FontCount: Integer; + FontIDs: PDispIDList; + PictureCount: Integer; + PictureIDs: PDispIDList; + Reserved: Integer; + InstanceCount: Integer; + EnumPropDescs: PList; + FirstEventOfs: Cardinal; + end; + + TOleCtlIntfClass = class of TOleCtlIntf; + TOleCtlIntf = class( TObject, IUnknown, IOleClientSite, + IOleControlSite, IOleInPlaceSite, IOleInPlaceFrame, IDispatch, + IPropertyNotifySink, ISimpleFrameSite) + private + FRefCount: Integer; + fOleCtl: POleCtl; + procedure GetEventMethod(DispID: TDispID; var Method: TMethod); + protected + { IUnknown } + function QueryInterface(const IID: TGUID; out Obj): HResult; stdcall; //override; + function _AddRef: Integer; stdcall; + function _Release: Integer; stdcall; + { IOleClientSite } + function SaveObject: HResult; stdcall; + function GetMoniker(dwAssign: Longint; dwWhichMoniker: Longint; + out mk: IMoniker): HResult; stdcall; + function GetContainer(out container: IOleContainer): 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 ContextSensitiveHelp(fEnterMode: BOOL): HResult; stdcall; + { IOleInPlaceSite } + function IOleInPlaceSite.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; + { 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: Windows.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; + { IPropertyNotifySink } + function OnChanged(dispid: TDispID): HResult; virtual; stdcall; + function OnRequestEdit(dispid: TDispID): HResult; virtual; stdcall; + public + property OleCtl: POleCtl read fOleCtl; + constructor Create; virtual; + end; + + + TOnGetIntfClass = function(): TOleCtlIntfClass of object; + + + TOleCtl = object( TControl ) + private + FOnGetIntfClass: TOnGetIntfClass; + function GetOleObject: Variant; + procedure CreateInstance; + function GetOnLeave: TOnEvent; + procedure SetOnLeave(const Value: TOnEvent); + procedure HookControlWndProc; + procedure SetUIActive(Active: Boolean); + procedure CreateControl; + procedure DestroyStorage; + procedure DestroyControl; + procedure StandardEvent(DispID: TDispID; var Params: TDispParams); + //procedure SetMouseDblClk(const Value: TOnMouse); + procedure SetOnChar(const Value: TOnChar); + protected + //{$IFDEF DELPHI_CODECOMPLETION_BUG} + fNotAvailable: Boolean; + //{$ENDIF} + {$IFNDEF USE_NAMES} + fName: String; + {$ENDIF} + FControlData: PControlData; + FOleObject: IOleObject; + FMiscStatus: Longint; + FFonts: PList; + FPictures: PList; + FEventDispatch: TEventDispatch; + fOleCtlIntf: TOleCtlIntf; + FPersistStream: IPersistStreamInit; + FOleInPlaceObject: IOleInPlaceObject; + FOleInPlaceActiveObject: IOleInPlaceActiveObject; + FOleControl: IOleControl; + FUpdatingColor: Boolean; + FUpdatingFont: Boolean; + FUpdatingEnabled: Boolean; + FObjectData: HGlobal; + FControlDispatch: IDispatch; + FPropBrowsing: IPerPropertyBrowsing; + FPropConnection: Longint; + FEventsConnection: Longint; + fCreatingWnd: Boolean; + procedure Init; virtual; + procedure InitControlData; virtual; + procedure InitControlInterface(const Obj: IUnknown); virtual; + property ControlData: PControlData read FControlData write FControlData; + function GetMainMenu: HMenu; + procedure InvokeEvent(DispID: TDispID; var Params: TDispParams); + procedure D2InvokeEvent(DispID: TDispID; var Params: TDispParams); + procedure DoHandleException; + procedure CreateEnumPropDescs; + procedure DestroyEnumPropDescs; + + property OnGetIntfClass: TOnGetIntfClass read FOnGetIntfClass write FOnGetIntfClass; + public + 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): PGraphicTool; + 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 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: String); virtual; + procedure SetWordBoolProp(Index: Integer; Value: WordBool); + procedure SetTDateTimeProp(Index: Integer; const Value: TDateTime); + procedure SetTFontProp(Index: Integer; Value:PGraphicTool); + 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: PControl); virtual; + //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); + + function GetEnumPropDesc(DispID: Integer): PEnumPropDesc; + + property DragCursor: Boolean read fNotAvailable; + property DragMode : Boolean read fNotAvailable; + property ParentShowHint: Boolean read fNotAvailable; + property PopupMenu: Boolean read fNotAvailable; + property ShowHint: Boolean read fNotAvailable; + property OnDragDrop: Boolean read fNotAvailable; + property OnDragOver: Boolean read fNotAvailable; + property OnEndDrag: Boolean read fNotAvailable; + property OnStartDrag: Boolean read fNotAvailable; + + property OnExit: TOnEvent read GetOnLeave write SetOnLeave; + property OleObject: Variant read GetOleObject; + + property Name: String read fName write fName; + function CreateWindow: Boolean; virtual; + procedure DblClk; + procedure KeyDown(var Key: Longint; AShift: DWORD); + procedure KeyUp(var Key: Longint; AShift: DWORD); + procedure KeyPress(var Key: KOLChar); + procedure MouseDown(Button: TMouseButton; AShift: DWORD; + X, Y: Integer); + procedure MouseMove(AShift: DWORD; X, Y: Integer); + procedure MouseUp(Button: TMouseButton; AShift: DWORD; + X, Y: Integer); + + property OnKeyPress: TOnChar + read {$IFDEF EVENTS_DYNAMIC} Get_OnChar {$ELSE} EV.fOnChar {$ENDIF} + write SetOnChar; + property OnDblClick: TOnMouse index idx_fOnMouseDblClk + read {$IFDEF EVENTS_DYNAMIC} Get_OnMouseEvent {$ELSE} EV.fOnMouseDblClk {$ENDIF} + write SetOnMouseEvent; // SetMouseDblClk; + + destructor Destroy; virtual; + + end; + +{$IFNDEF _D2orD3} +type + TVariantArray = Array of OleVariant; + TOleServer = class; + TConnectKind = (ckRunningOrNew, // Attach to a running or create a new instance of the server + ckNewInstance, // Create a new instance of the server + ckRunningInstance, // Attach to a running instance of the server + ckRemote, // Bind to a remote instance of the server + ckAttachToInterface); // Don't bind to server, user will provide interface via 'CpnnectTo' + + TServerEventDispatch = class(TObject, IUnknown, IDispatch) + private + FServer: TOleServer; + InternalRefCount : Integer; + protected + { IUnknown } + function QueryInterface(const IID: TGUID; out Obj): HResult; stdcall; + function _AddRef: Integer; stdcall; + function _Release: Integer; 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; + property Server: TOleServer read FServer; + function ServerDisconnect :Boolean; + public + constructor Create(Server: TOleServer); + end; + + PServerData = ^TServerData; + TServerData = record + ClassID: TGUID; // CLSID of CoClass + IntfIID: TGUID; // IID of default interface + EventIID: TGUID; // IID of default source interface + LicenseKey: Pointer; // Pointer to license string (not implemented) + Version: Integer; // Version of this structure + InstanceCount: Integer; // Instance of the Server running + end; + + TOleServer = class(TObject, IUnknown) + private + FServerData: PServerData; + FRefCount: Longint; + FEventDispatch: TServerEventDispatch; + FEventsConnection: Longint; + FAutoConnect: Boolean; + FRemoteMachineName: string; + FConnectKind: TConnectKind; + + protected + { IUnknown } + function QueryInterface(const IID: TGUID; out Obj): HResult; stdcall; //override; + function _AddRef: Integer; stdcall; + function _Release: Integer; stdcall; + + procedure Loaded; //override; + procedure InitServerData; virtual; abstract; + + function GetServer: IUnknown; virtual; + + procedure ConnectEvents(const Obj: IUnknown); + procedure DisconnectEvents(const Obj: Iunknown); + procedure InvokeEvent(DispID: TDispID; var Params: TVariantArray); virtual; + + function GetConnectKind: TConnectKind; + procedure SetConnectKind(ck: TConnectKind); + + function GetAutoConnect: Boolean; + procedure SetAutoConnect(flag: Boolean); + + property ServerData: PServerData read FServerData write FServerData; + property EventDispatch: TServerEventDispatch read FEventDispatch write FEventDispatch; + + public + constructor Create; //(AOwner: TComponent); override; + destructor Destroy; override; + + // NOTE: If derived class is generated by TLIBIMP or ImportTypeLibraryCodeGenerator, + // the derived class will also expose a 'ConnectTo(interface)' function. + // You must invoke that method if you're using 'ckAttachToInterface' connection + // kind. + procedure Connect; virtual; abstract; + procedure Disconnect; virtual; abstract; + + published + property AutoConnect: Boolean read GetAutoConnect write SetAutoConnect; + property ConnectKind: TConnectKind read GetConnectKind write SetConnectKind; + property RemoteMachineName: string read FRemoteMachineName write FRemoteMachineName; + end; +{$ENDIF} + +var + EmptyParam: OleVariant; { "Empty parameter" standard constant which can be + passed as an optional parameter on a dual interface. } + + +implementation + +uses + OleConst; + +const + // The following flags may be or'd into the TControlData.Reserved field to override + // default behaviors. + + // cdForceSetClientSite: + // Call SetClientSite early (in constructor) regardless of misc status flags + cdForceSetClientSite = 1; + + // cdDeferSetClientSite: + // Don't call SetClientSite early. Takes precedence over cdForceSetClientSite and misc status flags + cdDeferSetClientSite = 2; + +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; + +function StringToVarOleStr(const S: string): Variant; +begin + VarClear(Result); + TVarData(Result).VOleStr := StringToOleStr(S); + TVarData(Result).VType := varOleStr; +end; + +{ TEnumPropDesc } + +constructor TEnumPropDesc.Create(DispID, ValueCount: Integer; + const TypeInfo: ITypeInfo); +var + I: Integer; + VarDesc: PVarDesc; + XName: WideString; +begin + FDispID := DispID; + FValueCount := ValueCount; + FValues := AllocMem(ValueCount * SizeOf(TEnumValue)); + for I := 0 to ValueCount - 1 do + begin + OleCheck(TypeInfo.GetVarDesc(I, VarDesc)); + try + OleCheck(TypeInfo.GetDocumentation(VarDesc^.memid, @XName, + nil, nil, nil)); + with FValues^[I] do + begin + Value := TVarData(VarDesc^.lpVarValue^).VInteger; + Ident := XName; + while (Length(Ident) > 1) and (Ident[1] = '_') do + Delete(Ident, 1, 1); + end; + finally + TypeInfo.ReleaseVarDesc(VarDesc); + end; + end; +end; + +destructor TEnumPropDesc.Destroy; +begin + if FValues <> nil then + begin + Finalize(FValues^[0], FValueCount); + FreeMem(FValues, FValueCount * SizeOf(TEnumValue)); + end; + inherited; +end; + +procedure TEnumPropDesc.GetStrings(Proc: TGetStrProc); +var + I: Integer; +begin + for I := 0 to FValueCount - 1 do + with FValues^[I] do Proc(Format('%d - %s', [Value, Ident])); +end; + +function TEnumPropDesc.StringToValue(const S: string): Integer; +var + I: Integer; +begin + I := 1; + while (I <= Length(S)) and (S[I] in ['0'..'9', '-']) do Inc(I); + if I > 1 then + begin + Result := Str2Int(Copy(S, 1, I - 1)); + for I := 0 to FValueCount - 1 do + if Result = FValues^[I].Value then Exit; + end else + for I := 0 to FValueCount - 1 do + with FValues^[I] do + if AnsiCompareText(S, Ident) = 0 then + begin + Result := Value; + Exit; + end; + raise EOleError.CreateResFmt(e_Ole, Integer( @SBadPropValue ), [S]); +end; + +function TEnumPropDesc.ValueToString(V: Integer): string; +var + I: Integer; +begin + for I := 0 to FValueCount - 1 do + with FValues^[I] do + if V = Value then + begin + Result := Format('%d - %s', [Value, Ident]); + Exit; + end; + Result := Int2Str(V); +end; + +{ TOleCtl } + +procedure TOleCtl.CreateControl; +var + Stream: IStream; + CS: IOleClientSite; + X: Integer; +begin + if FOleControl = nil then + try + try // work around ATL bug + X := FOleObject.GetClientSite(CS); + except + X := -1; + end; + if (X <> 0) or (CS = nil) then + OleCheck(FOleObject.SetClientSite(fOleCtlIntf)); + if FObjectData = 0 then OleCheck(FPersistStream.InitNew) else + begin + OleCheck(CreateStreamOnHGlobal(FObjectData, False, Stream)); + OleCheck(FPersistStream.Load(Stream)); + DestroyStorage; + end; + OleCheck(FOleObject.QueryInterface(IOleControl, FOleControl)); + OleCheck(FOleObject.QueryInterface(IDispatch, FControlDispatch)); + FOleObject.QueryInterface(IPerPropertyBrowsing, FPropBrowsing); + InterfaceConnect(FOleObject, IPropertyNotifySink, + fOleCtlIntf, FPropConnection); + InterfaceConnect(FOleObject, FControlData^.EventIID, + FEventDispatch, FEventsConnection); + if FControlData^.Flags and cfBackColor <> 0 then + fOleCtlIntf.OnChanged(DISPID_BACKCOLOR); + if FControlData^.Flags and cfEnabled <> 0 then + fOleCtlIntf.OnChanged(DISPID_ENABLED); + if FControlData^.Flags and cfFont <> 0 then + fOleCtlIntf.OnChanged(DISPID_FONT); + if FControlData^.Flags and cfForeColor <> 0 then + fOleCtlIntf.OnChanged(DISPID_FORECOLOR); + FOleControl.OnAmbientPropertyChange(DISPID_UNKNOWN); + fOleCtlIntf.RequestNewObjectLayout; + except + DestroyControl; + raise; + end; +end; + +procedure TOleCtl.CreateEnumPropDescs; + + function FindMember(DispId: Integer): Boolean; + begin + Result := GetEnumPropDesc(DispId) <> nil; + end; + {var + I: Integer; + begin + for I := 0 to FControlData^.EnumPropDescs.Count - 1 do + if TEnumPropDesc(FControlData^.EnumPropDescs).FDispID = DispID then + begin + Result := True; + Exit; + end; + Result := False; + end;} + + procedure CreateEnum(TypeDesc: TTypeDesc; const TypeInfo: ITypeInfo; + DispId: Integer); + var + RefInfo: ITypeInfo; + RefAttr: PTypeAttr; + epd: PEnumPropDesc; + begin + if TypeDesc.vt <> VT_USERDEFINED then Exit; + OleCheck(TypeInfo.GetRefTypeInfo(TypeDesc.hreftype, RefInfo)); + OleCheck(RefInfo.GetTypeAttr(RefAttr)); + try + if RefAttr^.typekind = TKIND_ENUM then + begin + new( epd, Create(Dispid, RefAttr^.cVars, RefInfo) ); + FControlData^.EnumPropDescs.Add( epd ); + end; + finally + RefInfo.ReleaseTypeAttr(RefAttr); + end; + end; + + procedure ProcessTypeInfo(const TypeInfo: ITypeInfo); + var + I: Integer; + RefInfo: ITypeInfo; + TypeAttr: PTypeAttr; + VarDesc: PVarDesc; + FuncDesc: PFuncDesc; + RefType: HRefType; + begin + OleCheck(TypeInfo.GetTypeAttr(TypeAttr)); + try + if IsEqualGUID(TypeAttr^.guid, IDispatch) then Exit; + if ((TypeAttr.typekind = TKIND_INTERFACE) or + (TypeAttr.wTypeFlags and TYPEFLAG_FDUAL <> 0)) and + (TypeAttr.wTypeFlags and TYPEFLAG_FNONEXTENSIBLE <> 0) then + begin + OleCheck(TypeInfo.GetRefTypeOfImplType(0, RefType)); + OleCheck(TypeInfo.GetRefTypeInfo(RefType, RefInfo)); + ProcessTypeInfo(RefInfo); + end; + for I := 0 to TypeAttr^.cVars - 1 do + begin + OleCheck(TypeInfo.GetVarDesc(I, VarDesc)); + try + CreateEnum(VarDesc^.elemdescVar.tdesc, TypeInfo, VarDesc^.memid); + finally + TypeInfo.ReleaseVarDesc(VarDesc); + end; + end; + for I := 0 to TypeAttr^.cFuncs - 1 do + begin + OleCheck(TypeInfo.GetFuncDesc(I, FuncDesc)); + try + if not FindMember(FuncDesc^.memid) then + case FuncDesc^.invkind of + INVOKE_PROPERTYGET: + CreateEnum(FuncDesc^.elemdescFunc.tdesc, TypeInfo, FuncDesc^.memid); + INVOKE_PROPERTYPUT: + CreateEnum(FuncDesc^.lprgelemdescParam[FuncDesc.cParams - 1].tdesc, + TypeInfo, FuncDesc^.memid); + INVOKE_PROPERTYPUTREF: + 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 := NewList; + try + OleCheck(FControlDispatch.GetTypeInfo(0, 0, TypeInfo)); + ProcessTypeInfo(TypeInfo); + except + DestroyEnumPropDescs; + raise; + end; +end; + +procedure TOleCtl.CreateInstance; +var + ClassFactory2: IClassFactory2; + LicKeyStr: WideString; + + procedure LicenseCheck(Status: HResult; const Ident: string); + begin + if Status = CLASS_E_NOTLICENSED then + raise EOleError.CreateFmt(e_Ole, Ident, [SubClassName]); + OleCheck(Status); + end; + +begin + if (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, + LicKeyStr, FOleObject), SInvalidLicense); + end else + LicenseCheck(CoCreateInstance(FControlData^.ClassID, nil, + CLSCTX_INPROC_SERVER or CLSCTX_LOCAL_SERVER, IOleObject, + FOleObject), SNotLicensed); +end; + +procedure CallEventMethod(const EventInfo: TEventInfo); +asm + PUSH EBX + PUSH ESI + PUSH EBP + MOV EBP,ESP + MOV EBX,EAX + MOV EDX,[EBX].TEventInfo.ArgCount + TEST EDX,EDX + JE @@5 + XOR EAX,EAX + LEA ESI,[EBX].TEventInfo.Args +@@1: MOV AL,[ESI].TEventArg.Kind + CMP AL,1 + JA @@2 + JE @@3 + TEST AH,AH + JNE @@3 + MOV ECX,[ESI].Integer[4] + MOV AH,1 + JMP @@4 +@@2: PUSH [ESI].Integer[8] +@@3: PUSH [ESI].Integer[4] +@@4: ADD ESI,12 + DEC EDX + JNE @@1 +@@5: MOV EDX,[EBX].TEventInfo.Sender + MOV EAX,[EBX].TEventInfo.Method.Data + CALL [EBX].TEventInfo.Method.Code + MOV ESP,EBP + POP EBP + POP ESI + POP EBX +end; + +type + PVarArg = ^TVarArg; + TVarArg = array[0..3] of DWORD; + +function TOleCtl.CreateWindow: Boolean; +begin + Result := FALSE; + if fHandle <> 0 then + begin + Result := TRUE; + Exit; + end; + if fCreatingWnd then + Exit; + fCreatingWnd := TRUE; + try + CreateControl; + if FMiscStatus and OLEMISC_INVISIBLEATRUNTIME = 0 then + begin + FOleObject.DoVerb(OLEIVERB_INPLACEACTIVATE, nil, fOleCtlIntf, 0, + ParentWindow, BoundsRect); + if FOleInPlaceObject = nil then + raise EOleError.CreateResFmt(e_Ole, Integer( @SCannotActivate ), [nil]); + HookControlWndProc; + if {$IFDEF USE_FLAGS} not(F3_Visible in fStyle.f3_Style) + {$ELSE} not fVisible {$ENDIF} + and IsWindowVisible(fHandle) then + ShowWindow(fHandle, SW_HIDE); + Result := TRUE; + end + else + Result := inherited CreateWindow; + finally + fCreatingWnd := FALSE; + end; +end; + +procedure TOleCtl.D2InvokeEvent(DispID: TDispID; var Params: TDispParams); +type + TStringDesc = record + PStr: Pointer; + BStr: PBStr; + end; +var + I, J, K, ArgType, ArgCount, StrCount: Integer; + ArgPtr: PEventArg; + ParamPtr: PVarArg; + Strings: array[0..MaxDispArgs - 1] of TStringDesc; + EventInfo: TEventInfo; +begin + fOleCtlIntf.GetEventMethod(DispID, EventInfo.Method); + if Integer(EventInfo.Method.Code) >= $10000 then + begin + StrCount := 0; + try + ArgCount := Params.cArgs; + EventInfo.Sender := fOleCtlIntf; + EventInfo.ArgCount := ArgCount; + if ArgCount <> 0 then + begin + ParamPtr := @Params.rgvarg^[EventInfo.ArgCount]; + ArgPtr := @EventInfo.Args; + I := 0; + repeat + Dec(Integer(ParamPtr), SizeOf(TVarArg)); + ArgType := ParamPtr^[0] and $0000FFFF; + if ArgType and varTypeMask = varOleStr then + begin + ArgPtr^.Kind := akDWord; + with Strings[StrCount] do + begin + PStr := nil; + if ArgType and varByRef <> 0 then + begin + OleStrToStrVar(PBStr(ParamPtr^[2])^, string(PStr)); + BStr := PBStr(ParamPtr^[2]); + ArgPtr^.Data[0] := Integer(@PStr); + end else + begin + OleStrToStrVar(TBStr(ParamPtr^[2]), string(PStr)); + BStr := nil; + ArgPtr^.Data[0] := Integer(PStr); + end; + end; + Inc(StrCount); + end else + begin + case ArgType of + varSingle: + begin + ArgPtr^.Kind := akSingle; + ArgPtr^.Data[0] := ParamPtr^[2]; + end; + varDouble..varDate: + begin + ArgPtr^.Kind := akDouble; + ArgPtr^.Data[0] := ParamPtr^[2]; + ArgPtr^.Data[1] := ParamPtr^[3]; + end; + varDispatch: + begin + ArgPtr^.Kind := akDWord; + ArgPtr^.Data[0] := Integer(ParamPtr) + end; + else + ArgPtr^.Kind := akDWord; + if (ArgType and varArray) <> 0 then + ArgPtr^.Data[0] := Integer(ParamPtr) + else + ArgPtr^.Data[0] := ParamPtr^[2]; + end; + end; + Inc(Integer(ArgPtr), SizeOf(TEventArg)); + Inc(I); + until I = EventInfo.ArgCount; + end; + CallEventMethod(EventInfo); + J := StrCount; + while J <> 0 do + begin + Dec(J); + with Strings[J] do + if BStr <> nil then BStr^ := StringToOleStr(string(PStr)); + end; + except + DoHandleException; + end; + K := StrCount; + while K <> 0 do + begin + Dec(K); + string(Strings[K].PStr) := ''; + end; + end; +end; + +procedure TOleCtl.DblClk; +var MouseData: TMouseEventData; + P: TPoint; +begin + {$IFDEF NIL_EVENTS} + if Assigned(EV.fOnMouseDblClk) then + {$ENDIF} + begin + MouseData.Button := mbLeft; + MouseData.Shift := 0; + GetCursorPos( P ); + P := Screen2Client( P ); + MouseData.X := P.x; + MouseData.Y := P.y; + EV.fOnMouseDblClk(@Self, MouseData); + end; +end; + +destructor TOleCtl.Destroy; + + procedure FreeList(var L: PList); + begin + if L = nil then Exit; + L.Release; + L := nil; + end; + +begin + SetUIActive(False); + if FOleObject <> nil then FOleObject.Close(OLECLOSE_NOSAVE); + DestroyControl; + DestroyStorage; + FPersistStream := nil; + if FOleObject <> nil then FOleObject.SetClientSite(nil); + FOleObject := nil; + FEventDispatch.Free; + FreeList(FFonts); + FreeList(FPictures); + Dec(FControlData^.InstanceCount); + if FControlData^.InstanceCount = 0 then + DestroyEnumPropDescs; + fOleCtlIntf.Free; + inherited Destroy; +end; + +procedure TOleCtl.DestroyControl; +begin + InterfaceDisconnect(FOleObject, FControlData^.EventIID, FEventsConnection); + InterfaceDisconnect(FOleObject, IPropertyNotifySink, FPropConnection); + FPropBrowsing := nil; + FControlDispatch := nil; + FOleControl := nil; +end; + +procedure TOleCtl.DestroyEnumPropDescs; +var + I: Integer; +begin + with FControlData^ do + if EnumPropDescs <> nil then + begin + for I := 0 to EnumPropDescs.Count - 1 do + PEnumPropDesc(EnumPropDescs.Items[I]).Free; + EnumPropDescs.Free; + EnumPropDescs := nil; + end; +end; + +procedure TOleCtl.DestroyStorage; +begin + if FObjectData <> 0 then + begin + GlobalFree(FObjectData); + FObjectData := 0; + end; +end; + +procedure TOleCtl.DoHandleException; +begin + //Application.HandleException(Self); + //TODO: replace Application.HandleException with something +end; + +function TOleCtl.GetByteProp(Index: Integer): Byte; +begin + Result := GetIntegerProp(Index); +end; + +function TOleCtl.GetColorProp(Index: Integer): TColor; +begin + Result := GetIntegerProp(Index); +end; + +function TOleCtl.GetCompProp(Index: Integer): Comp; +begin + Result := GetDoubleProp(Index); +end; + +function TOleCtl.GetCurrencyProp(Index: Integer): Currency; +var + Temp: TVarData; +begin + GetProperty(Index, Temp); + Result := Temp.VCurrency; +end; + +function TOleCtl.GetDoubleProp(Index: Integer): Double; +var + Temp: TVarData; +begin + GetProperty(Index, Temp); + Result := Temp.VDouble; +end; + +procedure TOleCtlIntf.GetEventMethod(DispID: TDispID; var Method: TMethod); +{begin // test for D4 - it works... + Method.Code := nil; + Method.Data := nil; +end;} +const + szOleCtl = sizeof( TOleCtl ); +asm + PUSH EBX + PUSH ESI + PUSH EDI + PUSH ECX + MOV EBX,EAX + MOV ECX,[EBX].fOleCtl + ///////////////////////// fix of events handling + MOV EBX, ECX // by Alexey Izyumov + ///////////////////////// Octouber, 2001 + MOV ECX,[ECX].TOleCtl.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} + MOV EAX, szOleCtl + 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; + +function TOleCtl.GetEnumPropDesc(DispID: Integer): PEnumPropDesc; +var + I: Integer; +begin + with FControlData^ do + begin + if EnumPropDescs = nil then CreateEnumPropDescs; + for I := 0 to EnumPropDescs.Count - 1 do + begin + Result := EnumPropDescs.Items[I]; + if Result.FDispID = DispID then Exit; + end; + Result := nil; + end; +end; + +function TOleCtl.GetIDispatchProp(Index: Integer): IDispatch; +var + Temp: TVarData; +begin + GetProperty(Index, Temp); + Result := IDispatch(Temp.VDispatch); +end; + +function TOleCtl.GetIntegerProp(Index: Integer): Integer; +var + Temp: TVarData; +begin + GetProperty(Index, Temp); + Result := Temp.VInteger; +end; + +function TOleCtl.GetIUnknownProp(Index: Integer): IUnknown; +var + Temp: TVarData; +begin + GetProperty(Index, Temp); + Result := IUnknown(Temp.VUnknown); +end; + +function TOleCtl.GetMainMenu: HMenu; +var + Form: PControl; +begin + Result := 0; + Form := ParentForm; + if Form <> nil then + //if Form.FormStyle <> fsMDIChild then + Result := Form.Menu + {else + if Application.MainForm <> nil then + Result := Application.MainForm.Menu}; +end; + +function TOleCtl.GetOleBoolProp(Index: Integer): TOleBool; +var + Temp: TVarData; +begin + GetProperty(Index, Temp); + Result := Temp.VBoolean; +end; + +function TOleCtl.GetOleDateProp(Index: Integer): TOleDate; +var + Temp: TVarData; +begin + GetProperty(Index, Temp); + Result := Temp.VDate; +end; + +function TOleCtl.GetOleEnumProp(Index: Integer): TOleEnum; +begin + Result := GetIntegerProp(Index); +end; + +function TOleCtl.GetOleObject: Variant; +begin + CreateControl; + Result := Variant(FOleObject as IDispatch); +end; + +function TOleCtl.GetOleVariantProp(Index: Integer): OleVariant; +begin + VarClear(Result); + GetProperty(Index, TVarData(Result)); +end; + +function TOleCtl.GetOnLeave: TOnEvent; +begin + Result := OnExit; +end; + +var // init to zero, never written to + DispParams: TDispParams = (); + +procedure TOleCtl.GetProperty(Index: Integer; var Value: TVarData); +var + Status: HResult; + ExcepInfo: TExcepInfo; +begin + CreateControl; + Value.VType := varEmpty; + Status := FControlDispatch.Invoke(Index, GUID_NULL, 0, + DISPATCH_PROPERTYGET, DispParams, @Value, @ExcepInfo, nil); + if Status <> 0 then DispatchInvokeError(Status, ExcepInfo); +end; + +function TOleCtl.GetShortIntProp(Index: Integer): ShortInt; +begin + Result := GetIntegerProp(Index); +end; + +function TOleCtl.GetSingleProp(Index: Integer): Single; +var + Temp: TVarData; +begin + GetProperty(Index, Temp); + Result := Temp.VSingle; +end; + +function TOleCtl.GetSmallintProp(Index: Integer): Smallint; +var + Temp: TVarData; +begin + GetProperty(Index, Temp); + Result := Temp.VSmallint; +end; + +function TOleCtl.GetStringProp(Index: Integer): string; +begin + Result := GetVariantProp(Index); +end; + +function TOleCtl.GetTColorProp(Index: Integer): TColor; +begin + Result := GetIntegerProp(Index); +end; + +function TOleCtl.GetTDateTimeProp(Index: Integer): TDateTime; +var + Temp: TVarData; +begin + GetProperty(Index, Temp); + Result := Temp.VDate; +end; + +function TOleCtl.GetTFontProp(Index: Integer): PGraphicTool; +{var + I: Integer;} +begin + Result := nil; + {for I := 0 to FFonts.Count-1 do + if FControlData^.FontIDs^[I] = Index then + begin + Result := TFont(FFonts[I]); + if Result.FontAdapter = nil then + SetOleFont(Result, GetIDispatchProp(Index) as IFontDisp); + end;} + //TODO: implement TFont later +end; + +function TOleCtl.GetTOleEnumProp(Index: Integer): TOleEnum; +begin + Result := GetIntegerProp(Index); +end; + +function TOleCtl.GetVariantProp(Index: Integer): Variant; +begin + Result := GetOleVariantProp(Index); +end; + +function TOleCtl.GetWideStringProp(Index: Integer): WideString; +var + Temp: TVarData; +begin + Result := ''; + GetProperty(Index, Temp); + Pointer(Result) := Temp.VOleStr; +end; + +function TOleCtl.GetWordBoolProp(Index: Integer): WordBool; +var + Temp: TVarData; +begin + GetProperty(Index, Temp); + Result := Temp.VBoolean; +end; + +function TOleCtl.GetWordProp(Index: Integer): Word; +begin + Result := GetIntegerProp(Index); +end; + +procedure TOleCtl.HookControlWndProc; +var + WndHandle: HWnd; +begin + if (FOleInPlaceObject <> nil) and (fHandle = 0) then + begin + WndHandle := 0; + FOleInPlaceObject.GetWindow(WndHandle); + if WndHandle = 0 then + raise EOleError.CreateResFmt(e_Ole, Integer(@SNoWindowHandle), [nil]); + fHandle := WndHandle; + fDefWndProc := Pointer(GetWindowLong(fHandle, GWL_WNDPROC)); + CreatingWindow := @Self; + SetWindowLong(fHandle, GWL_WNDPROC, Longint(@WndFunc)); + SendMessage(fHandle, WM_NULL, 0, 0); + end; +end; + +procedure TOleCtl.Init; +var + I: Integer; + intfClass: TOleCtlIntfClass; +begin + OleInit; + inherited; + // overriding this method, we allow for constructor to initialize + // the object. + fControlClassName := 'OleCtl'; // ClassName + {$IFDEF USE_FLAGS} include( fFlagsG3, G3_IsControl ); + {$ELSE} fIsControl := TRUE; {$ENDIF} + fStyle.Value := WS_VISIBLE or WS_CLIPCHILDREN or WS_CLIPSIBLINGS or + WS_CHILD; // or WS_BORDER or WS_THICKFRAME; + + //AttachProc( WndProcCtrl ); for test only + + // The rest of initialization -- moved from OleCtrls + InitControlData; + Inc(FControlData^.InstanceCount); + if FControlData^.FontCount > 0 then + begin + FFonts := NewList; + //FFonts.Count := FControlData^.FontCount; + for I := 0 to FControlData^.FontCount-1 do + FFonts.Add( NewFont ); + end; + {if FControlData^.PictureCount > 0 then + begin + FPictures := NewList; + //FPictures.Count := FControlData^.PictureCount; + for I := 0 to FControlData^.PictureCount-1 do + begin + FPictures.Add( NewPicture ); + TPicture(FPictures[I]).OnChange := PictureChanged; + end; + end;} + FEventDispatch := TEventDispatch.Create(@Self); + CreateInstance; + InitControlInterface(FOleObject); + OleCheck(FOleObject.GetMiscStatus(DVASPECT_CONTENT, FMiscStatus)); + + if (Assigned(OnGetIntfClass)) then + intfClass := OnGetIntfClass() + else + intfClass := TOleCtlIntf; + fOleCtlIntf := intfClass.Create; + fOleCtlIntf.fOleCtl := @Self; + + if (FControlData^.Reserved and cdDeferSetClientSite) = 0 then + if ((FMiscStatus and OLEMISC_SETCLIENTSITEFIRST) <> 0) or + ((FControlData^.Reserved and cdForceSetClientSite) <> 0) then + OleCheck(FOleObject.SetClientSite(fOleCtlIntf)); + OleCheck(FOleObject.QueryInterface(IPersistStreamInit, FPersistStream)); + if FMiscStatus and OLEMISC_INVISIBLEATRUNTIME <> 0 then + {$IFDEF USE_FLAGS} exclude( fStyle.f3_Style, F3_Visible ); + {$ELSE} fVisible := False; {$ENDIF} + {if FMiscStatus and OLEMISC_SIMPLEFRAME <> 0 then + ControlStyle := [csAcceptsControls, csDoubleClicks, csNoStdEvents] else + ControlStyle := [csDoubleClicks, csNoStdEvents];} + if FMiscStatus and OLEMISC_SIMPLEFRAME = 0 then + fExStyle := 0; // clear WS_EX_CONTROLPARENT + TabStop := FMiscStatus and (OLEMISC_ACTSLIKELABEL or + OLEMISC_NOUIACTIVATE) = 0; + OleCheck(fOleCtlIntf.RequestNewObjectLayout); +end; + +procedure TOleCtl.InitControlData; +begin + // nothing here. Originally, this method was abstract. + // Since TOleControl class became TOleCtl object, abstract methods + // are not available. So, make this method empty to override it + // in descendant objects, which represent Active-X controls. +end; + +procedure TOleCtl.InitControlInterface(const Obj: IUnknown); +begin + // This method is to override it in derived Active-X control holder. +end; + +procedure TOleCtl.InvokeEvent(DispID: TDispID; var Params: TDispParams); +var + EventMethod: TMethod; +begin + if ControlData.Version < 300 then + D2InvokeEvent(DispID, Params) + else + begin + fOleCtlIntf.GetEventMethod(DispID, EventMethod); + if Integer(EventMethod.Code) < $10000 then Exit; + + try + asm + PUSH EBX + PUSH ESI + MOV ESI, Params + MOV EBX, [ESI].TDispParams.cArgs + TEST EBX, EBX + JZ @@7 + MOV ESI, [ESI].TDispParams.rgvarg + MOV EAX, EBX + SHL EAX, 4 // count * sizeof(TVarArg) + XOR EDX, EDX + ADD ESI, EAX // EDI = Params.rgvarg^[ArgCount] + @@1: SUB ESI, 16 // Sizeof(TVarArg) + MOV EAX, dword ptr [ESI] + CMP AX, varSingle + JA @@3 + JE @@4 + @@2: TEST DL,DL + JNE @@2a + MOV ECX, ESI + INC DL + TEST EAX, varArray + JNZ @@6 + MOV ECX, dword ptr [ESI+8] + JMP @@6 + @@2a: TEST EAX, varArray + JZ @@5 + PUSH ESI + JMP @@6 + @@3: CMP AX, varDate + JA @@2 + @@4: PUSH dword ptr [ESI+12] + @@5: PUSH dword ptr [ESI+8] + @@6: DEC EBX + JNE @@1 + @@7: MOV EDX, Self + MOV EAX, EventMethod.Data + CALL EventMethod.Code + POP ESI + POP EBX + end; + except + DoHandleException; + end; + end; +end; + +procedure TOleCtl.KeyDown(var Key: Longint; AShift: DWORD); +begin + if Assigned(EV.fOnKeyDown) then EV.fOnKeyDown(@Self, Key, AShift); +end; + +procedure TOleCtl.KeyPress(var Key: KOLChar); +begin + if Assigned(EV.fOnChar) then EV.fOnChar(@Self, Key, 0); +end; + +procedure TOleCtl.KeyUp(var Key: Longint; AShift: DWORD); +begin + if Assigned(EV.fOnKeyUp) then EV.fOnKeyUp(@Self, Key, AShift); +end; + +procedure TOleCtl.MouseDown(Button: TMouseButton; AShift: DWORD; X, + Y: Integer); +begin + //TODO: mouse +end; + +procedure TOleCtl.MouseMove(AShift: DWORD; X, Y: Integer); +begin + //TODO: mouse +end; + +procedure TOleCtl.MouseUp(Button: TMouseButton; AShift: DWORD; X, + Y: Integer); +begin + //TODO: mouse +end; + +procedure TOleCtl.SetByteProp(Index: Integer; Value: Byte); +begin + SetIntegerProp(Index, Value); +end; + +procedure TOleCtl.SetColorProp(Index: Integer; Value: TColor); +begin + SetIntegerProp(Index, Value); +end; + +procedure TOleCtl.SetCompProp(Index: Integer; const Value: Comp); +var + Temp: TVarData; +begin + Temp.VType := VT_I8; + Temp.VDouble := Value; + SetProperty(Index, Temp); +end; + +procedure TOleCtl.SetCurrencyProp(Index: Integer; const Value: Currency); +var + Temp: TVarData; +begin + Temp.VType := varCurrency; + Temp.VCurrency := Value; + SetProperty(Index, Temp); +end; + +procedure TOleCtl.SetDoubleProp(Index: Integer; const Value: Double); +var + Temp: TVarData; +begin + Temp.VType := varDouble; + Temp.VDouble := Value; + SetProperty(Index, Temp); +end; + +procedure TOleCtl.SetIDispatchProp(Index: Integer; const Value: IDispatch); +var + Temp: TVarData; +begin + Temp.VType := varDispatch; + Temp.VDispatch := Pointer(Value); + SetProperty(Index, Temp); +end; + +procedure TOleCtl.SetIntegerProp(Index, Value: Integer); +var + Temp: TVarData; +begin + Temp.VType := varInteger; + Temp.VInteger := Value; + SetProperty(Index, Temp); +end; + +procedure TOleCtl.SetIUnknownProp(Index: Integer; const Value: IUnknown); +var + Temp: TVarData; +begin + Temp.VType := VT_UNKNOWN; + Temp.VUnknown := Pointer(Value); + SetProperty(Index, Temp); +end; + +(*procedure TOleCtl.SetMouseDblClk(const Value: TOnMouse); +begin + {$IFDEF EVENTS_DYNAMIC} ProvideUniqueEvents {$ELSE} EV {$ENDIF} + .fOnMouseDblClk := Value; +end;*) + +procedure TOleCtl.SetName(const Value: String); +var + OldName: string; + DispID: Integer; +begin + OldName := Name; + Name := Value; //inherited SetName(Value); + if FOleControl <> nil then + begin + FOleControl.OnAmbientPropertyChange(DISPID_AMBIENT_DISPLAYNAME); + if FControlData^.Flags and (cfCaption or cfText) <> 0 then + begin + if FControlData^.Flags and cfCaption <> 0 then + DispID := DISPID_CAPTION else + DispID := DISPID_TEXT; + if OldName = GetStringProp(DispID) then SetStringProp(DispID, Value); + end; + end; +end; + +procedure TOleCtl.SetOleBoolProp(Index: Integer; Value: TOleBool); +var + Temp: TVarData; +begin + Temp.VType := varBoolean; + if Value then + Temp.VBoolean := WordBool(-1) else + Temp.VBoolean := WordBool(0); + SetProperty(Index, Temp); +end; + +procedure TOleCtl.SetOleDateProp(Index: Integer; const Value: TOleDate); +var + Temp: TVarData; +begin + Temp.VType := varDate; + Temp.VDate := Value; + SetProperty(Index, Temp); +end; + +procedure TOleCtl.SetOleEnumProp(Index: Integer; Value: TOleEnum); +begin + SetIntegerProp(Index, Value); +end; + +procedure TOleCtl.SetOleVariantProp(Index: Integer; + const Value: OleVariant); +begin + SetProperty(Index, TVarData(Value)); +end; + +procedure TOleCtl.SetOnChar(const Value: TOnChar); +begin + {$IFDEF EVENTS_DYNAMIC} ProvideUniqueEvents {$ELSE} EV {$ENDIF} + .fOnChar := Value; +end; + +procedure TOleCtl.SetOnLeave(const Value: TOnEvent); +begin + OnExit := Value; +end; + +procedure TOleCtl.SetParent(AParent: PControl); +var + CS: IOleClientSite; + X: Integer; +begin + inherited Parent := AParent; + if (AParent <> nil) then + begin + try // work around ATL bug + X := FOleObject.GetClientSite(CS); + except + X := -1; + end; + if (X <> 0) or (CS = nil) then + OleCheck(FOleObject.SetClientSite(fOleCtlIntf)); + if FOleControl <> nil then + FOleControl.OnAmbientPropertyChange(DISPID_UNKNOWN); + end; +end; + +procedure TOleCtl.SetProperty(Index: Integer; const Value: TVarData); +const + DispIDArgs: Longint = DISPID_PROPERTYPUT; +var + Status, InvKind: Integer; + DispParams: TDispParams; + ExcepInfo: TExcepInfo; +begin + CreateControl; + DispParams.rgvarg := @Value; + DispParams.rgdispidNamedArgs := @DispIDArgs; + DispParams.cArgs := 1; + DispParams.cNamedArgs := 1; + if Value.VType <> varDispatch then + InvKind := DISPATCH_PROPERTYPUT else + InvKind := DISPATCH_PROPERTYPUTREF; + Status := FControlDispatch.Invoke(Index, GUID_NULL, 0, + InvKind, DispParams, nil, @ExcepInfo, nil); + if Status <> 0 then DispatchInvokeError(Status, ExcepInfo); +end; + +procedure TOleCtl.SetShortIntProp(Index: Integer; Value: Shortint); +begin + SetIntegerProp(Index, Value); +end; + +procedure TOleCtl.SetSingleProp(Index: Integer; const Value: Single); +var + Temp: TVarData; +begin + Temp.VType := varSingle; + Temp.VSingle := Value; + SetProperty(Index, Temp); +end; + +procedure TOleCtl.SetSmallintProp(Index: Integer; Value: Smallint); +var + Temp: TVarData; +begin + Temp.VType := varSmallint; + Temp.VSmallint := Value; + SetProperty(Index, Temp); +end; + +procedure TOleCtl.SetStringProp(Index: Integer; const Value: string); +var + Temp: TVarData; +begin + Temp.VType := varOleStr; + Temp.VOleStr := StringToOleStr(Value); + try + SetProperty(Index, Temp); + finally + SysFreeString(Temp.VOleStr); + end; +end; + +procedure TOleCtl.SetTColorProp(Index: Integer; Value: TColor); +begin + SetIntegerProp(Index, Value); +end; + +procedure TOleCtl.SetTDateTimeProp(Index: Integer; const Value: TDateTime); +var + Temp: TVarData; +begin + Temp.VType := varDate; + Temp.VDate := Value; + SetProperty(Index, Temp); +end; + +procedure TOleCtl.SetTFontProp(Index: Integer; Value: PGraphicTool); +{var + I: Integer; + F: TFont; + Temp: IFontDisp;} +begin + {for I := 0 to FFonts.Count-1 do + if FControlData^.FontIDs^[I] = Index then + begin + F := TFont(FFonts[I]); + F.Assign(Value); + if F.FontAdapter = nil then + begin + GetOleFont(F, Temp); + SetIDispatchProp(Index, Temp); + end; + end;} + //TODO: implement TFont property later +end; + +procedure TOleCtl.SetTOleEnumProp(Index: Integer; Value: TOleEnum); +begin + SetIntegerProp(Index, Value); +end; + +procedure TOleCtl.SetUIActive(Active: Boolean); +var + Form: POleCtl; // declare it as POleCtl, though it is only PControl + // - to access its protected fields +begin + Form := POleCtl( ParentForm ); + if Form <> nil then + if Active then + begin + {if (Form.ActiveOleControl <> nil) and + (Form.ActiveOleControl <> Self) then + Form.ActiveOleControl.Perform(CM_UIDEACTIVATE, 0, 0); + Form.ActiveOleControl := Self;} + if (Form.DF.fCurrentControl <> nil) and + (Form.DF.fCurrentControl <> @Self) then + Form.DF.fCurrentControl.Perform(CM_UIDEACTIVATE, 0, 0); + Form.DF.fCurrentControl := @Self; + end else + if Form.DF.fCurrentControl = @Self then + Form.DF.fCurrentControl := nil; +end; + +procedure TOleCtl.SetVariantProp(Index: Integer; const Value: Variant); +begin + SetOleVariantProp(Index, Value); +end; + +procedure TOleCtl.SetWideStringProp(Index: Integer; + const Value: WideString); +var + Temp: TVarData; +begin + Temp.VType := varOleStr; + if Value <> '' then + Temp.VOleStr := PWideChar(Value) + else + Temp.VOleStr := nil; + SetProperty(Index, Temp); +end; + +procedure TOleCtl.SetWordBoolProp(Index: Integer; Value: WordBool); +var + Temp: TVarData; +begin + Temp.VType := varBoolean; + if Value then + Temp.VBoolean := WordBool(-1) else + Temp.VBoolean := WordBool(0); + SetProperty(Index, Temp); +end; + +procedure TOleCtl.SetWordProp(Index: Integer; Value: Word); +begin + SetIntegerProp(Index, Value); +end; + +procedure TOleCtl.StandardEvent(DispID: TDispID; var Params: TDispParams); +type + PVarDataList = ^TVarDataList; + TVarDataList = array[0..3] of TVarData; +const + {ShiftMap: array[0..7] of TShiftState = ( + [], + [ssShift], + [ssCtrl], + [ssShift, ssCtrl], + [ssAlt], + [ssShift, ssAlt], + [ssCtrl, ssAlt], + [ssShift, ssCtrl, ssAlt]); + MouseMap: array[0..7] of TShiftState = ( + [], + [ssLeft], + [ssRight], + [ssLeft, ssRight], + [ssMiddle], + [ssLeft, ssMiddle], + [ssRight, ssMiddle], + [ssLeft, ssRight, ssMiddle]);} + ShiftMap: array[0..7] of DWord = ( + 0, + MK_SHIFT, + MK_CONTROL, + MK_SHIFT or MK_CONTROL, + MK_ALT, + MK_SHIFT or MK_ALT, + MK_CONTROL or MK_ALT, + MK_SHIFT or MK_CONTROL or MK_ALT); + MouseMap: array[0..7] of DWORD = ( + 0, + MK_LBUTTON, + MK_RBUTTON, + MK_LBUTTON or MK_RBUTTON, + MK_MBUTTON, + MK_LBUTTON or MK_MBUTTON, + MK_RBUTTON or MK_MBUTTON, + MK_LBUTTON or MK_RBUTTON or MK_MBUTTON); + ButtonMap: array[0..7] of TMouseButton = ( + mbLeft, mbLeft, mbRight, mbLeft, mbMiddle, mbLeft, mbRight, mbLeft); +var + Args: PVarDataList; + AShift: DWORD; + Button: TMouseButton; + X, Y: Integer; + Key: Longint; + Ch: KOLChar; +begin + Args := PVarDataList(Params.rgvarg); + try + case DispID of + DISPID_CLICK: + Click; + DISPID_DBLCLICK: + DblClk; + DISPID_KEYDOWN, DISPID_KEYUP: + if Params.cArgs >= 2 then + begin + Key := Variant(Args^[1]); + X := Variant(Args^[0]); + case DispID of + DISPID_KEYDOWN: KeyDown(Key, X); + DISPID_KEYUP: KeyUp(Key, X); + end; + if ((Args^[1].vType and varByRef) <> 0) then + Word(Args^[1].VPointer^) := Key; + end; + DISPID_KEYPRESS: + if Params.cArgs > 0 then + begin + Ch := KOLChar(Integer(Variant(Args^[0]))); + KeyPress(Ch); + if ((Args^[0].vType and varByRef) <> 0) then + KOLChar(Args^[0].VPointer^) := Ch; + end; + {DISPID_KEYPRESS: + if Params.cArgs > 0 then + begin + Ch := KOLChar(Integer(Variant(Args^[0]))); + KeyPress(Ch); + if ((Args^[0].vType and varByRef) <> 0) then + KOLChar(Args^[0].VPointer^) := Ch; + end;} + DISPID_MOUSEDOWN, DISPID_MOUSEMOVE, DISPID_MOUSEUP: + if Params.cArgs >= 4 then + begin + X := Integer(Variant(Args^[3])) and 7; + Y := Integer(Variant(Args^[2])) and 7; + Button := ButtonMap[X]; + AShift := ShiftMap[Y] + MouseMap[X]; + X := Variant(Args^[1]); + Y := Variant(Args^[0]); + case DispID of + DISPID_MOUSEDOWN: + MouseDown(Button, AShift, X, Y); + DISPID_MOUSEMOVE: + MouseMove(AShift, X, Y); + DISPID_MOUSEUP: + MouseUp(Button, AShift, X, Y); + end; + end; + end; + except + DoHandleException; + end; +end; + +{$IFNDEF _D2orD3} +{ TServerEventDispatch } +constructor TServerEventDispatch.Create(Server: TOleServer); +begin + FServer := Server; + InternalRefCount := 1; +end; + +{ TServerEventDispatch.IUnknown } +function TServerEventDispatch.QueryInterface(const IID: TGUID; out Obj): HResult; +begin + if GetInterface(IID, Obj) then + begin + Result := S_OK; + Exit; + end; + if IsEqualIID(IID, FServer.FServerData^.EventIID) then + begin + GetInterface(IDispatch, Obj); + Result := S_OK; + Exit; + end; + Result := E_NOINTERFACE; +end; + +function TServerEventDispatch._AddRef: Integer; +begin + if FServer <> nil then FServer._AddRef; + InternalRefCount := InternalRefCount + 1; + Result := InternalRefCount; +end; + +function TServerEventDispatch._Release: Integer; +begin + if FServer <> nil then FServer._Release; + InternalRefCount := InternalRefCount -1; + Result := InternalRefCount; +end; + +{ TServerEventDispatch.IDispatch } +function TServerEventDispatch.GetTypeInfoCount(out Count: Integer): HResult; +begin + Count := 0; + Result:= S_OK; +end; + +function TServerEventDispatch.GetTypeInfo(Index, LocaleID: Integer; out TypeInfo): HResult; +begin + Pointer(TypeInfo) := nil; + Result := E_NOTIMPL; +end; + +function TServerEventDispatch.GetIDsOfNames(const IID: TGUID; Names: Pointer; + NameCount, LocaleID: Integer; DispIDs: Pointer): HResult; +begin + Result := E_NOTIMPL; +end; + +function TServerEventDispatch.Invoke(DispID: Integer; const IID: TGUID; + LocaleID: Integer; Flags: Word; var Params; + VarResult, ExcepInfo, ArgErr: Pointer): HResult; +var + ParamCount, I: integer; + VarArray : TVariantArray; +begin + // Get parameter count + ParamCount := TDispParams(Params).cArgs; + // Set our array to appropriate length + SetLength(VarArray, ParamCount); + // Copy over data + for I := Low(VarArray) to High(VarArray) do + VarArray[High(VarArray)-I] := OleVariant(TDispParams(Params).rgvarg^[I]); + // Invoke Server proxy class + if FServer <> nil then FServer.InvokeEvent(DispID, VarArray); + // Clean array + SetLength(VarArray, 0); + // Pascal Events return 'void' - so assume success! + Result := S_OK; +end; + +function TServerEventDispatch.ServerDisconnect : Boolean; +begin + FServer := nil; + if FServer <> nil then + Result := false + else Result := true; +end; + +{TOleServer} +constructor TOleServer.Create; //(AOwner: TComponent); +begin + inherited; // Create(AOwner); + // Allow derived class to initialize ServerData structure pointer + InitServerData; + // Make sure derived class set ServerData pointer to some valid structure + Assert(FServerData <> nil); + // Increment instance count (not used currently) + Inc(FServerData^.InstanceCount); + // Create Event Dispatch Handler + FEventDispatch := TServerEventDispatch.Create(Self); +end; + +destructor TOleServer.Destroy; +begin + // Disconnect from the Server (NOTE: Disconnect must handle case when we're no longer connected) + Disconnect; + // Free Events dispatcher + FEventDispatch.ServerDisconnect; + if (FEventDispatch._Release = 0) then FEventDispatch.Free; + // Decrement refcount + Dec(FServerData^.InstanceCount); + inherited Destroy; +end; + +procedure TOleServer.Loaded; +begin + {inherited Loaded;} + + // Load Server if user requested 'AutoConnect' and we're not in Design mode + {if not (csDesigning in ComponentState) then} + if AutoConnect then + Connect; +end; + +procedure TOleServer.InvokeEvent(DispID: TDispID; var Params: TVariantArray); +begin + // To be overriden in derived classes to do dispatching +end; + +function TOleServer.GetServer: IUnknown; +var + HR: HResult; + ErrorStr: string; +begin + case ConnectKind of + ckNewInstance: + Result := CreateComObject(FServerData^.ClassId); + + ckRunningInstance: + begin + HR := GetActiveObject(FServerData^.ClassId, nil, Result); + if not Succeeded(HR) then + begin + ErrorStr := Format(sNoRunningObject, [ClassIDToProgID(FServerData^.ClassId), + GuidToString(FServerData^.ClassId)]); + raise EOleSysError.Create( e_Ole, ErrorStr {, HR, 0} ); + end; + end; + + ckRunningOrNew: + if not Succeeded(GetActiveObject(FServerData^.ClassId, nil, Result)) then + Result := CreateComObject(FServerData^.ClassId); + + ckRemote: + {Highly inefficient: requires at least two round trips - GetClassObject + QI} + Result := CreateRemoteComObject(RemoteMachineName, FServerData^.ClassID); + end; +end; + +procedure TOleServer.ConnectEvents(const Obj: IUnknown); +begin + KOLComObj.InterfaceConnect(Obj, FServerData^.EventIID, FEventDispatch, FEventsConnection); +end; + +procedure TOleServer.DisconnectEvents(const Obj: Iunknown); +begin + KOLComObj.InterfaceDisconnect(Obj, FServerData^.EventIID, FEventsConnection); +end; + +function TOleServer.GetConnectKind: TConnectKind; +begin + // Should the setting of a RemoteMachine name override the Connection Kind ?? + if RemoteMachineName <> '' then + Result := ckRemote + else + Result := FConnectKind; +end; + +procedure TOleServer.SetConnectKind(cK: TConnectKind); +begin + // Should we validate that we have a RemoteMachineName for ckRemote ?? + FConnectKind := cK; +end; + +function TOleServer.GetAutoConnect: Boolean; +begin + // If user wants to provide the interface to connect to, then we won't + // 'automatically' connect to a server. + if ConnectKind = ckAttachToInterface then + Result := False + else + Result := FAutoConnect; +end; + +procedure TOleServer.SetAutoConnect(flag: Boolean); +begin + FAutoConnect := flag; +end; + +{ TOleServer.IUnknown } +function TOleServer.QueryInterface(const IID: TGUID; out Obj): HResult; +begin + if GetInterface(IID, Obj) then + Result := S_OK + else + Result := E_NOINTERFACE; +end; + +function TOleServer._AddRef: Integer; +begin + Inc(FRefCount); + Result := FRefCount; +end; + +function TOleServer._Release: Integer; +begin + Dec(FRefCount); + Result := FRefCount; +end; +{$ENDIF _D2orD3} + +{ TEventDispatch } + +constructor TEventDispatch.Create(Control: POleCtl); +begin + FControl := Control; +end; + +{ TEventDispatch.IUnknown } + +function TEventDispatch.QueryInterface(const IID: TGUID; out Obj): HResult; +begin + if GetInterface(IID, Obj) then + begin + Result := S_OK; + Exit; + end; + if IsEqualIID(IID, FControl.FControlData^.EventIID) then + begin + GetInterface(IDispatch, Obj); + Result := S_OK; + Exit; + end; + Result := E_NOINTERFACE; +end; + +function TEventDispatch._AddRef: Integer; +begin + Result := FControl.fOleCtlIntf._AddRef; +end; + +function TEventDispatch._Release: Integer; +begin + Result := FControl.fOleCtlIntf._Release; +end; + +{ TEventDispatch.IDispatch } + +function TEventDispatch.GetTypeInfoCount(out Count: Integer): HResult; +begin + Count := 0; + Result := S_OK; +end; + +function TEventDispatch.GetTypeInfo(Index, LocaleID: Integer; + out TypeInfo): HResult; +begin + Pointer(TypeInfo) := nil; + Result := E_NOTIMPL; +end; + +function TEventDispatch.GetIDsOfNames(const IID: TGUID; Names: Pointer; + NameCount, LocaleID: Integer; DispIDs: Pointer): HResult; +begin + Result := E_NOTIMPL; +end; + +function TEventDispatch.Invoke(DispID: Integer; const IID: TGUID; + LocaleID: Integer; Flags: Word; var Params; + VarResult, ExcepInfo, ArgErr: Pointer): HResult; +begin + if (DispID >= DISPID_MOUSEUP) and (DispID <= DISPID_CLICK) then + FControl.StandardEvent(DispID, TDispParams(Params)) else + FControl.InvokeEvent(DispID, TDispParams(Params)); + Result := S_OK; +end; + +{ TOleCtlIntf } + +function TOleCtlIntf._AddRef: Integer; +begin + //{$IFDEF _D2orD3} + //Result := inherited _AddRef; + //{$ELSE} + Inc(FRefCount); + Result := FRefCount; + //{$ENDIF} +end; + +function TOleCtlIntf._Release: Integer; +begin + //{$IFDEF _D2orD3} + //Result := inherited _Release; + //{$ELSE} + Dec(FRefCount); + Result := FRefCount; + //{$ENDIF} +end; + +function TOleCtlIntf.CanInPlaceActivate: HResult; +begin + Result := S_OK; +end; + +function TOleCtlIntf.ContextSensitiveHelp(fEnterMode: BOOL): HResult; +begin + Result := S_OK; +end; + +function TOleCtlIntf.DeactivateAndUndo: HResult; +begin + fOleCtl.FOleInPlaceObject.UIDeactivate; + Result := S_OK; +end; + +function TOleCtlIntf.DiscardUndoState: HResult; +begin + Result := E_NOTIMPL; +end; + +function TOleCtlIntf.EnableModeless(fEnable: BOOL): HResult; +begin + Result := S_OK; +end; + +function TOleCtlIntf.GetBorder(out rectBorder: TRect): HResult; +begin + Result := INPLACE_E_NOTOOLSPACE; +end; + +function TOleCtlIntf.GetContainer(out container: IOleContainer): HResult; +begin + Result := E_NOINTERFACE; +end; + +function TOleCtlIntf.GetExtendedControl(out disp: IDispatch): HResult; +begin + Result := E_NOTIMPL; +end; + +function TOleCtlIntf.GetIDsOfNames(const IID: TGUID; Names: Pointer; + NameCount, LocaleID: Integer; DispIDs: Pointer): HResult; +begin + Result := E_NOTIMPL; +end; + +function TOleCtlIntf.GetMoniker(dwAssign, dwWhichMoniker: Integer; + out mk: IMoniker): HResult; +begin + Result := E_NOTIMPL; +end; + +function TOleCtlIntf.GetTypeInfo(Index, LocaleID: Integer; + out TypeInfo): HResult; +begin + Pointer(TypeInfo) := nil; + Result := E_NOTIMPL; +end; + +function TOleCtlIntf.GetTypeInfoCount(out Count: Integer): HResult; +begin + Count := 0; + Result := S_OK; +end; + +function TOleCtlIntf.GetWindowContext(out frame: IOleInPlaceFrame; + out doc: IOleInPlaceUIWindow; out rcPosRect, rcClipRect: TRect; + out frameInfo: TOleInPlaceFrameInfo): HResult; +begin + frame := Self; + doc := nil; + rcPosRect := fOleCtl.BoundsRect; + rcClipRect := MakeRect( 0, 0, 32767, 32767 ); + with frameInfo do + begin + fMDIApp := False; + hWndFrame := fOleCtl.ParentForm.GetWindowHandle; + //GetTopParentHandle; + // now it is not possible to make alien window to be parent for KOL window + hAccel := 0; + cAccelEntries := 0; + end; + Result := S_OK; +end; + +function TOleCtlIntf.InsertMenus(hmenuShared: HMenu; + var menuWidths: TOleMenuGroupWidths): HResult; +{var + Menu: TMainMenu;} +begin + {Menu := GetMainMenu; + if Menu <> nil then + Menu.PopulateOle2Menu(hmenuShared, [0, 2, 4], menuWidths.width);} + //TODO: implement menu populate + Result := S_OK; +end; + +function TOleCtlIntf.Invoke(DispID: Integer; const IID: TGUID; + LocaleID: Integer; Flags: Word; var Params; VarResult, ExcepInfo, + ArgErr: Pointer): HResult; +{var + F: PGraphicTool;} +begin + if (Flags and DISPATCH_PROPERTYGET <> 0) and (VarResult <> nil) then + begin + Result := S_OK; + case DispID of + DISPID_AMBIENT_BACKCOLOR: + PVariant(VarResult)^ := fOleCtl.Color; + DISPID_AMBIENT_DISPLAYNAME: + PVariant(VarResult)^ := StringToVarOleStr( fOleCtl.Name ); + DISPID_AMBIENT_FONT: + begin + {if (fOleCtl.Parent <> nil) and fOleCtl.ParentFont then + F := Parent.Font // TOleControl(Parent).Font + else + F := Font; + PVariant(VarResult)^ := FontToOleFont(F);} + //TODO: implement Font later + end; + DISPID_AMBIENT_FORECOLOR: + PVariant(VarResult)^ := fOleCtl.fTextColor; // Font.Color; + DISPID_AMBIENT_LOCALEID: + PVariant(VarResult)^ := Integer(GetUserDefaultLCID); + DISPID_AMBIENT_MESSAGEREFLECT: + PVariant(VarResult)^ := True; + DISPID_AMBIENT_USERMODE: + PVariant(VarResult)^ := TRUE; // not (csDesigning in ComponentState); + DISPID_AMBIENT_UIDEAD: + PVariant(VarResult)^ := FALSE; // csDesigning in ComponentState; + DISPID_AMBIENT_SHOWGRABHANDLES: + PVariant(VarResult)^ := False; + DISPID_AMBIENT_SHOWHATCHING: + PVariant(VarResult)^ := False; + DISPID_AMBIENT_SUPPORTSMNEMONICS: + PVariant(VarResult)^ := True; + DISPID_AMBIENT_AUTOCLIP: + PVariant(VarResult)^ := True; + else + Result := DISP_E_MEMBERNOTFOUND; + end; + end else + Result := DISP_E_MEMBERNOTFOUND; +end; + +function TOleCtlIntf.LockInPlaceActive(fLock: BOOL): HResult; +begin + Result := E_NOTIMPL; +end; + +function TOleCtlIntf.OleControlSite_TranslateAccelerator(msg: PMsg; + grfModifiers: Integer): HResult; +begin + Result := E_NOTIMPL; +end; + +function TOleCtlIntf.OleInPlaceFrame_GetWindow(out wnd: HWnd): HResult; +begin + wnd := fOleCtl.ParentForm.GetWindowHandle; // GetTopParentHandle; + Result := S_OK; +end; + +function TOleCtlIntf.OleInPlaceFrame_TranslateAccelerator(var msg: Windows.TMsg; + wID: Word): HResult; +begin + Result := S_FALSE; +end; + +function TOleCtlIntf.OleInPlaceSite_GetWindow(out wnd: HWnd): HResult; +begin + Result := S_OK; + wnd := fOleCtl.ParentWindow; + if wnd = 0 then Result := E_FAIL; +end; + +function TOleCtlIntf.OnChanged(dispid: TDispID): HResult; +begin + try + case dispid of + DISPID_BACKCOLOR: + if not fOleCtl.FUpdatingColor then + begin + fOleCtl.FUpdatingColor := True; + try + fOleCtl.fColor := fOleCtl.GetIntegerProp(DISPID_BACKCOLOR); + finally + fOleCtl.FUpdatingColor := False; + end; + end; + DISPID_ENABLED: + if not fOleCtl.FUpdatingEnabled then + begin + fOleCtl.FUpdatingEnabled := True; + try + fOleCtl.Enabled := fOleCtl.GetWordBoolProp(DISPID_ENABLED); + finally + fOleCtl.FUpdatingEnabled := False; + end; + end; + DISPID_FONT: + if not fOleCtl.FUpdatingFont then + begin + fOleCtl.FUpdatingFont := True; + try + //OleFontToFont(GetVariantProp(DISPID_FONT), Font); + // font - implement later + finally + fOleCtl.FUpdatingFont := False; + end; + end; + DISPID_FORECOLOR: + if not fOleCtl.FUpdatingFont then + begin + fOleCtl.FUpdatingFont := True; + try + fOleCtl.fTextColor := fOleCtl.GetIntegerProp(DISPID_FORECOLOR); + //Font.Color := GetIntegerProp(DISPID_FORECOLOR); + finally + fOleCtl.FUpdatingFont := False; + end; + end; + end; + except // control sent us a notification for a dispid it doesn't have. + //on EOleError do ; + end; + Result := S_OK; +end; + +function TOleCtlIntf.OnControlInfoChanged: HResult; +begin + Result := E_NOTIMPL; +end; + +function TOleCtlIntf.OnFocus(fGotFocus: BOOL): HResult; +begin + Result := E_NOTIMPL; +end; + +function TOleCtlIntf.OnInPlaceActivate: HResult; +begin + fOleCtl.FOleObject.QueryInterface( IOleInPlaceObject, + fOleCtl.FOleInPlaceObject); + fOleCtl.FOleObject.QueryInterface( IOleInPlaceActiveObject, + fOleCtl.FOleInPlaceActiveObject); + Result := S_OK; +end; + +function TOleCtlIntf.OnInPlaceDeactivate: HResult; +begin + fOleCtl.FOleInPlaceActiveObject := nil; + fOleCtl.FOleInPlaceObject := nil; + Result := S_OK; +end; + +function TOleCtlIntf.OnPosRectChange(const rcPosRect: TRect): HResult; +begin + fOleCtl.FOleInPlaceObject.SetObjectRects(rcPosRect, MakeRect(0, 0, 32767, 32767)); + Result := S_OK; +end; + +function TOleCtlIntf.OnRequestEdit(dispid: TDispID): HResult; +begin + Result := S_OK; +end; + +function TOleCtlIntf.OnShowWindow(fShow: BOOL): HResult; +begin + Result := S_OK; +end; + +function TOleCtlIntf.OnUIActivate: HResult; +begin + fOleCtl.SetUIActive(True); + Result := S_OK; +end; + +function TOleCtlIntf.OnUIDeactivate(fUndoable: BOOL): HResult; +begin + SetMenu(0, 0, 0); + fOleCtl.SetUIActive(False); + Result := S_OK; +end; + +function TOleCtlIntf.PostMessageFilter(wnd: HWnd; msg, wp, lp: Integer; + out res: Integer; Cookie: Integer): HResult; +begin + Result := S_OK; +end; + +function TOleCtlIntf.PreMessageFilter(wnd: HWnd; msg, wp, lp: Integer; + out res, Cookie: Integer): HResult; +begin + Result := S_OK; +end; + +function TOleCtlIntf.QueryInterface(const IID: TGUID; out Obj): HResult; +begin + if GetInterface(IID, Obj) then Result := S_OK else Result := E_NOINTERFACE; +end; + +function TOleCtlIntf.RemoveMenus(hmenuShared: HMenu): HResult; +begin + while GetMenuItemCount(hmenuShared) > 0 do + RemoveMenu(hmenuShared, 0, MF_BYPOSITION); + Result := S_OK; +end; + +function TOleCtlIntf.RequestBorderSpace( + const borderwidths: TRect): HResult; +begin + Result := INPLACE_E_NOTOOLSPACE; +end; + +function TOleCtlIntf.RequestNewObjectLayout: HResult; +var + Extent: TPoint; + W, H: Integer; + DC: HDC; + PixelsPerInch: Integer; +begin + Result := fOleCtl.FOleObject.GetExtent(DVASPECT_CONTENT, Extent); + if Result <> S_OK then Exit; + + W := fOleCtl.Width; + H := fOleCtl.Height; + if (W = 0) or (H = 0) then + begin + DC := GetDC(0); + PixelsPerInch := GetDeviceCaps(DC, LOGPIXELSY); + ReleaseDC(0, DC); + + W := MulDiv(Extent.X, PixelsPerInch, 2540); + H := MulDiv(Extent.Y, PixelsPerInch, 2540); + if (fOleCtl.FMiscStatus and OLEMISC_INVISIBLEATRUNTIME <> 0) and + (fOleCtl.FOleControl = nil) then + begin + if W > 32 then W := 32; + if H > 32 then H := 32; + end; + end; + fOleCtl.SetBoundsRect( MakeRect( fOleCtl.Left, fOleCtl.Top, + fOleCtl.Left + W, fOleCtl.Top + H ) ); +end; + +function TOleCtlIntf.SaveObject: HResult; +begin + Result := S_OK; +end; + +function TOleCtlIntf.Scroll(scrollExtent: TPoint): HResult; +begin + Result := E_NOTIMPL; +end; + +function TOleCtlIntf.SetActiveObject( + const activeObject: IOleInPlaceActiveObject; + pszObjName: POleStr): HResult; +begin + Result := S_OK; +end; + +function TOleCtlIntf.SetBorderSpace(pborderwidths: PRect): HResult; +begin + Result := E_NOTIMPL; +end; + +function TOleCtlIntf.SetMenu(hmenuShared, holemenu: HMenu; + hwndActiveObject: HWnd): HResult; +var + Menu: HMenu; +begin + Menu := fOleCtl.GetMainMenu; + Result := S_OK; + if Menu <> 0 then + begin + //Menu.SetOle2MenuHandle(hmenuShared); + Result := OleSetMenuDescriptor( holemenu, + fOleCtl.ParentForm.GetWindowHandle, + hwndActiveObject, nil, nil); + end; +end; + +function TOleCtlIntf.SetStatusText(pszStatusText: POleStr): HResult; +begin + Result := S_OK; +end; + +function TOleCtlIntf.ShowObject: HResult; +begin + fOleCtl.HookControlWndProc; + Result := S_OK; +end; + +function TOleCtlIntf.ShowPropertyFrame: HResult; +begin + Result := E_NOTIMPL; +end; + +function TOleCtlIntf.TransformCoords(var ptlHimetric: TPoint; + var ptfContainer: TPointF; flags: Integer): HResult; +var DC: HDC; + PixelsPerInch: Integer; +begin + DC := GetDC(0); + PixelsPerInch := GetDeviceCaps(DC, LOGPIXELSY); + ReleaseDC(0, DC); + + if flags and XFORMCOORDS_HIMETRICTOCONTAINER <> 0 then + begin + ptfContainer.X := MulDiv(ptlHimetric.X, PixelsPerInch, 2540); + ptfContainer.Y := MulDiv(ptlHimetric.Y, PixelsPerInch, 2540); + end else + begin + ptlHimetric.X := Integer(Round(ptfContainer.X * 2540 / PixelsPerInch)); + ptlHimetric.Y := Integer(Round(ptfContainer.Y * 2540 / PixelsPerInch)); + end; + Result := S_OK; +end; + +constructor TOleCtlIntf.Create; +begin + inherited; +end; + + +end. diff --git a/plugins/Libs/BASS_DSHOW.pas b/plugins/Libs/BASS_DSHOW.pas new file mode 100644 index 0000000000..e8778f6f66 --- /dev/null +++ b/plugins/Libs/BASS_DSHOW.pas @@ -0,0 +1,275 @@ +unit BASS_DSHOW; +{ + BASS_DSHOW 2.4 Delphi unit + Copyright (c) 2009-2010 Cristea Aurel Ionut. +} + +interface + +uses + Windows,dynamic_bass; + +const + {BASS_DSHOW Plugin CLSID} + CLSID_DSHOWPLUGIN: TGUID = '{00000000-0000-0000-0000-000000000000}'; + BASS_DSHOW_VERSION = $20401; // API version + BASS_DSHOW_VERSIONTEXT = '2.4.1'; //TEXT version + +type + HENCODE = DWORD; + HWINDOW = DWORD; + HRECORD = DWORD; + +//for Mix_StreamCreate function + TMixingFiles = array[0..15] of PCHAR; + +/////////////CALLBACKS/////////////////// +/// + TCallBackEnumEncoderFilter = function(Filter : Pointer; FilterName: PChar) : BOOL; stdcall; + TCallBackConnectedFilters = function(Filter : Pointer; FilterName: PChar;pp:BOOL;user:pointer) : BOOL; stdcall; + TCallBackEnumDevices = function(device: PChar;user:Pointer) : BOOL; stdcall; + ///////////////////////////////////////// + +//for BASS_DSHOW_ChannelGetInfo function + PBASS_DSVIDEOINFO= ^TBASS_DSVIDEOINFO; + TBASS_DSVIDEOINFO = record + AvgTimePerFrame : Double; + Height, Width : integer; + end; +//for BASS_DSHOW_ChannelSetConfig function + PTTextOverlayStruct = ^TTextOverlayStruct; + TTextOverlayStruct = record + x: integer; //x position + y: integer; //y position + red: integer; + green: integer; + blue : integer; + end; + + PTVideoColors = ^TVideoColors; + TVideoColors=record + HUE: integer; //-180...180 + Contrast: integer; //0...128 + Brightness: integer; //-128...128. + Saturation: integer; //0...128 + end; + +const /////flags + DLLNAME = 'BASS_DSHOW.DLL'; + BASS_DSHOW_DECODE = BASS_STREAM_DECODE; + +//for BASS_DSHOW_SetConfig function + DSHOW_VMRWINDOW = 95; //VMR need an initial window so set a HWND to use properly VMR + BASS_DSHOW_VideoRenderer = 96; + BASS_DSHOW_USEDefault = 97; //pass this to select default video render + BASS_DSHOW_USEOverlay = 98; //pass this to select overlay video render + BASS_DSHOW_USEVMR = 99; //pass this to setconfig option to turn on/off VMR +//for BASS_DSHOW_DVDSetOption + DVD_TITLE = 100; + DVD_ROOT = 101; //go to DVD root + DVD_NEXTCHAPTER = 102; //go to dvd next chapter + DVD_PREVCHAPTER = 103; //go to dvd previous chapter + BD_ShowVideoWindow = 1001; //set this to show/hide video + +// BASS_DSHOW_ChannelSetOption function flags + DSHOW_Overlay = 1002; + DSHOW_OverlayText = 1003; + DSHOW_OverlayProp = 1004; + DSHOW_AVSync = 1005; + DSHOW_CONFIG_PITCH = 1007; + DSHOW_CheckChannel = 1009; //for sync with a channel when first is a decoded one + DSHOW_4p3 = 1010; + DSHOW_16p9 = 1011; + DSHOW_AspectRatio = 1012; + DSHOW_GetBitmap = 1013; + DSHOW_VideoColors = 1014; + DSHOW_EnablePitch = 1015; //2.4.1 +////////MIX FLAGS////////////////////// + BASS_DSHOW_MixRect = 2000; + BASS_DSHOW_MixAlpha = 2001; + +//ERROR CODES + + BASS_DSHOW_OK = 104; //all is ok + BASS_DSHOW_INVALIDCHAN = 113; //invalid channel + BASS_DSHOW_BADFILENAME = 105; + BASS_DSHOW_Unknown = 106; + BASS_DSHOW_ERROR1 = 107; //this is returned by set dvd menu function + BASS_DSHOW_ERROR2 = 108; // next chapter failed + BASS_DSHOW_ERROR3 = 109; //prev chapter failed + BASS_DSHOW_ERROR4 = 110; // title menu failed + BASS_DSHOW_ERROR5 = 111; //graph creation failed + BASS_DSHOW_ERROR6 = 112; //DVD Graph creation failed + BASS_DSHOW_ERROR7 = 114; + BASS_DSHOW_ERROR8 = 115; //NO DVD Decoder found + +//Converter Flags/// + Convert_EncoderVideo = 3000; + Convert_EncoderAudio = 3001; + Convert_AudioCompressor = 3002; + Convert_VideoCompressor = 3003; + + Convert_DisableAudio = 3005; //convert only audio. Disables video +//Profiles + Convert_ToAvi = 3007; //convert to avi + Convert_ToWMV = 3008; //convert to WMV + Convert_ToWAV = 3009; //convert to WAV + +///Recorder Flags/// + Record_AudioDevice = 5000; + Record_VideoDevice = 5001; + +/// +/// +var BASS_DSHOW_StreamCreateURL :function(str: PCHAR;flags: DWORD): HSTREAM; stdcall; +var BASS_DSHOW_StreamCreateFile:function(str: PCHAR;flags: DWORD): HSTREAM; stdcall; +var BASS_DSHOW_StreamFree :function(chan: HStream): bool; stdcall; +var BASS_DSHOW_StreamCreateDVD :function():HSTREAM; stdcall; + +var BASS_DSHOW_Init:function(handle: HWND):bool; stdcall; +var BASS_DSHOW_Free:function(): BOOL; stdcall; + +var BASS_DSHOW_ChannelSetPosition :procedure(chan: HSTREAM;pos: QWORD); stdcall; +var BASS_DSHOW_ChannelGetLength :function (chan: HSTREAM): QWORD; stdcall; +var BASS_DSHOW_ChannelGetPosition :function (chan: HSTREAM): QWORD; stdcall; +var BASS_DSHOW_ChannelSetWindow :procedure(chan: HSTREAM;handle: HWND); stdcall; +var BASS_DSHOW_ChannelResizeWindow :procedure(chan: HSTREAM;left,top,right,bottom: integer); stdcall; +var BASS_DSHOW_ChannelSetFullscreen :procedure(chan: HSTREAM;value: boolean); stdcall; +var BASS_DSHOW_ChannelPlay :function (chan: HSTREAM):bool; stdcall; +var BASS_DSHOW_ChannelPause :function (chan: HSTREAM):bool; stdcall; +var BASS_DSHOW_ChannelStop :function (chan: HStream): bool; stdcall; +var BASS_DSHOW_ChannelGetInfo :procedure(chan: HSTREAM;value: PBASS_DSVIDEOINFO);stdcall; +var BASS_DSHOW_ChannelSetOption :procedure(chan:HSTREAM;option:DWORD;value:DWORD;value2: pointer); stdcall; +var BASS_DSHOW_ChannelGetConnectedFilters:procedure(chan: HSTREAM;callback :Pointer;user:Pointer); stdcall; //2.4.1 +var BASS_DSHOW_ChannelSetTextOverlay :procedure(chan: HSTREAM ;text:PCHAR;x, y, red, green, blue: integer); stdcall; +var BASS_DSHOW_ChannelAddWindow :function(chan:HSTREAM;win:HWND): HWINDOW; stdcall; + +var BASS_DSHOW_DVDSetOption:function(chan: HStream;option: DWORD): bool; stdcall; +var BASS_DSHOW_SetConfig :procedure(config: integer;value: integer); stdcall; +var BASS_DSHOW_ErrorGetCode:function(): DWORD; stdcall; +var BASS_DSHOW_LoadPlugin :procedure(str: pchar;guid :TGUID;name: PCHAR); stdcall; +var BASS_DSHOW_LoadPlugin2 :procedure(str: Pointer;guid :Pointer;name: Pointer;flags: DWORD); stdcall; +var BASS_DSHOW_GetVersion :function(): DWORD; stdcall; + +var BASS_DSHOW_ShowFilterPropertyPage:procedure(chan:HSTREAM;filter:DWORD;hndparent: HWND); stdcall; //2.4.1 +var BASS_DSHOW_MIX_StreamCreateFile:function(files: TMixingFiles;fileno:integer;flags: DWORD): HSTREAM; stdcall; +var BASS_DSHOW_MIX_ChanOptions :function(chan: HSTREAM;option:DWORD;value: DWORD;value2: DWORD;rect: TRECT): BOOL; stdcall; + +//////// STILL TEsting encoding////// +var BASS_DSHOW_Encode_GetCodecs :function(CodecsType:DWORD;callback: Pointer):integer; stdcall; +var BASS_DSHOW_Encode_GetProfiles :function(CodecsType:DWORD;callback: Pointer):integer; stdcall; +var BASS_DSHOW_Encode_StreamCreate:function(inFile: PCHAR;outFile:PChar): HENCODE; stdcall; +var BASS_DSHOW_Encode_Start :function(hnd: HENCODE;profile:DWORD;flags: DWORD): BOOL; stdcall; +var BASS_DSHOW_Encode_Stop :function(hnd: HENCODE): BOOL; stdcall; +var BASS_DSHOW_Encode_GetPosition :function(hnd: HENCODE): DWORD; stdcall; +var BASS_DSHOW_Encode_SetEncoder :function(hnd:HENCODE;enctype: DWORD;encoder: DWORD): BOOL; stdcall; + +/////// +var BASS_DSHOW_Record_GetDevices:function(devicetype: DWORD;callback: Pointer;user: Pointer): integer; stdcall; +var BASS_DSHOW_RecordStart :function(audiodevice: Integer;videodevice: Integer;devicetype: DWORD;flags: DWORD): HRECORD; stdcall; +var BASS_DSHOW_RecordFree :function(rec: HRECORD): BOOL; stdcall; + +implementation +// END OF FILE ///////////////////////////////////////////////////////////////// + +procedure SetProcs(handle:THANDLE); +begin + @BASS_DSHOW_StreamCreateURL :=GetProcAddress(handle, 'BASS_DSHOW_StreamCreateURL'); + @BASS_DSHOW_StreamCreateFile:=GetProcAddress(handle, 'BASS_DSHOW_StreamCreateFile'); + @BASS_DSHOW_StreamFree :=GetProcAddress(handle, 'BASS_DSHOW_StreamFree'); + @BASS_DSHOW_StreamCreateDVD :=GetProcAddress(handle, 'BASS_DSHOW_StreamCreateDVD'); + + @BASS_DSHOW_Init:=GetProcAddress(handle, 'BASS_DSHOW_Init'); + @BASS_DSHOW_Free:=GetProcAddress(handle, 'BASS_DSHOW_Free'); + + @BASS_DSHOW_ChannelSetPosition :=GetProcAddress(handle, 'BASS_DSHOW_ChannelSetPosition'); + @BASS_DSHOW_ChannelGetLength :=GetProcAddress(handle, 'BASS_DSHOW_ChannelGetLength'); + @BASS_DSHOW_ChannelGetPosition :=GetProcAddress(handle, 'BASS_DSHOW_ChannelGetPosition'); + @BASS_DSHOW_ChannelSetWindow :=GetProcAddress(handle, 'BASS_DSHOW_ChannelSetWindow'); + @BASS_DSHOW_ChannelResizeWindow :=GetProcAddress(handle, 'BASS_DSHOW_ChannelResizeWindow'); + @BASS_DSHOW_ChannelSetFullscreen :=GetProcAddress(handle, 'BASS_DSHOW_ChannelSetFullscreen'); + @BASS_DSHOW_ChannelPlay :=GetProcAddress(handle, 'BASS_DSHOW_ChannelPlay'); + @BASS_DSHOW_ChannelPause :=GetProcAddress(handle, 'BASS_DSHOW_ChannelPause'); + @BASS_DSHOW_ChannelStop :=GetProcAddress(handle, 'BASS_DSHOW_ChannelStop'); + @BASS_DSHOW_ChannelGetInfo :=GetProcAddress(handle, 'BASS_DSHOW_ChannelGetInfo'); + @BASS_DSHOW_ChannelSetOption :=GetProcAddress(handle, 'BASS_DSHOW_ChannelSetOption'); + @BASS_DSHOW_ChannelGetConnectedFilters:=GetProcAddress(handle, 'BASS_DSHOW_ChannelGetConnectedFilters'); + @BASS_DSHOW_ChannelSetTextOverlay :=GetProcAddress(handle, 'BASS_DSHOW_ChannelSetTextOverlay'); + @BASS_DSHOW_ChannelAddWindow :=GetProcAddress(handle, 'BASS_DSHOW_ChannelAddWindow'); + + @BASS_DSHOW_DVDSetOption:=GetProcAddress(handle, 'BASS_DSHOW_DVDSetOption'); + @BASS_DSHOW_SetConfig :=GetProcAddress(handle, 'BASS_DSHOW_SetConfig'); + @BASS_DSHOW_ErrorGetCode:=GetProcAddress(handle, 'BASS_DSHOW_ErrorGetCode'); + @BASS_DSHOW_LoadPlugin :=GetProcAddress(handle, 'BASS_DSHOW_LoadPlugin'); + @BASS_DSHOW_LoadPlugin2 :=GetProcAddress(handle, 'BASS_DSHOW_LoadPlugin2'); + @BASS_DSHOW_GetVersion :=GetProcAddress(handle, 'BASS_DSHOW_GetVersion'); + + @BASS_DSHOW_ShowFilterPropertyPage:=GetProcAddress(handle, 'BASS_DSHOW_ShowFilterPropertyPage'); + @BASS_DSHOW_MIX_StreamCreateFile:=GetProcAddress(handle, 'BASS_DSHOW_MIX_StreamCreateFile'); + @BASS_DSHOW_MIX_ChanOptions :=GetProcAddress(handle, 'BASS_DSHOW_MIX_ChanOptions'); + + @BASS_DSHOW_Encode_GetCodecs :=GetProcAddress(handle, 'BASS_DSHOW_Encode_GetCodecs'); + @BASS_DSHOW_Encode_GetProfiles :=GetProcAddress(handle, 'BASS_DSHOW_Encode_GetProfiles'); + @BASS_DSHOW_Encode_StreamCreate:=GetProcAddress(handle, 'BASS_DSHOW_Encode_StreamCreate'); + @BASS_DSHOW_Encode_Start :=GetProcAddress(handle, 'BASS_DSHOW_Encode_Start'); + @BASS_DSHOW_Encode_Stop :=GetProcAddress(handle, 'BASS_DSHOW_Encode_Stop'); + @BASS_DSHOW_Encode_GetPosition :=GetProcAddress(handle, 'BASS_DSHOW_Encode_GetPosition'); + @BASS_DSHOW_Encode_SetEncoder :=GetProcAddress(handle, 'BASS_DSHOW_Encode_SetEncoder'); + + @BASS_DSHOW_Record_GetDevices:=GetProcAddress(handle, 'BASS_DSHOW_Record_GetDevices'); + @BASS_DSHOW_RecordStart :=GetProcAddress(handle, 'BASS_DSHOW_RecordStart'); + @BASS_DSHOW_RecordFree :=GetProcAddress(handle, 'BASS_DSHOW_RecordFree'); + +end; + +const + DSHOW_Handle:THANDLE = 0; + from:integer = 0; + +function InitDSHOW:bool; +var + info:PBASS_PLUGININFO; + i:dword; + pHPlugin:^HPLUGIN; +begin + if DSHOW_Handle<>0 then + begin + result:=true; + exit; + end; + result:=false; + pHPlugin:=pointer(BASS_PluginGetInfo(0)); + if pHPlugin=nil then exit; + while pHPlugin^<>0 do + begin + info:=BASS_PluginGetInfo(pHPlugin^); + i:=0; + while i0 then + begin {now we tie the functions to the VARs from above} + + @BASS_SetConfig :=GetProcAddress(BASS_Handle,PAnsiChar('BASS_SetConfig')); + {$IFDEF CHECK_PROC}if @BASS_SetConfig=nil then goto L_Exit;{$ENDIF} + @BASS_GetConfig :=GetProcAddress(BASS_Handle,PAnsiChar('BASS_GetConfig')); + {$IFDEF CHECK_PROC}if @BASS_GetConfig=nil then goto L_Exit;{$ENDIF} + @BASS_SetConfigPtr :=GetProcAddress(BASS_Handle,PAnsiChar('BASS_SetConfigPtr')); + {$IFDEF CHECK_PROC}if @BASS_SetConfigPtr=nil then goto L_Exit;{$ENDIF} + @BASS_GetConfigPtr :=GetProcAddress(BASS_Handle,PAnsiChar('BASS_GetConfigPtr')); + {$IFDEF CHECK_PROC}if @BASS_GetConfigPtr=nil then goto L_Exit;{$ENDIF} + @BASS_GetVersion :=GetProcAddress(BASS_Handle,PAnsiChar('BASS_GetVersion')); + {$IFDEF CHECK_PROC}if @BASS_GetVersion=nil then goto L_Exit;{$ENDIF} + @BASS_ErrorGetCode :=GetProcAddress(BASS_Handle,PAnsiChar('BASS_ErrorGetCode')); + {$IFDEF CHECK_PROC}if @BASS_ErrorGetCode=nil then goto L_Exit;{$ENDIF} + @BASS_GetDeviceInfo :=GetProcAddress(BASS_Handle,PAnsiChar('BASS_GetDeviceInfo')); + {$IFDEF CHECK_PROC}if @BASS_GetDeviceInfo=nil then goto L_Exit;{$ENDIF} + @BASS_Init :=GetProcAddress(BASS_Handle,PAnsiChar('BASS_Init')); + {$IFDEF CHECK_PROC}if @BASS_Init=nil then goto L_Exit;{$ENDIF} + @BASS_SetDevice :=GetProcAddress(BASS_Handle,PAnsiChar('BASS_SetDevice')); + {$IFDEF CHECK_PROC}if @BASS_SetDevice=nil then goto L_Exit;{$ENDIF} + @BASS_GetDevice :=GetProcAddress(BASS_Handle,PAnsiChar('BASS_GetDevice')); + {$IFDEF CHECK_PROC}if @BASS_GetDevice=nil then goto L_Exit;{$ENDIF} + @BASS_Free :=GetProcAddress(BASS_Handle,PAnsiChar('BASS_Free')); + {$IFDEF CHECK_PROC}if @BASS_Free=nil then goto L_Exit;{$ENDIF} + @BASS_GetDSoundObject:=GetProcAddress(BASS_Handle,PAnsiChar('BASS_GetDSoundObject')); + {$IFDEF CHECK_PROC}if @BASS_GetDSoundObject=nil then goto L_Exit;{$ENDIF} + @BASS_GetInfo :=GetProcAddress(BASS_Handle,PAnsiChar('BASS_GetInfo')); + {$IFDEF CHECK_PROC}if @BASS_GetInfo=nil then goto L_Exit;{$ENDIF} + @BASS_Update :=GetProcAddress(BASS_Handle,PAnsiChar('BASS_Update')); + {$IFDEF CHECK_PROC}if @BASS_Update=nil then goto L_Exit;{$ENDIF} + @BASS_GetCPU :=GetProcAddress(BASS_Handle,PAnsiChar('BASS_GetCPU')); + {$IFDEF CHECK_PROC}if @BASS_GetCPU=nil then goto L_Exit;{$ENDIF} + @BASS_Start :=GetProcAddress(BASS_Handle,PAnsiChar('BASS_Start')); + {$IFDEF CHECK_PROC}if @BASS_Start=nil then goto L_Exit;{$ENDIF} + @BASS_Stop :=GetProcAddress(BASS_Handle,PAnsiChar('BASS_Stop')); + {$IFDEF CHECK_PROC}if @BASS_Stop=nil then goto L_Exit;{$ENDIF} + @BASS_Pause :=GetProcAddress(BASS_Handle,PAnsiChar('BASS_Pause')); + {$IFDEF CHECK_PROC}if @BASS_Pause=nil then goto L_Exit;{$ENDIF} + @BASS_SetVolume :=GetProcAddress(BASS_Handle,PAnsiChar('BASS_SetVolume')); + {$IFDEF CHECK_PROC}if @BASS_SetVolume=nil then goto L_Exit;{$ENDIF} + @BASS_GetVolume :=GetProcAddress(BASS_Handle,PAnsiChar('BASS_GetVolume')); + {$IFDEF CHECK_PROC}if @BASS_GetVolume=nil then goto L_Exit;{$ENDIF} + + @BASS_PluginLoad_ :=GetProcAddress(BASS_Handle,PAnsiChar('BASS_PluginLoad')); + {$IFDEF CHECK_PROC}if @BASS_PluginLoad_=nil then goto L_Exit;{$ENDIF} + @BASS_PluginFree_ :=GetProcAddress(BASS_Handle,PAnsiChar('BASS_PluginFree')); + {$IFDEF CHECK_PROC}if @BASS_PluginFree_=nil then goto L_Exit;{$ENDIF} + @BASS_PluginGetInfo_:=GetProcAddress(BASS_Handle,PAnsiChar('BASS_PluginGetInfo')); + {$IFDEF CHECK_PROC}if @BASS_PluginGetInfo_=nil then goto L_Exit;{$ENDIF} + + @BASS_Set3DFactors :=GetProcAddress(BASS_Handle,PAnsiChar('BASS_Set3DFactors')); + {$IFDEF CHECK_PROC}if @BASS_Set3DFactors=nil then goto L_Exit;{$ENDIF} + @BASS_Get3DFactors :=GetProcAddress(BASS_Handle,PAnsiChar('BASS_Get3DFactors')); + {$IFDEF CHECK_PROC}if @BASS_Get3DFactors=nil then goto L_Exit;{$ENDIF} + @BASS_Set3DPosition :=GetProcAddress(BASS_Handle,PAnsiChar('BASS_Set3DPosition')); + {$IFDEF CHECK_PROC}if @BASS_Set3DPosition=nil then goto L_Exit;{$ENDIF} + @BASS_Get3DPosition :=GetProcAddress(BASS_Handle,PAnsiChar('BASS_Get3DPosition')); + {$IFDEF CHECK_PROC}if @BASS_Get3DPosition=nil then goto L_Exit;{$ENDIF} + @BASS_Apply3D :=GetProcAddress(BASS_Handle,PAnsiChar('BASS_Apply3D')); + {$IFDEF CHECK_PROC}if @BASS_Apply3D=nil then goto L_Exit;{$ENDIF} + @BASS_SetEAXParameters:=GetProcAddress(BASS_Handle,PAnsiChar('BASS_SetEAXParameters')); + {$IFDEF CHECK_PROC}if @BASS_SetEAXParameters=nil then goto L_Exit;{$ENDIF} + @BASS_GetEAXParameters:=GetProcAddress(BASS_Handle,PAnsiChar('BASS_GetEAXParameters')); + {$IFDEF CHECK_PROC}if @BASS_GetEAXParameters=nil then goto L_Exit;{$ENDIF} + + @BASS_MusicLoad:=GetProcAddress(BASS_Handle,PAnsiChar('BASS_MusicLoad')); + {$IFDEF CHECK_PROC}if @BASS_MusicLoad=nil then goto L_Exit;{$ENDIF} + @BASS_MusicFree:=GetProcAddress(BASS_Handle,PAnsiChar('BASS_MusicFree')); + {$IFDEF CHECK_PROC}if @BASS_MusicFree=nil then goto L_Exit;{$ENDIF} + + @BASS_SampleLoad :=GetProcAddress(BASS_Handle,PAnsiChar('BASS_SampleLoad')); + {$IFDEF CHECK_PROC}if @BASS_SampleLoad=nil then goto L_Exit;{$ENDIF} + @BASS_SampleCreate :=GetProcAddress(BASS_Handle,PAnsiChar('BASS_SampleCreate')); + {$IFDEF CHECK_PROC}if @BASS_SampleCreate=nil then goto L_Exit;{$ENDIF} + @BASS_SampleFree :=GetProcAddress(BASS_Handle,PAnsiChar('BASS_SampleFree')); + {$IFDEF CHECK_PROC}if @BASS_SampleFree=nil then goto L_Exit;{$ENDIF} + @BASS_SampleSetData :=GetProcAddress(BASS_Handle,PAnsiChar('BASS_SampleSetData')); + {$IFDEF CHECK_PROC}if @BASS_SampleSetData=nil then goto L_Exit;{$ENDIF} + @BASS_SampleGetData :=GetProcAddress(BASS_Handle,PAnsiChar('BASS_SampleGetData')); + {$IFDEF CHECK_PROC}if @BASS_SampleGetData=nil then goto L_Exit;{$ENDIF} + @BASS_SampleGetInfo :=GetProcAddress(BASS_Handle,PAnsiChar('BASS_SampleGetInfo')); + {$IFDEF CHECK_PROC}if @BASS_SampleGetInfo=nil then goto L_Exit;{$ENDIF} + @BASS_SampleSetInfo :=GetProcAddress(BASS_Handle,PAnsiChar('BASS_SampleSetInfo')); + {$IFDEF CHECK_PROC}if @BASS_SampleSetInfo=nil then goto L_Exit;{$ENDIF} + @BASS_SampleGetChannel :=GetProcAddress(BASS_Handle,PAnsiChar('BASS_SampleGetChannel')); + {$IFDEF CHECK_PROC}if @BASS_SampleGetChannel=nil then goto L_Exit;{$ENDIF} + @BASS_SampleGetChannels:=GetProcAddress(BASS_Handle,PAnsiChar('BASS_SampleGetChannels')); + {$IFDEF CHECK_PROC}if @BASS_SampleGetChannels=nil then goto L_Exit;{$ENDIF} + @BASS_SampleStop :=GetProcAddress(BASS_Handle,PAnsiChar('BASS_SampleStop')); + {$IFDEF CHECK_PROC}if @BASS_SampleStop=nil then goto L_Exit;{$ENDIF} + + @BASS_StreamCreate :=GetProcAddress(BASS_Handle,PAnsiChar('BASS_StreamCreate')); + {$IFDEF CHECK_PROC}if @BASS_StreamCreate=nil then goto L_Exit;{$ENDIF} + @BASS_StreamCreateFile :=GetProcAddress(BASS_Handle,PAnsiChar('BASS_StreamCreateFile')); + {$IFDEF CHECK_PROC}if @BASS_StreamCreateFile=nil then goto L_Exit;{$ENDIF} + @BASS_StreamCreateURL :=GetProcAddress(BASS_Handle,PAnsiChar('BASS_StreamCreateURL')); + {$IFDEF CHECK_PROC}if @BASS_StreamCreateURL=nil then goto L_Exit;{$ENDIF} + @BASS_StreamCreateFileUser :=GetProcAddress(BASS_Handle,PAnsiChar('BASS_StreamCreateFileUser')); + {$IFDEF CHECK_PROC}if @BASS_StreamCreateFileUser=nil then goto L_Exit;{$ENDIF} + @BASS_StreamFree :=GetProcAddress(BASS_Handle,PAnsiChar('BASS_StreamFree')); + {$IFDEF CHECK_PROC}if @BASS_StreamFree=nil then goto L_Exit;{$ENDIF} + @BASS_StreamGetFilePosition:=GetProcAddress(BASS_Handle,PAnsiChar('BASS_StreamGetFilePosition')); + {$IFDEF CHECK_PROC}if @BASS_StreamGetFilePosition=nil then goto L_Exit;{$ENDIF} + @BASS_StreamPutData :=GetProcAddress(BASS_Handle,PAnsiChar('BASS_StreamPutData')); + {$IFDEF CHECK_PROC}if @BASS_StreamPutData=nil then goto L_Exit;{$ENDIF} + @BASS_StreamPutFileData :=GetProcAddress(BASS_Handle,PAnsiChar('BASS_StreamPutFileData')); + {$IFDEF CHECK_PROC}if @BASS_StreamPutFileData=nil then goto L_Exit;{$ENDIF} + + @BASS_RecordGetDeviceInfo:=GetProcAddress(BASS_Handle,PAnsiChar('BASS_RecordGetDeviceInfo')); + {$IFDEF CHECK_PROC}if @BASS_RecordGetDeviceInfo=nil then goto L_Exit;{$ENDIF} + @BASS_RecordInit :=GetProcAddress(BASS_Handle,PAnsiChar('BASS_RecordInit')); + {$IFDEF CHECK_PROC}if @BASS_RecordInit=nil then goto L_Exit;{$ENDIF} + @BASS_RecordSetDevice :=GetProcAddress(BASS_Handle,PAnsiChar('BASS_RecordSetDevice')); + {$IFDEF CHECK_PROC}if @BASS_RecordSetDevice=nil then goto L_Exit;{$ENDIF} + @BASS_RecordGetDevice :=GetProcAddress(BASS_Handle,PAnsiChar('BASS_RecordGetDevice')); + {$IFDEF CHECK_PROC}if @BASS_RecordGetDevice=nil then goto L_Exit;{$ENDIF} + @BASS_RecordFree :=GetProcAddress(BASS_Handle,PAnsiChar('BASS_RecordFree')); + {$IFDEF CHECK_PROC}if @BASS_RecordFree=nil then goto L_Exit;{$ENDIF} + @BASS_RecordGetInfo :=GetProcAddress(BASS_Handle,PAnsiChar('BASS_RecordGetInfo')); + {$IFDEF CHECK_PROC}if @BASS_RecordGetInfo=nil then goto L_Exit;{$ENDIF} + @BASS_RecordGetInputName :=GetProcAddress(BASS_Handle,PAnsiChar('BASS_RecordGetInputName')); + {$IFDEF CHECK_PROC}if @BASS_RecordGetInputName=nil then goto L_Exit;{$ENDIF} + @BASS_RecordSetInput :=GetProcAddress(BASS_Handle,PAnsiChar('BASS_RecordSetInput')); + {$IFDEF CHECK_PROC}if @BASS_RecordSetInput=nil then goto L_Exit;{$ENDIF} + @BASS_RecordGetInput :=GetProcAddress(BASS_Handle,PAnsiChar('BASS_RecordGetInput')); + {$IFDEF CHECK_PROC}if @BASS_RecordGetInput=nil then goto L_Exit;{$ENDIF} + @BASS_RecordStart :=GetProcAddress(BASS_Handle,PAnsiChar('BASS_RecordStart')); + {$IFDEF CHECK_PROC}if @BASS_RecordStart=nil then goto L_Exit;{$ENDIF} + + @BASS_ChannelBytes2Seconds :=GetProcAddress(BASS_Handle,PAnsiChar('BASS_ChannelBytes2Seconds')); + {$IFDEF CHECK_PROC}if @BASS_ChannelBytes2Seconds=nil then goto L_Exit;{$ENDIF} + @BASS_ChannelSeconds2Bytes :=GetProcAddress(BASS_Handle,PAnsiChar('BASS_ChannelSeconds2Bytes')); + {$IFDEF CHECK_PROC}if @BASS_ChannelSeconds2Bytes=nil then goto L_Exit;{$ENDIF} + @BASS_ChannelGetDevice :=GetProcAddress(BASS_Handle,PAnsiChar('BASS_ChannelGetDevice')); + {$IFDEF CHECK_PROC}if @BASS_ChannelGetDevice=nil then goto L_Exit;{$ENDIF} + @BASS_ChannelSetDevice :=GetProcAddress(BASS_Handle,PAnsiChar('BASS_ChannelSetDevice')); + {$IFDEF CHECK_PROC}if @BASS_ChannelSetDevice=nil then goto L_Exit;{$ENDIF} + @BASS_ChannelIsActive :=GetProcAddress(BASS_Handle,PAnsiChar('BASS_ChannelIsActive')); + {$IFDEF CHECK_PROC}if @BASS_ChannelIsActive=nil then goto L_Exit;{$ENDIF} + @BASS_ChannelGetInfo :=GetProcAddress(BASS_Handle,PAnsiChar('BASS_ChannelGetInfo')); + {$IFDEF CHECK_PROC}if @BASS_ChannelGetInfo=nil then goto L_Exit;{$ENDIF} + @BASS_ChannelGetTags :=GetProcAddress(BASS_Handle,PAnsiChar('BASS_ChannelGetTags')); + {$IFDEF CHECK_PROC}if @BASS_ChannelGetTags=nil then goto L_Exit;{$ENDIF} + @BASS_ChannelFlags :=GetProcAddress(BASS_Handle,PAnsiChar('BASS_ChannelFlags')); + {$IFDEF CHECK_PROC}if @BASS_ChannelFlags=nil then goto L_Exit;{$ENDIF} + @BASS_ChannelUpdate :=GetProcAddress(BASS_Handle,PAnsiChar('BASS_ChannelUpdate')); + {$IFDEF CHECK_PROC}if @BASS_ChannelUpdate=nil then goto L_Exit;{$ENDIF} + @BASS_ChannelLock :=GetProcAddress(BASS_Handle,PAnsiChar('BASS_ChannelLock')); + {$IFDEF CHECK_PROC}if @BASS_ChannelLock=nil then goto L_Exit;{$ENDIF} + @BASS_ChannelPlay :=GetProcAddress(BASS_Handle,PAnsiChar('BASS_ChannelPlay')); + {$IFDEF CHECK_PROC}if @BASS_ChannelPlay=nil then goto L_Exit;{$ENDIF} + @BASS_ChannelStop :=GetProcAddress(BASS_Handle,PAnsiChar('BASS_ChannelStop')); + {$IFDEF CHECK_PROC}if @BASS_ChannelStop=nil then goto L_Exit;{$ENDIF} + @BASS_ChannelPause :=GetProcAddress(BASS_Handle,PAnsiChar('BASS_ChannelPause')); + {$IFDEF CHECK_PROC}if @BASS_ChannelPause=nil then goto L_Exit;{$ENDIF} + @BASS_ChannelSetAttribute :=GetProcAddress(BASS_Handle,PAnsiChar('BASS_ChannelSetAttribute')); + {$IFDEF CHECK_PROC}if @BASS_ChannelSetAttribute=nil then goto L_Exit;{$ENDIF} + @BASS_ChannelGetAttribute :=GetProcAddress(BASS_Handle,PAnsiChar('BASS_ChannelGetAttribute')); + {$IFDEF CHECK_PROC}if @BASS_ChannelGetAttribute=nil then goto L_Exit;{$ENDIF} + @BASS_ChannelSlideAttribute :=GetProcAddress(BASS_Handle,PAnsiChar('BASS_ChannelSlideAttribute')); + {$IFDEF CHECK_PROC}if @BASS_ChannelSlideAttribute=nil then goto L_Exit;{$ENDIF} + @BASS_ChannelIsSliding :=GetProcAddress(BASS_Handle,PAnsiChar('BASS_ChannelIsSliding')); + {$IFDEF CHECK_PROC}if @BASS_ChannelIsSliding=nil then goto L_Exit;{$ENDIF} + @BASS_ChannelSet3DAttributes:=GetProcAddress(BASS_Handle,PAnsiChar('BASS_ChannelSet3DAttributes')); + {$IFDEF CHECK_PROC}if @BASS_ChannelSet3DAttributes=nil then goto L_Exit;{$ENDIF} + @BASS_ChannelGet3DAttributes:=GetProcAddress(BASS_Handle,PAnsiChar('BASS_ChannelGet3DAttributes')); + {$IFDEF CHECK_PROC}if @BASS_ChannelGet3DAttributes=nil then goto L_Exit;{$ENDIF} + @BASS_ChannelSet3DPosition :=GetProcAddress(BASS_Handle,PAnsiChar('BASS_ChannelSet3DPosition')); + {$IFDEF CHECK_PROC}if @BASS_ChannelSet3DPosition=nil then goto L_Exit;{$ENDIF} + @BASS_ChannelGet3DPosition :=GetProcAddress(BASS_Handle,PAnsiChar('BASS_ChannelGet3DPosition')); + {$IFDEF CHECK_PROC}if @BASS_ChannelGet3DPosition=nil then goto L_Exit;{$ENDIF} + @BASS_ChannelGetLength :=GetProcAddress(BASS_Handle,PAnsiChar('BASS_ChannelGetLength')); + {$IFDEF CHECK_PROC}if @BASS_ChannelGetLength=nil then goto L_Exit;{$ENDIF} + @BASS_ChannelSetPosition :=GetProcAddress(BASS_Handle,PAnsiChar('BASS_ChannelSetPosition')); + {$IFDEF CHECK_PROC}if @BASS_ChannelSetPosition=nil then goto L_Exit;{$ENDIF} + @BASS_ChannelGetPosition :=GetProcAddress(BASS_Handle,PAnsiChar('BASS_ChannelGetPosition')); + {$IFDEF CHECK_PROC}if @BASS_ChannelGetPosition=nil then goto L_Exit;{$ENDIF} + @BASS_ChannelGetLevel :=GetProcAddress(BASS_Handle,PAnsiChar('BASS_ChannelGetLevel')); + {$IFDEF CHECK_PROC}if @BASS_ChannelGetLevel=nil then goto L_Exit;{$ENDIF} + @BASS_ChannelGetData :=GetProcAddress(BASS_Handle,PAnsiChar('BASS_ChannelGetData')); + {$IFDEF CHECK_PROC}if @BASS_ChannelGetData=nil then goto L_Exit;{$ENDIF} + @BASS_ChannelSetSync :=GetProcAddress(BASS_Handle,PAnsiChar('BASS_ChannelSetSync')); + {$IFDEF CHECK_PROC}if @BASS_ChannelSetSync=nil then goto L_Exit;{$ENDIF} + @BASS_ChannelRemoveSync :=GetProcAddress(BASS_Handle,PAnsiChar('BASS_ChannelRemoveSync')); + {$IFDEF CHECK_PROC}if @BASS_ChannelRemoveSync=nil then goto L_Exit;{$ENDIF} + @BASS_ChannelSetDSP :=GetProcAddress(BASS_Handle,PAnsiChar('BASS_ChannelSetDSP')); + {$IFDEF CHECK_PROC}if @BASS_ChannelSetDSP=nil then goto L_Exit;{$ENDIF} + @BASS_ChannelRemoveDSP :=GetProcAddress(BASS_Handle,PAnsiChar('BASS_ChannelRemoveDSP')); + {$IFDEF CHECK_PROC}if @BASS_ChannelRemoveDSP=nil then goto L_Exit;{$ENDIF} + @BASS_ChannelSetLink :=GetProcAddress(BASS_Handle,PAnsiChar('BASS_ChannelSetLink')); + {$IFDEF CHECK_PROC}if @BASS_ChannelSetLink=nil then goto L_Exit;{$ENDIF} + @BASS_ChannelRemoveLink :=GetProcAddress(BASS_Handle,PAnsiChar('BASS_ChannelRemoveLink')); + {$IFDEF CHECK_PROC}if @BASS_ChannelRemoveLink=nil then goto L_Exit;{$ENDIF} + @BASS_ChannelSetFX :=GetProcAddress(BASS_Handle,PAnsiChar('BASS_ChannelSetFX')); + {$IFDEF CHECK_PROC}if @BASS_ChannelSetFX=nil then goto L_Exit;{$ENDIF} + @BASS_ChannelRemoveFX :=GetProcAddress(BASS_Handle,PAnsiChar('BASS_ChannelRemoveFX')); + {$IFDEF CHECK_PROC}if @BASS_ChannelRemoveFX=nil then goto L_Exit;{$ENDIF} + + @BASS_FXSetParameters:=GetProcAddress(BASS_Handle,PAnsiChar('BASS_FXSetParameters')); + {$IFDEF CHECK_PROC}if @BASS_FXSetParameters=nil then goto L_Exit;{$ENDIF} + @BASS_FXGetParameters:=GetProcAddress(BASS_Handle,PAnsiChar('BASS_FXGetParameters')); + {$IFDEF CHECK_PROC}if @BASS_FXGetParameters=nil then goto L_Exit;{$ENDIF} + @BASS_FXReset :=GetProcAddress(BASS_Handle,PAnsiChar('BASS_FXReset')); + {$IFDEF CHECK_PROC}if @BASS_FXReset=nil then goto L_Exit;{$ENDIF} + + result:=true; + exit; +{$IFDEF CHECK_PROC} +L_Exit: + FreeLibrary(BASS_Handle); + BASS_Handle:=0; +{$ENDIF} + end; + result:=false; +end; + +Function Load_BASSDLL(dllfilename:PAnsiChar):boolean; +var + oldmode:integer; +begin + if BASS_Handle<>0 then result:=true + else + begin + oldmode:=SetErrorMode($8001); + BASS_Handle:=LoadLibraryA(dllfilename); + SetErrorMode(oldmode); + result:=CheckBASSHandle; + end; +end; + +Function Load_BASSDLL(dllfilename:PWideChar):boolean; +var + oldmode:integer; +begin + if BASS_Handle<>0 then result:=true + else + begin + oldmode:=SetErrorMode($8001); + BASS_Handle:=LoadLibraryW(dllfilename); + SetErrorMode(oldmode); + result:=CheckBASSHandle; + end; +end; + +Procedure Unload_BASSDLL; +begin + if BASS_Handle<>0 then + begin + BASS_Free; // make sure we release everything + FreeLibrary(BASS_Handle); + end; + BASS_Handle:=0; +end; + +function BASS_SPEAKER_N(n: DWORD): DWORD; +begin + Result := n shl 24; +end; + +type + tEAXrec = record + vol , + decay, + damp : FLOAT; + end; + +const + EAXTable : array [0..EAX_ENVIRONMENT_COUNT-1] of tEAXRec = ( + (vol:0.5 ; decay: 1.493; damp:0.5 ), + (vol:0.25 ; decay: 0.1 ; damp:0 ), + (vol:0.417; decay: 0.4 ; damp:0.666), + (vol:0.653; decay: 1.499; damp:0.166), + (vol:0.208; decay: 0.478; damp:0 ), + (vol:0.5 ; decay: 2.309; damp:0.888), + (vol:0.403; decay: 4.279; damp:0.5 ), + (vol:0.5 ; decay: 3.961; damp:0.5 ), + (vol:0.5 ; decay: 2.886; damp:1.304), + (vol:0.361; decay: 7.284; damp:0.332), + (vol:0.5 ; decay:10.0 ; damp:0.3 ), + (vol:0.153; decay: 0.259; damp:2.0 ), + (vol:0.361; decay: 1.493; damp:0 ), + (vol:0.444; decay: 2.697; damp:0.638), + (vol:0.25 ; decay: 1.752; damp:0.776), + (vol:0.111; decay: 3.145; damp:0.472), + (vol:0.111; decay: 2.767; damp:0.224), + (vol:0.194; decay: 7.841; damp:0.472), + (vol:1 ; decay: 1.499; damp:0.5 ), + (vol:0.097; decay: 2.767; damp:0.224), + (vol:0.208; decay: 1.652; damp:1.5 ), + (vol:0.652; decay: 2.886; damp:0.25 ), + (vol:1 ; decay: 1.499; damp:0 ), + (vol:0.875; decay: 8.392; damp:1.388), + (vol:0.139; decay:17.234; damp:0.666), + (vol:0.486; decay: 7.563; damp:0.806)); + +function BASS_SetEAXPreset(env: Integer): BOOL; +begin + if env0 then // 0 - not plugin? + begin + i:=0; + while i