|
:: MVP ::
|
|
|
:: RSS ::
|
|
|
Как показать диалог "Open With"?
uses
{...,} ShellAPI;
procedure OpenWith( FileName: string );
begin
ShellExecute( Application.Handle, 'open', PChar( 'rundll32.exe' ),
PChar( 'shell32.dll,OpenAs_RunDLL ' + FileName ), nil, SW_SHOWNORMAL );
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
OpenWith( 'c:\boot.ini' );
end;
|
Как открыть диалог свойств аудио?
uses
{...,} ShellAPI;
procedure TForm1.Button1Click(Sender: TObject);
begin
ShellExecute( Application.Handle, 'open', PChar( 'rundll32.exe' ),
PChar( 'shell32.dll,Control_RunDLL mmsys.cpl'), nil, SW_SHOWNORMAL );
end;
|
Как вызвать диалог "Найти файлы и паки" проводника?
// Способ первый
uses
{...,} DDEMan;
procedure SearchInFolder(Folder: string);
begin
with TDDEClientConv.Create( Form1 ) do
begin
ConnectMode := ddeManual;
ServiceApplication := 'Explorer.exe';
SetLink( 'Folders', 'AppProperties' );
OpenLink;
ExecuteMacro( PChar( '[FindFolder(, ' + Folder + ')]' ), false );
CloseLink;
Free;
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
SearchInFolder( 'c:\' );
end;
// Способ второй
uses
{...,} ShellAPI;
procedure TForm1.Button1Click(Sender: TObject);
begin
ShellExecute( Handle, 'find', 'C:\Windows', nil, nil, SW_SHOW );
end;
// Способ третий
uses
{...,} DDEMan;
procedure WindowsSuchenDialog( Verzeichnis, Suchstring: string );
var
hOtherWin, hFocusWin: HWND;
OtherThreadID, iTimeOut: Integer;
aDwordVar: DWORD;
buf: array [0..40] of Char;
sVerz: string;
begin
with TDDEClientConv.Create( nil ) do
begin
ConnectMode := ddeManual;
ServiceApplication := 'explorer.exe';
SetLink( 'Folders', 'AppProperties' );
OpenLink;
sVerz := IncludeTrailingBackslash( Verzeichnis );
ExecuteMacro( PChar('[FindFolder(, '+ sVerz +')]'), false );
CloseLink;
Free;
end;
iTimeOut := 0;
repeat
{Warten, bis der Such Dialog erscheint.
Unter Win95/98/NT4 hat der Suchdilaog die Klasse #32770.
Unter ME/2000/XP ist die Suche in den Explorer integriert,
darum auf CabinetWClass warten}
Sleep( 100 );
hOtherWin := GetForegroundWindow;
buf[0] := #0;
GetClassName( hOtherWin, buf, 60 );
Inc( iTimeOut );
until ( StrComp( buf, '#32770' ) = 0 ) or ( StrComp( buf, 'CabinetWClass' ) = 0 ) or ( iTimeOut > 20 );
if iTimeOut > 20 then Exit;
repeat
{ Wait until it is visible }
{ Warten, bis das Fenster erscheint }
Sleep( 100 );
until IsWindowVisible( hOtherWin );
{ Handle vom Control finden, welches den Fokus besitzt }
OtherThreadID := GetWindowThreadProcessID( hOtherWin, @aDwordvar );
if AttachThreadInput( GetCurrentThreadID, OtherThreadID, true ) then
begin
hFocusWin := GetFocus;
if hFocusWin <> 0 then
try
SendMessage( hFocusWin, WM_SETTEXT, 0, Longint( PChar( Suchstring ) ) );
finally
AttachThreadInput( GetCurrentThreadID, OtherThreadID, false );
end;
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
WindowsSuchenDialog( 'c:\temp', 'test.txt' );
end;
|
Как показать диалог выбора пользователей?
uses
{...,} ActiveX;
const
CLSID_DsObjectPicker: TGUID = (
D1:$17d6ccd8; D2:$3b7b; D3:$11d2; D4:($b9,$e0,$00,$c0,$4f,$d8,$db,$f7));
IID_IDsObjectPicker: TGUID = (
D1:$0c87e64e; D2:$3b7a; D3:$11d2; D4:($b9,$e0,$00,$c0,$4f,$d8,$db,$f7));
ANYSIZE_ARRAY = 1;
CFSTR_DSOP_DS_SELECTION_LIST = 'CFSTR_DSOP_DS_SELECTION_LIST';
const
DSOP_SCOPE_TYPE_TARGET_COMPUTER = $00000001;
DSOP_SCOPE_TYPE_USER_ENTERED_DOWNLEVEL_SCOPE = $00000200;
DSOP_FILTER_USERS = $00000002;
DSOP_DOWNLEVEL_FILTER_USERS = DWORD($80000001);
DSOP_FLAG_SKIP_TARGET_COMPUTER_DC_CHECK = $00000002;
type
LPLPWSTR = ^PWideChar;
TDsOpUpLevelFilterFlags = record
flBothModes: ULONG;
flMixedModeOnly: ULONG;
flNativeModeOnly: ULONG;
end;
TDsOpFilterFlags = record
Uplevel: TDsOpUpLevelFilterFlags;
flDownlevel: ULONG;
end;
PDsOpScopeInitInfo = ^TDsOpScopeInitInfo;
TDsOpScopeInitInfo = record
cbSize: ULONG;
flType: ULONG;
flScope: ULONG;
FilterFlags: TDsOpFilterFlags;
pwzDcName: PWideChar;
pwzADsPath: PWideChar;
hr: HRESULT;
end;
TDsOpInitInfo = record
cbSize: ULONG;
pwzTargetComputer: PWideChar;
cDsScopeInfos: ULONG;
aDsScopeInfos: PDsOpScopeInitInfo;
flOptions: ULONG;
cAttributesToFetch: ULONG;
apwzAttributeNames: LPLPWSTR;
end;
TDsSelection = record
pwzName: PWideChar;
pwzADsPath: PWideChar;
pwzClass: PWideChar;
pwzUPN: PWideChar;
pvarFetchedAttributes: POleVariant;
flScopeType: ULONG;
end;
PDSSelectionList = ^TDsSelectionList;
TDsSelectionList = record
cItems: ULONG;
cFetchedAttributes: ULONG;
aDsSelection: array [0..ANYSIZE_ARRAY - 1] of TDsSelection;
end;
IDsObjectPicker = interface (IUnknown)
['{0c87e64e-3b7a-11d2-b9e0-00c04fd8dbf7}']
function Initialize(const pInitInfo: TDsOpInitInfo): HRESULT; stdcall;
function InvokeDialog(hwndParent: HWND; out ppdoSelections: IDataObject): HRESULT; stdcall;
end;
TForm1 = class(TForm)
Button1: TButton;
procedure Button1Click(Sender: TObject);
end;
{...}
implementation
function InitObjectPicker(Picker: IDsObjectPicker): HRESULT;
var
ScopeInit: array [0..0] of TDSOPScopeInitInfo; // Объект, который указывает что будем выбирать
InitInfo: TDSOPInitInfo; // Информация об инициализации
begin
if nil = Picker then
Result := E_INVALIDARG
else
begin
ZeroMemory( @ScopeInit, SizeOf( ScopeInit ) ); // Заполняем нулями
ScopeInit[0].cbSize := SizeOf( TDSOPScopeInitInfo ); // Заполняем структуру TDSOPScopeInitInfo
ScopeInit[0].flType := DSOP_SCOPE_TYPE_TARGET_COMPUTER;
ScopeInit[0].flScope := DSOP_SCOPE_TYPE_USER_ENTERED_DOWNLEVEL_SCOPE;
ScopeInit[0].FilterFlags.Uplevel.flBothModes := DSOP_FILTER_USERS;
ScopeInit[0].FilterFlags.flDownlevel := DSOP_DOWNLEVEL_FILTER_USERS;
ZeroMemory( @InitInfo, SizeOf( InitInfo ) ); // Заполняем структуру TDSOPInitInfo
InitInfo.cbSize := SizeOf( InitInfo );
InitInfo.cDsScopeInfos := SizeOf( ScopeInit ) div SizeOf( TDSOPScopeInitInfo );
InitInfo.aDsScopeInfos := @ScopeInit;
InitInfo.flOptions := DSOP_FLAG_SKIP_TARGET_COMPUTER_DC_CHECK;
// Инициализируем объект выбора
Result := Picker.Initialize( InitInfo );
end;
end;
function ProcessSelectedObjects(DatObj: IDataObject): HRESULT;
var
StgMed: TStgMedium; // Объект хранения данных
FmtEtc: TFormatEtc; // Формат ыввода данных
SelLst: PDSSelectionList; // Выбранные объекты
Index: ULONG;
Text: string;
begin
// Проверка на "дурака"
if nil = DatObj then
Result := E_INVALIDARG
else
begin
with FmtEtc do
begin
// Регистрируем формат вывода данных
cfFormat := RegisterClipboardFormat( CFSTR_DSOP_DS_SELECTION_LIST );
ptd := nil;
dwAspect := DVASPECT_CONTENT;
lindex := -1;
tymed := TYMED_HGLOBAL;
end;
Result := DatObj.GetData( FmtEtc, StgMed );
if Succeeded( Result ) then
begin
// Получаем результат вызора в удобоваримом формате
SelLst := PDsSelectionList( GlobalLock( StgMed.hGlobal ) );
// и если не nil обрабатываем его
if SelLst <> nil then
try
Text := '';
for Index := 0 to SelLst.cItems-1 do
begin
Text := Text + Format( 'Object : %u'#13#10 +
' Name : %s'#13#10 +
' Class: %s'#13#10 +
' Path : %s'#13#10 +
' UPN : %s'#13#10, [
Index,
WideCharToString( SelLst.aDsSelection[Index].pwzName ),
WideCharToString( SelLst.aDsSelection[Index].pwzClass ),
WideCharToString( SelLst.aDsSelection[Index].pwzADsPath ),
WideCharToString( SelLst.aDsSelection[Index].pwzUPN )] );
end;
ShowMessage( Text );
finally
GlobalUnlock( StgMed.hGlobal );
end
else
Result := E_POINTER;
ReleaseStgMedium(StgMed);
end;
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
var
Picker: IDsObjectPicker;
DatObj: IDataObject;
begin
// Инициализируем COM+
if Succeeded( CoInitialize( nil ) ) then
try
// Создаем Picker как объект COM+
if Succeeded( CoCreateInstance( CLSID_DsObjectPicker, nil,
CLSCTX_INPROC_SERVER, IID_IDsObjectPicker, Picker ) ) then
try
// Если инициализация Picker успешна вызываем сам диалог
if Succeeded( InitObjectPicker( Picker ) ) then
case Picker.InvokeDialog( Self.Handle, DatObj ) of
S_OK:
try
// Вызов диалога
ProcessSelectedObjects( DatObj );
finally
// Освобождаем DatObj
DatObj := nil;
end;
S_FALSE: ShowMessage( 'Ничего не выбрано' );
end;
finally
Picker := nil;
end;
finally
CoUninitialize;
end;
end;
|
Как показать полупрозрачный MessageBox?
const
WM_MSGBOX = WM_USER + 1;
type
TForm1 = class(TForm)
Button1: TButton;
procedure Button1Click(Sender: TObject);
private
procedure MsgBoxShow( var Msg: TMessage ); message WM_MSGBOX;
public
end;
implementation
procedure MakeTransp( Wnd: HWND; Value: Byte );
var
ExStyle: Longint;
begin
ExStyle := GetWindowLong( Wnd, GWL_EXSTYLE );
if ExStyle and WS_EX_LAYERED = 0 then
begin
ExStyle := ExStyle or WS_EX_LAYERED;
SetwindowLong( Wnd, GWL_EXSTYLE, ExStyle );
end;
SetLayeredWindowAttributes( Wnd, 0, Value, LWA_ALPHA );
end;
procedure TForm1.MsgBoxShow(var Msg: TMessage);
var
MsgbHandle: HWND;
begin
MsgbHandle := GetActiveWindow;
if MsgbHandle <> 0 then
MakeTransp( MsgbHandle, 128 );
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
PostMessage( Handle, WM_USER + 1, 0, 0 );
MessageBox( Handle, 'This Is A Transparent Message Box', '50% MessageBox.', MB_OK or MB_ICONWARNING );
end;
|
Как показать системный диалог ввода логина/пароля?
// Способ первый (Windows XP и выше)
function LoginUser(const ACaption, ADescription: string; var AUser,
APassword: string; var ASavePassword: Boolean): Boolean;
type
PCredUIInfo = ^TCredUIInfo;
TCredUIInfo = record
cbSize: DWORD;
hwndParent: HWND;
pszMessageText: PChar;
pszCaptionText: PChar;
hbmBanner: HBITMAP;
end;
var
Lib: HMODULE;
CredUIPromptForCredentials: function(pUiInfo: PCredUIInfo; pszTargetName: PChar;
pContext: Pointer; dwAuthError: DWORD; pszUserName: PChar; ulUserNameBufferSize: ULONG;
pszPassword: PChar; ulPasswordBufferSize: ULONG; var pfSave: BOOL; dwFlags: DWORD): DWORD; stdcall;
CredInfo: TCredUIInfo;
User, Password: string;
Save: BOOL;
const
CREDUI_MAX_USERNAME_LENGTH = 256; // does not include the terminating null character.
CREDUI_MAX_PASSWORD_LENGTH = 256; // does not include the terminating null character.
// Maximum length of the UserName field. The worst case is <User>@<DnsDomain>
MAXBUFLEN = CREDUI_MAX_USERNAME_LENGTH + 1 + CREDUI_MAX_PASSWORD_LENGTH;
credui = 'credui.dll';
CredUIPromptForCredentialsName = {$IFDEF UNICODE}
'CredUIPromptForCredentialsW'
{$ELSE}
'CredUIPromptForCredentialsA'
{$ENDIF};
CREDUI_FLAGS_INCORRECT_PASSWORD = $00001;
CREDUI_FLAGS_DO_NOT_PERSIST = $00002;
CREDUI_FLAGS_REQUEST_ADMINISTRATOR = $00004;
CREDUI_FLAGS_EXCLUDE_CERTIFICATES = $00008;
CREDUI_FLAGS_REQUIRE_CERTIFICATE = $00010;
CREDUI_FLAGS_SHOW_SAVE_CHECK_BOX = $00040;
CREDUI_FLAGS_ALWAYS_SHOW_UI = $00080;
CREDUI_FLAGS_REQUIRE_SMARTCARD = $00100;
CREDUI_FLAGS_PASSWORD_ONLY_OK = $00200;
CREDUI_FLAGS_VALIDATE_USERNAME = $00400;
CREDUI_FLAGS_COMPLETE_USERNAME = $00800;
CREDUI_FLAGS_PERSIST = $01000;
CREDUI_FLAGS_SERVER_CREDENTIAL = $04000;
CREDUI_FLAGS_EXPECT_CONFIRMATION = $20000;
CREDUI_FLAGS_GENERIC_CREDENTIALS = $40000;
CREDUI_FLAGS_USERNAME_TARGET_CREDENTIALS = $80000;
CREDUI_FLAGS_KEEP_USERNAME = $100000;
begin
Lib := SafeLoadLibrary(credui);
if Lib <> 0 then
try
CredUIPromptForCredentials := GetProcAddress(Lib, CredUIPromptForCredentialsName);
if Assigned(CredUIPromptForCredentials) then
begin
FillChar(CredInfo, SizeOf(CredInfo), 0);
CredInfo.cbSize := SizeOf(CredInfo);
if Screen.FocusedForm <> nil then
CredInfo.hwndParent := Screen.FocusedForm.Handle
else
if Screen.ActiveForm <> nil then
CredInfo.hwndParent := Screen.ActiveForm.Handle
else
CredInfo.hwndParent := 0;
CredInfo.pszCaptionText := PChar(ACaption);
CredInfo.pszMessageText := PChar(ADescription);
User := AUser + #0;
Password := APassword + #0;
Save := ASavePassword;
SetLength(User, MAXBUFLEN);
SetLength(Password, MAXBUFLEN);
case CredUIPromptForCredentials(@CredInfo, nil, nil, 0, PChar(User),
MAXBUFLEN, PChar(Password), MAXBUFLEN, Save,
CREDUI_FLAGS_ALWAYS_SHOW_UI or CREDUI_FLAGS_DO_NOT_PERSIST or
CREDUI_FLAGS_SHOW_SAVE_CHECK_BOX or CREDUI_FLAGS_GENERIC_CREDENTIALS) of
NO_ERROR: begin
AUser := PChar(User);
APassword := PChar(Password);
ASavePassword := Save;
Result := True;
Exit;
end;
ERROR_CANCELLED:
Result := False;
else
raise Exception.Create('CredUIPromptForCredentials failed');
end;
end
else
RaiseLastOSError;
finally
FreeLibrary(Lib);
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
var
Username, Password: string;
Token: NativeUInt;
SavePassword: Boolean;
begin
Username := 'some_user';
Password := 'some_password';
if not LoginUser('Авторизация', 'Введите данные вашей учётки:',
Username, Password, SavePassword) then
Exit;
if not LogonUser(@Username[1], nil, @Password[1], LOGON32_LOGON_INTERACTIVE,
LOGON32_PROVIDER_DEFAULT, Token) then
raise Exception.Create('Invalid login or password')
else
ShowMessage('Успешная авторизация!');
// OK!
end;
// Способ второй (Windows Vista и выше)
function LoginUser(const ACaption, ADescription: string;
AAuthError: Cardinal; var AUser, APassword, ADomain: string;
var ASavePassword: Boolean): Boolean;
type
PCredUIInfo = ^TCredUIInfo;
TCredUIInfo = record
cbSize: DWORD;
hwndParent: HWND;
pszMessageText: PChar;
pszCaptionText: PChar;
hbmBanner: HBITMAP;
end;
const
CRED_MAX_USERNAME_LENGTH = 256;
CREDUI_MAX_PASSWORD_LENGTH = 256;
CRED_MAX_DOMAIN_TARGET_NAME_LENGTH = 256;
credui = 'credui.dll';
CredUIPromptForWindowsCredentialsName = {$IFDEF UNICODE}
'CredUIPromptForWindowsCredentialsW'
{$ELSE}
'CredUIPromptForWindowsCredentialsA'
{$ENDIF};
CredUnPackAuthenticationBufferName = {$IFDEF UNICODE}
'CredUnPackAuthenticationBufferW'
{$ELSE}
'CredUnPackAuthenticationBufferA'
{$ENDIF};
CREDUIWIN_GENERIC = $00000001;
CREDUIWIN_CHECKBOX = $00000002;
CREDUIWIN_AUTHPACKAGE_ONLY = $00000010;
CREDUIWIN_IN_CRED_ONLY = $00000020;
CREDUIWIN_ENUMERATE_ADMINS = $00000100;
CREDUIWIN_ENUMERATE_CURRENT_USER = $00000200;
CREDUIWIN_SECURE_PROMPT = $00001000;
CREDUIWIN_PREPROMPTING = $00002000;
CREDUIWIN_PACK_32_WOW = $10000000;
var
Lib: HMODULE;
CredUIPromptForWindowsCredentials: function(
var pUiInfo: TCredUIInfo; dwAuthError: DWORD; var pulAuthPackage: NativeUInt;
pvInAuthBuffer: PCardinal; ulInAuthBufferSize: ULONG;
out ppvOutAuthBuffer: Cardinal; out pulOutAuthBufferSize: ULONG;
pfSave: PVOID; dwFlags: DWORD): DWORD; stdcall;
CredUnPackAuthenticationBuffer: function(
dwFlags: DWORD; pAuthBuffer: PVOID; cbAuthBuffer: DWORD;
pszUserName: LPTSTR; var pcchMaxUserName: DWORD;
pszDomainName: LPTSTR; var pcchMaxDomainname: DWORD;
pszPassword: LPTSTR; var pcchMaxPassword: DWORD
): LONGBOOL; stdcall;
CredInfo: TCredUIInfo;
lUserName, lPassword, lDomain: array [Byte] of Char;
lMaxUserName, lMaxDomainName, lMaxPassword: DWORD;
User, Password: string;
lAuthPackage: NativeUInt;
lOutBuffer: Cardinal;
lOutBufferSize: DWORD;
Save: BOOL;
begin
Lib := SafeLoadLibrary(credui);
if Lib <> 0 then
try
CredUIPromptForWindowsCredentials := GetProcAddress(Lib, CredUIPromptForWindowsCredentialsName);
CredUnPackAuthenticationBuffer := GetProcAddress(Lib, CredUnPackAuthenticationBufferName);
if Assigned(CredUIPromptForWindowsCredentials) and Assigned(CredUnPackAuthenticationBuffer) then
begin
FillChar(CredInfo, SizeOf(CredInfo), 0);
CredInfo.cbSize := SizeOf(CredInfo);
if Screen.FocusedForm <> nil then
CredInfo.hwndParent := Screen.FocusedForm.Handle
else
if Screen.ActiveForm <> nil then
CredInfo.hwndParent := Screen.ActiveForm.Handle
else
CredInfo.hwndParent := 0;
CredInfo.pszCaptionText := PChar(ACaption);
CredInfo.pszMessageText := PChar(ADescription);
lAuthPackage := 0;
case CredUIPromptForWindowsCredentials(
CredInfo, AAuthError, lAuthPackage, nil, 0,
lOutBuffer, lOutBufferSize, @ASavePassword,
CREDUIWIN_GENERIC or CREDUIWIN_CHECKBOX) of
NO_ERROR: begin
ZeroMemory(@lUserName, SizeOf(lUserName));
ZeroMemory(@lPassword, SizeOf(lPassword));
ZeroMemory(@lDomain, SizeOf(lDomain));
Result := CredUnPackAuthenticationBuffer(
0, Pointer(lOutBuffer), lOutBufferSize,
@lUserName, lMaxUserName,
@lDomain, lMaxDomainName,
@lPassword, lMaxPassword);
if Result then
begin
AUser := String(lUserName);
APassword := String(lPassword);
ADomain := String(lDomain);
Result := True;
end;
end;
ERROR_CANCELLED:
Result := False;
else
raise Exception.Create('CredUIPromptForWindowsCredentials failed');
end;
end
else
RaiseLastOSError;
finally
FreeLibrary(Lib);
end;
end;
procedure TForm1.Button2Click(Sender: TObject);
var
Username, Password, Domain: string;
Token: NativeUInt;
SavePassword: Boolean;
begin
if not LoginUser('Авторизация', 'Введите данные вашей учётки:', $963 {или 0},
Username, Password, Domain, SavePassword) then
Exit;
if not LogonUser(@Username[1], nil, @Password[1], LOGON32_LOGON_INTERACTIVE,
LOGON32_PROVIDER_DEFAULT, Token) then
raise Exception.Create('Invalid login or password')
else
ShowMessage('Успешная авторизация!');
// OK!
end;
|
Как показать Messagebox без кнопок, закрывающийся по истечении указанного времени?
type
TForm1 = class(TForm)
Button1: TButton;
procedure Button1Click(Sender: TObject);
private
procedure WMUser(var Message: TMessage); message WM_USER;
public
end;
var
Form1: TForm1;
implementation
function MessageBoxTimeOutA(hWnd: HWND; lpText: PChar; lpCaption: PChar;
uType: UINT; wLanguageId: WORD; dwMilliseconds: DWORD): Integer; stdcall;
external user32 name 'MessageBoxTimeoutA';
function MessageBoxTimeOutW(hWnd: HWND; lpText: PWideChar; lpCaption: PWideChar;
uType: UINT; wLanguageId: WORD; dwMilliseconds: DWORD): Integer; stdcall;
external user32 name 'MessageBoxTimeoutW';
function MessageBoxTimeOut(hWnd: HWND; lpText: PChar; lpCaption: PChar;
uType: UINT; wLanguageId: WORD; dwMilliseconds: DWORD): Integer; stdcall;
external user32 name 'MessageBoxTimeoutW';
procedure TForm1.Button1Click(Sender: TObject);
begin
PostMessage(Handle, WM_USER, 0, 0);
MessageBoxTimeOut(Handle, 'MessageBox без кнопки',
'Тест', MB_ICONINFORMATION, 0, 3000);
end;
// При желании можно уменьшить
// высоту диалога
{.$DEFINE CHANGE_MESSAGE_HEIGHT}
procedure TForm1.WMUser(var Message: TMessage);
var
hDlgHandle: THandle;
{$IFDEF CHANGE_MESSAGE_HEIGHT}
r: TRect;
{$ENDIF}
begin
hDlgHandle := GetForegroundWindow;
ShowWindow(FindWindowEx(hDlgHandle, 0, 'BUTTON', nil), SW_HIDE);
{$IFDEF CHANGE_MESSAGE_HEIGHT}
GetWindowRect(hDlgHandle, r);
with r do
SetWindowPos(hDlgHandle, 0, Left, Top,
Right - Left, Bottom - Top - 48, SWP_NOSENDCHANGING);
{$ENDIF}
end;
|
Как спозиционировать диалог относительно вызвавшего его компонента?
procedure TForm1.ColorDialog1Show(Sender: TObject);
var
dx, dy: Integer;
ParentRect, SelfRect: TRect;
begin
if Sender is TColorDialog then
begin
// Получение координат вызывающего объекта
GetWindowRect(TColorDialog(Sender).Tag, ParentRect);
// Получение координат окна диалога
GetWindowRect(TColorDialog(Sender).Handle, SelfRect);
// Вычисление смещения
dx := ParentRect.Left - SelfRect.Left;
dy := ParentRect.Bottom - SelfRect.Top;
// Корректировка позиции
Inc(SelfRect.Left, dx);
Inc(SelfRect.Right, dx);
Inc(SelfRect.Top, dy);
Inc(SelfRect.Bottom, dy);
// Выравнивание
if SelfRect.Left < 0 then
SelfRect.Left := 0;
if SelfRect.Right > Screen.WorkAreaWidth then
SelfRect.Left := Screen.WorkAreaWidth - (SelfRect.Right - SelfRect.Left);
if SelfRect.Top < 0 then
SelfRect.Top := 0;
if SelfRect.Bottom > Screen.WorkAreaHeight then
SelfRect.Top := ParentRect.Top - (SelfRect.Bottom - SelfRect.Top);
// Позиционирование диалога
SetWindowPos(TColorDialog(Sender).Handle, Handle, SelfRect.Left, SelfRect.Top, 0, 0, SWP_NOSIZE);
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
ColorDialog1.Tag := (Sender as TButton).Handle;
ColorDialog1.Execute;
end;
// Или немного по другому
type
TColorDialog = class(Vcl.Dialogs.TColorDialog)
protected
procedure DoShow; override;
end;
{...}
implementation
{ TColorDialog }
procedure TColorDialog.DoShow;
var
dx, dy: Integer;
ParentRect, SelfRect: TRect;
begin
inherited;
// Получение координат вызывающего объекта
GetWindowRect(Tag, ParentRect);
// Получение координат окна диалога
GetWindowRect(Handle, SelfRect);
// Вычисление смещения
dx := ParentRect.Left - SelfRect.Left;
dy := ParentRect.Bottom - SelfRect.Top;
// Корректировка позиции
Inc(SelfRect.Left, dx);
Inc(SelfRect.Right, dx);
Inc(SelfRect.Top, dy);
Inc(SelfRect.Bottom, dy);
// Выравнивание
if SelfRect.Left < 0 then
SelfRect.Left := 0;
if SelfRect.Right > Screen.WorkAreaWidth then
SelfRect.Left := Screen.WorkAreaWidth - (SelfRect.Right - SelfRect.Left);
if SelfRect.Top < 0 then
SelfRect.Top := 0;
if SelfRect.Bottom > Screen.WorkAreaHeight then
SelfRect.Top := Screen.WorkAreaHeight - (SelfRect.Bottom - SelfRect.Top);
// Позиционирование диалога
SetWindowPos(Handle, 0, SelfRect.Left, SelfRect.Top, 0, 0, SWP_NOSIZE or SWP_NOZORDER);
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
ColorDialog1.Tag := (Sender as TButton).Handle;
ColorDialog1.Execute;
end;
|
|
При использовании материала - ссылка на сайт обязательна
|
|
