I have been able to implement a preview handler for most file types, except outlook msg files. How can I achieve this? The code doesnt seem to be able to open either in stream or file mode.
var
ACLSID: String;
AGUID: TGUID;
ARect: TRect;
FileInit: IInitializeWithFile;
StreamInit : IInitializeWithStream;
begin
FPreviewHandler := CreateComObject(AGUID) as IPreviewHandler;
if (FPreviewHandler = nil) then
begin
MessageDlg('No preview handler found for this file format.', mtError, [mbOK], 0);
Result := False;
Exit;
end;
// First attempt opening in file mode, if fails, attempt stream mode.
if FPreviewHandler.QueryInterface(IInitializeWithFile, FileInit) = 0 then
begin
FileInit.Initialize(StringToOleStr(FFileName), STGM_READ);
FInStreamMode := False;
FLoaded := True;
end else
if FPreviewHandler.QueryInterface(IInitializeWithStream, StreamInit) = 0 then
begin
try
FFileStream := TFileStream.Create(FFileName, fmOpenRead);
except on
E: EFOpenError do
begin
MessageDlg(E.Message, mtError, [mbOK], 0);
Result := False;
Exit;
end;
end;
FIStream := TStreamAdapter.Create(FFileStream, soOwned) as IStream;
StreamInit.Initialize(FIStream, STGM_READ);
FInStreamMode := True;
FLoaded := True;
end else
begin // Cannot load file
Result := False;
FPreviewHandler.Unload;
Exit;
end;
ARect := Rect(0, 0, AParentControl.Width, AParentControl.Height);
Parent := AParentControl;
Align := alClient;
FPreviewHandler.SetWindow(Self.Handle, ARect);
FPreviewHandler.SetRect(ARect);
FPreviewHandler.DoPreview;
FPreviewHandler.SetFocus;
Related
I'm writing MITM ssl proxy using indy. i use IdHTTPserver component with self signed certificate for proxy server, and on event of CommandOther i do TcpCleint request to site and return data in HTTPServer. But problem is, some scripts, especially JS and some pictures from web pages not being loaded at all, or load after timeout, so i recieve html code in browser, but crippled by not working js (mostly). Here's my code for CommandOther:
procedure TForm3.IdHTTPServer1CommandOther(AContext: TIdContext;
ARequestInfo: TIdHTTPRequestInfo; AResponseInfo: TIdHTTPResponseInfo);
var
client: TIdTCPClient;
Headers, headers1: TIdHeaderList;
s, ResponseCode, ResponseText: string;
req,req2:string;
Size: Int64;
Strm,strm2: TIdTCPStream;
ssl: TIdSSLIOHandlerSocketOpenSSL;
clientcount:integer;
begin
Memo3.lines.Add('start');
client := TIdtCPClient.Create(nil);
ssl := TIdSSLIOHandlerSocketOpenSSL.Create(client);
client.IOHandler := ssl;
s := ARequestInfo.URI;
client.Host := Fetch(s, ':', True);
client.Port := StrToIntDef(s, 443);
client.ConnectTimeout := 2000;
s := '';
Memo3.lines.Add('connecting');
client.UseNagle:=true;
client.Connect;
//here i handle CONNECT command
AResponseInfo.ResponseNo := 200;
AResponseInfo.ResponseText := 'Connection established';
aresponseinfo.WriteHeader;
// activate SSL between this proxy and the client
TIdSSLIOHandlerSocketOpenSSL(AContext.Connection.Socket).PassThrough
:= false;
Memo3.lines.Add('connected');
while AContext.Connection.Connected and Client.Connected do
begin
try
memo4.Lines.Add('---start header-------');
headers1 := TIdHeaderList.Create(QuoteHTTP);
headers1.FoldLength := MaxInt;
repeat
s := AContext.Connection.IOHandler.ReadLn;
Memo4.lines.Add(s);
headers1.Add(s);
if s = '' then
Break;
until False;
client.WriteHeader(headers1);
memo4.Lines.Add('-----header written-----');
memo5.Lines.Add('----------');
if Headers1.IndexOfName('Content-Length') <> -1 then
begin
strm2:=TIdTCPStream.Create(client);
memo5.Lines.Add('post');
Size := StrToInt64(Headers1.Values['Content-Length']);
if Size > 0 then
AContext.Connection.IOHandler.ReadStream(Strm2, Size, False);
end;
memo4.Lines.Add('---response headers-------');
Headers := TIdHeaderList.Create(QuoteHTTP);
try
Headers.FoldLength := MaxInt;
repeat
s := client.IOHandler.ReadLn;
Memo4.lines.Add(s);
acontext.Connection.IOHandler.WriteLn(s);
Headers.Add(s);
if s = '' then
Break;
until False;
memo4.Lines.Add('---respone headers read-------');
Strm := TIdTCPStream.Create(AContext.Connection);
try
if Pos('chunked', Headers.Values['Transfer-Encoding']) <> 0 then
begin
memo4.Lines.Add('chunked');
repeat
s := client.IOHandler.ReadLn;
AContext.Connection.IOHandler.WriteLn(s);
Size := StrToInt64('$' + Fetch(s, ';'));
if Size = 0 then
Break;
client.IOHandler.ReadStream(Strm, Size, False);
s := client.IOHandler.ReadLn;
AContext.Connection.IOHandler.WriteLn(s);
until False;
repeat
s := client.IOHandler.ReadLn;
AContext.Connection.IOHandler.WriteLn(s);
until s = '';
end
else if Headers.IndexOfName('Content-Length') <> -1 then
begin
Size := StrToInt64(Headers.Values['Content-Length']);
end;
if Size > 0 then
client.IOHandler.ReadStream(Strm, Size, False);
end
else
begin
memo5.Lines.Add('big read(');
AResponseInfo.CloseConnection := true;
try
client.IOHandler.ReadStream(Strm, -1, True);
except
on E: EIdSocketError do
begin
raise;
end;
end;
end;
finally
Strm.Free;
end;
finally
Headers.Free;
strm2.Free;
headers1.Free;
end;
finally
client.Disconnect;
end;
client.Free;
end;
end;
I am writing a Keyboard application that hooks the keyboard and remaps the keys. For this, I have created two projects, one .exe and .dll. In the .dll project, I detect the Handle of the Window in which the user is typing by GetFocus(). However, it works fine in notepad, but not in MS Word since I am not able to get the Window's Handle for the MS Word, using GetFocus()
I understand, that is because it might be running under different thread and hence, I need to get the Parent Window Handle by GetForegroundWindow() and iterate through its child windows and somehow get the right Handle.
While searching on internet I found following code (http://www.codeproject.com/Articles/34752/Control-in-Focus-in-Other-Processes)
activeWindowHandle:= GetForegroundWindow();
activeWindowThread:= GetWindowThreadProcessId(activeWindowHandle, 0);
thisWindowThread:= GetWindowThreadProcessId(lpHookRec^.TheHookHandle, 0);
AttachThreadInput(activeWindowThread, thisWindowThread, true);
lpHookRec^.TheAppWinHandle:= GetFocus();
AttachThreadInput(activeWindowThread, thisWindowThread, false);
However, it is not working for me :(
In my code I have written
lpHookRec^.TheAppWinHandle := GetFocus();
and that gives me the Handle of the NotePad window in lpHookRec^.TheAppWinHandle. However, if I use MS Word instead of NotePad, the above code gives me null(zero). So need to write function that returns the correct Handle, irrespective of thread it is running under, something like
function GetAppliWinHandle: Hwnd;
var
activeWindowHandle,activeWindowThread,thisWindowThread,focusedControlHandle: Hwnd;
begin { GetAppliWinHandle }
focusedControlHandle := GetFocus();
if focusedControlHandle = 0 then
begin
activeWindowHandle := GetForegroundWindow();
activeWindowThread := GetWindowThreadProcessId(activeWindowHandle, 0);
thisWindowThread := GetWindowThreadProcessId(lpHookRec^.TheHookHandle, 0);
AttachThreadInput(activeWindowThread, thisWindowThread, true);
focusedControlHandle := GetFocus();
AttachThreadInput(activeWindowThread, thisWindowThread, false);
end;
Result:=focusedControlHandle
end; { GetAppliWinHandle }
and here is the complete code for the dll
library TheHook;
uses
Windows, Messages, SysUtils;
{Define a record for recording and passing information process wide}
type
PHookRec = ^THookRec;
THookRec = packed record
TheHookHandle: HHOOK;
TheAppWinHandle: HWND;
TheCtrlWinHandle: HWND;
TheKeyCount: DWORD;
end;
var
hObjHandle: THandle; {Variable for the file mapping object}
lpHookRec: PHookRec; {Pointer to our hook record}
procedure MapFileMemory(dwAllocSize: DWORD);
begin
{Create a process wide memory mapped variable}
hObjHandle := CreateFileMapping($FFFFFFFF, nil, PAGE_READWRITE, 0, dwAllocSize,
'HookRecMemBlock');
if (hObjHandle = 0) then
begin
MessageBox(0, 'Hook DLL', 'Could not create file map object', MB_OK);
exit;
end;
{Get a pointer to our process wide memory mapped variable}
lpHookRec := MapViewOfFile(hObjHandle, file_MAP_write, 0, 0, dwAllocSize);
if (lpHookRec = nil) then
begin
CloseHandle(hObjHandle);
MessageBox(0, 'Hook DLL', 'Could not map file', MB_OK);
exit;
end;
end;
procedure UnMapFileMemory;
begin
{Delete our process wide memory mapped variable}
if (lpHookRec <> nil) then
begin
UnMapViewOfFile(lpHookRec);
lpHookRec := nil;
end;
if (hObjHandle > 0) then
begin
CloseHandle(hObjHandle);
hObjHandle := 0;
end;
end;
function GetHookRecPointer: pointer stdcall;
begin
{Return a pointer to our process wide memory mapped variable}
result := lpHookRec;
end;
{The function that actually processes the keystrokes for our hook}
function KeyBoardProc(Code: integer; wParam: integer; lParam: integer): integer;
stdcall;
function GetAppliWinHandle: Hwnd;
var
activeWindowHandle,activeWindowThread,thisWindowThread,focusedControlHandle: Hwnd;
begin { GetAppliWinHandle }
focusedControlHandle := GetFocus();
if focusedControlHandle = 0 then
begin
activeWindowHandle := GetForegroundWindow();
activeWindowThread := GetWindowThreadProcessId(activeWindowHandle, 0);
thisWindowThread := GetWindowThreadProcessId(lpHookRec^.TheHookHandle, 0);
AttachThreadInput(activeWindowThread, thisWindowThread, true);
focusedControlHandle := GetFocus();
AttachThreadInput(activeWindowThread, thisWindowThread, false);
end;
Result:=focusedControlHandle
end; { GetAppliWinHandle }
var
KeyUp: bool;
{Remove comments for additional functionability ... :
IsAltPressed: bool;
IsCtrlPressed: bool;
IsShiftPressed: bool;
}
begin
result := 0;
case Code of
HC_ACTION:
begin
{We trap the keystrokes here}
{is this a key up message?}
KeyUp := ((lParam and (1 shl 31)) <> 0);
{Remove comments for additional functionability ... :
{is the Alt key pressed}
if ((lParam and (1 shl 29)) <> 0) then
begin
IsAltPressed := TRUE;
end
else
begin
IsAltPressed := FALSE;
end;
{is the Control key pressed}
if ((GetKeyState(VK_CONTROL) and (1 shl 15)) <> 0) then
begin
IsCtrlPressed := TRUE;
end
else
begin
IsCtrlPressed := FALSE;
end;
{if the Shift key pressed}
if ((GetKeyState(VK_SHIFT) and (1 shl 15)) <> 0) then
begin
IsShiftPressed := TRUE;
end
else
begin
IsShiftPressed := FALSE;
end;
}
{if KeyUp then increment the key count}
if (KeyUp <> FALSE) then
begin
Inc(lpHookRec^.TheKeyCount);
end;
case wParam of
{Was the enter key pressed?}
VK_RETURN:
begin
{if KeyUp}
if (KeyUp <> FALSE) then
begin
{Post a bogus message to the window control in our app}
PostMessage(lpHookRec^.TheCtrlWinHandle, WM_KEYDOWN, 0, 0);
PostMessage(lpHookRec^.TheCtrlWinHandle, WM_KEYUP, 0, 0);
end;
{if you wanted to swallow the keystroke then return -1, else if you
want
to allow the keystroke then return 0}
result := 0;
exit;
end; {VK_RETURN}
{if the left arrow key is pressed then lets play a joke!}
VK_LEFT:
begin
{Get the Handle of the Application Window in lpHookRec^.TheAppWinHandle}
lpHookRec^.TheAppWinHandle:=GetAppliWinHandle;
{if KeyUp}
if (KeyUp <> FALSE) then
begin
{Create a UpArrow keyboard event}
keybd_event(VK_RIGHT, 0, 0, 0);
keybd_event(VK_RIGHT, 0, KEYEVENTF_KEYUP, 0);
end;
{Swallow the keystroke}
result := -1;
exit;
end; {VK_LEFT}
end; {case wParam}
{Allow the keystroke}
result := 0;
end; {HC_ACTION}
HC_NOREMOVE:
begin
{This is a keystroke message, but the keystroke message has not been removed
from the message queue, since an application has called PeekMessage()
specifying PM_NOREMOVE}
result := 0;
exit;
end;
end; {case code}
if (Code < 0) then
{Call the next hook in the hook chain}
result := CallNextHookEx(lpHookRec^.TheHookHandle, Code, wParam, lParam);
end;
procedure StartKeyBoardHook stdcall;
begin
{if we have a process wide memory variable and the hook has not already been
set...}
if ((lpHookRec <> nil) and (lpHookRec^.TheHookHandle = 0)) then
begin
{set the hook and remember our hook handle}
lpHookRec^.TheHookHandle := SetWindowsHookEx(WH_KEYBOARD, #KeyBoardProc,
hInstance, 0);
end;
end;
procedure StopKeyBoardHook stdcall;
begin
{if we have a process wide memory variable and the hook has already been set...}
if ((lpHookRec <> nil) and (lpHookRec^.TheHookHandle <> 0)) then
begin
{Remove our hook and clear our hook handle}
if (UnHookWindowsHookEx(lpHookRec^.TheHookHandle) <> FALSE) then
begin
lpHookRec^.TheHookHandle := 0;
end;
end;
end;
procedure DllEntryPoint(dwReason: DWORD);
begin
case dwReason of
Dll_Process_Attach:
begin
{if we are getting mapped into a process, then get a pointer to our
process wide memory mapped variable}
hObjHandle := 0;
lpHookRec := nil;
MapFileMemory(sizeof(lpHookRec^));
end;
Dll_Process_Detach:
begin
{if we are getting unmapped from a process then, remove the pointer to
our process wide memory mapped variable}
UnMapFileMemory;
end;
end;
end;
exports
KeyBoardProc name 'KEYBOARDPROC',
GetHookRecPointer name 'GETHOOKRECPOINTER',
StartKeyBoardHook name 'STARTKEYBOARDHOOK',
StopKeyBoardHook name 'STOPKEYBOARDHOOK';
begin
{set our Dll's main entry point}
DLLProc := #DllEntryPoint;
{Call our Dll's main entry point}
DllEntryPoint(Dll_Process_Attach);
end.
Per the GetFocus() documentation:
Retrieves the handle to the window that has the keyboard focus, if the window is attached to the calling thread's message queue.
...
GetFocus returns the window with the keyboard focus for the current thread's message queue. If GetFocus returns NULL, another thread's queue may be attached to a window that has the keyboard focus.
Use the GetForegroundWindow function to retrieve the handle to the window with which the user is currently working. You can associate your thread's message queue with the windows owned by another thread by using the AttachThreadInput function.
You are trying to do this part, but you are not doing it correctly, and you are not checking for errors along the way. You are also mistakenly using the HWND data type for thread IDs, but they are not HWNDs, they are DWORDs instead.
Try something more like this:
function GetAppliWinHandle: HWND;
var
activeWindowHandle: HWND;
activeWindowThread, thisThread: DWORD;
begin
Result := GetFocus();
if Result = 0 then
begin
activeWindowHandle := GetForegroundWindow();
if activeWindowHandle <> 0 then
begin
activeWindowThread := GetWindowThreadProcessId(activeWindowHandle, 0);
thisThread := GetCurrentThreadId();
if AttachThreadInput(activeWindowThread, thisThread, TRUE) then
begin
Result := GetFocus();
AttachThreadInput(activeWindowThread, thisThread, FALSE);
end;
end;
end;
end;
However, the same documentation also says:
To get the window with the keyboard focus on the foreground queue or the queue of another thread, use the GetGUIThreadInfo function.
For example:
function GetAppliWinHandle: HWND;
var
activeWindowHandle: HWND;
activeWindowThread: DWORD;
gui: TGUIThreadinfo;
begin
Result := GetFocus();
if Result = 0 then
begin
activeWindowHandle := GetForegroundWindow();
if activeWindowHandle <> 0 then
begin
activeWindowThread := GetWindowThreadProcessId(activeWindowHandle, 0);
gui.cbSize := sizeof(gui);
if GetGUIThreadInfo(activeWindowThread, gui) then
Result := gui.hwndFocus;
end;
end;
end;
Or simpler:
function GetAppliWinHandle: HWND;
var
gui: TGUIThreadinfo;
begin
gui.cbSize := sizeof(gui);
if GetGUIThreadInfo(0, gui) then
Result := gui.hwndFocus
else
Result := 0;
end;
I have a delphi 6 application wich uses mapi to open the outlook send dialog
with attachment.
This works on my PC and also on other clients PC.
I have now 2 clients where the send dialog isn't opening. I don't even get a
Error message. The clients have a W7 PC and outlook 2013.
I've tried Fixmapi, but this doesn't help.
Outlook is working fine and Via explorer the send dialogue is working fine.
I just tried MAPI and it worked for me, with thunderbird, and outlook 2013.
I did get a FIXMAPI dialog and then I got the new outlook email window, same as ever.
If you have a problem only on specific machines, then that's not a programming question, it's a windows question. Be sure to use the Control Panel to look at what default programs you have selected, including which is the default MAPI mail program.
program MapiSample;
uses
{Vcl.}Forms,
Windows,
SysUtils,
{Vcl.}Dialogs,
{WinApi.}MAPI;
type
LPSTR = PAnsiChar;
PSTR = PChar;
function SendMailMAPI(const Subject, Body, FileName, SenderName, SenderEMail,
RecepientName, RecepientEMail: AnsiString) : Integer;
var
message: TMapiMessage;
lpSender,
lpRecepient: TMapiRecipDesc;
FileAttach: TMapiFileDesc;
SM: TFNMapiSendMail;
MAPIModule: HModule;
begin
FillChar(message, SizeOf(message), 0);
with message do
begin
if (Subject<>'') then
begin
lpszSubject := LPSTR(Subject)
end;
if (Body<>'') then
begin
lpszNoteText := LPSTR(Body)
end;
if (SenderEMail<>'') then
begin
lpSender.ulRecipClass := MAPI_ORIG;
if (SenderName='') then
begin
lpSender.lpszName := LPSTR(SenderEMail)
end
else
begin
lpSender.lpszName := LPSTR(SenderName)
end;
lpSender.lpszAddress := LPSTR('SMTP:'+SenderEMail);
lpSender.ulReserved := 0;
lpSender.ulEIDSize := 0;
lpSender.lpEntryID := nil;
lpOriginator := #lpSender;
end;
if (RecepientEMail<>'') then
begin
lpRecepient.ulRecipClass := MAPI_TO;
if (RecepientName='') then
begin
lpRecepient.lpszName := LPSTR(RecepientEMail)
end
else
begin
lpRecepient.lpszName := LPSTR(RecepientName)
end;
lpRecepient.lpszAddress := LPSTR('SMTP:'+RecepientEMail);
lpRecepient.ulReserved := 0;
lpRecepient.ulEIDSize := 0;
lpRecepient.lpEntryID := nil;
nRecipCount := 1;
lpRecips := #lpRecepient;
end
else
begin
lpRecips := nil
end;
if (FileName='') then
begin
nFileCount := 0;
lpFiles := nil;
end
else
begin
FillChar(FileAttach, SizeOf(FileAttach), 0);
FileAttach.nPosition := Cardinal($FFFFFFFF);
FileAttach.lpszPathName := LPSTR(FileName);
nFileCount := 1;
lpFiles := #FileAttach;
end;
end;
MAPIModule := LoadLibrary(PSTR(MAPIDLL));
if MAPIModule=0 then
begin
Result := -1
end
else
begin
try
#SM := GetProcAddress(MAPIModule, 'MAPISendMail');
if #SM<>nil then
begin
Result := SM(0, Application.Handle, message, MAPI_DIALOG or
MAPI_LOGON_UI, 0);
end
else
begin
Result := 1
end;
finally
FreeLibrary(MAPIModule);
end;
end;
if Result<>0 then
begin
MessageDlg('Error sending mail ('+IntToStr(Result)+').', mtError, [mbOk],
0)
end;
end;
begin
SendMailMapi('test','test','','My Name', 'sender#sender.com', 'Your Name', 'receiver#something.com');
end.
I am trying to transform my delphi project from VCL to ActiveX. I have issues with a client thread. Here is my client thread type:
type
TClientThread = class(TThread)
private
Command: string;
procedure HandleInput;
protected
procedure Execute; override;
end;
And here is the implementation:
procedure TClientThread.HandleInput;
begin
activext.ProcessCommands(Command);
Command := '';
end;
procedure Tactivextest.ProcessCommands(Command: string);
var
Params: array [1 .. 10] of String;
ParamsCount, P: Integer;
PackedParams: TPackedParams;
PStr: String;
IdBytes: TIdBytes;
Ms: TMemoryStream;
ReceiveParams, ReceiveStream: Boolean;
Size: Int64;
begin
Ms := TMemoryStream.Create;
ReceiveParams := False;
ReceiveStream := False;
if Command[1] = '1' then // command with params
begin
Command := Copy(Command, 2, Length(Command));
ReceiveParams := True;
end
else if Command[1] = '2' then // command + memorystream
begin
Command := Copy(Command, 2, Length(Command));
ReceiveStream := True;
Ms.Position := 0;
end
else if Command[1] = '3' then // command with params + memorystream
begin
Command := Copy(Command, 2, Length(Command));
ReceiveParams := True;
ReceiveStream := True;
end;
if ReceiveParams then // params incomming
begin
TCPClient.Socket.ReadBytes(IdBytes, SizeOf(PackedParams), False);
BytesToRaw(IdBytes, PackedParams, SizeOf(PackedParams));
ParamsCount := 0;
repeat
Inc(ParamsCount);
P := Pos(Sep, String(PackedParams.Params));
Params[ParamsCount] := Copy(String(PackedParams.Params), 1, P - 1);
Delete(PackedParams.Params, 1, P + 4);
until PackedParams.Params = '';
end;
if ReceiveStream then // stream incomming
begin
Size := TCPClient.Socket.ReadInt64;
TCPClient.Socket.ReadStream(Ms, Size, False);
Ms.Position := 0;
end;
if Command = 'SIMPLEMESSAGE' then
begin
MessageDlg(Params[1], mtInformation, [mbOk], 0);
end;
if Command = 'INVALIDPASSWORD' then
begin
TCPClient.Disconnect;
MessageDlg('Invalid password!', mtError, [mbOk], 0);
end;
if Command = 'SENDYOURINFO' then // succesfully loged in
begin
UniqueID := StrToInt(Params[1]);
Panel1.Caption := 'connect ' + namewithicon + ')';
PStr := namewithicon + Sep;
SendCommandWithParams(TCPClient, 'TAKEMYINFO', PStr);
end;
if Command = 'DISCONNECTED' then
begin
if TCPClient.Connected then
TCPClient.Disconnect;
end;
if Command = 'TEXTMESSAGE' then
begin
memo1.Lines.Add(Params[1] + ' : ' + Params[2] )
end;
end;
procedure TClientThread.Execute;
begin
inherited;
while not Terminated do
begin
if not activext.TCPClient.Connected then
Terminate
else
begin
if activext.TCPClient.Connected then
Command := activext.TCPClient.Socket.ReadLn('', 5);
if Command <> '' then
Synchronize(HandleInput);
end;
end;
end;
initialization
TActiveFormFactory.Create(
ComServer,
TActiveFormControl,
Tactivextest,
Class_activextest,
0,
'',
OLEMISC_SIMPLEFRAME or OLEMISC_ACTSLIKELABEL,
tmApartment);
end.
And here is how I start the client thread with Indy's TCP OnConnected event:
procedure Tactivextest.TCPClientConnected(Sender: TObject);
begin
ClientThread := TClientThread.Create(True);
ClientThread.Start;
SendCommandWithParams(TCPClient, 'LOGIN', namewithicon + Sep);
end;
And here is how I connect to the server on the Form's OnCreate event:
begin
if not TCPClient.Connected then
begin
TCPClient.Host := 'localhost';
TCPClient.Port := 31000;
try
TCPClient.Connect;
except
on E: Exception do
begin
MessageDlg('Cannot connect to server!', mtInformation, [mbOk], 0);
Application.Terminate;
end;
end;
end
else
begin
SendCommand(TCPClient, 'DISCONNECTED');
if TCPClient.Connected then
TCPClient.Disconnect;
end;
end;
send commands
procedure Tactivextest.SendBuffer(TCPClient: TIdTCPClient; Buffer: TIdBytes;
BufferSize: Cardinal);
begin
if not TCPClient.Connected then
Exit;
TCPClient.Socket.WriteLn('AUDIO');
TCPClient.Socket.Write(BufferSize);
TCPClient.Socket.Write(Buffer, BufferSize);
end;
procedure Tactivextest.SendCommand(TCPClient: TIdTCPClient; Command: string);
begin
if not TCPClient.Connected then
Exit;
TCPClient.Socket.WriteLn(Command);
end;
procedure Tactivextest.SendCommandWithParams(TCPClient: TIdTCPClient;
Command, Params: String);
var
PackedParams: TPackedParams;
begin
if not TCPClient.Connected then
Exit;
TCPClient.Socket.WriteLn('1' + Command);
PackedParams.Params := ShortString(Params);
TCPClient.Socket.Write(RawToBytes(PackedParams, SizeOf(PackedParams)));
end;
procedure Tactivextest.SendStream(TCPClient: TIdTCPClient; Ms: TMemoryStream);
begin
if not TCPClient.Connected then
Exit;
Ms.Position := 0;
with TCPClient.Socket do
begin
Write(Ms.Size);
WriteBufferOpen;
Write(Ms, 0);
WriteBufferClose;
end;
end;
procedure Tactivextest.SendCommandAndStream(TCPClient: TIdTCPClient; Command: String;
Ms: TMemoryStream);
begin
if not TCPClient.Connected then
Exit;
TCPClient.Socket.WriteLn('2' + Command);
Ms.Position := 0;
with TCPClient.Socket do
begin
Write(Ms.Size);
WriteBufferOpen;
Write(Ms, 0);
WriteBufferClose;
end;
end;
procedure Tactivextest.SendCommandWithParamsAndStream(TCPClient: TIdTCPClient;
Command, Params: String; Ms: TMemoryStream);
var
PackedParams: TPackedParams;
begin
if not TCPClient.Connected then
Exit;
SendCommand(TCPClient, '3' + Command);
PackedParams.Params := ShortString(Params);
TCPClient.Socket.Write(RawToBytes(PackedParams, SizeOf(PackedParams)));
Ms.Position := 0;
with TCPClient.Socket do
begin
Write(Ms.Size);
WriteBufferOpen;
Write(Ms, 0);
WriteBufferClose;
end;
end;
I am able to connect to the server, but the client thread cannot be started same as VCL so I am unable to call SendCommands() as I have been disconnected because I cannot use client thread inside ActiveX. I have searched for many days about how to solve, and I cannot find a solution to this problem. I know ActiveX is dead, but this is for education purposes.
It is not possible for TIdTCPClient.OnConnected to not be triggered if Connect() is successful, so the client thread has to be getting created. And if Start() is not raising an exception, then the thread will start running.
However, a major problem with your thread code is that HandleInput() is being run in the context of the main thread via TThread.Synchronize(), which DOES NOT work in a DLL (ActiveX or otherwise) without extra cooperation of the main thread of the hosting EXE. HandleInput() should not be synchronized at all, but then once you fix that, ProcessCommands() is doing things that are not thread-safe (using MessageDlg(), and accessing Panel1 and Memo1 directly), which do need to be synchronized.
So, you need to re-write your thread logic to avoid these pitfalls. Try something more like this:
type
TClientThread = class(TThread)
protected
procedure Execute; override;
end;
procedure TClientThread.Execute;
begin
activext.SendCommandWithParams(activext.TCPClient, 'LOGIN', activext.namewithicon + activext.Sep);
while (not Terminated) and activext.TCPClient.Connected do
begin
Command := activext.TCPClient.Socket.ReadLn('', 5);
if Command <> '' then
activext.ProcessCommands(Command);
end;
end;
type
Tactivextest = class(TActiveForm)
TCPClient: TIdTCPClient;
...
private
...
LineToAdd: string;
procedure UpdatePanel;
procedure AddLineToMemo;
...
end;
procedure Tactivextest.FormCreate(Sender: TObject);
begin
TCPClient.Host := 'localhost';
TCPClient.Port := 31000;
try
TCPClient.Connect;
except
on E: Exception do
begin
MessageBox(0, 'Cannot connect to server!', 'Error', MB_OK);
raise;
end;
end;
end;
// TTimer OnTimer event handler
procedure Tactivextest.Timer1Timer(Sender: TObject);
begin
// needed for TThread.Synchronize() to work in a DLL...
CheckSynchronize;
end;
procedure Tactivextest.TCPClientConnected(Sender: TObject);
begin
ClientThread := TClientThread.Create(False);
end;
procedure Tactivextest.UpdatePanel;
begin
Panel1.Caption := 'connect ' + namewithicon + ')';
end;
procedure Tactivextest.AddLineToMemo;
begin
Memo1.Lines.Add(LineToAdd);
end;
procedure Tactivextest.ProcessCommands(Command: string);
var
Params: array [1 .. 10] of String;
ParamsCount, P: Integer;
PackedParams: TPackedParams;
IdBytes: TIdBytes;
Ms: TMemoryStream;
ReceiveParams, ReceiveStream: Boolean;
Size: Int64;
begin
ReceiveParams := False;
ReceiveStream := False;
Ms := TMemoryStream.Create;
try
case Command[1] of
'1': // command with params
begin
Command := Copy(Command, 2, MaxInt);
ReceiveParams := True;
end;
'2': // command + stream
begin
Command := Copy(Command, 2, MaxInt);
ReceiveStream := True;
end;
'3': // command with params + stream
begin
Command := Copy(Command, 2, MaxInt);
ReceiveParams := True;
ReceiveStream := True;
end;
end;
if ReceiveParams then // params incoming
begin
TCPClient.Socket.ReadBytes(IdBytes, SizeOf(PackedParams), False);
BytesToRaw(IdBytes, PackedParams, SizeOf(PackedParams));
ParamsCount := 0;
repeat
Inc(ParamsCount);
P := Pos(Sep, String(PackedParams.Params));
Params[ParamsCount] := Copy(String(PackedParams.Params), 1, P - 1);
Delete(PackedParams.Params, 1, P + 4);
until (PackedParams.Params = '') or (ParamsCount = 10);
end;
if ReceiveStream then // stream incoming
begin
Size := TCPClient.Socket.ReadInt64;
if Size > 0 then
begin
TCPClient.Socket.ReadStream(Ms, Size, False);
Ms.Position := 0;
end;
end;
if Command = 'SIMPLEMESSAGE' then
begin
MessageBox(0, PChar(Params[1]), 'Message', MB_OK);
end
else if Command = 'INVALIDPASSWORD' then
begin
TCPClient.Disconnect;
MessageBox(0, 'Invalid password!', 'Error', MB_OK);
end
else if Command = 'SENDYOURINFO' then // successfully logged in
begin
UniqueID := StrToInt(Params[1]);
TThread.Synchronize(nil, UpdatePanel);
SendCommandWithParams(TCPClient, 'TAKEMYINFO', namewithicon + Sep);
end
else if Command = 'DISCONNECTED' then
begin
TCPClient.Disconnect;
end
else if Command = 'TEXTMESSAGE' then
begin
LineToAdd := Params[1] + ' : ' + Params[2];
TThread.Synchronize(nil, AddLineToMemo);
end;
finally
Ms.Free;
end;
end;
initialization
TActiveFormFactory.Create(
ComServer,
TActiveFormControl,
Tactivextest,
Class_activextest,
0,
'',
OLEMISC_SIMPLEFRAME or OLEMISC_ACTSLIKELABEL,
tmApartment);
end.
I'm building a Delphi XE3 application which needs to be able to have files dropped onto it. I have the Explorer > Application side of things working, but for the life of me can't figure out to get the filename when going from Application > Application.
Assuming one file is dropped from say Outlook (or any other application), I have this which works as long as I manually assign filename before hand.
SetFormatEtc( FormatEtc , CF_FILECONTENTS );
OleCheck( dataObj.GetData( FormatEtc , Medium ) );
OleStream := TOleStream.Create( IUnknown( Medium.stm ) as IStream );
MemStream := TMemoryStream.Create;
OleStream.Position := 0;
MemStream.CopyFrom( OleStream , OleStream.Size );
TMemoryStream( MemStream ).SaveToFile( 'C:\' + filename );
MemStream.Free;
OleStream.Free;
ReleaseStgMedium( Medium );
CF_FILECONTENTS format can contain several stream. You must check CF_FILEDESCRIPTORW and CF_FILEDESCRIPTORA formats for detection of stream count and stream names. Some sources:
function ContainFormat(ADataObject: IDataObject; AFormat: TClipFormat;
ATymed: Longint; AAspect: LongInt = DVASPECT_CONTENT; AIndex: LongInt = -1): Boolean;
var Format: TFormatEtc;
begin
ZeroMemory(#Format, SizeOf(Format));
Format.cfFormat := AFormat;
Format.dwAspect := AAspect;
Format.lindex := AIndex;
Format.tymed := ATymed;
Result := ADataObject.QueryGetData(Format) = S_OK;
end;
procedure InvalidMedium;
begin
raise Exception.Create('Invalid medium');
end;
function ExtractStream(ADataObject: IDataObject; AIndex: Integer): IStream;
var Format: TFormatEtc;
Medium: TStgMedium;
begin
ZeroMemory(#Format, SizeOf(Format));
Format.cfFormat := CF_FILECONTENTS;
Format.dwAspect := DVASPECT_CONTENT;
Format.lindex := AIndex;
Format.tymed := TYMED_ISTREAM;
ZeroMemory(#Medium, SizeOf(Medium));
OleCheck(ADataObject.GetData(Format, Medium));
try
if (Medium.tymed and TYMED_ISTREAM = 0) or not Assigned(Medium.stm) then
InvalidMedium;
Result := IStream(Medium.stm);
finally
ReleaseStgMedium(Medium);
end
end;
procedure WorkWithDropObject(const AFileName: UnicodeString; AStream: IStream);
begin
end;
procedure ProcessDataObject(ADataObject: IDataObject);
var Format: TFormatEtc;
Medium: TStgMedium;
FGDA: PFileGroupDescriptorA;
FGDW: PFileGroupDescriptorW;
i: Integer;
Stream: IStream;
begin
if ContainFormat(ADataObject, CF_FILECONTENTS, TYMED_ISTREAM) then
begin
if ContainFormat(ADataObject, CF_FILEDESCRIPTORW, TYMED_HGLOBAL) then
begin
Format.cfFormat := CF_FILEDESCRIPTORW;
Format.dwAspect := DVASPECT_CONTENT;
Format.lindex := -1;
Format.tymed := TYMED_HGLOBAL;
ZeroMemory(#Medium, SizeOf(Medium));
OleCheck(ADataObject.GetData(Format, Medium));
try
if (Medium.tymed and TYMED_HGLOBAL = 0) or (Medium.hGlobal = 0) then
InvalidMedium;
FGDW := GlobalLock(Medium.hGlobal);
if not Assigned(FGDW) then
RaiseLastOSError;
try
for i := 0 to FGDW.cItems - 1 do
begin
Stream := ExtractStream(ADataObject, i);
try
WorkWithDropObject(FGDW.fgd[i].cFileName, Stream);
finally
Stream := nil;
end;
end;
finally
GlobalUnlock(Medium.hGlobal);
end;
finally
ReleaseStgMedium(Medium);
end
end
else
if ContainFormat(ADataObject, CF_FILEDESCRIPTORA, TYMED_HGLOBAL) then
begin
Format.cfFormat := CF_FILEDESCRIPTORA;
Format.dwAspect := DVASPECT_CONTENT;
Format.lindex := -1;
Format.tymed := TYMED_HGLOBAL;
ZeroMemory(#Medium, SizeOf(Medium));
OleCheck(ADataObject.GetData(Format, Medium));
try
if (Medium.tymed and TYMED_HGLOBAL = 0) or (Medium.hGlobal = 0) then
InvalidMedium;
FGDA := GlobalLock(Medium.hGlobal);
if not Assigned(FGDA) then
RaiseLastOSError;
try
for i := 0 to FGDA.cItems - 1 do
begin
Stream := ExtractStream(ADataObject, i);
try
WorkWithDropObject(FGDA.fgd[i].cFileName, Stream);
finally
Stream := nil;
end;
end;
finally
GlobalUnlock(Medium.hGlobal);
end;
finally
ReleaseStgMedium(Medium);
end
end;
end;
end;
Also I you want to create universal software you should process the following formats:
CF_FILENAMEW/CF_FILENAMEA
CF_HDROP
CF_IDLIST
CF_FILEDESCRIPTORW/CF_FILEDESCRIPTORA/CF_FILECONTENTS