Cannot make DragAcceptFiles work when using a dialog box - delphi

I am using Delphi to code a simple app that needs to accept dropped directory names onto it. Though I am using Delphi, this program is straight Windows API (no VCL, no object oriented stuff) just as it would be in plain C.
I had some code that already worked using a normal window (as created by CreateWindowEx). When I converted that code to use a dialog box, the drag and drop functionality broke and I cannot figure out why.
This is (part of) the code I had that worked fine:
function WndProc (Wnd : hWnd; Msg, wParam, lParam : DWORD) : DWORD; stdcall;
{ main application/window handler function }
const
DROPPED_FILE_COUNT = -1;
var
FileCnt : integer; { number of files dropped }
Filename : packed array[0..MAX_PATH] of char; { filename buffer }
DropInfo : HDROP absolute wParam; { wParam points to Drop...}
I : integer; { for loop }
begin
WndProc := 0;
{ let the Windows default handler take care of everything }
case msg of
WM_CREATE:
begin
InitCommonControls;
if CreateWindowEx(WS_EX_CLIENTEDGE or WS_EX_RIGHTSCROLLBAR,
'LISTBOX',
nil,
WS_CHILD or WS_HSCROLL or WS_VSCROLL or
WS_CLIPSIBLINGS or WS_CLIPCHILDREN or
WS_VISIBLE or LBS_NOINTEGRALHEIGHT,
0,
0,
0,
0,
Wnd,
IDC_LISTBOX,
hInstance,
nil) = 0 then
begin
MessageBox(Wnd,
'Couldn''t create the listbox', 'Main Window', MB_OK);
WndProc := -1;
end;
{ let Windows know that we accept files being dragged over our client}
{ area. }
DragAcceptFiles(Wnd, TRUE);
{ tell the listbox to use a nice font }
SendMessage(GetDlgItem(Wnd, IDC_LISTBOX),
WM_SETFONT, GetStockObject(DEFAULT_GUI_FONT), 0);
exit;
end; { WM_CREATE }
WM_DROPFILES:
begin
{ one or more files have been dropped on us! }
FileCnt := DragQueryFile(DropInfo, DROPPED_FILE_COUNT, nil, 0);
for I := 0 to FileCnt - 1 do
begin
{ get the dropped files names and add them to the listbox }
DragQueryFile(DropInfo, I, Filename, sizeof(Filename));
ListBox_AddString(GetDlgItem(Wnd, IDC_LISTBOX), Filename);
end;
{ tell Windows that we are done grabbing the dropped files }
DragFinish(DropInfo);
exit;
end; { WM_DROPFILES }
... followed by other stuff that has nothing to do with drag and drop ...
I converted that to this:
procedure ExecWM_INITDIALOG(wnd : hWnd);
begin
{ ensure that the listbox isn't accepting dropped files }
DragAcceptFiles(GetDlgItem(Wnd, IDC_DIRECTORIES), FALSE);
{ ensure the main dialog window accept dropped files }
DragAcceptFiles(Wnd, TRUE);
{ load the current values in the registry }
LoadRegistrySettings(RegistryKey, RegistrySettings, RegistrySettingsCount)
end;
procedure ExecWM_DROPFILES(Wnd : hWnd; wParam : word; lParam : longint);
const
DROPPED_FILE_COUNT = -1;
var
FileCnt : integer; { number of files dropped }
Filename : packed array[0..MAX_PATH] of char; { filename buffer }
DropInfo : HDROP absolute wParam; { wParam points to Drop...}
I : integer; { for loop }
begin
{ one or more files have been dropped on us! }
{ -->>> The problem seems to show up at this statement: }
{ the DropInfo (wParam) has a value that seems too low ($20) }
{ when using the code that works the value is much larger }
FileCnt := DragQueryFile(DropInfo, DROPPED_FILE_COUNT, nil, 0);
for I := 0 to FileCnt - 1 do
begin
{ get the dropped files names and add them to the listbox }
DragQueryFile(DropInfo, I, Filename, sizeof(Filename));
ListBox_AddString(GetDlgItem(Wnd, IDC_DIRECTORIES), Filename);
end;
{ tell Windows that we are done grabbing the dropped files }
DragFinish(DropInfo);
end;
function BackupConfigProc(wnd : hWnd;
msg : word;
wParam : word;
lParam : longint) : bool; stdcall;
begin
BackupConfigProc := FALSE; { default return value }
case msg of
WM_COMMAND:
begin
ExecWM_COMMAND (wnd, wParam, lParam);
BackupConfigProc := TRUE;
end;
WM_DROPFILES:
begin
ExecWM_DROPFILES(Wnd, wParam, lParam);
//BackupConfigProc := TRUE; { this was a shot in the dark }
end;
WM_INITDIALOG:
begin
ExecWM_INITDIALOG (wnd);
BackupConfigProc := TRUE;
end;
WM_CLOSE:
begin
EndDialog(wnd, 0); { and return the default FALSE }
end;
end;
end;
begin
DialogBox(hInstance, 'BackupConfigDlg', 0, #BackupConfigProc);
end.
It looks like the value of the DropInfo (wParam) received by the dialog box is not valid (as it is much lower in value than the one received by the non dialog code that works).
I will be grateful to all who can shed some light as to why the Dialog version does not work and what needs to be done to make it work.
Thank you,
John.

procedure ExecWM_DROPFILES(Wnd : hWnd; wParam : word; lParam : longint);
wParam should not be typed word but Windows.WPARAM which is actually a long int (on Win32).

Related

How to eliminate header artifacts during tracking - HDN_TRACK?

When doing "real time" tracking, the header control occasionally leaves artifacts behind, as the image below shows:
The first two images are from the attached program. The third image (without the blue coloring) is from Windows Explorer.
To get the artifacts, simply drag the separator off the right side of program's window right edge and bring it back quickly into view. It may take a couple of tries, depending on how quickly you bring the separator back into the window.
Windows Explorer avoids the problem by having the header not paint that black vertical bar when dragging.
EDIT: As Sertac below pointed out, Windows Explorer uses a different control, which is why it does not exhibit the problem.
I have two (2) questions:
How does one tell the header control not to paint that vertical black bar? I couldn't find anything in the documentation on that.
If getting rid of the black bar is not possible without "owner-drawing" the header, is there some way to prevent the artifact from appearing?
The program I am using to test the header control is below.
{$LONGSTRINGS OFF}
{$WRITEABLECONST ON}
{$ifdef WIN32} { tell Windows we want v6 of commctrl }
{$R Manifest32.res}
{$endif}
{$ifdef WIN64}
{$R Manifest64.res}
{$endif}
program _Header_Track;
uses Windows, Messages, CommCtrl;
const
ProgramName = 'Header_Track';
{-----------------------------------------------------------------------------}
{$ifdef VER90} { Delphi 2.0 }
type
ptrint = longint;
ptruint = dword;
const
ICC_WIN95_CLASSES = $000000FF; { missing in Delphi 2 }
type
TINITCOMMONCONTROLSEX = packed record
dwSize : DWORD;
dwICC : DWORD;
end;
PINITCOMMONCONTROLSEX = ^TINITCOMMONCONTROLSEX;
function InitCommonControlsEx(var InitClasses : TINITCOMMONCONTROLSEX)
: BOOL; stdcall; external comctl32;
{$endif}
{$ifdef VER90}
// for Delphi 2.0 define GetWindowLongPtr and SetWindowLongPtr as synonyms of
// GetWindowLong and SetWindowLong respectively.
function GetWindowLongPtr(Wnd : HWND;
Index : ptrint)
: ptruint; stdcall; external 'user32' name 'GetWindowLongA';
function SetWindowLongPtr(Wnd : HWND;
Index : ptrint;
NewLong : DWORD)
: ptruint; stdcall; external 'user32' name 'SetWindowLongA';
function GetClassLongPtr(Wnd : HWND;
Index : ptrint)
: ptruint; stdcall; external 'user32' name 'GetClassLongA';
function SetClassLongPtr(Wnd : HWND;
Index : ptrint;
NewLong : ptruint)
: ptruint; stdcall; external 'user32' name 'SetClassLongA';
{$endif}
{$ifdef FPC}
{ make the FPC definitions match Delphi's }
type
THDLAYOUT = record
Rect : PRECT;
WindowPos : PWINDOWPOS;
end;
PHDLAYOUT = ^THDLAYOUT;
function Header_Layout(Wnd : HWND; Layout : PHDLAYOUT) : WINBOOL; inline;
begin
Header_Layout := WINBOOL(SendMessage(Wnd, HDM_LAYOUT, 0, ptruint(Layout)));
end;
{$endif}
{-----------------------------------------------------------------------------}
function WndProc (Wnd : HWND; Msg : UINT; wParam, lParam : ptrint)
: ptrint; stdcall;
{ main application/window handler function }
const
HEADER_ID = 1000;
HEADER_ITEMS_WIDTH = 100;
Header : HWND = 0;
HeaderText : packed array[0..2] of pchar =
(
'Name',
'Date modified',
'Type'
);
var
ControlsInit : TINITCOMMONCONTROLSEX;
HeaderPos : TWINDOWPOS;
HeaderRect : TRECT;
HeaderNotification : PHDNOTIFY absolute lParam; { note overlay on lParam }
HeaderLayout : THDLAYOUT;
HeaderItem : THDITEM;
ClientRect : TRECT;
Style : ptruint;
i : integer;
begin
WndProc := 0;
case Msg of
WM_CREATE:
begin
{ initialize the common controls library }
with ControlsInit do
begin
dwSize := sizeof(ControlsInit);
dwICC := ICC_WIN95_CLASSES; { includes headers }
end;
InitCommonControlsEx(ControlsInit);
{ create the header control }
Header := CreateWindowEx(0,
WC_HEADER, { class name }
nil, { caption }
HDS_BUTTONS or
WS_CHILD or
WS_VISIBLE or
WS_CLIPCHILDREN or
WS_CLIPSIBLINGS,
0, { at parent x = 0 }
0, { y = 0 }
0, { width }
0, { height }
Wnd, { parent }
HEADER_ID, { child id }
hInstance,
nil);
if Header = 0 then
begin
MessageBox(Wnd,
'Couldn''t create a header',
'Main Window - WM_CREATE',
MB_ICONERROR or MB_OK);
WndProc := -1; { abort window creation }
exit;
end;
{ remove the annoying double click behavior of the header buttons }
Style := GetClassLongPtr(Header, GCL_STYLE);
Style := Style and (not CS_DBLCLKS);
SetClassLongPtr(Header, GCL_STYLE, Style);
{ tell the header which font to use }
SendMessage(Header, WM_SETFONT, GetStockObject(DEFAULT_GUI_FONT), 0);
{ insert the column header in the header control }
with HeaderItem do
for i := low(HeaderText) to high(HeaderText) do
begin
mask := HDI_FORMAT or HDI_TEXT or HDI_WIDTH;
pszText := HeaderText[i];
fmt := HDF_STRING;
cxy := HEADER_ITEMS_WIDTH; { width }
Header_InsertItem(Header, i, HeaderItem);
end;
exit;
end;
WM_SIZE:
begin
{ update the header size and location }
with HeaderLayout do
begin
WindowPos := #HeaderPos;
Rect := #HeaderRect;
end;
GetClientRect(Wnd, ClientRect);
CopyRect(HeaderRect, ClientRect);
ZeroMemory(#HeaderPos, sizeof(HeaderPos));
Header_Layout(Header, #HeaderLayout); { updates HeaderPos }
{ use HeaderPos to place the header where it should be in the window }
with HeaderPos do
begin
SetWindowPos(Header,
Wnd, x, y, cx, cy,
Flags);
end;
exit;
end; { WM_SIZE }
WM_NOTIFY:
begin
case HeaderNotification^.Hdr.Code of
HDN_BEGINTRACK:
begin
{ Allow dragging using the left mouse button only }
if HeaderNotification^.Button <> 0 then
begin
WndProc := ptrint(TRUE); { don't track }
exit;
end;
exit;
end;
HDN_TRACK:
begin
{ tell the header to resize itself }
Header_SetItem(Header,
HeaderNotification^.Item,
HeaderNotification^.pitem^);
exit;
end;
end;
end;
WM_DESTROY:
begin
PostQuitMessage(0);
exit;
end;
end; { case msg }
WndProc := DefWindowProc (Wnd, Msg, wParam, lParam);
end;
{-----------------------------------------------------------------------------}
function InitAppClass: WordBool;
{ registers the application's window classes }
var
cls : TWndClassEx;
begin
cls.cbSize := sizeof(TWndClassEx); { must be initialized }
if not GetClassInfoEx (hInstance, ProgramName, cls) then
begin
with cls do
begin
style := CS_BYTEALIGNCLIENT;
lpfnWndProc := #WndProc;
cbClsExtra := 0;
cbWndExtra := 0;
hInstance := system.hInstance;
hIcon := 0;
hCursor := LoadCursor(0, IDC_ARROW);
hbrBackground := COLOR_WINDOW + 1;
lpszMenuName := nil;
lpszClassName := ProgramName;
hIconSm := 0;
end;
InitAppClass := WordBool(RegisterClassEx(cls));
end
else InitAppClass := TRUE;
end;
{-----------------------------------------------------------------------------}
function WinMain : integer;
{ application entry point }
var
Wnd : HWND;
Msg : TMsg;
begin
if not InitAppClass then Halt (255); { register application's class }
{ Create the main application window }
Wnd := CreateWindowEx(WS_EX_CLIENTEDGE,
ProgramName, { class name }
ProgramName, { window caption text }
ws_OverlappedWindow or { window style }
ws_SysMenu or
ws_MinimizeBox or
ws_ClipSiblings or
ws_ClipChildren or { don't affect children }
ws_visible, { make showwindow unnecessary }
20, { x pos on screen }
20, { y pos on screen }
600, { window width }
200, { window height }
0, { parent window handle }
0, { menu handle 0 = use class }
hInstance, { instance handle }
nil); { parameter sent to WM_CREATE }
if Wnd = 0 then Halt; { could not create the window }
while GetMessage (Msg, 0, 0, 0) do { wait for message }
begin
TranslateMessage (Msg); { key conversions }
DispatchMessage (Msg); { send to window procedure }
end;
WinMain := Msg.wParam; { terminate with return code }
end;
begin
WinMain;
end.
This is an artifact caused by attempting to use the control in two different functionality modes at the same time. That, and of course fast mouse movement...
The black vertical line is actually the indicator that hints the final separator position when the mouse button will be released. Of course this indicator is only to be used when the header control does not reflect column resizing at real time.
You are, however, resizing the column at real time responding to the tracking notification. You should instead use the header control in live column drag mode and so that the indicator will not be drawn at all.
In summary, include HDS_FULLDRAG control style:
Header := CreateWindowEx(0,
WC_HEADER, { class name }
nil, { caption }
HDS_BUTTONS or
WS_CHILD or
WS_VISIBLE or
WS_CLIPCHILDREN or
WS_CLIPSIBLINGS or
HDS_FULLDRAG,
0, { at parent x = 0 }
0, { y = 0 }
0, { width }
0, { height }
Wnd, { parent }
HEADER_ID, { child id }
hInstance,
nil);
and leave out the track notification:
...
{ // don't tell the header to resize, it will do it itself
HDN_TRACK:
begin
// tell the header to resize itself
Header_SetItem(Header,
HeaderNotification^.Item,
HeaderNotification^.pitem^);
exit;
end;
}
...

SendMessage(WM_COPYDATA) + Record + String

I want to send a record, that right now have only a string on it, but I will add more variables. Is the first time I work with records, so this maybe is a silly question. But, why this works:
type
TDataPipe = record
WindowTitle: String[255];
end;
var
Data: TDataPipe;
copyDataStruct : TCopyDataStruct;
begin
Data.WindowTitle:= String(PChar(HookedMessage.lParam));
copyDataStruct.dwData := 0;
copyDataStruct.cbData := SizeOf(Data);
copyDataStruct.lpData := #Data;
SendMessage(FindWindow('TForm1', nil), WM_COPYDATA, Integer(hInstance), Integer(#copyDataStruct));
end;
Receiving side:
type
TDataPipe = record
WindowTitle: String[255];
end;
procedure TForm1.WMCopyData(var Msg: TWMCopyData);
var
sampleRecord : TDataPipe;
begin
sampleRecord.WindowTitle:= TDataPipe(Msg.CopyDataStruct.lpData^).WindowTitle;
Memo1.Lines.Add(sampleRecord.WindowTitle);
end;
Why if on the record, I use:
WindowTitle: String; //removed the fixed size
and on the sending side I use:
Data.WindowTitle:= PChar(HookedMessage.lParam); //removed String()
it simply doesn't go?
I get access violations / app freeze...
The scenario is: sending side is a DLL hooked using SetWindowsHookEx, receiving side a simple exe that loaded / called SetWindowsHookEx...
A String[255] is a fixed 256-byte block of memory, where the character data is stored directly in that memory. As such, it is safe to pass as-is across process boundaries without serialization.
A String, on the other hand, is a dynamic type. It just contains a pointer to character data that is stored elsewhere in memory. As such, you can't pass a String as-is across process boundaries, all you would be passing is the pointer value, which has no meaning to the receiving process. You have to serialize String data into a flat format that can safely by passed to, and deserialized by, the receiving process. For example:
Sending side:
type
PDataPipe = ^TDataPipe;
TDataPipe = record
WindowTitleLen: Integer;
WindowTitleData: array[0..0] of Char;
//WindowTitleData: array[0..WindowTitleLen-1] of Char;
end;
var
Wnd: HWND;
s: String;
Data: PDataPipe;
DataLen: Integer;
copyDataStruct : TCopyDataStruct;
begin
Wnd := FindWindow('TForm1', nil);
if Wnd = 0 then Exit;
s := PChar(HookedMessage.lParam);
DataLen := SizeOf(Integer) + (SizeOf(Char) * Length(s));
GetMem(Data, DataLen);
try
Data.WindowTitleLen := Length(s);
StrMove(Data.WindowTitleData, PChar(s), Length(s));
copyDataStruct.dwData := ...; // see notes further below
copyDataStruct.cbData := DataLen;
copyDataStruct.lpData := Data;
SendMessage(Wnd, WM_COPYDATA, 0, LPARAM(#copyDataStruct));
finally
FreeMem(Data);
end;
end;
Receiving side:
type
PDataPipe = ^TDataPipe;
TDataPipe = record
WindowTitleLen: Integer;
WindowTitleData: array[0..0] of Char;
//WindowTitleData: array[0..WindowTitleLen-1] of Char;
end;
procedure TForm1.WMCopyData(var Msg: TWMCopyData);
var
Data: PDataPipe;
s: string;
begin
Data := PDataPipe(Msg.CopyDataStruct.lpData);
SetString(s, Data.WindowTitleData, Data.WindowTitleLen);
Memo1.Lines.Add(s);
end;
That being said, in either situation, you really should be assigning your own custom ID number to the copyDataStruct.dwData field. The VCL itself uses WM_COPYDATA internally, so you don't want to get those messages confused with yours, and vice versa. You can use RegisterWindowMessage() to create a unique ID to avoid conflicts with IDs used by other WM_COPYDATA users:
var
dwMyCopyDataID: DWORD;
...
var
...
copyDataStruct : TCopyDataStruct;
begin
...
copyDataStruct.dwData := dwMyCopyDataID;
...
end;
...
initialization
dwMyCopyDataID := RegisterWindowMessage('MyCopyDataID');
var
dwMyCopyDataID: DWORD;
...
procedure TForm1.WMCopyData(var Msg: TWMCopyData);
var
...
begin
if Msg.CopyDataStruct.dwData = dwMyCopyDataID then
begin
...
end else
inherited;
end;
...
initialization
dwMyCopyDataID := RegisterWindowMessage('MyCopyDataID');
Lastly, the WPARAM parameter of WM_COPYDATA is an HWND, not an HINSTANCE. If the sender does not have its own HWND, just pass 0. Do not pass your sender's HInstance variable.
Preparation:
procedure TMainForm.CreateParams(var Params: TCreateParams);
begin
inherited;
StrCopy(Params.WinClassName, PChar(SingleInstClassName)); // Copies a null-terminated string. StrCopy is designed to copy up to 255 characters from the source buffer into the destination buffer. If the source buffer contains more than 255 characters, the procedure will copy only the first 255 characters.
end;
Sender:
procedure TAppData.ResurectInstance(Arg: string);
VAR
Window: HWND;
DataToSend: TCopyDataStruct;
begin
Arg:= Trim(Arg);
{ Prepare the data you want to send }
DataToSend.dwData := CopyDataID; // CopyDataID = Unique ID for my apps
DataToSend.cbData := Length(Arg) * SizeOf(Char);
DataToSend.lpData := PChar(Arg);
{ We should never use PostMessage() with the WM_COPYDATA message because the data that is passed to the receiving application is only valid during the call. Finally, be aware that the call to SendMessage will not return until the message is processed.}
Window:= WinApi.Windows.FindWindow(PWideChar(SingleInstClassName), NIL); // This is a copy of cmWindow.FindTopWindowByClass
SendMessage(Window, WM_COPYDATA, 0, LPARAM(#DataToSend));
end;
Receiver:
procedure TMainForm.WMCopyData(var Msg: TWMCopyData);
VAR
FileName: string;
begin
{ Receives filename from another instance of this program }
if (Msg.CopyDataStruct.dwData = AppData.CopyDataID) { Only react on this specific message }
AND (Msg.CopyDataStruct.cbData > 0) { Do I receive an empty string? }
then
begin
SetString(FileName, PChar(Msg.CopyDataStruct.lpData), Msg.CopyDataStruct.cbData div SizeOf(Char));
msg.Result:= 2006; { Send something back as positive answer }
AppData.Restore;
...
end
else
inherited;
end;

Tabs and colored lines in Listbox

I am using a Tabbed Listbox component that was written by Fredric Rylander back in 1999 and it has been serving me well since then. :) Can't seem to find him anymore.
I now have an application that needs both Tabbed Data and alternating colored lines in the Listbox.
I can include the Component here for perusal if desired.
I tried coloring the lines from here
http://delphi.about.com/cs/adptips2002/a/bltip0602_4.htm
But then it eats the Tabs, but I do get the alternating colored lines.
Can someone please show me how to incorporate the two.
Thanks
Here's the Component
unit myListBoxTabbed;
{
Copyright © 1999 Fredric Rylander
You can easily add a header control to this list box: drop a header
control onto the form (it's default align property is set to alTop, if
it's not--set it); then set the myTabbedListBox's aligned property
to alClient; now, add the following two events and their code.
1) HeaderControl's OnSectionResize event:
var
i, last: integer;
begin
last := 0;
for i:=0 to HeaderControl1.Sections.Count-1 do begin
last := last + HeaderControl1.Sections[i].Width;
myTabbedListBox1.TabStops[i] := last;
end;
end;
2) Main form's OnCreate event:
var
i, last: integer;
begin
last := 0;
for i:=0 to HeaderControl1.Sections.Count-1 do begin
last := last + HeaderControl1.Sections[i].Width;
myTabbedListBox1.TabStops[i] := last;
end;
for i:=HeaderControl1.Sections.Count to MaxNumSections do
myTabbedListBox1.TabStops[i] := 2000;
end;
To get tab characters into the list box items either use the
string list property editor in the Delphi GUI and press
Ctrl + Tab or add tab characters (#9) in strings as so:
myTabbedListBox1.Items.Add( Edit1.Text + #9 + Edit2.Text );
I hope you find this tutorial helpful! :^)
(!) This is not a retail product, it's a tutorial and don't claim to
meet a potential user's demands.
If you find anything that seems odd (or incorrect even) don't hesitate to
write me a line. You can communicate with me at fredric#rylander.nu.
The source is available for you to use, abuse, modify and/or improve.
Happy trails!
/ Fredric
___________________________________F_r_e_d_r_i_c__R_y_l_a_n_d_e_r__
fredric#rylander.nu : www.rylander.nu : 6429296#pager.mirabilis.com
"power to the source sharing community"
}
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls;
type
TTabsArray = array[0..9] of integer;
type
TmyTabbedListBox = class( TListBox )
private
{ Private declarations }
fTabStops: TTabsArray;
function GetTabStops( iIndex: integer ): integer;
procedure SetTabStops( iIndex, iValue: integer);
function GetTabsString: string;
procedure SetTabsString( const sValue: string );
protected
{ Protected declarations }
procedure UpdateTabStops;
public
{ Public declarations }
procedure CreateParams( var cParams: TCreateParams ); override;
procedure CreateWnd; override;
property TabStops[ iIndex: integer ]: integer
read GetTabStops write SetTabStops;
published
{ Published declarations }
property TabsString: string
read GetTabsString write SetTabsString;
end;
procedure Register;
resourcestring
STR_ALPHA_UPPERLOWER = 'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz';
CHAR_SEMICOLON = ';';
implementation
procedure Register;
begin
RegisterComponents('Additional', [TmyTabbedListBox]);
end;
{ myTabbedListBox }
procedure TmyTabbedListBox.CreateParams(var cParams: TCreateParams);
begin
inherited CreateParams( cParams );
// add the window style LBS_USETABSTOPS to accept tabs
cParams.Style := cParams.Style or LBS_USETABSTOPS;
end;
procedure TmyTabbedListBox.CreateWnd;
var
i: integer;
begin
inherited CreateWnd;
// set all the tabs into the box
for i := Low( fTabStops ) to High( fTabStops ) do
fTabStops[i] := i * 100;
// show the real tab positions
UpdateTabStops;
end;
function TmyTabbedListBox.GetTabsString: string;
var
sBuffer: string;
i: integer;
begin
// init var
sBuffer := SysUtils.EmptyStr;
// set all tabstops to the string (separated by ';'-char)
for i := Low( fTabStops ) to High( fTabStops ) do
sBuffer := sBuffer + IntToStr( fTabStops[i] ) + CHAR_SEMICOLON;
// and here we have the results
Result := sBuffer;
end;
function TmyTabbedListBox.GetTabStops( iIndex: integer ): integer;
begin
// nothing funny here
Result := fTabStops[iIndex];
end;
procedure TmyTabbedListBox.SetTabsString( const sValue: string );
var
sBuffer: string;
i, len: integer;
begin
// copy value into buffer
sBuffer := sValue;
// set the tabstops as specified
for i := Low( fTabStops ) to High( fTabStops ) do begin
len := Pos( sBuffer, CHAR_SEMICOLON );
fTabStops[i] := StrToIntDef( Copy( sBuffer, 1, len ), 0 );
Delete( sBuffer, 1, len );
end;
// show/redraw the results
UpdateTabStops;
Invalidate;
end;
procedure TmyTabbedListBox.SetTabStops( iIndex, iValue: integer );
begin
// do we really need to update?
if fTabStops[iIndex] <> iValue then begin
// oki, let's then
fTabStops[iIndex] := iValue;
// show/redraw the results
UpdateTabStops;
Invalidate;
end;
end;
procedure TmyTabbedListBox.UpdateTabStops;
var
i, iHUnits: integer;
arrConvertedTabs: TTabsArray;
begin
// convert dialog box units to pixels.
// dialog box unit = average character width/height div 4/8
// determine the horizontal dialog box units used by the
// list box (which depend on its current font)
Canvas.Font := Font;
iHUnits := Canvas.TextWidth( STR_ALPHA_UPPERLOWER ) div 52;
// convert the array of tab values
for i := Low( arrConvertedTabs ) to High( arrConvertedTabs ) do
arrConvertedTabs[i] := ( fTabStops[i] * 4 ) div iHUnits;
// activate the tabs stops in the list box,
// sending a Windows list box message
SendMessage( Handle, LB_SETTABSTOPS,
1 + High( arrConvertedTabs ) - Low( arrConvertedTabs ),
LongInt( #arrConvertedTabs ) );
end;
end.
Here's an example using a standard TListBox and it's OnDrawItem event, based on the code from the link you provided and tested in Delphi 2007. Note you need to set the ListBox.Style to lbOwnerDrawFixed. You can perhaps use this as a base for modifying the component (or just abandon it altogether).
procedure TForm1.ListBox1DrawItem(Control: TWinControl; Index: Integer;
Rect: TRect; State: TOwnerDrawState);
var
LB: TListBox;
NewColor: TColor;
NewBrush: TBrush;
R: TRect;
Fmt: Cardinal;
ItemText: string;
begin
NewBrush := TBrush.Create;
LB := (Control as TListBox);
if (odSelected in State) then
begin
NewColor := LB.Canvas.Brush.Color;
end
else
begin
if not Odd(Index) then
NewColor := clSilver
else
NewColor := clYellow;
end;
NewBrush.Style := bsSolid;
NewBrush.Color := NewColor;
// This is the ListBox.Canvas brush itself, not to be
// confused with the NewBrush we've created above
LB.Canvas.Brush.Style := bsClear;
R := Rect;
ItemText := LB.Items[Index];
Fmt := DT_EXPANDTABS or DT_CALCRECT or DT_NOCLIP;
DrawText(LB.Canvas.Handle, PChar(ItemText), Length(ItemText),
R, Fmt);
// Note we need to FillRect on the original Rect and not
// the one we're using in the call to DrawText
Windows.FillRect(LB.Canvas.Handle, Rect, NewBrush.Handle) ;
DrawText(LB.Canvas.Handle, PChar(ItemText), Length(ItemText),
R, DT_EXPANDTABS);
NewBrush.Free;
end;
Here's the output of the above code:

How do you drag and drop a file from Explorer Shell into a VirtualTreeView control in a Delphi application?

There is extensive drag and drop support in VirtualTreeView by Mike Lischke, and I am using TVirtualStringTree, which has some on-drag-and-drop events, but I can not figure out how to get it to accept a shell drag-and-drop of some files from the windows explorer shell, into my application. I want to load the files, when they are dragged onto the drop control.
I tried using a third-party set of code from Anders Melander, to handle drag and drop, but because VirtualTreeView already registers itself as a drop target, I can't use that.
edit: I found a simple workaround: Turn off toAcceptOLEDrop in VT.TreeOptions.MiscOptions.
It would be cool if anybody knows a way to use VirtualTreeView without using a third party OLE-shell-drag-drop library and using its extensive OLE drag/drop support to extract a list of filenames dragged in from the Shell.
My implementation (Works very well with Delphi 2010. Must add ActiveX, ShellApi to uses to compile):
procedure TfMain.vstTreeDragDrop(Sender: TBaseVirtualTree; Source: TObject;
DataObject: IDataObject; Formats: TFormatArray; Shift: TShiftState;
Pt: TPoint; var Effect: Integer; Mode: TDropMode);
var
I, j: Integer;
MyList: TStringList;
AttachMode: TVTNodeAttachMode;
begin
if Mode = dmOnNode then
AttachMode := amInsertBefore
else if Mode = dmAbove then
AttachMode := amInsertBefore
else if Mode = dmBelow then
AttachMode := amInsertAfter
else
AttachMode := amAddChildLast;
MyList := TStringList.Create;
try
for i := 0 to High(formats) - 1 do
begin
if (Formats[i] = CF_HDROP) then
begin
GetFileListFromObj(DataObject, MyList);
//here we have all filenames
for j:=0 to MyList.Count - 1 do
begin
Sender.InsertNode(Sender.DropTargetNode, AttachMode);
end;
end;
end;
finally
MyList.Free;
end;
end;
procedure TfMain.GetFileListFromObj(const DataObj: IDataObject;
FileList: TStringList);
var
FmtEtc: TFormatEtc; // specifies required data format
Medium: TStgMedium; // storage medium containing file list
DroppedFileCount: Integer; // number of dropped files
I: Integer; // loops thru dropped files
FileNameLength: Integer; // length of a dropped file name
FileName: string; // name of a dropped file
begin
// Get required storage medium from data object
FmtEtc.cfFormat := CF_HDROP;
FmtEtc.ptd := nil;
FmtEtc.dwAspect := DVASPECT_CONTENT;
FmtEtc.lindex := -1;
FmtEtc.tymed := TYMED_HGLOBAL;
OleCheck(DataObj.GetData(FmtEtc, Medium));
try
try
// Get count of files dropped
DroppedFileCount := DragQueryFile(
Medium.hGlobal, $FFFFFFFF, nil, 0
);
// Get name of each file dropped and process it
for I := 0 to Pred(DroppedFileCount) do
begin
// get length of file name, then name itself
FileNameLength := DragQueryFile(Medium.hGlobal, I, nil, 0);
SetLength(FileName, FileNameLength);
DragQueryFileW(
Medium.hGlobal, I, PWideChar(FileName), FileNameLength + 1
);
// add file name to list
FileList.Append(FileName);
end;
finally
// Tidy up - release the drop handle
// don't use DropH again after this
DragFinish(Medium.hGlobal);
end;
finally
ReleaseStgMedium(Medium);
end;
end;
I use this method to capture (receive) files dragged into a TWinControl from explorer.
You can test it on your control. In a standard TTreeView work fine.
Add ShellAPI to uses.
At private section:
private
originalEditWindowProc : TWndMethod;
procedure EditWindowProc(var Msg:TMessage);
// accept the files dropped
procedure FilesDrop(var Msg: TWMDROPFILES);
At OnCreate of your form:
// Assign procedures
originalEditWindowProc := TreeView1.WindowProc;
TreeView1.WindowProc := EditWindowProc;
// Aceptar ficheros arrastrados // Accept the files
ShellAPI.DragAcceptFiles(TreeView1.Handle, True);
And the two procedure are these:
// Al arrastrar ficheros sobre el TV. On drop files to TV
procedure TForm1.FilesDrop(var Msg: TWMDROPFILES);
var
i:Integer;
DroppedFilename:string;
numFiles : longInt;
buffer : array[0..MAX_PATH] of char;
begin
// Número de ficheros arrastrados // Number of files
numFiles := DragQueryFile(Msg.Drop, $FFFFFFFF, nil, 0) ;
// Recorrido por todos los arrastrados // Accept all files
for i := 0 to (numFiles - 1) do begin
DragQueryFile(Msg.Drop, i, #buffer, sizeof(buffer));
// Proteccion
try
DroppedFilename := buffer;
// HERE you can do something with the file...
TreeView1.Items.AddChild(nil, DroppedFilename);
except
on E:Exception do begin
// catch
end;
end;
end;
end;
procedure TForm1.EditWindowProc(var Msg: TMessage);
begin
// if correct message, execute the procedure
if Msg.Msg = WM_DROPFILES then begin
FilesDrop(TWMDROPFILES(Msg))
end
else begin
// in other case do default...
originalEditWindowProc(Msg) ;
end;
end;
I hope that this are usefull for you.
Regards.

Enumerate running processes in Delphi

How do I get a list of the running processes (with details of PID, Owner etc) on my machine using Delphi?
EDIT: None of the solutions proposed gives me the user that owns the process, only info such as PID, ExeName etc...
One way is using the Tool Help library (see TlHelp32 unit), or EnumProcesses on Windows NT (see PsAPI unit). Have a look at JclSysInfo.RunningProcessesList in the JCL for an example.
Here's a quick example of how to get the user name of a process:
type
PTokenUser = ^TTokenUser;
TTokenUser = packed record
User: SID_AND_ATTRIBUTES;
end;
function GetProcessUserName(ProcessID: Cardinal; out DomainName, UserName: string): Boolean;
var
ProcessHandle, ProcessToken: THandle;
InfoSize, UserNameSize, DomainNameSize: Cardinal;
User: PTokenUser;
Use: SID_NAME_USE;
_DomainName, _UserName: array[0..255] of Char;
begin
Result := False;
DomainName := '';
UserName := '';
ProcessHandle := OpenProcess(PROCESS_QUERY_INFORMATION or PROCESS_VM_READ, False, ProcessID);
if ProcessHandle = 0 then
Exit;
try
if not OpenProcessToken(ProcessHandle, TOKEN_QUERY, ProcessToken) then
Exit;
try
GetTokenInformation(ProcessToken, TokenUser, nil, 0, InfoSize);
User := AllocMem(InfoSize * 2);
try
if GetTokenInformation(ProcessToken, TokenUser, User, InfoSize * 2, InfoSize) then
begin
DomainNameSize := SizeOf(_DomainName);
UserNameSize := SizeOf(_UserName);
Result := LookupAccountSid(nil, User^.User.Sid, _UserName, UserNameSize, _DomainName, DomainNameSize, Use);
if Result then
begin
SetString(DomainName, _DomainName, StrLen(_DomainName));
SetString(UserName, _UserName, StrLen(_UserName));
end;
end;
finally
FreeMem(User);
end;
finally
CloseHandle(ProcessToken);
end;
finally
CloseHandle(ProcessHandle);
end;
end;
This is the function we use to check if a process exists, the FProcessEntry32 holds all the info on the process, so you should be able to extend it to what every you need.
it was taken from here
uses TlHelp32
function processExists(exeFileName: string): Boolean;
{description checks if the process is running
URL: http://www.swissdelphicenter.ch/torry/showcode.php?id=2554}
var
ContinueLoop: BOOL;
FSnapshotHandle: THandle;
FProcessEntry32: TProcessEntry32;
begin
FSnapshotHandle := CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS, 0);
FProcessEntry32.dwSize := SizeOf(FProcessEntry32);
ContinueLoop := Process32First(FSnapshotHandle, FProcessEntry32);
Result := False;
while Integer(ContinueLoop) <> 0 do
begin
if ((UpperCase(ExtractFileName(FProcessEntry32.szExeFile)) =
UpperCase(ExeFileName)) or (UpperCase(FProcessEntry32.szExeFile) =
UpperCase(ExeFileName))) then
begin
Result := True;
end;
ContinueLoop := Process32Next(FSnapshotHandle, FProcessEntry32);
end;
CloseHandle(FSnapshotHandle);
end;
The TProcessEntry32 record looks like so:
tagPROCESSENTRY32 = packed record
dwSize: DWORD;
cntUsage: DWORD;
th32ProcessID: DWORD; // this process
th32DefaultHeapID: DWORD;
th32ModuleID: DWORD; // associated exe
cntThreads: DWORD;
th32ParentProcessID: DWORD; // this process's parent process
pcPriClassBase: Longint; // Base priority of process's threads
dwFlags: DWORD;
szExeFile: array[0..MAX_PATH - 1] of Char;// Path
end;
You have to use:
CreateToolhelp32Snapshot Function
Process32First Function
Process32Next Function
PROCESSENTRY32 Structure will contain all the informations that you may need.
The documentation is from MDSN, for C++, but it's the same in Delphi.
This class will give you a list of all open windows (listed below) with PID, caption, dimensions, etc. It's not exactly running processes information, but I've used it to find apps via it.
// Window List Component 1.5 by Jerry Ryle
//
// Aaugh! I accidentally uploaded the wrong source
// which had a nasty bug in the refresh procedure!
// Thanks to Serge, who found my mistake and suggested
// a few other improvements!
//
// This component will enumerate windows and return
// information about them in the Windows property.
// The component currently returns a handle, caption text,
// associated ProcessID, visibility, and dimensions.
// For documentation, please read the accompanying
// WindowList.txt
//
// This component is completely free of course. If you find
// it useful, and are compelled to send me cash, beer, or
// dead things in envelopes, please feel free to do so.
//
// email me if you make it better: gryle#calpoly.edu
unit WindowList;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs;
type
TWindowObject = record
WinHandle : HWnd; // Window Handle
WinCaption : String; // Window Caption Text (If any)
ProcessID : Integer; // Process the window belongs to
IsVisible : Boolean; // Is the window visible?
IsEnabled : Boolean; // Is the window enabled for mouse/keyboard input?
IsIconic : Boolean; // Is the window minimized?
WindowRect : TRect; // Window Dimensions
// Add more properties here if you like,
// then fill them in at the WindowCallback
// function.
end;
PTWindowObject = ^TWindowObject;
TWindowList = class(TComponent)
private
WindowLst : TList;
FCount : Integer;
protected
Function GetAWindow(Index : Integer) : TWindowObject;
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
Procedure Refresh;
Property Windows[Index : Integer]: TWindowObject read GetAWindow;
Property Count : Integer read FCount;
published
// Published declarations
end;
procedure Register;
implementation
// Note that this function is not a member of WindowList.
// Therefore, the list to be filled needs to be passed
// as a pointer. Note that this is passed as a VAR. if you
// don't do this, bad things happen in memory.
Function WindowCallback(WHandle : HWnd; Var Parm : Pointer) : Boolean; stdcall;
// This function is called once for each window
Var MyString : PChar;
MyInt : Integer;
MyWindowPtr : ^TWindowObject;
begin
New(MyWindowPtr);
// Window Handle (Passed by the enumeration)
MyWindowPtr.WinHandle := WHandle;
// Window text
MyString := Allocmem(255);
GetWindowText(WHandle,MyString,255);
MyWindowPtr.WinCaption := String(MyString);
FreeMem(MyString,255);
// Process ID
MyInt := 0;
MyWindowPtr.ProcessID := GetWindowThreadProcessId(WHandle,#MyInt);
// Visiblity
MyWindowPtr.IsVisible := IsWindowVisible(WHandle);
// Enabled
MyWindowPtr.IsEnabled := IsWindowEnabled(WHandle);
// Iconic
MyWindowPtr.IsIconic := IsIconic(WHandle);
// Window Dimensions
MyWindowPtr.WindowRect := Rect(0,0,0,0);
GetWindowRect(WHandle,MyWindowPtr.WindowRect);
// Add the structure to the list. Do not dereference Parm...
// once again, bad things happen.
TList(Parm).Add(MyWindowPtr);
Result := True; // Everything's okay. Continue to enumerate windows
end;
constructor TWindowList.Create(AOwner: TComponent);
var MyWindowPtr : PTWindowObject;
begin
inherited;
WindowLst := TList.Create;
// Thanks Serge, I should've done this from the start :)
// Sloppy me.
If Not ( csDesigning in ComponentState ) Then
Begin
EnumWindows(#WindowCallback,Longint(#WindowLst));
FCount := WindowLst.Count;
End
Else
FCount := 0;
end;
destructor TWindowList.Destroy;
var I : Integer;
begin
If WindowLst.Count > 0 Then
Begin
For I := 0 To (WindowLst.Count - 1) Do
Dispose(PTWindowObject(WindowLst[I]));
End;
WindowLst.Free;
inherited;
end;
procedure TWindowList.Refresh;
begin
WindowLst.Clear; {Clear the list!}
EnumWindows(#WindowCallback,Longint(#WindowLst));
FCount := WindowLst.Count;
end;
function TWindowList.GetAWindow(Index : Integer) : TWindowObject;
begin
Result := PTWindowObject(WindowLst[Index])^;
end;
procedure Register;
begin
RegisterComponents('System', [TWindowList]);
end;
end.
You could look at using the WMISet components ($69 single licence, $199 for site licence, trial version available). The TWmiProcessControl component seems to encapsulate calls to Win32_Process. They also have an example of getting a process owner.
I think Madshi madKernel could be interesting to check out.

Resources