Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Browse files

added lazactivex.lpk, thanks to Ludo Brands

git-svn-id: http://svn.freepascal.org/svn/lazarus/trunk@36802 4005530d-fff6-0310-9dd1-cebe43e6787f
  • Loading branch information...
commit 02c60b3e88073b17d38f13eecf37c362eab73b65 1 parent 08cb2cf
mattias authored
View
57 components/activex/LazActiveX.lpk
@@ -0,0 +1,57 @@
+<?xml version="1.0"?>
+<CONFIG>
+ <Package Version="4">
+ <PathDelim Value="\"/>
+ <Name Value="LazActiveX"/>
+ <Author Value="Ludo Brands"/>
+ <CompilerOptions>
+ <Version Value="11"/>
+ <PathDelim Value="\"/>
+ <SearchPaths>
+ <UnitOutputDirectory Value="lib\$(TargetCPU)-$(TargetOS)"/>
+ </SearchPaths>
+ <Other>
+ <CompilerMessages>
+ <UseMsgFile Value="True"/>
+ </CompilerMessages>
+ <CustomOptions Value="-Ur"/>
+ <CompilerPath Value="$(CompPath)"/>
+ </Other>
+ </CompilerOptions>
+ <Description Value="Type Library importer and visual ActiveX container"/>
+ <License Value="modified LGPL-2"/>
+ <Version Minor="1"/>
+ <Files Count="4">
+ <Item1>
+ <Filename Value="activexcontainer.pas"/>
+ <UnitName Value="activexcontainer"/>
+ </Item1>
+ <Item2>
+ <Filename Value="lazactivexreg.pas"/>
+ <HasRegisterProc Value="True"/>
+ <AddToUsesPkgSection Value="False"/>
+ <UnitName Value="lazactivexreg"/>
+ </Item2>
+ <Item3>
+ <Filename Value="importtypelib.lfm"/>
+ <Type Value="LFM"/>
+ </Item3>
+ <Item4>
+ <Filename Value="importtypelib.pas"/>
+ <UnitName Value="ImportTypelib"/>
+ </Item4>
+ </Files>
+ <Type Value="RunAndDesignTime"/>
+ <RequiredPkgs Count="1">
+ <Item1>
+ <PackageName Value="IDEIntf"/>
+ </Item1>
+ </RequiredPkgs>
+ <UsageOptions>
+ <UnitPath Value="$(PkgOutDir)"/>
+ </UsageOptions>
+ <PublishOptions>
+ <Version Value="2"/>
+ </PublishOptions>
+ </Package>
+</CONFIG>
View
21 components/activex/LazActiveX.pas
@@ -0,0 +1,21 @@
+{ This file was automatically created by Lazarus. Do not edit!
+ This source is only used to compile and install the package.
+ }
+
+unit LazActiveX;
+
+interface
+
+uses
+ activexcontainer, lazactivexreg, ImportTypelib, LazarusPackageIntf;
+
+implementation
+
+procedure Register;
+begin
+ RegisterUnit('lazactivexreg', @lazactivexreg.Register);
+end;
+
+initialization
+ RegisterPackage('LazActiveX', @Register);
+end.
View
16 components/activex/README.txt
@@ -0,0 +1,16 @@
+LazActiveX Package
+------------------
+The LazActiveX package contains the TActiveXContainer component and the IDE
+integration of the necessary tools to create ActiveX components from a type
+library or directly from the object (exe or dll).
+
+REQUIREMENTS:
+-------------
+Windows XP or newer
+FPC >= 2.6.1
+
+DOCUMENTATION:
+--------------
+Documentation and samples can be found at http://wiki.freepascal.org/LazActiveX
+
+
View
629 components/activex/activexcontainer.pas
@@ -0,0 +1,629 @@
+unit activexcontainer;
+
+{$mode delphi}{$H+}
+
+{ Visual ActiveX container.
+
+ Copyright (C) 2011 Ludo Brands
+
+ This library is free software; you can redistribute it and/or modify it
+ under the terms of the GNU Library General Public License as published by
+ the Free Software Foundation; either version 2 of the License, or (at your
+ option) any later version with the following modification:
+
+ As a special exception, the copyright holders of this library give you
+ permission to link this library with independent modules to produce an
+ executable, regardless of the license terms of these independent modules,and
+ to copy and distribute the resulting executable under terms of your choice,
+ provided that you also meet, for each linked independent module, the terms
+ and conditions of the license of that module. An independent module is a
+ module which is not derived from or based on this library. If you modify
+ this library, you may extend this exception to your version of the library,
+ but you are not obligated to do so. If you do not wish to do so, delete this
+ exception statement from your version.
+
+ This program is distributed in the hope that it will be useful, but WITHOUT
+ ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
+ FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public License
+ for more details.
+
+ You should have received a copy of the GNU Library General Public License
+ along with this library; if not, write to the Free Software Foundation,
+ Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+}
+
+interface
+
+uses
+ Classes, SysUtils,Controls,windows, ActiveX, ComObj,forms,graphics;
+
+type
+ //from OCIDL.h
+ PPointF = ^TPointF;
+ tagPOINTF = record
+ x: Single;
+ y: Single;
+ end;
+ TPointF = tagPOINTF;
+ POINTF = TPointF;
+
+
+ IOleControlSite = interface
+ ['{B196B289-BAB4-101A-B69C-00AA00341D07}']
+ 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 TranslateAccelerator(msg: PMsg; grfModifiers: Longint): HResult;
+ stdcall;
+ function OnFocus(fGotFocus: BOOL): HResult; stdcall;
+ function ShowPropertyFrame: HResult; stdcall;
+ end;
+
+ IPropertyNotifySink = interface
+ ['{9BFBBC02-EFF1-101A-84ED-00AA00341D07}']
+ function OnChanged(dispid: TDispID): HResult; stdcall;
+ function OnRequestEdit(dispid: TDispID): HResult; stdcall;
+ end;
+
+ ISimpleFrameSite = interface
+ ['{742B0E01-14E6-101B-914E-00AA00300CAB}']
+ 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;
+ end;
+
+
+ TStatusTextEvent = procedure(Sender: TObject; Status:string) of object;
+
+ { TActiveXContainer }
+
+ TActiveXContainer = class(TWinControl, IUnknown, IOleClientSite,
+ IOleControlSite, IOleInPlaceSite, IOleInPlaceFrame, IDispatch)
+ private
+ FActive: boolean;
+ FAttached: boolean;
+ FClassName: string;
+ FOleObject: IDispatch;
+ FOnStatusText: TStatusTextEvent;
+ FPrevWndProc:windows.WNDPROC;
+ Function GetvObject:variant;
+ //IOleClientSite
+ Function SaveObject: HResult;StdCall;
+ Function GetMoniker(dwAssign: Longint; dwWhichMoniker: Longint;OUT mk: IMoniker):HResult;StdCall;
+ Function GetContainer(OUT container: IOleContainer):HResult;StdCall;
+ procedure SetActive(AValue: boolean);
+ procedure SetClassName(AValue: string);
+ procedure SetOleObject(AValue: IDispatch);
+ 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 TranslateAccelerator(msg: PMsg; grfModifiers: Longint): HResult;overload;
+ stdcall;
+ function OnFocus(fGotFocus: BOOL): HResult; stdcall;
+ function ShowPropertyFrame: HResult; stdcall;
+ //IOleInPlaceSite
+ function CanInPlaceActivate : HResult;stdcall;
+ function OnInPlaceActivate : HResult;stdcall;
+ function OnUIActivate : HResult;stdcall;
+ function GetWindowContext(out ppframe:IOleInPlaceFrame;out ppdoc:IOleInPlaceUIWindow;lprcposrect:LPRECT;lprccliprect:LPRECT;lpframeinfo:LPOLEINPLACEFRAMEINFO):hresult; stdcall;
+ function Scroll(scrollExtant:TSIZE):hresult; stdcall;
+ function OnUIDeactivate(fUndoable:BOOL):hresult; stdcall;
+ function OnInPlaceDeactivate :hresult; stdcall;
+ function DiscardUndoState :hresult; stdcall;
+ function DeactivateAndUndo :hresult; stdcall;
+ function OnPosRectChange(lprcPosRect:LPRect):hresult; stdcall;
+ //IOleWindow
+ function GetWindow(out wnd: HWnd): HResult; stdcall;
+ function ContextSensitiveHelp(fEnterMode: BOOL): HResult; stdcall;
+ //IOleInPlaceFrame
+ 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 TranslateAccelerator(var msg: TMsg; wID: Word): HResult;StdCall;overload;
+ //IOleInPlaceUIWindow
+ function GetBorder(out rectBorder: TRect):HResult;StdCall;
+ function RequestBorderSpace(const borderwidths: TRect):HResult;StdCall;
+ function SetBorderSpace(const borderwidths: TRect):HResult;StdCall;
+ function SetActiveObject(const activeObject: IOleInPlaceActiveObject;pszObjName: POleStr):HResult;StdCall;
+ //IDispatch
+ function GetTypeInfoCount(out count : longint) : HResult;stdcall;
+ function GetTypeInfo(Index,LocaleID : longint;
+ out TypeInfo): HResult;stdcall;
+ function GetIDsOfNames(const iid: TGUID; names: Pointer;
+ NameCount, LocaleID: LongInt; DispIDs: Pointer) : HResult;stdcall;
+ function Invoke(DispID: LongInt;const iid : TGUID;
+ LocaleID : longint; Flags: Word;var params;
+ VarResult,ExcepInfo,ArgErr : pointer) : HResult;stdcall;
+ //internal
+ procedure Attach;
+ procedure Detach;
+ public
+ constructor Create(TheOwner: TComponent); override;
+ destructor Destroy; override;
+ //VT_DISPATCH variant used for late binding
+ property vObject:Variant read GetvObject;
+ published
+ property Align;
+ property Anchors;
+ property AutoSize;
+ property BorderSpacing;
+ property ChildSizing;
+ //ActiveX object is automatically created from classname and destroyed when set
+ property OleClassName:string read FClassName write SetClassName;
+ property ClientHeight;
+ property ClientWidth;
+ property Constraints;
+ property DockSite;
+ property DragCursor;
+ property DragKind;
+ property DragMode;
+ property Enabled;
+ {IDispatch interface for ActiveX object. Overrides classname. Set ComServer
+ when you create and destroy the object yourself, fe. using CoClass.
+ When Active, returns the IDispatch for the object.
+ }
+ property ComServer:IDispatch read FOleObject write SetOleObject;
+ property ParentShowHint;
+ property PopupMenu;
+ property ShowHint;
+ property TabOrder;
+ property TabStop;
+ property UseDockManager default True;
+ property Visible;
+ property OnDockDrop;
+ property OnDockOver;
+ property OnDragDrop;
+ property OnDragOver;
+ property OnEndDock;
+ property OnEndDrag;
+ property OnEnter;
+ property OnExit;
+ property OnGetSiteInfo;
+ property OnGetDockCaption;
+ property OnResize;
+ property OnStartDock;
+ property OnStartDrag;
+ property OnStatusText:TStatusTextEvent read FOnStatusText write FOnStatusText;
+ property OnUnDock;
+ {When set, binds ActiveX component to control.
+ When cleared, detaches the component from the control
+ If Classname is provided the ActiveX component will also be created and destroyed
+ automatically.}
+ property Active:boolean read FActive write SetActive;
+ end;
+
+
+
+implementation
+
+
+function WndCallback(Ahwnd: HWND; uMsg: UINT; wParam: WParam;
+ lParam: LParam): LRESULT; stdcall;
+ var
+ bounds:TRect;
+ DC: HDC;
+ PS: TPaintStruct;
+ size:TPOINT;
+ AXC:TActiveXContainer;
+begin
+ AXC:=TActiveXContainer(GetWindowLongPtrW( Ahwnd, GWLP_USERDATA));
+ case uMsg of
+ WM_DESTROY:AXC.Detach;
+ WM_SIZE:
+ begin
+ size.x:=(LOWORD(lparam)*2540) div Screen.PixelsPerInch;
+ size.y:=(HIWORD(lparam)*2540) div Screen.PixelsPerInch;
+ AXC.Width:=LOWORD(lparam);
+ AXC.Height:=LOWORD(lparam);
+ olecheck((AXC.ComServer as IOleObject).SetExtent(DVASPECT_CONTENT,size));
+ bounds:=AXC.BoundsRect;
+ olecheck((AXC.ComServer as IOleInPlaceObject).SetObjectRects(@bounds,@bounds));
+ end;
+ WM_PAINT:
+ begin
+ DC:=GetDC(AXC.handle);
+ bounds:=AXC.BoundsRect;
+ olecheck((AXC.ComServer as IViewObject).Draw(DVASPECT_CONTENT,0,nil,nil,0,DC,@bounds,@bounds,nil,0));
+ ReleaseDC(AXC.handle,DC);
+ end;
+ end;
+ result:=CallWindowProc(AXC.FPrevWndProc,Ahwnd, uMsg, WParam, LParam);
+end;
+
+
+
+{ TActiveXContainer }
+
+function TActiveXContainer.GetvObject: variant;
+begin
+ result:=FOleObject;
+end;
+
+function TActiveXContainer.SaveObject: HResult; StdCall;
+begin
+ Result := S_OK;
+end;
+
+function TActiveXContainer.GetMoniker(dwAssign: Longint; dwWhichMoniker: Longint; out
+ mk: IMoniker): HResult; StdCall;
+begin
+ mk := nil;
+ Result := E_NOTIMPL;
+end;
+
+function TActiveXContainer.GetContainer(out container: IOleContainer): HResult;
+ StdCall;
+begin
+ container := nil;
+ Result := E_NOINTERFACE;
+end;
+
+procedure TActiveXContainer.SetActive(AValue: boolean);
+begin
+ if FActive=AValue then Exit;
+ if AValue then
+ begin
+ if (FClassName='') and not assigned(ComServer) then
+ raise exception.Create('OleClassName and ComServer not assigned.');
+ if not assigned(FOleObject) then
+ FOleObject:=CreateOleObject(FClassName);
+ Attach;
+ end
+ else
+ begin
+ Detach;
+ if FClassName<>'' then //destroy com object
+ FOleObject:=nil;
+ end;
+ FActive:=AValue;
+end;
+
+procedure TActiveXContainer.SetClassName(AValue: string);
+begin
+ if (FClassName=AValue) or FActive then Exit;
+ FClassName:=AValue;
+end;
+
+procedure TActiveXContainer.SetOleObject(AValue: IDispatch);
+begin
+ if (FOleObject=AValue) or FActive then Exit;
+ FOleObject:=AValue;
+end;
+
+function TActiveXContainer.ShowObject: HResult; StdCall;
+begin
+ Result := S_OK;
+end;
+
+function TActiveXContainer.OnShowWindow(fShow: BOOL): HResult; StdCall;
+begin
+ Result := S_OK;
+end;
+
+function TActiveXContainer.RequestNewObjectLayout: HResult; StdCall;
+begin
+ Result := S_OK;
+end;
+
+function TActiveXContainer.OnControlInfoChanged: HResult; stdcall;
+begin
+ Result := E_NOTIMPL;
+end;
+
+function TActiveXContainer.LockInPlaceActive(fLock: BOOL): HResult; stdcall;
+begin
+ Result := E_NOTIMPL;
+end;
+
+function TActiveXContainer.GetExtendedControl(out disp: IDispatch): HResult; stdcall;
+begin
+ Result := E_NOTIMPL;
+end;
+
+function TActiveXContainer.TransformCoords(var ptlHimetric: TPoint;
+ var ptfContainer: TPointF; flags: Longint): HResult; stdcall;
+begin
+ if flags and 4 <> 0 then //XFORMCOORDS_HIMETRICTOCONTAINER=4
+ begin
+ ptfContainer.X := (ptlHimetric.X * Screen.PixelsPerInch) div 2540;
+ ptfContainer.Y := (ptlHimetric.Y * Screen.PixelsPerInch) div 2540;
+ end
+ else if assigned(@ptlHimetric) and (flags and 8 <> 0) then //XFORMCOORDS_CONTAINERTOHIMETRIC = 8
+ begin
+ ptlHimetric.X := Integer(Round(ptfContainer.X * 2540 / Screen.PixelsPerInch));
+ ptlHimetric.Y := Integer(Round(ptfContainer.Y * 2540 / Screen.PixelsPerInch));
+ end;
+ Result := S_OK;
+end;
+
+function TActiveXContainer.TranslateAccelerator(msg: PMsg; grfModifiers: Longint
+ ): HResult; stdcall;
+begin
+ Result := E_NOTIMPL;
+end;
+
+function TActiveXContainer.OnFocus(fGotFocus: BOOL): HResult; stdcall;
+begin
+ Result := S_OK;
+end;
+
+function TActiveXContainer.ShowPropertyFrame: HResult; stdcall;
+begin
+ Result := E_NOTIMPL;
+end;
+
+function TActiveXContainer.CanInPlaceActivate: HResult;stdcall;
+begin
+ Result := S_OK;
+end;
+
+function TActiveXContainer.OnInPlaceActivate: HResult;stdcall;
+begin
+ Result := S_OK;
+end;
+
+function TActiveXContainer.OnUIActivate: HResult; stdcall;
+begin
+ Result := S_OK;
+end;
+
+function TActiveXContainer.GetWindowContext(out ppframe: IOleInPlaceFrame; out
+ ppdoc: IOleInPlaceUIWindow; lprcposrect: LPRECT; lprccliprect: LPRECT;
+ lpframeinfo: LPOLEINPLACEFRAMEINFO): hresult; stdcall;
+begin
+ if assigned (ppframe) then
+ ppframe := Self as IOleInPlaceFrame;
+ if assigned(ppdoc) then
+ ppdoc:= nil;
+ if assigned(lpframeinfo) then
+ begin
+ lpframeinfo.fMDIApp := False;
+ lpframeinfo.cAccelEntries := 0;
+ lpframeinfo.haccel := 0;
+ lpframeinfo.hwndFrame := Handle;
+ end;
+
+ if assigned (lprcPosRect) then
+ lprcPosRect^:=GetClientRect;
+ if assigned (lprcClipRect) then
+ lprcClipRect^:=GetClientRect;
+
+ Result := S_OK;
+end;
+
+function TActiveXContainer.Scroll(scrollExtant: TSIZE): hresult; stdcall;
+begin
+ Result := E_NOTIMPL;
+end;
+
+function TActiveXContainer.OnUIDeactivate(fUndoable: BOOL): hresult; stdcall;
+begin
+ Result := S_OK;
+end;
+
+function TActiveXContainer.OnInPlaceDeactivate: hresult; stdcall;
+begin
+ Result := S_OK;
+end;
+
+function TActiveXContainer.DiscardUndoState: hresult; stdcall;
+begin
+ Result := E_NOTIMPL;
+end;
+
+function TActiveXContainer.DeactivateAndUndo: hresult; stdcall;
+begin
+ Result := E_NOTIMPL;
+end;
+
+function TActiveXContainer.OnPosRectChange(lprcPosRect: LPRect): hresult; stdcall;
+begin
+ Result := S_OK;
+end;
+
+function TActiveXContainer.GetWindow(out wnd: HWnd): HResult; stdcall;
+begin
+ wnd:=Handle;
+ Result := S_OK;
+end;
+
+function TActiveXContainer.ContextSensitiveHelp(fEnterMode: BOOL): HResult; stdcall;
+begin
+ Result := E_NOTIMPL;
+end;
+
+function TActiveXContainer.InsertMenus(hmenuShared: HMenu;
+ var menuWidths: TOleMenuGroupWidths): HResult; StdCall;
+begin
+ Result := E_NOTIMPL;
+end;
+
+function TActiveXContainer.SetMenu(hmenuShared: HMenu; holemenu: HMenu;
+ hwndActiveObject: HWnd): HResult; StdCall;
+begin
+ Result := E_NOTIMPL;
+end;
+
+function TActiveXContainer.RemoveMenus(hmenuShared: HMenu): HResult; StdCall;
+begin
+ Result := S_OK;
+end;
+
+function TActiveXContainer.SetStatusText(pszStatusText: POleStr): HResult; StdCall;
+begin
+ if assigned(FOnStatusText) then
+ FOnStatusText(Self,utf8encode(WideString(pszStatusText)));
+ Result := S_OK;
+end;
+
+function TActiveXContainer.EnableModeless(fEnable: BOOL): HResult; StdCall;
+begin
+ Result := S_OK;
+end;
+
+function TActiveXContainer.TranslateAccelerator(var msg: TMsg; wID: Word): HResult;
+ StdCall;
+begin
+ Result := E_NOTIMPL;
+end;
+
+function TActiveXContainer.GetBorder(out rectBorder: TRect): HResult; StdCall;
+begin
+ Result := INPLACE_E_NOTOOLSPACE;
+end;
+
+function TActiveXContainer.RequestBorderSpace(const borderwidths: TRect): HResult;
+ StdCall;
+begin
+ Result := INPLACE_E_NOTOOLSPACE;
+end;
+
+function TActiveXContainer.SetBorderSpace(const borderwidths: TRect): HResult;
+ StdCall;
+begin
+ Result := E_NOTIMPL;
+end;
+
+function TActiveXContainer.SetActiveObject(
+ const activeObject: IOleInPlaceActiveObject; pszObjName: POleStr): HResult;
+ StdCall;
+begin
+ Result := S_OK;
+end;
+
+function TActiveXContainer.GetTypeInfoCount(out count: longint): HResult;
+ stdcall;
+begin
+ Count := 0;
+ Result := S_OK;
+end;
+
+function TActiveXContainer.GetTypeInfo(Index, LocaleID: longint; out TypeInfo
+ ): HResult; stdcall;
+begin
+ Pointer(TypeInfo) := nil;
+ Result := E_NOTIMPL;
+end;
+
+function TActiveXContainer.GetIDsOfNames(const iid: TGUID; names: Pointer;
+ NameCount, LocaleID: LongInt; DispIDs: Pointer): HResult; stdcall;
+begin
+ Result := E_NOTIMPL;
+end;
+
+function TActiveXContainer.Invoke(DispID: LongInt; const iid: TGUID;
+ LocaleID: longint; Flags: Word; var params; VarResult, ExcepInfo,
+ ArgErr: pointer): HResult; stdcall;
+var
+ F: TFont;
+const
+ DISPID_AMBIENT_BACKCOLOR = -701;
+ DISPID_AMBIENT_DISPLAYNAME = -702;
+ DISPID_AMBIENT_FONT = -703;
+ DISPID_AMBIENT_FORECOLOR = -704;
+ DISPID_AMBIENT_LOCALEID = -705;
+ DISPID_AMBIENT_MESSAGEREFLECT = -706;
+ DISPID_AMBIENT_USERMODE = -709;
+ DISPID_AMBIENT_UIDEAD = -710;
+ DISPID_AMBIENT_SHOWGRABHANDLES = -711;
+ DISPID_AMBIENT_SHOWHATCHING = -712;
+ DISPID_AMBIENT_SUPPORTSMNEMONICS = -714;
+ DISPID_AMBIENT_AUTOCLIP = -715;
+
+
+begin
+ if (Flags and DISPATCH_PROPERTYGET <> 0) and (VarResult <> nil) then
+ begin
+ Result := S_OK;
+ case DispID of
+ DISPID_AMBIENT_BACKCOLOR:
+ PVariant(VarResult)^ := Color;
+ DISPID_AMBIENT_DISPLAYNAME:
+ PVariant(VarResult)^ := OleVariant(Name);
+ DISPID_AMBIENT_FONT:
+ PVariant(VarResult)^ :=nil;
+ DISPID_AMBIENT_FORECOLOR:
+ PVariant(VarResult)^ := Font.Color;
+ DISPID_AMBIENT_LOCALEID:
+ PVariant(VarResult)^ := Integer(GetUserDefaultLCID);
+ DISPID_AMBIENT_MESSAGEREFLECT:
+ PVariant(VarResult)^ := False;
+ DISPID_AMBIENT_USERMODE:
+ PVariant(VarResult)^ := not (csDesigning in ComponentState);
+ DISPID_AMBIENT_UIDEAD:
+ PVariant(VarResult)^ := 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;
+
+procedure TActiveXContainer.Attach;
+var
+ size:TPOINT;
+begin
+ SetWindowLong(Handle,GWLP_USERDATA, ptruint(Self));
+ FPrevWndProc:=Windows.WNDPROC(SetWindowLong(Handle,GWL_WNDPROC,PtrInt(@WndCallback)));
+ FAttached:=true;
+ olecheck((FOleObject as IOleObject).SetClientSite(Self as IOleClientSite));
+ olecheck((FOleObject as IOleObject).SetHostNames(PWideChar(name),PWideChar(name)));
+ size.x:=(Width*2540) div Screen.PixelsPerInch;
+ size.y:=(Height*2540) div Screen.PixelsPerInch;
+ olecheck((FOleObject as IOleObject).SetExtent(DVASPECT_CONTENT,size));
+ olecheck((FOleObject as IOleObject).DoVerb(OLEIVERB_INPLACEACTIVATE,nil,Self as IOleClientSite,0,Handle,BoundsRect));
+end;
+
+procedure TActiveXContainer.Detach;
+const
+ OLECLOSE_NOSAVE = 1;
+begin
+ if FAttached then
+ begin
+ SetWindowLong(Handle,GWL_WNDPROC,PtrUInt(@FPrevWndProc));
+ SetWindowLong(Handle,GWLP_USERDATA, 0);
+ end;
+ if assigned(FOleObject) then
+ begin
+ olecheck((FOleObject as IOleObject).SetClientSite(nil));
+ olecheck((FOleObject as IOleObject).Close(OLECLOSE_NOSAVE));
+ end;
+end;
+
+constructor TActiveXContainer.Create(TheOwner: TComponent);
+begin
+ inherited Create(TheOwner);
+ parent:=TWinControl(TheOwner);
+ Width:=24;
+ Height:=24;
+end;
+
+destructor TActiveXContainer.Destroy;
+begin
+ Active:=false; //destroys com object if created by Self
+ inherited Destroy;
+end;
+
+end.
+
View
82 components/activex/importtypelib.lfm
@@ -0,0 +1,82 @@
+object FrmTL: TFrmTL
+ Left = 251
+ Height = 186
+ Top = 189
+ Width = 341
+ Caption = 'Import Type Library'
+ ClientHeight = 186
+ ClientWidth = 341
+ LCLVersion = '1.1'
+ object FNETL: TFileNameEdit
+ Left = 12
+ Height = 21
+ Top = 40
+ Width = 292
+ DialogOptions = []
+ Filter = 'Type library files (*.tlb;*.dll;*.exe;*.ocx;*.olb)|*.tlb;*.dll;*.exe;*.ocx;*.olb|All Files (*.*)|*.*'
+ FilterIndex = 0
+ HideDirectories = False
+ ButtonWidth = 23
+ NumGlyphs = 0
+ Anchors = [akTop, akLeft, akRight]
+ MaxLength = 0
+ TabOrder = 0
+ end
+ object Label1: TLabel
+ Left = 12
+ Height = 14
+ Top = 16
+ Width = 131
+ Caption = 'File containing type library:'
+ ParentColor = False
+ end
+ object CBxTLActiveX: TCheckBox
+ Left = 12
+ Height = 17
+ Hint = 'CBxTLActiveX'
+ Top = 72
+ Width = 298
+ Caption = 'Create visual component (TActiveXContainer descendant)'
+ OnChange = CBxTLActiveXChange
+ TabOrder = 1
+ end
+ object CBxTLPackage: TCheckBox
+ Left = 12
+ Height = 17
+ Top = 96
+ Width = 96
+ Caption = 'Create package'
+ OnChange = CBxTLPackageChange
+ TabOrder = 2
+ end
+ object BtnTLOK: TButton
+ Left = 248
+ Height = 25
+ Top = 152
+ Width = 75
+ Caption = 'OK'
+ ModalResult = 1
+ TabOrder = 3
+ end
+ object BtnTLCancel: TButton
+ Left = 157
+ Height = 25
+ Top = 152
+ Width = 75
+ Caption = 'Cancel'
+ ModalResult = 2
+ TabOrder = 4
+ end
+ object CBxTLRecurse: TCheckBox
+ Left = 12
+ Height = 17
+ Top = 120
+ Width = 154
+ Caption = 'Convert dependant typelibs'
+ TabOrder = 5
+ end
+ object SelectDirectoryDialog1: TSelectDirectoryDialog
+ left = 220
+ top = 8
+ end
+end
View
143 components/activex/importtypelib.pas
@@ -0,0 +1,143 @@
+unit ImportTypelib;
+
+{$mode objfpc}{$H+}
+
+interface
+
+uses
+ Classes, SysUtils, FileUtil, Forms, Controls, Graphics, Dialogs, EditBtn,
+ StdCtrls,lazideintf,projectintf,PackageIntf;
+
+type
+
+ { TFrmTL }
+
+ TFrmTL = class(TForm)
+ BtnTLOK: TButton;
+ BtnTLCancel: TButton;
+ CBxTLActiveX: TCheckBox;
+ CBxTLPackage: TCheckBox;
+ CBxTLRecurse: TCheckBox;
+ FNETL: TFileNameEdit;
+ Label1: TLabel;
+ SelectDirectoryDialog1: TSelectDirectoryDialog;
+ procedure CBxTLActiveXChange(Sender: TObject);
+ procedure CBxTLPackageChange(Sender: TObject);
+ private
+ { private declarations }
+ public
+ { public declarations }
+ end;
+
+var
+ FrmTL: TFrmTL;
+
+procedure ImpTypeLib(Sender: TObject);
+
+implementation
+
+uses typelib;
+
+procedure ImpTypeLib(Sender: TObject);
+
+var TLI:TTypeLibImporter;
+ bPackage,bActiveX,bRecurse:boolean;
+ slTypelibs:TStringList; //sys charset
+ i,j:integer;
+ F:text;
+ sDir,sUnitName:string; //utf8
+begin
+ FrmTL:= TFrmTL.create(nil);
+ try
+ if (FrmTL.ShowModal=mrOK) and (FrmTL.FNETL.Filename<>'') then
+ begin
+ slTypelibs:=TStringList.Create;
+ slTypelibs.add(UTF8ToSys(FrmTL.FNETL.Filename));
+ bActiveX:=FrmTL.CBxTLActiveX.Checked;
+ bPackage:=FrmTL.CBxTLPackage.Checked;
+ bRecurse:=FrmTL.CBxTLRecurse.Checked;
+ i:=0;
+ sDir:='';
+ repeat
+ TLI:=TTypeLibImporter.Create(nil);
+ try
+ TLI.InputFileName:=slTypelibs[i];
+ TLI.ActiveX:=bActiveX;
+ TLI.CreatePackage:=bPackage;
+ try
+ TLI.Execute;
+ sUnitName:=SysToUTF8(TLI.UnitName);
+ if bPackage then
+ begin
+ with FrmTL.SelectDirectoryDialog1 do
+ begin
+ Title:='Select directory to store package '+sUnitName+'P.lpk';
+ Execute;
+ sDir:=Filename;
+ end;
+ if (sDir<>'') and (sDir[length(sdir)]<>'\') then
+ sDir:=sDir+'\';
+ AssignFile(F,UTF8ToSys(sDir+sUnitName+'P.lpk'));
+ Rewrite(F);
+ Write(F,TLI.PackageSource.Text);
+ CloseFile(F);
+ AssignFile(F,UTF8ToSys(sDir+sUnitName+'Preg.pas'));
+ Rewrite(F);
+ Write(F,TLI.PackageRegUnitSource.Text);
+ CloseFile(F);
+ if PackageEditingInterface.FindPackageWithName(sUnitName+'P')<>nil then
+ begin
+ PackageEditingInterface.DoOpenPackageFile(sDir+sUnitName+'P.lpk',[pofRevert],false);
+ PackageEditingInterface.DoOpenPackageWithName(sUnitName+'P',[],false);
+ end
+ else
+ PackageEditingInterface.DoOpenPackageFile(sDir+sUnitName+'P.lpk',[pofAddToRecent],false);
+ end;
+ if sDir='' then // no package, open file in editor
+ LazarusIDE.DoNewEditorFile(FileDescriptorUnit,sUnitName+'.pas',
+ TLI.UnitSource.Text,[nfIsPartOfProject,nfOpenInEditor])
+ else
+ begin //save in same dir as package
+ AssignFile(F,UTF8ToSys(sDir+sUnitName+'.pas'));
+ Rewrite(F);
+ Write(F,TLI.UnitSource.Text);
+ CloseFile(F);
+ end;
+ // don't create package or ActiveX container for dependencies
+ bPackage:=false;
+ bActiveX:=false;
+ for j:=0 to TLI.Dependencies.Count-1 do
+ if slTypelibs.IndexOf(TLI.Dependencies[j])=-1 then
+ slTypelibs.Add(TLI.Dependencies[j]);
+ except
+ on E: Exception do ShowMessage(E.Message)
+ end;
+ finally
+ TLI.destroy;
+ end;
+ i:=i+1;
+ until not bRecurse or (i=slTypelibs.Count)
+ end;
+ finally
+ FrmTL.Destroy;
+ end;
+end;
+
+{ TFrmTL }
+
+procedure TFrmTL.CBxTLActiveXChange(Sender: TObject);
+begin
+ if not CBxTLActiveX.Checked then
+ CBxTLPackage.Checked:=false;
+end;
+
+procedure TFrmTL.CBxTLPackageChange(Sender: TObject);
+begin
+ if CBxTLPackage.Checked then
+ CBxTLActiveX.Checked:=true;
+end;
+
+{$R *.lfm}
+
+end.
+
View
104 components/activex/lazactivexreg.pas
@@ -0,0 +1,104 @@
+unit lazactivexreg;
+
+{ ActiveX component registration unit.
+
+ Copyright (C) 2011 Ludo Brands
+
+ This library is free software; you can redistribute it and/or modify it
+ under the terms of the GNU Library General Public License as published by
+ the Free Software Foundation; either version 2 of the License, or (at your
+ option) any later version with the following modification:
+
+ As a special exception, the copyright holders of this library give you
+ permission to link this library with independent modules to produce an
+ executable, regardless of the license terms of these independent modules,and
+ to copy and distribute the resulting executable under terms of your choice,
+ provided that you also meet, for each linked independent module, the terms
+ and conditions of the license of that module. An independent module is a
+ module which is not derived from or based on this library. If you modify
+ this library, you may extend this exception to your version of the library,
+ but you are not obligated to do so. If you do not wish to do so, delete this
+ exception statement from your version.
+
+ This program is distributed in the hope that it will be useful, but WITHOUT
+ ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
+ FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public License
+ for more details.
+
+ You should have received a copy of the GNU Library General Public License
+ along with this library; if not, write to the Free Software Foundation,
+ Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+}
+
+interface
+
+uses
+ activexcontainer,ImportTypelib;
+
+procedure Register;
+
+implementation
+
+uses classes,LResources,MenuIntf, LCLIntf;
+
+
+procedure Register;
+begin
+ RegisterIDEMenuCommand(itmSecondaryTools, 'ImportTL','Import Type Library',nil,@ImpTypeLib);
+ RegisterComponents('ActiveX', [TActiveXContainer]);
+end;
+
+initialization
+LazarusResources.Add('TActiveXContainer','PNG',[
+ #137'PNG'#13#10#26#10#0#0#0#13'IHDR'#0#0#0#24#0#0#0#24#8#6#0#0#0#224'w='#248#0
+ +#0#0#1'sRGB'#0#174#206#28#233#0#0#0#6'bKGD'#0#0#0#0#0#0#249'C'#187#127#0#0#0
+ +#9'pHYs'#0#0#11#19#0#0#11#19#1#0#154#156#24#0#0#0#7'tIME'#7#219#12#29#15''''
+ +#14#229#143#252'P'#0#0#0#25'tEXtComment'#0'Created with GIMPW'#129#14#23#0#0
+ +#4')IDATH'#199#181'U{L[e'#20#255#221'{K'#233#198#128'B-'#143#14'6'#137#136
+ +#145#133'm'#248#136#178#224#20#31#141'!Y'#156#203'6'#19#163#152#12'uc2'#147
+ +#205'L'#137'qf'#3'u'#137#25'f'#226#8#198'E'#205'fDE'#156'l#'#153#147#9's'#15
+ +#31'A'#172#186'!'#8#148#142'G'#25#184#130#164#133#246#182#183#189'?'#255#168
+ +#180'tc'#19'f<'#201#151#220#243#251#206#247#157#243';'#231#220#243#129#215'!'
+ +#129#128#159#173'?[X'#177'{'#23#11#205#133'4'#153'R'#168#145't'#20'5Zfd.fI'
+ +#201's'#236#183#245#146'$'#5#146#196','#197'91'#129#143#15#30#196#254#253'5'
+ +#24#232#27#196#205#183','#193'M'#153#153'HH'#140#3'D'#21#23#251#134#241#195
+ +#175'm'#176#219#250#144#148'l'#196#201#211#223#2#179#137#216#227#245#176#186
+ +#178#154#249#249#249',+{'#137#223#159'=EY'#150'g'#180'U'#252#10#27#27#191'd'
+ +#154')'#141'E'#143#23#241'_'#29#252'x'#230#12#183'n-a'#227#209#6#250#188#222
+ +'Y'#167#209#242#203'o\'#190#252#142#171#167'H'#9'(8'#252#217#17'$.'#212#163
+ +'`'#229#253#16#4#1's'#18#2'e'#175#150#205#156'"'#167'k'#130#13#13'G'#216'?'
+ +#216#207#255'"'#173#167'N'#135#25#144#132#127'2'#128'q'#223'_'#240#184'ehU'
+ +#21'Z'#173#17'q'#198'hH'#146#8#1#151'1'#8'('#145#186' '#0#162#6#160#10#168
+ +#129'iL'#168#210#218#221#206#141#165'E\'#176#192#200' '#185#169'%'#241#6'S'#6
+ +#183'm'#127#145#206'1'#231#180'>U'#232#223#187#134'|'#6#225#245#154#153'Td'
+ +#178'n['#24'+'#141'%l'#253'Vf'#230'f]v'#241#149'k'#195#19'OF'#208#247#14'v'
+ +#146'['#226#167'9'#153'O'#182#188'On'#137#253'G'#215#145'-'#31'Q|go'#5'z,]A'
+ +#150#0#30'-|'#4#159#31':'#140'=o'#238#137#200#192#209#227'_'#195#237'q'#134
+ +'t'#173')'#11#184'm'#245'4'#11'7P['#12#200#174#160#250#192'v'#224#158'u'#16#6
+ +'G'''#233#153#184#4#199#208#5't'#245#158'G'#140'a!d'#167#11'#]N'#188#242'z)<'
+ +#158#160'}BB'#2'::~GrrJ'#248'Nk;'#240'V>'#160#140'G'#214'c'#201'z'#224#249'O'
+ +#0'A'#132'&%>'#26'g[;PUY'#141#150's'#205#24#27'v'#207#216'u'#138#162#192#225
+ +#24#141'tpc'#6#160#215#3#151#166'9'#136#210#1#143#149#3#130#8#0#16'kk'#15#161
+ +'p'#205'Z|'#209#212#136#177'a7$'#9#184'7o'#25'J7o'#130#30#209#161's'#170#170
+ +#194#231#243'Ez'#253#230#3'`l '#18#243#251#0#155'%'#172#167#153#210'#'#138'Y'
+ +#252't1='#147#19#28#31#178'S'#132#24#194#227#227#227'i'#179#217#194'U'#254
+ +#238#0'Y'#162#11#22#244'Y)'#178#163'v'#230#146#178#135'$)'#142#143'8"'#2#136
+ +'I4`'#200'1'#138#154#154'w'#161'B'#13#225#162'(A'#21#162'A'#18#242#248#16#240
+ +#225'S'#128'_'#14'n'#174#170#2#140#139#195#151#216'-'#192'O'#245#193#239#149
+ +'y'#183'G0'#144'$'#137#177#6#3#5'Q$'#180#218#16#30#27#23#199#246#206'n*'#178
+ +#151#220#183'*'#28#237#190#135#200'@'#128'<'#240'r$'#139#221#185#164#215'E'
+ +#177#170#242'=dg'#166#135#127#208'@'#0#174#137'Q'#188#176#185#8'wg'#223#25
+ +#194'eY'#134'u'#168#31#154#230'7'#128#243#199#130#160'!'#21'X'#251'6 '#138'@'
+ +#193#6'`'#158'1'#204#162#215#2#180'5B IYQ@'#191#2#18'P'#252'^Di'#162'0O7'#31
+ +#170#26'L'#145'J'#194#229'r# '#1#198#216#24'`j>N'#141#135'P'''#248#195'{@'
+ +#176#147#186';;'#175'k'#144'MNN'#178#233#228#9#246#246't]'#211'N2-J'#219#153
+ +#179'4'#7#186'h'#221#172#166#240#232#184#3#159#214#213#193#250#135#21'f'#243
+ +#131'0'#26'S'#174'}'#224#216#241#175#184'bE'#30'-mmW'#141#194#241#167#131#245
+ +#245#245#220'X'#178#137';v'#236#226#160'}`'#214'L5'#15#155#205#232#232'8'#135
+ +#251#10#10#144#150#190#8'9Ko'#133'A'#159#10#149'n'#12#219'G`'#187#208#15#189
+ +#222#128'u'#235'W'#163#188#162#28'I'#6#227#156#222#157#208'{`'#191'hG'#211
+ +#137'ft'#247#244'@U|0&&#;+'#11#203#238#202'EjR*0'#199#7#237#10#7#255#151#252
+ +#13#208#236#3#252#184#199'u'#249#0#0#0#0'IEND'#174'B`'#130
+]);
+
+end.
View
1  packager/globallinks/lazactivex-0.1.lpl
@@ -0,0 +1 @@
+$(LazarusDir)/components/activex/LazActiveX.lpk
Please sign in to comment.
Something went wrong with that request. Please try again.