Delphi 调用Windows 远程桌面核心代码

byc6352

于 2020-04-05 09:09:13 发布

阅读量2.3k

点赞数 1

分类专栏： delphi 文章标签： windows

本文链接：https://blog.csdn.net/byc6352/article/details/105322123

版权

delphi 专栏收录该内容

39 篇文章 4 订阅

订阅专栏

通过COM接口调用远程桌面，将远程桌面显示在应用程序窗体内：

一、主程序：

unit uMain;

interface

uses
  Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
  Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.ExtCtrls, Vcl.StdCtrls, Winapi.ActiveX
  , System.Win.ComObj, uEventSink,uShow, Vcl.ComCtrls,
  uConfig,uLog;

type
  TfMain = class(TForm)
    bar1: TStatusBar;
    MemoInfo: TMemo;
    Panel4: TPanel;
    Label2: TLabel;
    Label3: TLabel;
    Label4: TLabel;
    Label1: TLabel;
    edtHost: TEdit;
    edtPort: TEdit;
    edtUser: TEdit;
    edtPwd: TEdit;
    btnConnect: TButton;
    btnClose: TButton;
    Panel1: TPanel;
    btnFullScreen: TButton;
    procedure Button1Click(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure btnCloseClick(Sender: TObject);
    procedure FormShow(Sender: TObject);
    procedure btnConnectClick(Sender: TObject);
    procedure btnFullScreenClick(Sender: TObject);
  private
    { Private declarations }
    mHost,mUser,mPwd:string;
    mPort:integer;
    EventSink: TEventSink;

    mScreenX,mScreenY:integer;
    function InitAtl: Boolean;
    procedure EventSinkInvoke(Sender: TObject; DispID: Integer;
       const IID: TGUID; LocaleID: Integer; Flags: Word;
       Params: tagDISPPARAMS; VarResult, ExcepInfo, ArgErr: Pointer);
    function verifyInput():boolean;
    procedure AppException(Sender: TObject; E: Exception);
    procedure LogMain(msg:string);
  public
    { Public declarations }
    ActiveXCon: Variant;
  end;

var
  fMain: TfMain;

const
  CLASS_MsRdpClient: TGUID = '{7CACBD7B-0D99-468F-AC33-22E495C0AFE5}';//'{791FA017-2DE3-492E-ACC5-53C67A2B94D0}';

type
  PIUnknown=^IUnknown;
  TAtlAxAttachControl = function(Control:IUnknown; hwind:hwnd;ppUnkContainer:PIUnknown): HRESULT; stdcall;
  //--此处参考mstscax.dll的接口文件，如果没有，在 Component->Import Component->Import a Type Library
  //--导入：Microsoft Terminal Services Active Client 1.0 Type Library 1.0
  IMsTscAxEvents = dispinterface
    ['{336D5562-EFA8-482E-8CB3-C5C0FC7A7DB6}']
    {
    procedure OnConnecting; dispid 1;
    procedure OnConnected; dispid 2;
    procedure OnLoginComplete; dispid 3;
    procedure OnDisconnected(discReason: Integer); dispid 4;
    procedure OnEnterFullScreenMode; dispid 5;
    procedure OnLeaveFullScreenMode; dispid 6;
    procedure OnChannelReceivedData(const chanName: WideString; const data: WideString); dispid 7;
    procedure OnRequestGoFullScreen; dispid 8;
    procedure OnRequestLeaveFullScreen; dispid 9;
    procedure OnFatalError(errorCode: Integer); dispid 10;
    procedure OnWarning(warningCode: Integer); dispid 11;
    procedure OnRemoteDesktopSizeChange(width: Integer; height: Integer); dispid 12;
    procedure OnIdleTimeoutNotification; dispid 13;
    procedure OnRequestContainerMinimize; dispid 14;
    function OnConfirmClose: WordBool; dispid 15;
    function OnReceivedTSPublicKey(const publicKey: WideString): WordBool; dispid 16;
    function OnAutoReconnecting(disconnectReason: Integer; attemptCount: Integer): AutoReconnectContinueState; dispid 17;
    procedure OnAuthenticationWarningDisplayed; dispid 18;
    procedure OnAuthenticationWarningDismissed; dispid 19;
    }
  end;
implementation
   //regsvr32 mstscax.dll
{$R *.dfm}
procedure TfMain.LogMain(msg:string);
var
  info:string;
begin
  info:=uLog.Log(msg);
  memoinfo.Lines.Add(info);
  bar1.Panels[0].Text:=msg;
end;
procedure TfMain.AppException(Sender: TObject; E: Exception);
begin
  LogMain(e.Message);
  //Log(e.Message);
end;
function TfMain.verifyInput():boolean;
begin
  result:=false;
  mHost:=trim(edtHost.Text);
  if mHost='' then
  begin
    showmessage('服务器地址不能为空！');
    exit;
  end;
  mUser:=trim(edtUser.Text);
  if mUser='' then
  begin
    showmessage('用户名不能为空！');
    exit;
  end;
  mPwd:=trim(edtPwd.Text);
  if mHost='' then
  begin
    showmessage('密码不能为空！');
    exit;
  end;
  mPort:=strtointdef(trim(edtPort.Text),3389);
  if mPort=0 then
  begin
    showmessage('端口号不能为０！');
    exit;
  end;
  result:=true;
end;
function CreateComObjectFromDll(CLSID: TGUID; DllHandle: THandle): IUnknown;
var
  Factory: IClassFactory;
  DllGetClassObject: function(const CLSID, IID: TGUID; var Obj): HResult; stdcall;
  hr: HRESULT;
begin
  DllGetClassObject := GetProcAddress(DllHandle, 'DllGetClassObject');
  if Assigned(DllGetClassObject) then
  begin
    hr := DllGetClassObject(CLSID, IClassFactory, Factory);
    if hr = S_OK then
    try
      hr := Factory.CreateInstance(nil, IUnknown, Result);
      if hr <> S_OK then begin
        ShowMessage('Error');
      end;
    except
      ShowMessage(IntToStr(GetLastError));
    end;
  end;
end;


procedure TfMain.EventSinkInvoke(Sender: TObject; DispID: Integer; const IID: TGUID; LocaleID: Integer; Flags: Word;
  Params: tagDISPPARAMS; VarResult, ExcepInfo, ArgErr: Pointer);
begin {
&nbsp;&nbsp;&nbsp; 这里需要注明Params这个参数, 包含了事件的参数
&nbsp;&nbsp;&nbsp; 如：
&nbsp;&nbsp;&nbsp; Params.rgvarg[0] 代表第一个参数
&nbsp;&nbsp;&nbsp; Params.rgvarg[1] 代表第二个参数
&nbsp;&nbsp;&nbsp; ......
&nbsp;&nbsp;&nbsp; Params.rgvarg[65535] 代表第65535个参数
&nbsp;&nbsp;&nbsp; 最多65535个参数
&nbsp;&nbsp;&nbsp; 具体可以参考 tagDISPPARAMS 的定义</p><p>&nbsp;&nbsp;&nbsp; 这里只列出了怎么扑获相关事件，具体功能具体实现
&nbsp; }  case dispid of
    $00000001: LogMain('正在连接');
    $00000002: LogMain('连接成功');
    $00000003: LogMain('登陆成功');
    $00000004: LogMain('断开连接');
    $00000005: LogMain('进入全屏模式');
    $00000006: LogMain('离开全屏模式');
    $00000007: LogMain('通道接收数据');
    $00000008: LogMain('OnRequestGoFullScreen');
    $00000009: LogMain('OnRequestLeaveFullScreen');
    $00000010: LogMain( 'OnFatalError');
    $00000011: LogMain('OnWarning');
    $00000012: LogMain('OnRemoteDesktopSizeChange');
    $00000013: LogMain('OnIdleTimeoutNotification');
    $00000014: LogMain('OnRequestContainerMinimize');
    $00000015: LogMain('OnConfirmClose');
    $00000016: LogMain('OnReceivedTSPublicKey');
    $00000017: LogMain('OnAutoReconnecting');
    $00000018: LogMain('OnAuthenticationWarningDisplayed');
    $00000019: LogMain('OnAuthenticationWarningDismissed');
  end
end;
procedure TfMain.btnCloseClick(Sender: TObject);
begin
  close;
end;

procedure TfMain.btnConnectClick(Sender: TObject);
begin
  if not verifyInput() then exit;
  InitAtl();
  btnConnect.Enabled:=false;
end;

procedure TfMain.btnFullScreenClick(Sender: TObject);
begin
  fMain.ActiveXCon.FullScreen := true;
end;

procedure TfMain.Button1Click(Sender: TObject);

begin
  //ActiveXCon.Navigate(edit1.Text);
  InitAtl;
end;


procedure TfMain.FormCreate(Sender: TObject);
begin
  Application.OnException := AppException;
end;

procedure TfMain.FormShow(Sender: TObject);
begin
  fmain.Caption:=uConfig.APP_NAME+uConfig.APP_VERSION+uConfig.APP_CONTACT;
  edthost.Text:=uConfig.SERVER_HOST;
  edtuser.Text:=uConfig.SERVER_USER;
  edtport.Text:=inttostr(uConfig.SERVER_PORT);
  edtpwd.Text:=uConfig.SERVER_PWD;
  mScreenX:=GetSystemMetrics(SM_CXSCREEN);
  mScreenY:=GetSystemMetrics(SM_CYSCREEN);
end;

function TfMain.InitAtl: Boolean;
var
  hModule, hDll: THandle;
  AtlAxAttachControl: TAtlAxAttachControl;
begin
  hModule := LoadLibrary('atl.dll');
  if hModule < 32 then begin
    Exit(False);
  end;
  AtlAxAttachControl := TAtlAxAttachControl(GetProcAddress(hModule, 'AtlAxAttachControl'));
  EventSink := TEventSink.Create(Self);
  EventSink.OnInvoke := EventSinkInvoke;
  if not Assigned(AtlAxAttachControl) then
    Exit(False);
  try
    {--后期绑定}
//    ActiveXCon := CreateComObject(CLASS_MsRdpClient); //CreateOleObject('Shell.Explorer');  //CreateComObject(CLASS_MsRdpClient);
    {--前期绑定}
    hDll := LoadLibrary('mstscax.dll');
    ActiveXCon := CreateComObjectFromDll(CLASS_MsRdpClient, hDll) as IDispatch;
//    if Assigned(ActiveXCon) then begin
//
//    end;
    if VarIsNull(ActiveXCon) then begin
      Result := False;
      Exit;
    end;
    EventSink.Connect(ActiveXCon, IMsTscAxEvents);
    //AtlAxAttachControl(ActiveXCon,pnlCom.Handle, nil);
    AtlAxAttachControl(ActiveXCon,fshow.Handle, nil);
//    ActiveXCon.GoHome;
    ActiveXCon.Server := mHost;
    ActiveXCon.UserName := mUser;
    ActiveXCon.AdvancedSettings2.ClearTextPassword := mPwd;
    ActiveXCon.AdvancedSettings2.RDPport:=3389;
    ActiveXCon.FullScreen := false;// 窗口/全屏模式
    ActiveXCon.ConnectingText := '欢迎使用远程桌面服务！';
    ActiveXCon.DisconnectedText := '正在停止远程桌面服务！';
    ActiveXCon.DesktopHeight := mScreenY;
    ActiveXCon.DesktopWidth := mScreenX;
    //ActiveXCon.AdvancedSettings.BitmapPeristence = 1;;
    //ActiveXCon.AdvancedSettings.Compress = 1;
    //ActiveXCon.SecuredSettings.set_StartProgram('C:\ccrun\123.exe');
    ActiveXCon.Connect;
    Result := True;
    //fshow.Width:=1024;
    //fshow.Height:=768;
    fshow.WindowState :=  wsMaximized; //wsnormal wsminimized
    fshow.Show;
  except
    Result := False;
  end;
end;
end.

二、显示远程桌面的窗体

unit uShow;

interface

uses
  Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
  Vcl.Controls, Vcl.Forms, Vcl.Dialogs;

type
  TfShow = class(TForm)
    procedure FormResize(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  fShow: TfShow;

implementation

{$R *.dfm}
uses
  uMain;
procedure TfShow.FormResize(Sender: TObject);
begin
  if self.WindowState=wsMaximized then
  begin
    //fMain.ActiveXCon.FullScreen := true;
  end;

end;

end.

三、配置文件：

unit uConfig;

interface
uses
  Vcl.Forms,System.SysUtils,windows;
const
  DEBUG:boolean=false;
  APP_NAME='远程桌面';
  APP_VERSION='v1.01';
  APP_CONTACT='联系方式：QQ:1409232611微信:byc6352';
  WORK_DIR:string='remotedesk';
  LOG_NAME:string='remotedeskLog.txt';

  SERVER_HOST:string='127.0.0.1';
  SERVER_PORT:DWORD=3389;
  SERVER_USER:string='administrator';
  SERVER_PWD:string='123456';

var
  workdir:string;//工作目录
  logfile:string;//
  apkfilename:string;
  isInit:boolean=false;

  procedure init();
implementation
procedure init();
var
    me:String;
begin
  isInit:=true;
  me:=application.ExeName;
  workdir:=extractfiledir(me)+'\'+WORK_DIR;
  if(not DirectoryExists(workdir))then ForceDirectories(workdir);

  logfile:=workdir+'\'+LOG_NAME;

end;
begin
  init();
end.

四、事件回调单元

unit uEventSink;

interface

uses
  Winapi.Windows, Winapi.Messages, System.SysUtils, System.Classes,
  Vcl.Graphics, Vcl.Controls, Vcl.Forms, Vcl.Dialogs,
  Winapi.ActiveX;

type
  TInvokeEvent = procedure(Sender: TObject; DispID: Integer; const IID: TGUID;
    LocaleID: Integer; Flags: Word; Params: TDispParams;
    VarResult, ExcepInfo, ArgErr: Pointer) of object;

  TAbstractEventSink = class(TObject, IUnknown, IDispatch)
  private
    FDispatch: IDispatch;
    FDispIntfIID: TGUID;
    FConnection: LongInt;
    FOwner: TComponent;
  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;
  public
    constructor Create(AOwner: TComponent);
    destructor Destroy; override;
    procedure Connect(AnAppDispatch: IDispatch; const AnAppDispIntfIID: TGUID);
    procedure Disconnect;
  end;

  TEventSink = class(TComponent)
  private
    { Private declarations }
    FSink: TAbstractEventSink;
    FOnInvoke: TInvokeEvent;
  protected
    { Protected declarations }
    procedure DoInvoke(DispID: Integer; const IID: TGUID; LocaleID: Integer;
      Flags: Word; var Params; VarResult, ExcepInfo, ArgErr: Pointer); virtual;
  public
    { Public declarations }
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure Connect(AnAppDispatch: IDispatch; const AnAppDispIntfIID: TGUID);
  published
    { Published declarations }
    property OnInvoke: TInvokeEvent read FOnInvoke write FOnInvoke;
  end;

implementation

uses
  ComObj;

procedure InterfaceConnect(const Source: IUnknown; const IID: TIID;
  const Sink: IUnknown; var Connection: LongInt);
var
  CPC: IConnectionPointContainer;
  CP: IConnectionPoint;
  i: HRESULT;
begin
  Connection := 0;
  if Succeeded(Source.QueryInterface(IConnectionPointContainer, CPC)) then
    if Succeeded(CPC.FindConnectionPoint(IID, CP)) then
      i := CP.Advise(Sink, Connection);
end;

procedure InterfaceDisconnect(const Source: IUnknown; const IID: TIID;
  var Connection: LongInt);
var
  CPC: IConnectionPointContainer;
  CP: IConnectionPoint;
begin
  if Connection <> 0 then
    if Succeeded(Source.QueryInterface(IConnectionPointContainer, CPC)) then
      if Succeeded(CPC.FindConnectionPoint(IID, CP)) then
        if Succeeded(CP.Unadvise(Connection)) then
          Connection := 0;
end;

{ TAbstractEventSink }
function TAbstractEventSink._AddRef: Integer; stdcall;
begin
  Result := 2;
end;

function TAbstractEventSink._Release: Integer; stdcall;
begin
  Result := 1;
end;

constructor TAbstractEventSink.Create(AOwner: TComponent);
begin
  inherited Create;
  FOwner := AOwner;
end;

destructor TAbstractEventSink.Destroy;
var
  p: Pointer;
begin
  Disconnect;

  inherited Destroy;
end;

function TAbstractEventSink.GetIDsOfNames(const IID: TGUID; Names: Pointer;
  NameCount, LocaleID: Integer; DispIDs: Pointer): HRESULT; stdcall;
begin
  Result := E_NOTIMPL;
end;

function TAbstractEventSink.GetTypeInfo(Index, LocaleID: Integer; out TypeInfo)
  : HRESULT; stdcall;
begin
  Result := E_NOTIMPL;
end;

function TAbstractEventSink.GetTypeInfoCount(out Count: Integer)
  : HRESULT; stdcall;
begin
  Count := 0;
  Result := S_OK;
end;

function TAbstractEventSink.Invoke(DispID: Integer; const IID: TGUID;
  LocaleID: Integer; Flags: Word; var Params;
  VarResult, ExcepInfo, ArgErr: Pointer): HRESULT; stdcall;
begin
  (FOwner as TEventSink).DoInvoke(DispID, IID, LocaleID, Flags, Params,
    VarResult, ExcepInfo, ArgErr);
  Result := S_OK;
end;

function TAbstractEventSink.QueryInterface(const IID: TGUID; out Obj)
  : HRESULT; stdcall;
begin
  // We need to return the event interface when it's asked for
  Result := E_NOINTERFACE;
  if GetInterface(IID, Obj) then
    Result := S_OK;
  if IsEqualGUID(IID, FDispIntfIID) and GetInterface(IDispatch, Obj) then
    Result := S_OK;
end;

procedure TAbstractEventSink.Connect(AnAppDispatch: IDispatch;
  const AnAppDispIntfIID: TGUID);
begin
  FDispIntfIID := AnAppDispIntfIID;
  FDispatch := AnAppDispatch;
  // Hook the sink up to the automation server
  InterfaceConnect(FDispatch, FDispIntfIID, Self, FConnection);
end;

procedure TAbstractEventSink.Disconnect;
begin
  if Assigned(FDispatch) then
  begin
    // Unhook the sink from the automation server
    InterfaceDisconnect(FDispatch, FDispIntfIID, FConnection);
    FDispatch := nil;
    FConnection := 0;
  end;
end;

{ TEventSink }

procedure TEventSink.Connect(AnAppDispatch: IDispatch;
  const AnAppDispIntfIID: TGUID);
begin
  FSink.Connect(AnAppDispatch, AnAppDispIntfIID);
end;

constructor TEventSink.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);

  FSink := TAbstractEventSink.Create(Self);
end;

destructor TEventSink.Destroy;
begin
  FSink.Free;

  inherited Destroy;
end;

procedure TEventSink.DoInvoke(DispID: Integer; const IID: TGUID;
  LocaleID: Integer; Flags: Word; var Params;
  VarResult, ExcepInfo, ArgErr: Pointer);
begin
  if Assigned(FOnInvoke) then
    FOnInvoke(Self, DispID, IID, LocaleID, Flags, TDispParams(Params),
      VarResult, ExcepInfo, ArgErr);
end;

end.

五、日志单元

unit uLog;


interface
uses windows,sysutils,uConfig;
procedure init();
function Log(txt:string):string;
var
  tf:TextFile;
implementation
procedure init();
begin
  if not uConfig.isInit then uConfig.init();
  AssignFile(tf,uconfig.logfile);
  if(not fileexists(uconfig.logfile))then
    Rewrite(tF)  //会覆盖已存在的文件
  else
    Append(tF);  //打开准备追加
end;
function Log(txt:string):string;
var
  t:string;
begin
  t:=FormatDateTime('yyyy-mm-dd hh:nn:ss:zzz', Now);
  WriteLn(tf,t);
  WriteLn(tf,txt);
  flush(tf);
  result:=t+#13#10+txt+#13#10;
end;
initialization
  {初始化部分}
  {程序启动时先执行,并顺序执行}
  {一个单元的初始化代码运行之前,就运行了它使用的每一个单元的初始化部分}
   init();
finalization
  {结束化部分,程序结束时执行}
  CloseFile(tF);
end.

byc6352

关注

1
点赞
踩
6

收藏

觉得还不错? 一键收藏
0
评论
Delphi 调用Windows 远程桌面核心代码

通过COM接口调用远程桌面，将远程桌面显示在应用程序窗体内：一、主程序：unit uMain;interfaceuses Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics, Vcl.Controls, Vcl.Forms, Vcl....
复制链接

扫一扫