Как поместить иконку в Tray?
Nomadic приводит следующий код:
|
function TaskBarAddIcon( hWindow : THandle; ID : Cardinal; ICON : hicon; CallbackMessage : Cardinal; Tip : String ) : Boolean; var NID : TNotifyIconData; begin FillChar( NID, SizeOf( TNotifyIconData ), 0 ); with NID do begin cbSize := SizeOf( TNotifyIconData ); Wnd := hWindow; uID := ID; uFlags := NIF_MESSAGE or NIF_ICON or NIF_TIP; uCallbackMessage := CallbackMessage; hIcon := Icon; if Length( Tip ) > 63 then SetLength( Tip, 63 ); StrPCopy( szTip, Tip ); end; Result := Shell_NotifyIcon( NIM_ADD, @NID ); end; |
[001681]
Как пpогpаммно вывести окно свойств экpана?
Nomadic отвечает:
| ShellExecute(Application.Handle, 'open', 'desk.cpl', nil, nil, sw_ShowNormal); |
[001669]
Как программно переключать режимы дисплея?
Олег Кулабухов делится опытом:
Нужно использовать EnumDisplaySettings() для получения полного списка доступных режимов. Затем ChangeDisplaySettings() - для изменения текущего режима. Обратите внимание, что многие драверы не меняют режим без перезагрузки.
|
unit Unit1; interface uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls, Spin; type PdmArray = ^TDmArray; TDmArray = array[0..0] of TDeviceMode; type TForm1 = class(TForm) Memo1: TMemo; SpinEdit1: TSpinEdit; Button1: TButton; procedure FormCreate(Sender: TObject); procedure FormDestroy(Sender: TObject); procedure Button1Click(Sender: TObject); private lpDmArray : PDmArray; NumModes : integer; { Private declarations } public { Public declarations } end; var Form1: TForm1; implementation {$R *.DFM} procedure TForm1.FormCreate(Sender: TObject); var i : integer; // auto-initialized to zero MoreModes : bool; dm : TDeviceMode; begin Memo1.Lines.Clear; MoreModes := True; while MoreModes do begin MoreModes := EnumDisplaySettings(nil, i, dm); Memo1.Lines.Add('Mode ' + IntToStr(i) + ': ' + IntToStr(dm.dmBitsPerPel) + ' Bits Per Pixel ' + IntToStr(dm.dmPelsWidth) + ' x ' + IntToStr(dm.dmPelsHeight)); Inc(i); end; NumModes := i; SpinEdit1.MinValue := 0; SpinEdit1.MaxValue := NumModes; GetMem(lpDmArray, sizeof(TDeviceMode) * NumModes); FillChar(lpDmArray^, sizeof(TDeviceMode) * NumModes, #0); {$IFOPT R+} {$DEFINE CKRANGE} {$R-} {$ENDIF} for i := 0 to (NumModes - 1) do EnumDisplaySettings(nil, i, lpDmArray[i]); {$IFDEF CKRANGE} {$UNDEF CKRANGE} {$R+} {$ENDIF} end; procedure TForm1.Button1Click(Sender: TObject); var ReturnVal : LongInt; begin {$IFOPT R+} {$DEFINE CKRANGE} {$R-} {$ENDIF} ReturnVal := ChangeDisplaySettings(lpDmArray[SpinEdit1.Value], CDS_UPDATEREGISTRY); {$IFDEF CKRANGE} {$UNDEF CKRANGE} {$R+} {$ENDIF} with Memo1.Lines do begin case ReturnVal of DISP_CHANGE_SUCCESSFUL: Add('DISP_CHANGE_SUCCESSFUL'); DISP_CHANGE_RESTART : Add('DISP_CHANGE_RESTART'); DISP_CHANGE_BADFLAGS : Add('DISP_CHANGE_BADFLAGS'); DISP_CHANGE_FAILED : Add('DISP_CHANGE_FAILED'); DISP_CHANGE_BADMODE : Add('DISP_CHANGE_BADMODE'); DISP_CHANGE_NOTUPDATED: Add('DISP_CHANGE_NOTUPDATED'); end; end; end; procedure TForm1.FormDestroy(Sender: TObject); begin FreeMem(lpDmArray, sizeof(TDeviceMode) * NumModes); end; end. |
[001934]
Как программно включить хранитель экрана?
Олег Кулабухов отвечает:
Нижеприведенный пример показывает возможность такого включения, одновременно проверяя доступность хранителя экрана.
|
function TurnScreenSaverOn : bool; var b : bool; begin result := false; if SystemParametersInfo(SPI_GETSCREENSAVEACTIVE, 0, @b, 0) <> true then exit; if not b then exit; PostMessage(GetDesktopWindow, WM_SYSCOMMAND, SC_SCREENSAVE, 0); result := true; end; |
[001873]
Как программно заменить обои на рабочем столе? I
Решение 1
Вот что я нашел в файлах помощи Ллойда (расположены на большинстве сайтов, посвященных Delphi). Я не пробовал это, но уже имею несколько положительных откликов. Сообщите мне, как это работает у вас.
|
unit Unit1; interface uses SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls, Forms, Dialogs; type TForm1 = class(TForm) procedure FormCreate(Sender: TObject); procedure FormPaint(Sender: TObject); private { Private declarations } public { Public declarations } end; var Form1: TForm1; Bitmap: TBitmap; implementation {$R *.DFM} procedure TForm1.FormCreate(Sender: TObject); begin Bitmap := TBitmap.Create; Bitmap.LoadFromFile('C:\WINDOWS\cars.BMP'); end; procedure TForm1.FormPaint(Sender: TObject); var X, Y, W, H: LongInt; begin with Bitmap do begin W := Width; H := Height; end; Y := 0; while Y < Height do begin X := 0; while X < Width do begin Canvas.Draw(X, Y, Bitmap); Inc(X, W); end; Inc(Y, H); end; end; end. |
Решение 1
Кто-нибудь знает как можно во время выполнения программы заменить обои рабочего стола на определенное изображение?
|
procedure ChangeWallpaper(bitmap: string); {имя файла с изображением: *.bmp} var pBitmap : pchar; begin bitmap:=bitmap+#0; pBitmap:=@bitmap[1]; SystemParametersInfo(SPI_SETDESKWALLPAPER, 0, pBitmap, SPIF_UPDATEINIFILE); end; |
Можно ли сохранить сделанные изменения в INI-файле для последующих сессий?
добавьте inifiles в список используемых модулей. создайте inifile в текстовом редакторе как показано ниже:
|
[LastUsedBitmap] LUBitmap= c:\mybitmap.bmp |
используйте примерно такую процедуру (исходим из предположения, что inifile подобно вышеупомянутому с именем c:\Bitmap.ini):
|
procedure WriteToIniFile(bitmap : string); var MyIniFile : TInifile; begin MyIniFile := Tinifile.Create( 'c:\Bitmap.ini' ); MyIniFile.WriteString( 'LastUsedBitmap', 'LUBitmap', bitmap); MyIniFile.Free; end; procedure ReadFromIniFile(var bitmap: string); var MyIniFile : TInifile; begin MyIniFile := Tinifile.Create( 'c:\Bitmap.ini' ); bitmap:= MyIniFile.ReadString('LastUsedBitmap', 'LUBitmap'); MyIniFile.Free; end; |
[000279]
Как программно заменить обои на рабочем столе? II
Для этого необходимо заставить Windows перечитать файл Win.ini с новым параметром обоев рабочего стола. Это возможно с помощью функции Windows API SystemParametersInfo, примерно так:
| SystemParametersInfo(spi_SetDeskWallPaper,0,Addr(BmpFileName),spif_UpdateIniFile + spif_SendWinIniChange); |
где BmpFileName - PChar, содержащий имя файла с изображением. Обратите внимание на четвертый параметр, spif_UpdateIniFile. Он записывает изменения в Win.ini. Параметр spif_SendWinIniChange посылает всем окнам сообщение о факте изменения Win.ini. [000453]
Как программно заменить обои на рабочем столе? III
Igor Nikolaev aKa The Sprite советует:
|
program wallpapr; uses Registry, WinProcs; procedure SetWallpaper(sWallpaperBMPPath:String;bTile:boolean); var reg : TRegIniFile; begin // Изменяем ключи реестра // HKEY_CURRENT_USER // Control Panel\Desktop // TileWallpaper (REG_SZ) // Wallpaper (REG_SZ) reg := TRegIniFile.Create('Control Panel\Desktop' ); with reg do begin WriteString( '', 'Wallpaper', sWallpaperBMPPath ); if( bTile )then begin WriteString('', 'TileWallpaper', '1' ); end else begin WriteString('', 'TileWallpaper', '0' ); end; end; reg.Free; // Оповещаем всех о том, что мы изменили системные настройки SystemParametersInfo(SPI_SETDESKWALLPAPER, 0, Nil, {Эта строка - продолжение предыдущей}SPIF_SENDWININICHANGE ); end; // пример установки WallPaper по центру рабочего стола SetWallpaper('c:\winnt\winnt.bmp', False ); //Эту строчку надо написать где-то в программе. |
[001409]
Как программно заменить обои на рабочем столе? IV
Владимир Рыбант пишет:
Советы "Как програмно заменить обои на рабочем столе" I,II,III не изменяют обои, если в Windows работает в режиме Active Desktop
Нужно использовать следующее:
|
uses ComObj, ShlObj; procedure ChangeActiveWallpaper; const CLSID_ActiveDesktop: TGUID = '{75048700-EF1F-11D0-9888-006097DEACF9}'; var ActiveDesktop: IActiveDesktop; begin ActiveDesktop := CreateComObject(CLSID_ActiveDesktop) as IActiveDesktop; ActiveDesktop.SetWallpaper('c:\windows\forest.bmp', 0); ActiveDesktop.ApplyChanges(AD_APPLY_ALL or AD_APPLY_FORCE); end; |
Этим способом можно также изменять обои картинками jpg и gif [001543]
Как програмным путем задавать координаты ярлыкам на рабочем столе?
Рабочий стол перекрыт сверху компонентом ListView. Вам просто необходимо взять хэндл этого органа управления. Пример:
|
function GetDesktopListViewHandle: THandle; var S: String; begin Result := FindWindow('ProgMan', nil); Result := GetWindow(Result, GW_CHILD); Result := GetWindow(Result, GW_CHILD); SetLength(S, 40); GetClassName(Result, PChar(S), 39); if PChar(S) <> 'SysListView32' then Result := 0; end; |
После того, как Вы взяли тот хэндл, Вы можете использовать API этого ListView, определенный в модуле CommCtrl, для того, чтобы манипулировать рабочим столом. Смотрите тему "LVM_xxxx messages" в оперативной справке по Win32.
К примеру, следующая строка кода:
| ListView_SetItemPosition(GetDesktopListViewHandle,i,x,y); {Не забудьте в uses добавить CommCtrl} |
ярлыку с индексом i, задаст координаты (x,y). К примеру Мой компьютер имеет индекс 0, т.е i:=0;
С наилучшими пожеланиями, Сергей.
E-mail: ssa_sss@mail.ru
Nomadic дополняет:
К примеру, следующая строка кода:
| SendMessage( GetDesktopListViewHandle, LVM_ALIGN, LVA_ALIGNLEFT, 0 ); |
разместит иконки рабочего стола по левой стороне рабочего стола Windows. [001074]
Как создать приложение, которое работало бы в трее (где часы)?
Олег Кулабухов приводит следующий код:
Если вы узнали ответ на этот вопрос здесь, а не в RU.DELPHI, где он является одним из самых популярных и то же время самым надоевшим, то вы просто молодец.
На самом деле приложение не работает в трее, и даже не сворачивается туда, как думают очень многие, задающие этот вопрос. Хитрость заключается в следующем - приложение прячется из TaskBar'a, вместо этого в трей помещается созданная произвольная иконка. Усложняется все это различными разворачиваниями/сворачиваниями окна. Не более.
Нижеприведенный пример показывает структуру самой этой процедуры. Для испоьзования в повседневной работе я все-таки рекомендую написать свой компонент, либо использовать существующие, например из пакета компонентов RxLIB (rxTrayIcon)
|
{TrayIt.dpr} program TrayIt; uses Windows, Forms, TrayIt1 in 'TrayIt1.pas' {Form1}; {$R *.RES} begin Application.Initialize; Application.ShowMainForm := False; Application.CreateForm(TForm1, Form1); ShowWindow(Application.Handle, SW_HIDE); Application.Run; end. {TrayIt1.pas} unit TrayIt1; interface uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, Menus, ShellAPI, ExtCtrls; type TForm1 = class(TForm) PopupMenu1: TPopupMenu; Open1: TMenuItem; Exit1: TMenuItem; Timer1: TTimer; procedure FormCreate(Sender: TObject); procedure Open1Click(Sender: TObject); procedure Exit1Click(Sender: TObject); procedure FormClose(Sender: TObject; var Action: TCloseAction); procedure Timer1Timer(Sender: TObject); private { Private declarations } procedure WndProc(var Msg : TMessage); override; public { Public declarations } IconData : TNotifyIconData; IconCount : integer; end; var Form1: TForm1; implementation {$R *.DFM} procedure TForm1.WndProc(var Msg : TMessage); var p : TPoint; begin case Msg.Msg of WM_USER + 1: case Msg.lParam of WM_RBUTTONDOWN: begin GetCursorPos(p); PopupMenu1.Popup(p.x, p.y); end end; end; inherited; end; procedure TForm1.FormCreate(Sender: TObject); begin BorderIcons := [biSystemMenu]; IconCount := 0; IconData.cbSize := sizeof(IconData); IconData.Wnd := Handle; IconData.uID := 100; IconData.uFlags := NIF_MESSAGE + NIF_ICON + NIF_TIP; IconData.uCallbackMessage := WM_USER + 1; IconData.hIcon := Application.Icon.Handle; StrPCopy(IconData.szTip, Application.Title); Shell_NotifyIcon(NIM_ADD, @IconData); Timer1.Interval := 1000; Timer1.Enabled := true; end; procedure TForm1.Open1Click(Sender: TObject); begin Form1.Show; ShowWindow(Application.Handle, SW_HIDE); end; procedure TForm1.Exit1Click(Sender: TObject); begin Shell_NotifyIcon(NIM_DELETE, @IconData); Application.ProcessMessages; Application.Terminate; end; procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction); begin Action := caNone; Form1.Hide; end; procedure TForm1.Timer1Timer(Sender: TObject); begin case(IconCount) of 0 : IconData.hIcon := LoadIcon(0, IDI_APPLICATION); 1 : IconData.hIcon := LoadIcon(0, IDI_ASTERISK); 2 : IconData.hIcon := LoadIcon(0, IDI_EXCLAMATION); 3 : IconData.hIcon := LoadIcon(0, IDI_HAND); 4 : IconData.hIcon := LoadIcon(0, IDI_QUESTION); 5 : IconData.hIcon := Application.Icon.Handle; end; inc(IconCount); if IconCount > 5 then IconCount := 0; Application.Title := TimeToStr(Now); StrPCopy(IconData.szTip, Application.Title); Shell_NotifyIcon(NIM_MODIFY, @IconData); end; begin ShowWindow(Application.Handle, SW_HIDE); end. |
[001910]
Как спрятать панель задач в Windows 95?
Можно ли спрятать панель задач при запуске моего приложения? Когда пользователь закрывает приложение, панель задач должна снова стать видимой.
Я догадываюсь, вам нужно послать сообщение окну панели задач или области системных иконок в Windows 95, не в окно состояния. Ответ на ваш вопрос: конечно можно! Классная идея! Попробуйте так:
Сначала объявим переменную типа HWND, в которой будем хранить дескриптор окна панели задач Windows 95:
| TForm1 = class(TForm) ... private hTaskBar: HWND; ... end; |
| hTaskBar := FindWindow('Shell_TrayWnd', nil); ShowWindow(hTaskBar, SW_HIDE); |
| ShowWindow(hTaskBar, SW_SHOW); |
|
PROCEDURE HideWin95TaskBar;
VAR
WindowHandle: hWnd;
BEGIN
{Скрытие панели задач Windows 95}
WindowHandle := FindWindow('Shell_TrayWnd', '');
IF WindowHandle <> 0
THEN ShowWindow(WindowHandle, SW_HIDE)
END {HideWin95TaskBar};
PROCEDURE ShowWin95TaskBar; VAR WindowHandle: hWnd; BEGIN {Восстанавливаем видимость панели задач Windows 95} WindowHandle := FindWindow('Shell_TrayWnd', ''); IF WindowHandle <> 0 THEN ShowWindow(WindowHandle, SW_RESTORE) END {ShowWin95TaskBar}; |
[000276]
Как узнать и поменять разрешение экрана?
Nomadic отвечает:
Поменять:
|
procedure ChangeDisplayResolution(x, y : word); var dm : TDEVMODE; begin ZeroMemory(@dm, sizeof(TDEVMODE)); dm.dmSize := sizeof(TDEVMODE); dm.dmPelsWidth := x; dm.dmPelsHeight := y; dm.dmFields := DM_PELSWIDTH or DM_PELSHEIGHT; ChangeDisplaySettings(dm, 0); end; |
[001556]
Как узнать текущее разрешение экрана?
Из советов Nomadic'a:
Советуем ознакомиться с Help topic относительно глобального обьекта Screen типа TScreen. У этого обьекта есть свойства Width и Height.
|
{ Example } begin iScreenWidth := Screen.Width; end; |
Заодно и другие свойства могут Вас заинтересовать, например, Fonts и Cursors. [001187]
Как включить/отключить кнопку 'Старт'?
Олег Кулабухов приводит следующий код:
Вот пример, показывающий, как это сделать, а заодно и некоторые другие вещи с несчастной кнопкой.
|
procedure TForm1.Button1Click(Sender: TObject); var Rgn : hRgn; begin {Hide the start button} Rgn := CreateRectRgn(0, 0, 0, 0); SetWindowRgn(FindWindowEx(FindWindow('Shell_TrayWnd', nil), 0, 'Button', nil), Rgn, true); end; procedure TForm1.Button2Click(Sender: TObject); begin {Turn the start button back on} SetWindowRgn(FindWindowEx(FindWindow('Shell_TrayWnd', nil), 0, 'Button', nil), 0, true); end; procedure TForm1.Button3Click(Sender: TObject); begin {Disable the start button} EnableWindow(FindWindowEx(FindWindow('Shell_TrayWnd', nil), 0, 'Button', nil), false); end; procedure TForm1.Button4Click(Sender: TObject); begin {Enable the start button} EnableWindow(FindWindowEx(FindWindow('Shell_TrayWnd', nil), 0, 'Button', nil), true); end |
[001833]
Как запустить или закрыть скринсэйвер?
Nomadic приводит сиплюсплюсное решение:
Starting ~~~~~~~~ The method for starting a screen saver is simple, but surprising. You post your own window a message ! Post yourself the WM_SYSCOMMAND message with the SC_SCREENSAVE parameter : // Uses MFC CWnd::PostMessage PostMessage (WM_SYSCOMMAND, SC_SCREENSAVE); Stopping ~~~~~~~~ Stopping a screen saver is somewhat more complex. The Microsoft-documented way of doing this is to look for the special screen-saver desktop, enumerate all windows on that desktop, and close them, as follows: hdesk = OpenDesktop(TEXT("Screen-saver"), 0, FALSE, DESKTOP_READOBJECTS | DESKTOP_WRITEOBJECTS); if (hdesk) { EnumDesktopWindows (hdesk, (WNDENUMPROC)KillScreenSaverFunc, 0); CloseDesktop (hdesk); } // ---------------------------------------------------------------- BOOL CALLBACK KillScreenSaverFunc (HWND hwnd, LPARAM lParam) { PostMessage(hwnd, WM_CLOSE, 0, 0); return TRUE; } However, I can't recommend this approach. I have found when using this code, NT4 very occasionally seems to get confused and pass you back the normal desktop handle, in which case you end up trying to close all the normal application windows. Note, in MS' defence, that the code above for closing 32 bit savers is derived from a sample that is only marked as valid for NT3.51 - there is no mention of NT4 in the sample. Unfortunately, there is also nothing to indicate that it doesn't work properly. I have subsequently performed some tests, and found that the stock screen savers supplied with NT4 will in any case get a hit on the window class search normally used for 16 bit savers ("WindowsScreenSaverClass"). I don't believe for a moment that the OpenGL savers (for example) are 16 bit, so maybe MS are supplying a saver window class that will give the necessary hit. So anyway, you can use this route : HWND hSaver = FindWindow ("WindowsScreenSaverClass", NULL); if (hSaver) PostMessage (hSaver, WM_CLOSE, 0, 0); Yet another alternative is now available, which depends upon new functionality in SystemParametersInfo. This should be even more general : BOOL bSaver; if (::SystemParametersInfo (SPI_GETSCREENSAVEACTIVE,0,&bSaver,0)) { if (bSaver) { ::PostMessage (::GetForegroundWindow(), WM_CLOSE, 0L, 0L); } } So you can try that one as well. An embarassment of riches ! //***************************************************************************// [001585]
нибудь поделиться информацией, компонентом или
Может ли кто- нибудь поделиться информацией, компонентом или еще чем, позволяющим в Delphi 2 или 3 создать кнопку в панели задач так, как это делает PowerDesk 2.0 Toolbar.
Да запросто!
|
// Это необходимо объявить в секции public в верхней части вашего pas-файла procedure TForm1.IconCallBackMessage( var Mess : TMessage ); message WM_USER + 100; |
|
procedure TForm1.FormCreate(Sender: TObject); var nid : TNotifyIconData; begin with nid do begin cbSize := SizeOf( TNotifyIconData ); Wnd := Form1.Handle; uID := 1; uFlags := NIF_ICON or NIF_MESSAGE or NIF_TIP; uCallbackMessage := WM_USER + 100; hIcon := Application.Icon.Handle; szTip := 'Текст всплывающей подсказки'; end; Shell_NotifyIcon( NIM_ADD, @nid ); end; procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction); var nid : TNotifyIconData; begin with nid do begin cbSize := SizeOf( TNotifyIconData ); Wnd := Form1.Handle; uID := 1; uFlags := NIF_ICON or NIF_MESSAGE or NIF_TIP; uCallbackMessage := WM_USER + 100; hIcon := Application.Icon.Handle; szTip := 'Текст всплывающей подсказки'; // Все, что указано выше, не является обязательным end; Shell_NotifyIcon( NIM_DELETE, @nid ); end; procedure TForm1.IconCallBackMessage( var Mess : TMessage ); var sEventLog : String; begin case Mess.lParam of // Сделайте здесь все что вы хотите. Например, вызов контекстного меню при нажатии правой кнопки мыши. WM_LBUTTONDBLCLK : sEventLog := 'Двойной щелчок левой кнопкой'; WM_LBUTTONDOWN : sEventLog := 'Нажатие левой кнопки мыши'; WM_LBUTTONUP : sEventLog := 'Отжатие левой кнопки мыши'; WM_MBUTTONDBLCLK : sEventLog := 'Двойной щелчок мышью'; WM_MBUTTONDOWN : sEventLog := 'Нажатие кнопки мыши'; WM_MBUTTONUP : sEventLog := 'Отжатие кнопки мыши'; WM_MOUSEMOVE : sEventLog := 'перемещение мыши'; WM_MOUSEWHEEL : sEventLog := 'Вращение колесика мыши'; WM_RBUTTONDBLCLK : sEventLog := 'Двойной щелчок правой кнопкой'; WM_RBUTTONDOWN : sEventLog := 'Нажатие правой кнопки мыши'; WM_RBUTTONUP : sEventLog := 'Отжатие правой кнопки мыши'; end; end; |
Количество цветов в системе
Мне необходимо узнать как сконфигурирована система: для работы с 16 или 256 цветами.
Приведенное ниже выражение возвращает количество цветов, используемое в текущий момент в системе. Canvas должен быть холстом экранного элемента управления, например, формы.
| 1 shl GetDeviceCaps( Canvas.Handle, BITSPIXEL ) |
- Mike Scott [000877]
Определение имени Группы Запуска (StartUp)
В различный языковых версих Windows папка 'StartUp' звучит по-разному. Как мне определить ее текущее имя??
Вам следует обратиться к регистрам:
| HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\Explorer\Shell Folders\Start Menu |
Надеюсь это то, что вам нужно. [000284]
Пpоцедуpу котоpая убиpает или показывает кнопку "Стаpт" в выне...
Nomadic приводит следующий код:
|
Uses TypInfo; Var hTaskBar, hButton: HWND; begin hTaskBar:= FindWindow('Shell_TrayWnd', nil); hButton:= GetWindow(hTaskBar, GW_CHILD); // Hажать кнопку "Пуск" SendMessage(hButton, WM_LBUTTONDOWN, MK_LBUTTON,LoWord(5)+HiWord(Screen.Height-20)); // Убpать кнопку "Пуск" ShowWindow(hButton, SW_HIDE); // Показать кнопку "Пуск" ShowWindow(hButton, SW_NORMAL); end; |
[001722]
Shell_NotifyIcon
У меня есть несколько вопросов по функции Shell_NotifyIcon: Как добавить иконку в системную область панели задач? Как изменить иконку? Как удалить иконку? И я не могу получать сообщения от иконки!!
Чтобы получать сообщения, вы должны добавить флаг NIF_MESSAGE в вашу notify-структуру и записать то сообщение, которое вы хотите послать. Вот код, который я использую:
|
procedure TMainForm.UpdateTaskBar; // обновление области системных иконок win95
var NotifyData: TNotifyIconData; begin With NotifyData do // устанавливаем структуру данных begin cbSize := SizeOf(TNotifyIconData); Wnd := MyForm.Handle; uID := 0; uFlags := NIF_ICON or NIF_MESSAGE or NIF_TIP; // ... установки, которые необходимо изменить ... uCallbackMessage := WM_MY_MESSAGE; // ... возвращаемое нам сообщение ... hIcon := hMyIcon; szTip := 'Текст всплывающей подсказки'; // ... и соответствующий текст end; Shell_NotifyIcon(dwMessage, @NotifyData); // теперь производим обновление end; |
WM_MYMESSAGE - определенное пользователем сообщение. Обычно определяется как:
|
const WM_MYMESSAGE = WM_USER + <какой-то номер, может быть нулем>; |
[000273]
Скрытие кнопки "Пуск"
Используйте модуль proc. Для скрытия стартовой кнопки используйте следующий код:
|
procedure hideStartbutton(visi:boolean); Var Tray, Child : hWnd; C : Array[0..127] of Char; S : String; Begin Tray := FindWindow('Shell_TrayWnd', NIL); Child := GetWindow(Tray, GW_CHILD); While Child <> 0 do Begin If GetClassName(Child, C, SizeOf(C)) > 0 Then Begin S := StrPAS(C); If UpperCase(S) = 'BUTTON' then begin // IsWindowVisible(Child) startbutton_handle:=child; If Visi then ShowWindow(Child, 1) else ShowWindow(Child, 0); end; End; Child := GetWindow(Child, GW_HWNDNEXT); End; End; |
[000292]
Снимок DESKTOP в form.canvas
Попробуйте это:
|
procedure TScrnFrm.GrabScreen; var DeskTopDC: HDc; DeskTopCanvas: TCanvas; DeskTopRect: TRect; begin DeskTopDC := GetWindowDC(GetDeskTopWindow); DeskTopCanvas := TCanvas.Create; DeskTopCanvas.Handle := DeskTopDC; DeskTopRect := Rect(0,0,Screen.Width,Screen.Height); ScrnForm.Canvas.CopyRect(DeskTopRect,DeskTopCanvas,DeskTopRect); ReleaseDC(GetDeskTopWindow,DeskTopDC); end; |
Примечание: Я не тестировал это, так что не удивляйтесь некоторым системным сообщениям об ошибках. Вы можете передалать данный код под себя, в зависимости от стоящей перед вами задачей. Да, еще, если ваша форма уже загружена и отображена, то вам необходимо предусмотреть механизм обновления снимка при скрытии и показе окна, привязав данную функцию к соответствующим событиям.
[000119]
Центрирование информационного диалога (MessageDlg)
Используйте следующую процедуру:
|
unit kns; {$R-} interface uses Forms, Dialogs; { Центрирование информационного диалога } function MessageDlgCtr(const Msg: string; DlgType: TMsgDlgType; Buttons: TMsgDlgButtons; HelpCtx: Longint): Integer; implementation uses Consts; { Функция MessageDlg располагает диалог над центром активного окна } function MessageDlgCtr(const Msg: string; DlgType: TMsgDlgType; Buttons: TMsgDlgButtons; HelpCtx: Longint): Integer; begin with CreateMessageDialog(Msg, DlgType, Buttons) do try HelpContext := HelpCtx; Left := Screen.ActiveForm.Left + (Screen.ActiveForm.Width div 2) - (Width div 2); Top := Screen.ActiveForm.Top + (Screen.ActiveForm.Height div 2) - (Height div 2); Result := ShowModal; finally Free; end; end; end. |
Диалоги, модальные для всей системы
Ознакомьтесь с API-функцией SetSysModalWindow
Ознакомьтесь с API-функцией BringWindowToTop
Если вам необходим простой диалог с небольшим количеством текста, дополнительной иконкой и некоторыми кнопками, используйте MessageBox из WinProcs с MB_SYSTEMMODAL в параметре TextType.
Используйте функцию Windows API SetSysModalWindow(). Код ниже демонстрирует технологию работы с этой функцией. В любой момент времени может быть возможен только один модально-системны диалог, чей дескриптор возвращается функцией SetSysModalWindow(). Вам необходимо запомнить возвращаемую функцией величину для того, чтобы завершить показ диалога таким образом. Вот как примерно это должно выглядеть:
|
procedure TForm1.Button1Click(Sender: TObject); var x : word ; begin x := SetSysModalWindow(AboutBox.handle) ; AboutBox.showmodal ; SetSysModalWindow(x) ; end; |
[001740]
Использование InputBox и InputQuery
Тема: Использование InputBox, InputQuery и ShowMessage
Данная функция демонстрирует 3 очень мощных и полезных процедуры, интегрированных в Delphi.
Диалоговые окна InputBox и InputQuery позволяют пользователю вводить данные.
Функция InputBox используется в том случае, когда не имеет значения что пользователь выбирает для закрытия диалогового окна - кнопку OK или кнопку Cancel (или нажатие клавиши Esc). Если вам необходимо знать какую кнопку нажал пользователь (OK или Cancel (или нажал клавишу Esc)), используйте функцию InputQuery.
ShowMessage - другой простой путь отображения сообщения для пользователя.
|
procedure TForm1.Button1Click(Sender: TObject); var s, s1: string; b: boolean; begin s := Trim(InputBox('Новый пароль', 'Пароль', 'masterkey')); b := s <> ''; s1 := s; if b then b := InputQuery('Повторите пароль', 'Пароль', s1); if not b or (s1 <> s) then ShowMessage('Пароль неверен'); end; |
[001085]
Избавление от системного окна с ошибкой
Имеется функция Windows API, преобразующя уродливые Windows-окна, информирующие об ошибках в в привычные исключения Delphi, что, по крайней мере, более эстетично и полезно (поскольку в этом случае ошибка может быть перехвачена и обработана вашей программой).
| SetErrorMode(SEM_FAILCRITICALERRORS); |
Это все! Эта функция сообщает Windows о том, что вызвавшая ошибку программа будет сама обрабатывать критические ошибки.
- Neil J. Rubenking [000768]
Изменения в TOpenDialog
Почитайте про Open Dialog Box (диалоговое окно открытия файла) в файле помощи Windows API. Ознакомьтесь в статье с описанием аргумента lpTemplateName. Главное, вы можете создать новое диалоговое окно для Open Dialog Box и заменить стандартный диалог вашим собственным. [001474]
Как можно вывести диалог выбора директории?
Своим опытом делится Олег Кулабухов:
|
uses ShellAPI, ShlObj; procedure TForm1.Button1Click(Sender: TObject); var TitleName : string; lpItemID : PItemIDList; BrowseInfo : TBrowseInfo; DisplayName : array[0..MAX_PATH] of char; TempPath : array[0..MAX_PATH] of char; begin FillChar(BrowseInfo, sizeof(TBrowseInfo), #0); BrowseInfo.hwndOwner := Form1.Handle; BrowseInfo.pszDisplayName := @DisplayName; TitleName := 'Please specify a directory'; BrowseInfo.lpszTitle := PChar(TitleName); BrowseInfo.ulFlags := BIF_RETURNONLYFSDIRS; lpItemID := SHBrowseForFolder(BrowseInfo); if lpItemId <> nil then begin SHGetPathFromIDList(lpItemID, TempPath); ShowMessage(TempPath); GlobalFreePtr(lpItemID); end; end; |
[001870]
Как показать стандартное окно копирования файлов?
Своим опытом делится Олег Кулабухов:
Используйте SHFileOperation.
|
uses ShellAPI; procedure TForm1.Button1Click(Sender: TObject); var Fo : TSHFileOpStruct; buffer : array[0..4096] of char; p : pchar; begin FillChar(Buffer, sizeof(Buffer), #0); p := @buffer; p := StrECopy(p, 'C:\DownLoad\1.ZIP') + 1; p := StrECopy(p, 'C:\DownLoad\2.ZIP') + 1; p := StrECopy(p, 'C:\DownLoad\3.ZIP') + 1; StrECopy(p, 'C:\DownLoad\4.ZIP'); FillChar(Fo, sizeof(Fo), #0); Fo.Wnd := Handle; Fo.wFunc := FO_COPY; Fo.pFrom := @Buffer; Fo.pTo := 'D:\'; Fo.fFlags := 0; if ((SHFileOperation(Fo) <> 0) or (Fo.fAnyOperationsAborted <> false)) then ShowMessage('Cancelled') end; |
[001848]
Как вывести диалог выбора каталога?
Nomadic советует:
A: (DS): SelectDirectory, rxLib: TDirectoryEdit. [001514]
Как вывести окно свойств компьютеpа?
Nomadic отвечает:
| ShellExecute(Application.Handle, 'open', 'sysdm.cpl', nil, nil, sw_ShowNormal); |
[001671]
Как запустить диалог поиска файла?
Своим опытом делится Олег Кулабухов:
|
procedure TForm1.Button1Click(Sender: TObject); begin with TDDEClientConv.Create(Self) do begin ConnectMode := ddeManual; ServiceApplication := 'explorer.exe'; SetLink( 'Folders', 'AppProperties'); OpenLink; ExecuteMacro('[FindFolder(, C:\DOWNLOAD)]', False); CloseLink; Free; end; end; |
[001844]
MessageDlg без Gliph
Как мне получить информационное окошко c 3D-стилем и простыми кнопками (без Glyph), не особо изголяясь в программировании?
Просто добавьте следующую строчку в ваш код диалогового окошка:
| MsgDlgGlyphs := false; |
Лично я для дальнейшего использования создал целую коллекцию информационных окошек с моими собственными иконками. Моя основная претензия к стандартному окошку - близкое расположение иконки к левому краю кнопки - заставляет его выглядеть непрофессионально.
Steve Samuelson [000741]
MessageDlg в обработчике OnExit
Я пытаюсь использовать MessageDlg в обработчике OnExit компонента TEdit. При показе диалогового окна пользователь нажимает одну из кнопок, после чего, по идее, должно возникнуть событие OnEnter компонента, но оно не возникает! Если вызов диалога сопровождается комментарием, событие OnEnter инициализируется верно. В любом случае, событие OnExit завершает весь код.
Фактически (в момент показа диалога), фокус имеет поле редактирование, но курсор при этом не выводится. Передавая фокус "вперед" и снова "назад", вы получите желаемый результат. Например: В обработчике события OnExit поля редактирования после вызова MessageDlg попробуйте вызвать следующие функции:
|
PostMessage(Handle, WM_NEXTDLGCTL, 0, 0) ; PostMessage(Handle, WM_NEXTDLGCTL, 1, 0) ; |
OAmiry/Borland [000573]
Процедура обертки диалогового окна объектом
Нужно создать новую форму со стилем Dialog, заполнить ее необходимыми компонентами, и использовать ее приблизительно таким образом:
| with TMyForm.Create(self) do begin Parent := Self; MyExecute(inParam, outParam); Release; end; |
где MyExecute() должен делать Show[Modal] и другие вещи... [001776]
Размер диалогового окна
Давайте начнем с Microsoft Windows User Interface Guidelines (Руководящие Принципы Построения Интерфейса Пользователя Microsoft Windows) и допустим, что мы создаем диалоговое окно, содержащее компонент TMemo, занимающий большую часть площади формы и кнопки OK и Cancel, размещенные в ее нижней части.
Несколько примечаний из "Принципов": Диалоговые окна должны быть основаны на базовых диалоговых модулях, dialog base units (DBU), которые создаются с учетом размера шрифта и разрешения экрана. Диалоговые окна должны быть созданы, по возможности, на основе одного из нескольких стандартных размеров. Для нашего окна мы используем размер 212x188 DBU. Все элементы управления должны распологаться как минимум на расстоянии 7 DBU от края окна. Все элементы управления должны иметь между друг другом зазор размером минимум 4 DBU. Кнопки должны иметь высоту 14 DBU. (Про ширину кнопок "принципы" умалчивают; в обычном случая я использую кнопки шириной 40 DBU.) Вот необходимая для создания формы и элементов управления информация, которую мы можем получить во время выполнения приложения:
| procedure TMyForm.FormCreate(Sender: TObject); var BaseUnit, Margin, Spacing, BtnW, BtnH: Integer; begin BaseUnit := Canvas.TextHeight('0'); { 1 BaseUnit = 8 DBU определениям } Width := (212 * BaseUnit) div 8; Height := (188 * BaseUnit) div 8; Margin := (7 * BaseUnit) div 8 - GetSystemMetrics(SM_CXFIXEDFRAME); Spacing := (4 * BaseUnit) div 8; BtnW := (40 * BaseUnit) div 8; BtnH := (14 * BaseUnit) div 8; Memo1.SetBounds(Margin, Margin, ClientWidth - 2 * Margin, ClientHeight - 2 * Margin - Spacing - BtnH); OkButton.SetBounds(ClientWidth - Margin - Spacing - 2 * BtnW, ClientHeight - Margin - BtnH, BtnW, BtnH); CancelButton.SetBounds(ClientWidth - Margin - BtnW, ClientHeight - Margin - BtnH, BtnW, BtnH); end; |
Данный код позволяет создать диалоговое окно с правильными размерами и пропорциями, независимо от разрешения экрана и шрифтов.
- Steve Schafer [000976]
Текст на кнопках MessageDlg
Как можно сменить текст на кнопках диалогового окна MessageDlg? Английский язык для текста кнопок пользователь хочет заменить на родной.
Текст кнопок извлекается из списка строк, расположенных в файле ...\DELPHI\SOURCE\VCL\CONSTS.PAS. Отредактируйте его, после чего пересоберите VCL.
-Steve Schafer
Дополнение
VS дополняет:
Но можно ничего не менять. Вместо MessageDlg использовать MessageBox - функция WINDOWS. И, если ваш WINDOWS русифицирован, то надписи на кнопках в диалоговых окнах будут на русском языке. [001121]
Вызов стандартного системного окна "О программе"
Прислал Aleksey msalex@tomcat.ru:
|
{процедура показывает стандартное виндусовское окно абаута} {Не забудьте - ShellAPI поместить в uses} procedure ShowAbout; begin ShellAbout(Form1.Handle, 'Напиши здесь название программы', 'Заяви здесь о своих авторских правах на программу' #13#10 'можно в две строки', Application.Icon.Handle); end; |
Спасибо за замеченную неточность Andrew Balahonov. [000113]
Заголовок диалогового окна
Заголовок диалогового окна устанавливается в момент вызова CreateMessageDialog, чей код расположен в Dialogs.pas. При этом происходит вызов LoadStr, который получает Warningcaption, Cautioncaption и пр., так что у вас есть два пути: Или вы изменяете Dialogs.pas, или вы редактируете строки в .res-файле. [001738]
Drag and Drop: как использовать ITEMATPOS для получения элемента DIRLISTBOX?
Просто сохраните результат функции ItematPos в переменной формы, и затем используйте эту переменную в обработчике ListBoxDragDrop. Пример:
|
FDragItem:= ItematPos(X, Y, True);
if FDragItem >= 0 then
BeginDrag(false);
... procedure TForm1.ListBoxDragDrop(Sender, Source: TObject; X, Y: Integer); begin if Source is TDirectoryListBox then ListBox.Items.Add(TDirectoryListBox(Source).GetItemPath(FDragItem)); end; |
[001664]
Drag & Drop c Win95 Explorer I
Вот что я почерпнул из эхоконференций:
|
interface uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, ComCtrls; type TForm1 = class(TForm) procedure FormCreate(Sender: TObject); private { Private declarations } PROCEDURE FileIsDropped ( VAR Msg : TMessage ) ; Message WM_DropFiles ; public { Public declarations } end; var Form1: TForm1; implementation uses shellapi; {$R *.DFM} procedure TForm1.FormCreate(Sender: TObject); begin DragAcceptFiles( Handle,True ) ; end; PROCEDURE TForm1.FileIsDropped ( VAR Msg : TMessage ) ; VAR hDrop : THandle ; fName : ARRAY[0..254] OF CHAR ; NumberOfFiles : INTEGER ; fCounter : INTEGER ; Names : STRING ; BEGIN hDrop := Msg.WParam ; NumberOfFiles := DragQueryFile(hDrop,-1,fName,254); Names := '' ; FOR fCounter := 1 TO NumberOfFiles DO BEGIN DragQueryFile(hDrop,fCounter,fName,254); // Здесь вы получаете один к одному имя вашего файла Names := Names + #13#10 + fName ; END ; ShowMessage('Бросаем '+IntToStr(NumberOfFiles) + ' файла(ов) : ' + Names ); DragFinish ( hDrop); END ; end. |
[000089]
Drag & Drop c Win95 Explorer II
Прислал Aleksey msalex@tomcat.ru:
|
{Так можно заставить окно принимать файлы, перетаскиваемые из проводника} {ОБЯЗАТЕЛЬНО ПОМЕСТИТЕ В СЕКЦИЮ PRIVATE СТРОКИ procedure CreateParams(var Params: TCreateParams); override; procedure WMDropFiles(var Message: TWMDropFiles); message WM_DROPFILES; и не забудьте - ShellAPI поместить в uses} procedure TForm1.CreateParams(var Params: TCreateParams); begin inherited CreateParams(Params); Params.ExStyle := Params.ExStyle or WS_EX_ACCEPTFILES; {сделаем окно способным принимать файлы} end; procedure TForm1.WMDropFiles(var Message: TWMDropFiles); var aFile: array [0..255] of Char; //FilesCount : Integer; begin inherited; // FilesCount := DragQueryFile(Message.drop, $FFFFFFFF, nil, 0); {так можно узнать сколько файлов перетягивается} begin {здесь можно поставить цикл открытия всех перетаскиваемых файлов for N := 0 to FilesCount - 1 do DragQueryFile(Message.drop, N, aFile, 256); а в данном случае открывается только первый файл в списке} DragQueryFile(Message.drop, 0, aFile, 256); Memo1.Lines.LoadFromFile(aFile); end; DragFinish(Message.Drop); end; procedure TForm1.FormCreate(Sender: TObject); {Form1.OnCreate} begin DragAcceptFiles(Handle, True); {сделаем окно неравнодушным к пролетающим над ним файлам} end; |
Drag & Drop между двумя компонентами ListBox
Вот пересмотренный OnDragDrop, использующий source (источник) и sender (передатчик) вместо DstList и SrcList. Теперь, если вы установили SrcList и DstList для использования тех же методов OnDragOver и OnDragDrop и создали обработчик события OnDragDrop, то для операции Drag and Drop вы можете использовать оба решения.
|
procedure TDualListDlg.DstListDragDrop(Sender, Source: TObject; X, Y: Integer); var droppedOnIndex: integer; anItem: integer; numberOfItems: integer; begin if (Sender is TListbox) and (Source is TListBox) then begin droppedOnIndex := TListBox(Sender).ItemAtPos(Point(X,Y),false); numberOfItems := TListBox(Source).SelCount; anItem := 0; while numberOfItems > 0 do begin if TListBox(Source).Selected[anItem] = true then begin TListBox(Sender).Items.Insert(droppedOnIndex,TListBox(Source).Items[anItem]); TListBox(Source).Items.Delete(anItem); TListBox(Source).Update; TListBox(Sender).Update; numberOfItems := numberOfItems - 1; end else anItem := anItem + 1; end; end; end; |
Для того, чтобы предотвратить операцию Drag and Drop с одним и тем же компонентом, используйте следующий код в обработчике события OnDragOver:
|
if (Sender is TListBox) and (Source is TListBox) then begin if TListBox(Sender).Name = TListBox(Source).Name then Accept := False else Accept := true; end |
[000445]
Drag&Drop с минимизированным приложением
В ситуации, когда ваше приложение минимизировано, необходимо понимать, что окно главной формы НЕ работает. Фактически, если вы проверяете окно главной формы, и обнаруживаете, что оно имеет прежний размер, не удивляйтесь, оно просто невидимо. Иконка минимизированного Delphi-приложения принадлежит объекту Application, чей дескриптор окна - Application.Handle.
Вот некоторый код из моей программы, который с помощью компонента CheckBox проверяет возможность принятия перетаскиваемых файлов минимизированным приложением:
|
procedure TForm1.WMDropFiles(VAR Msg: TWMDropFiles);
{Вызывается только если TApplication НЕ получает drag/drop}
BEGIN
RecordDragDrop(Msg.Drop, False); {внутренняя функция}
Msg.Result := 0;
END;
procedure TForm1.AppOnMessage(VAR Msg: TMsg; VAR Handled: Boolean); {когда активно, получаем сообщения WM_DROPFILES, посылаемые форме ИЛИ минимизированному приложению} BEGIN IF Msg.message = WM_DROPFILES THEN BEGIN RecordDragDrop(Msg.wParam, Msg.hWnd = Application.Handle); Handled := True; END; procedure TForm1.FormCreate(Sender: TObject); begin DragAcceptFiles(Handle, True); DragAcceptFiles(Application.Handle, False); Application.OnMessage := NIL; END; end; |
OK? Первоначально вызов DragAcceptFiles работает с дескриптором главной формы...
- Neil J. Rubenking [000754]
Drag & Drop TImage
Вот рабочий пример. Расположите на форме панель побольше, скопируйте и измените приведенный код так, чтобы изображение загружалось из ВАШЕГО каталога Delphi.
|
procedure TForm1.Panel1DragDrop(Sender, Source: TObject; X, Y: Integer); begin WITH Source AS TImage DO BEGIN Left := X; Top := Y; END; end; procedure TForm1.Panel1DragOver(Sender, Source: TObject; X, Y: Integer; State: TDragState; var Accept: Boolean); begin Accept := Source IS TImage; end; procedure TForm1.FormCreate(Sender: TObject); begin WITH TImage.Create(Self) DO BEGIN Parent := Panel1; AutoSize := True; Picture.LoadFromFile('D:\DELPHI\IMAGES\CHIP.BMP'); DragMode := dmAutomatic; OnDragOver := Panel1DragOver; OnDragDrop := Panel1DragDrop; END; end; |
[000651]
Как получить список файлов, которые были перенесены на мою форму, например, из Проводника?
Из советов Nomadic'a:
Развлекался когда-то - вот, осталось:
|
unit Unit1; interface uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, ShellAPI, Grids, StdCtrls; type TForm1 = class(TForm) lb: TListBox; Memo1: TMemo; Button1: TButton; Button2: TButton; procedure FormCreate(Sender: TObject); procedure Button1Click(Sender: TObject); procedure Button2Click(Sender: TObject); private procedure WMDropFiles(var M: TMessage); message WM_DROPFILES; { Private declarations } public { Public declarations } end; var Form1: TForm1; implementation Var CountFiles : integer; SizeName : integer; cch : integer; Var hDrop : integer; Point : TPoint; lpszFile : PChar; {$R *.DFM} procedure TForm1.WMDropFiles(var M: TMessage); Var i: integer; begin hDrop := M.WParam; DragQueryPoint(hDrop,Point); CountFiles := DragQueryFile(hDrop, $FFFFFFFF, nil, cch); for i:=0 to CountFiles-1 do begin SizeName := DragQueryFile(hDrop, i, nil, cch); GetMem(lpszFile,SizeName+1); DragQueryFile(hDrop, i, lpszFile, SizeName+1); lb.Items.Add(lpszFile); FreeMem(lpszFile,SizeName+1); end; DragFinish(hDrop); end; procedure TForm1.FormCreate(Sender: TObject); begin DragAcceptFiles(Handle,True); end; procedure TForm1.Button1Click(Sender: TObject); begin lb.Items.Clear; end; procedure TForm1.Button2Click(Sender: TObject); begin ShellAbout(Handle,'Anton Saburov','APSystems',0); end; end. |
[001082]
Как пpинимать яpлыки пpи пеpетягивании их на контpол?
Из советов Nomadic'a:
|
TForm1 = class(TForm)
...
private
{ Private declarations }
procedure WMDropFiles(var M : TWMDropFiles); message WM_DROPFILES;
...
end;
var Form1: TForm1; implementation uses StrUtils, ShellAPI, ComObj, ShlObj, ActiveX;; procedure TForm1.FormCreate(Sender: TObject); begin ... DragAcceptFiles(Handle, True); ... end; procedure TForm1.FormDestroy(Sender: TObject); begin ... DragAcceptFiles(Handle, False); ... end; procedure TForm1.WMDropFiles(var M : TWMDropFiles); var hDrop: Cardinal; n: Integer; s: string; begin hDrop := M.Drop; n := DragQueryFile(hDrop, 0, nil, 0); SetLength(s, n); DragQueryFile(hDrop, 0, PChar(s), n + 1); DragFinish(hDrop); M.Result := 0; FileOpen(s); end; procedure TForm1.FileOpen(FileName: string); begin if CompareText(ExtractFileExt(FileName), '.lnk') = 0 then FileName := ResolveShortcut(Application.Handle, FileName); DocName := ExtractFileName(FileName); Caption := Application.Title + ' - ' + DocName; ... end; function ResolveShortcut(Wnd: HWND; ShortcutPath: string): string; var obj: IUnknown; isl: IShellLink; ipf: IPersistFile; pfd: TWin32FindDataA; begin Result := ''; obj := CreateComObject(CLSID_ShellLink); isl := obj as IShellLink; ipf := obj as IPersistFile; ipf.Load(PWChar(WideString(ShortcutPath)), STGM_READ); with isl do begin Resolve(Wnd, SLR_ANY_MATCH); SetLength(Result, MAX_PATH); GetPath(PChar(Result), Length(Result), pfd, SLGP_UNCPRIORITY); Result := PChar(Result); end; end; |
[001709]
ListBox и Drag&Drop
Расположите на форме ListBox и Label. Установите свойство списка dragmode на dmAutomatic. Поместите следующую строку в обработчике события OnDragOver:
| Label1.Caption := IntToStr(Y); |
Теперь запустите программу и тащите какой-либо элемент в направлении правого верхнего угла до верхней границы списка. Обратите внимание как изменяется координата Y - уменьшаясь, она принимает значение -1, когда курсор выходит за верхнюю границу. (Примечание - только что попробовал это в Delphi 5 - нижнее значение показало -2).
Теперь осталось только определить, около какого элемента списка находится курсор мыши, для чего используйте ItemAtPos. [000344]
Перетаскивание элементов управления c рамкой контура
...как перетаскивать элементы управления с контурной рамкой по их форме, "приклеенной" к курсору? Решение, найденное вами, работать не будет, поскольку таскаемая рамка не обязательно может находиться в пределах области компонента (а вы отрисовываете ее только на компоненте).
В общих чертах, вы должны рисовать на всей поверхности формы и даже рабочего стола, для чего необходимо сделать растровую КОПИЮ окна или десктопа и рисовать на ней. Вот что нам нужно.
Начните со свеженькой формы. Бросьте на нее компонент Notebook и установите его свойство Align в alClient. Разработайте форму на первой странице компонента Notebook. Создайте вторую страницу в Notebook, поместите туда Paintbox и установите его свойство Align в alClient. Далее добавьте нижеследующие строчки в секцию Private вашей формы:
| Img : TBitmap; DragX, DragY, DragW, DragH, XOff, YOff : Integer; |
В обработчике формы OnCreate:
| Img := TBitmap.Create; |
В общем, для всех перетаскиваемых компонентов, обработчике события OnMouseDown:
| IF NOT (ssShift IN Shift) THEN Exit; Img := GetFormImage; Notebook1.PageIndex := 1; WITH Sender AS TControl DO BEGIN DragW := Width; DragH := Height; XOff:= X; YOff := Y; BeginDrag(True); END; |
В общем, для всех перетаскиваемых компонентов, обработчике события EndDrag:
| Notebook1.PageIndex := 0; WITH Sender AS Tcontrol DO BEGIN Left := X-Xoff; Top := Y-YOff; END; |
Поместите следующую строку в обработчик события OnPaint компонента PaintBox:
| PaintBox1.Canvas.Draw(0, 0, Img); |
И наконец, если вам еще это не надоело, поместите следующую строчку в обработчик OnDragOver компонента PaintBox:
| IF (X=DragX) AND (Y=DragY) THEN Exit; WITH PaintBox1.Canvas DO BEGIN DrawFocusRect(Bounds(DragX-XOff, DragY-YOff, DragW, DragH); DragX := X; DragY := Y; DrawFocusRect(Bounds(DragX-XOff, DragY-YOff, DragW, DragH); END; |
ФУ!! Но это работает! Я не хотел убирать в компонентах возможность перетаскивания их мышью обычным способом, поэтому для включения дополнительной характеристики необходимо при старте держать нажатой клавишу Shift. Попробуйте это!
- NEil
Я пытаюсь "потаскать" TPanel, используемую в качестве ToolBar и всегда почему-то получаю иконку с перечеркнутым кругом. Я понимаю, что это означает невозможность перетаскивания. К сожалению, в документации я ничего не нашел как решить эту проблему. Я пробовал и ручные, и автоматические настройки (DragMode = dmManual/dmAutomatic - В.О.), но все без толку.
Иногда я вообще не могу "оторвать" TPanel!
Начнем с самого начала. Причина того, что вы получаете курсор "crNoDrop" в том, что под курсором элемент управления не готов принять перетаскиваемый компонент. Чтобы исправить эту ситуацию, дважды щелкните (в Инспекторе Объектов) на событии формы или компонента OnDragOver и установите параметр Accept в, например так:
|
procedure TForm1.FormDragOver(Sender, Source: TObject; X, Y: Integer; State: TDragState; var Accept: Boolean); begin Accept := true ; end; |
Благодарю за пример создания прямоугольника при перетаскивании. Ваши инструкции помогли мне первое время и я легко интегрировал ваш код в мое приложение. Но если вы не возражаете, я хотел бы получить другой небольшой совет .... есть ли возможность во время операции перетаскивания (PaintBox1DragOver) работать с элементами управления, находящимимя под PainBox с тем, чтобы они также изменяли курсор и также могли бы принимать перетаскиваемый элемент? Когда перетаскиваемый элемент выдает сообщение EndDrag, параметр Target должен быть PaintBox (логически).
Можно как-то определить, с каким конкретно элементом управления, расположенным под PainBox, взаимодействует в данный момент перетаскиваемый элемент (для его акцептования)? Я опять что-то упустил, но я не знаю как это сделать.
Вы можете получить координаты в методе OnDragOver при сравнении BoundsRect с областью компонентов. Например, вы не хотите принимать перетаскиваемый компонент кнопкой, перекрывающей любую другую имеющуюся кнопку. В обработчике OnDragOver напишите примерно следующее:
| FOR N := 0 TO ComponentCount-1 DO IF COmponents[N] IS TButton THEN IF IntersectRect(DummyRect, TControl(Components[N]).BoundsRect, (Bounds(X-XOff, Y-YOff, DragW, DragH)) >0 THEN Accept := False; |
В этом случае курсор будет изменяться на перечеркнутый кружок при пересечении перетаскиваемым элементом границы интересующей вас кнопки. Вы должны сделать аналогичную логику или в обработчике EndDrag или OnDragDrop компонента PainBox. [000436]
Преобразование координат
Поверьте, достаточно просто преобразовать X,Y координаты, передаваемые в параметрах событий OnDragOver и OnDragDrop, в координаты формы.
Работайте со свойствами Left и Top компонента, над которым перемещается курсор. Приведу простой пример. Поместите на форму компонент Memo и присвойте свойству Align значение alTop. Поместите на форму панель, также присвойсте свойству Align значение alTop и задайте небольшое значение свойству Height, скажем 6 или 7 пикселей. Установите DragMode на dmAutomatica и DragCursor на crVSplit. Поместите другой Memo-компонент и установите Align на alClient. Одновременно выберите оба Memo-компонента, панель и создайте общий обработчик события OnDragOver как показано ниже:
| procedure TForm1.Memo1DragOver(Sender, Source: TObject; X, Y: Integer; State: TDragState; var Accept: Boolean); begin IF Source = Panel1 THEN WITH Sender AS TControl DO BEGIN Accept := True; Memo1.Height := Y + Top; END ELSE Accept := False; end; |
Теперь попробуйте это!
- Neil [000355]
Прием файлов из Program Manager I
Смотри функцию Windows API DragAcceptFiles. Вы должны это вызвать, чтобы зарегистрировать вашу программу в качестве "приемного пункта" перетаскиваемых файлов. Далее в вашем приложении вы должны реагировать на сообщение WM_DROPFILES, возникающее при операции drag/drop из File Manager. [000413]
