/ КОМПЬЮТЕРЫ И ПО / Языки программирования / Delphi

Выпуск № 766
от 31.03.2007, 09:35

Вопрос № 79.726

Здравствуйте уважаемые Эксперты! У меня возникла проблема с drag and drop: не могу понять, как переключиться между копированием и перемещением объектов в процессе их перетаскивания (когда нажата кнопка мыши). Иными словами, как в Windows: Shift - объект перемещается, Ctrl - копируется. Получается только, если клавиша была нажата, до старта drag.

Отправлен: 26.03.2007, 01:58 Вопрос задал: Шеллер Алексей Каспарович (статус: Посетитель) Всего ответов: 1 Мини-форум вопроса >>> (сообщений: 0)

Отвечает: Coupler Здравствуйте, Шеллер Алексей Каспарович! В приложении модуль для реализации drag and drop и текст программы, иллюстрирующей функции модуля на примере перетаскивания строк между двумя ListBox-ами. Если нужно, сообщите мне свой e-mail, и я вышлю проект полностью. Приложение: { ***************************************************************************** Copyright (c) 2003-2004, Dave Carlile, Willow Ridge Software Email: dave@willowridgesoftware.com ***************************************************************************** Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. This software is provided by the copyright holders and contributors Уas isФ and any express or implied warranties, including, but not limited to, the implied warranties of merchantability and fitness for a particular purpose are disclaimed. In no event shall the foundation or contributors be liable for any direct, indirect, incidental, special, exemplary, or consequential damages (including, but not limited to, procurement of substitute goods or services; loss of use, data, or profits; or business interruption) however caused and on any theory of liability, whether in contract, strict liability, or tort (including negligence or otherwise) arising in any way out of the use of this software, even if advised of the possibility of such damage. ***************************************************************************** } unit DragEffects; interface uses Windows, Messages, Controls, Forms; const { drag state } drgsNormal = 0; drgsCopy = 1; drgsShortcut = 2; { custom cursor identifiers } crShortcut = 1000; crCopy = 1001; { no definition for this so create our own } CN_SYSKEYUP = CN_BASE + WM_SYSKEYUP; type { inheriting from TDragControlObjectEx allows the drag object to be destroyed automatically } TDragWithEffectsObject = class(TDragControlObjectEx) private fDragState : Integer; protected function GetDragCursor(Accepted: Boolean; X, Y: Integer): TCursor; override; procedure WndProc(var Msg: TMessage); override; public property DragState : Integer read fDragState; end; implementation {$R DragCursors.res} { TDragWithEffectsObject } function TDragWithEffectsObject.GetDragCursor(Accepted: Boolean; X, Y: Integer): TCursor; begin if Accepted then begin case fDragState of drgsCopy : Result := crCopy; drgsShortcut : Result := crShortcut; else Result := crDrag; end; end else Result := inherited GetDragCursor(Accepted, X, Y); end; procedure TDragWithEffectsObject.WndProc(var Msg: TMessage); var ForceDragTo : Boolean; begin ForceDragTo := False; case Msg.Msg of CN_KEYUP : if Msg.WParam = VK_CONTROL then // control key pressed fDragState := drgsNormal; CN_KEYDOWN: if Msg.wParam = VK_CONTROL then // control key released fDragState := drgsCopy; CN_SYSKEYDOWN : if Msg.wParam = VK_MENU then // alt key pressed begin fDragState := drgsShortcut; ForceDragTo := True; end; CN_SYSKEYUP : if Msg.wParam = VK_MENU then // alt key released begin fDragState := drgsNormal; ForceDragTo := True; end; end; inherited; { send a cn_keyup msg to ancestor object so it will call DragTo which unfortunately isn't surfaced - this is required in some instances to get the mouse cursor to update } if ForceDragTo then begin Msg.Msg := CN_KEYUP; Msg.wParam := VK_CONTROL; inherited WndProc(Msg); end; end; initialization Screen.Cursors[crCopy] := LoadCursor(hInstance, 'Copy'); Screen.Cursors[crShortcut] := LoadCursor(hInstance, 'Shortcut'); end. {Пример:} unit fMain; interface uses Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls, DragEffects; type TMainForm = class(TForm) SourceListBox: TListBox; TargetListBox: TListBox; Label1: TLabel; procedure SourceListBoxStartDrag(Sender: TObject; var DragObject: TDragObject); procedure TargetListBoxDragOver(Sender, Source: TObject; X, Y: Integer; State: TDragState; var Accept: Boolean); procedure TargetListBoxDragDrop(Sender, Source: TObject; X, Y: Integer); private fDragObject : TDragWithEffectsObject; public end; var MainForm: TMainForm; implementation {$R *.dfm} procedure TMainForm.SourceListBoxStartDrag(Sender: TObject; var DragObject: TDragObject); begin fDragObject := TDragWithEffectsObject.Create(SourceListBox); DragObject := fDragObject; end; procedure TMainForm.TargetListBoxDragOver(Sender, Source: TObject; X, Y: Integer; State: TDragState; var Accept: Boolean); var Drag : TDragWithEffectsObject; begin Drag := TDragWithEffectsObject(Source); Accept := (Drag.Control = SourceListBox) and (SourceListBox.ItemIndex >= 0); end; procedure TMainForm.TargetListBoxDragDrop(Sender, Source: TObject; X, Y: Integer); var Drag : TDragWithEffectsObject; Value : String; begin Drag := TDragWithEffectsObject(Source); Value := SourceListBox.Items[SourceListBox.ItemIndex]; case Drag.DragState of drgsNormal : begin TargetListBox.Items.Add(Value); SourceListBox.Items.Delete(SourceListBox.ItemIndex); end; drgsCopy : TargetListBox.Items.Add('Copy of ' + Value); drgsShortcut : TargetListBox.Items.Add('Shortcut to ' + Value); end; end; end.

Ответ отправил: Coupler (статус: Студент) Ответ отправлен: 26.03.2007, 04:53 Оценка за ответ: 5 Комментарий оценки: ОГРОМНОЕ СПАСИБО!!! Модуль работает как часы!

Вопрос № 79.753

Здравствуйте!!! Скажите пожалуйста, как программно узнать запущена ли конкретная программа (меня интересует сервер Апач). Спасибо.

Отправлен: 26.03.2007, 09:15 Вопрос задал: Piit (статус: 2-ой класс) Всего ответов: 2 Мини-форум вопроса >>> (сообщений: 1)

Отвечает: Pavel Maltsev Здравствуйте, Piit! В приложении пример получения списка процессов Приложение: // Получение снимка состояния системы //hSnapshot := CreateToolhelp32Snapshot (TH32CS_SNAPPROCESS, 0); // Получене инфоpмации о пеpвом пpоцессе в списке //Process32First(); // Получение инфоpмации о следующем пpоцессе в списке //Далее в цикле Process32Next(); unit KernlUtl; interface uses TlHelp32, Windows, Classes, Sysutils; procedure GetProcessList(List: TStrings); procedure GetModuleList(List: TStrings); function GetProcessHandle(ProcessID: DWORD): THandle; procedure GetParentProcessInfo(var ID: DWORD; var Path: string); const PROCESS_TERMINATE = $0001; PROCESS_CREATE_THREAD = $0002; PROCESS_VM_OPERATION = $0008; PROCESS_VM_READ = $0010; PROCESS_VM_WRITE = $0020; PROCESS_DUP_HANDLE = $0040; PROCESS_CREATE_PROCESS = $0080; PROCESS_SET_QUOTA = $0100; PROCESS_SET_INFORMATION = $0200; PROCESS_QUERY_INFORMATION = $0400; PROCESS_ALL_ACCESS = STANDARD_RIGHTS_REQUIRED or SYNCHRONIZE or $0FFF; implementation procedure GetProcessList(List: TStrings); var I: Integer; hSnapshoot: THandle; pe32: TProcessEntry32; begin List.Clear; hSnapshoot := CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS, 0); if (hSnapshoot = -1) then Exit; pe32.dwSize := SizeOf(TProcessEntry32); if (Process32First(hSnapshoot, pe32)) then repeat I := List.Add(Format('%x, %x: %s', [pe32.th32ProcessID, pe32.th32ParentProcessID, pe32.szExeFile])); List.Objects[I] := Pointer(pe32.th32ProcessID); until not Process32Next(hSnapshoot, pe32); CloseHandle (hSnapshoot); end; procedure GetModuleList(List: TStrings); var I: Integer; hSnapshoot: THandle; me32: TModuleEntry32; begin List.Clear; hSnapshoot := CreateToolhelp32Snapshot(TH32CS_SNAPMODULE, 0); if (hSnapshoot = -1) then Exit; me32.dwSize := SizeOf(TModuleEntry32); if (Module32First(hSnapshoot, me32)) then repeat I := List.Add(me32.szModule); List.Objects[I] := Pointer(me32.th32ModuleID); until not Module32Next(hSnapshoot, me32); CloseHandle (hSnapshoot); end; procedure GetParentProcessInfo(var ID: DWORD; var Path: string); var ProcessID: DWORD; hSnapshoot: THandle; pe32: TProcessEntry32; begin ProcessID := GetCurrentProcessID; ID := -1; Path := ''; hSnapshoot := CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS, 0); if (hSnapshoot = -1) then Exit; pe32.dwSize := SizeOf(TProcessEntry32); if (Process32First(hSnapshoot, pe32)) then repeat if pe32.th32ProcessID = ProcessID then begin ID := pe32.th32ParentProcessID; Break; end; until not Process32Next(hSnapshoot, pe32); if ID <> -1 then begin if (Process32First(hSnapshoot, pe32)) then repeat if pe32.th32ProcessID = ID then begin Path := pe32.szExeFile; Break; end; until not Process32Next(hSnapshoot, pe32); end; CloseHandle (hSnapshoot); end; function GetProcessHandle(ProcessID: DWORD): THandle; begin Result := OpenProcess(PROCESS_ALL_ACCESS, True, ProcessID); end; end.

Ответ отправил: Pavel Maltsev (статус: 3-ий класс) Ответ отправлен: 26.03.2007, 11:35 Оценка за ответ: 3 Комментарий оценки: Что-то непонятно, где Апач фигурирует. Если бы вот с конкретной прогой, а то общая схема какая-то чтоли.

Отвечает: МЕДВЕД Превед, Piit! юзай API. findwindow(class,wn); где class - класс окна (чтоб узнать использ winsight32, поставляем вмест с Дельфи) wn - заголовок окна (если неизвестен пиши null); если окно нашлось, то функца вернет хендл окна. если так не хотишь, то юзай следущ(болье долгий способ и не рациональный:) function EnumProc (Wd: HWnd; Param: LongInt): Boolean; stdcall; begin ListBox1.Items.add(IntToStr(Wd)); // mov listbox, handle of window EnumProc := True; end; procedure TForm1.GetWindowz; begin ListBox1.Items.Clear; // clear before EnumWindows (@EnumProc, 0); //and start searching.. end; после этого у тебя в листбоксе будут фсе хендлы окон системы, дальше банальным перебором сверяешь их классы, с эталонным, в данном случае класс главного окна апач. гм. класс можно получить с помощью getclassname(handle,buffer,sizeofbuffer) --------- У меня зазвонил телефон -Кто говорит? -Слон!! А потом позвонили гуууси.. ну когда меня отпустит??

Ответ отправил: МЕДВЕД (статус: 2-ой класс) Ответ отправлен: 26.03.2007, 13:13 Оценка за ответ: 5

© 2001-2007, Портал RusFAQ.ru, Россия, Москва. Идея, дизайн, программирование: Калашников О.А. Email: support@rusfaq.ru, Тел.: +7 (926) 535-23-31 ООО "Мастер-Эксперт Про", Москва, 2007 Авторские права | Реклама на портале Версия системы: 4.46 от 18.03.2007