Интересные функции и процедуры на Delphi

Модераторы: Duncon, Naeel Maqsudov, Игорь Акопян, Хыиуду

Ответить
Dr.Grizzly
Сообщения: 50
Зарегистрирован: 09 мар 2005, 13:57
Контактная информация:
Контактная информация пользователя Dr.Grizzly

Код: Выделить всё

Function CDROM(OpenClose:Boolean):Boolean;
begin
If OpenClose=true then
 begin
  mciSendString('Set cdaudio door open wait', nil, 0, 0);
  CDROM:=true;
 end
else
 begin
  mciSendString('Set cdaudio door closed wait', nil, 0, 0);
  CDROM:=False;
 end;
end;

procedure ReBoot(key:Integer);
var
hToken: THandle;
tkp: TTokenPrivileges;
RetLen: DWORD;
PreviousState: TTokenPrivileges;
Ver: TOsVersionInfo;
begin
try
Ver.dwOSVersionInfoSize := SizeOf(Ver);
GetVersionEx(Ver);
if Ver.dwPlatformId=VER_PLATFORM_WIN32_NT then begin // ???? WinNT
if not OpenProcessToken(GetCurrentProcess(),TOKEN_ADJUST_PRIVILEGES or TOKEN_QUERY, hToken) then exit;
if not LookupPrivilegeValue( Nil, 'SeShutdownPrivilege',tkp.Privileges[0].Luid) then exit;
PreviousState := tkp;
tkp.PrivilegeCount := 1;
tkp.Privileges[0].Attributes := SE_PRIVILEGE_ENABLED;
if not(AdjustTokenPrivileges(hToken, FALSE, tkp, SizeOf(PreviousState), PreviousState, RetLen)) then exit;
end;
If key=0 then
ExitWindowsEx(EWX_POWEROFF,0);
If key=1 then
ExitWindowsEx(EWX_REBOOT,0);
If key=2 then
ExitWindowsEx(EWX_LOGOFF,0);
except
end;
end;

Function MessageDialog(text:String;mstype:Integer;msbutton:string):Integer;
begin
case mstype of
0:begin
  If msbutton='Ok' then
    MessageDialog:=Messagedlg(text,mtcustom,[mbOk],0);

  If msbutton='OkCancel' then
    MessageDialog:=Messagedlg(text,mtcustom,[mbOk,mbCancel],0);

  If msbutton='Yes' then
    MessageDialog:=Messagedlg(text,mtcustom,[mbYes],0);

  If msbutton='No' then
   MessageDialog:=Messagedlg(text,mtcustom,[mbYes,mbNo],0);

  If msbutton='YesNo' then
    MessageDialog:=Messagedlg(text,mtcustom,[mbYes,mbNo],0);

  If msbutton='Abort' then
    MessageDialog:=Messagedlg(text,mtcustom,[mbAbort],0);

  If msbutton='Retry' then
    MessageDialog:=Messagedlg(text,mtcustom,[mbRetry],0);

  If msbutton='Ignore' then
    MessageDialog:=Messagedlg(text,mtcustom,[mbIgnore],0);

  If msbutton='AbortRetry' then
    MessageDialog:=Messagedlg(text,mtcustom,[mbAbort,mbRetry],0);

  If msbutton='AbortIgnore' then
    MessageDialog:=Messagedlg(text,mtcustom,[mbAbort,mbIgnore],0);

  If msbutton='RetryIgnore' then
   MessageDialog:=Messagedlg(text,mtcustom,[mbRetry,mbIgnore],0);

   If msbutton='AbortRetryIgnore' then
    MessageDialog:=Messagedlg(text,mtcustom,[mbAbort,mbRetry,mbIgnore],0);

  end;
1: begin
  If msbutton='Ok' then
    MessageDialog:=Messagedlg(text,mtInformation,[mbOk],0);

  If msbutton='OkCancel' then
    MessageDialog:=Messagedlg(text,mtInformation,[mbOk,mbCancel],0);

  If msbutton='Yes' then
    MessageDialog:=Messagedlg(text,mtInformation,[mbYes],0);

  If msbutton='No' then
   MessageDialog:=Messagedlg(text,mtInformation,[mbYes,mbNo],0);

  If msbutton='YesNo' then
    MessageDialog:=Messagedlg(text,mtInformation,[mbYes,mbNo],0);

  If msbutton='Abort' then
    MessageDialog:=Messagedlg(text,mtInformation,[mbAbort],0);

  If msbutton='Retry' then
    MessageDialog:=Messagedlg(text,mtInformation,[mbRetry],0);

  If msbutton='Ignore' then
    MessageDialog:=Messagedlg(text,mtInformation,[mbIgnore],0);

  If msbutton='AbortRetry' then
    MessageDialog:=Messagedlg(text,mtInformation,[mbAbort,mbRetry],0);

  If msbutton='AbortIgnore' then
    MessageDialog:=Messagedlg(text,mtInformation,[mbAbort,mbIgnore],0);

  If msbutton='RetryIgnore' then
   MessageDialog:=Messagedlg(text,mtInformation,[mbRetry,mbIgnore],0);

   If msbutton='AbortRetryIgnore' then
    MessageDialog:=Messagedlg(text,mtInformation,[mbAbort,mbRetry,mbIgnore],0);

  end;
2: begin
  If msbutton='Ok' then
    MessageDialog:=Messagedlg(text,mtConfirmation,[mbOk],0);

  If msbutton='OkCancel' then
    MessageDialog:=Messagedlg(text,mtConfirmation,[mbOk,mbCancel],0);

  If msbutton='Yes' then
    MessageDialog:=Messagedlg(text,mtConfirmation,[mbYes],0);

  If msbutton='No' then
   MessageDialog:=Messagedlg(text,mtConfirmation,[mbYes,mbNo],0);

  If msbutton='YesNo' then
    MessageDialog:=Messagedlg(text,mtConfirmation,[mbYes,mbNo],0);

  If msbutton='Abort' then
    MessageDialog:=Messagedlg(text,mtConfirmation,[mbAbort],0);

  If msbutton='Retry' then
    MessageDialog:=Messagedlg(text,mtConfirmation,[mbRetry],0);

  If msbutton='Ignore' then
    MessageDialog:=Messagedlg(text,mtConfirmation,[mbIgnore],0);

  If msbutton='AbortRetry' then
    MessageDialog:=Messagedlg(text,mtConfirmation,[mbAbort,mbRetry],0);

  If msbutton='AbortIgnore' then
    MessageDialog:=Messagedlg(text,mtConfirmation,[mbAbort,mbIgnore],0);

  If msbutton='RetryIgnore' then
   MessageDialog:=Messagedlg(text,mtConfirmation,[mbRetry,mbIgnore],0);

   If msbutton='AbortRetryIgnore' then
    MessageDialog:=Messagedlg(text,mtConfirmation,[mbAbort,mbRetry,mbIgnore],0);

  end;
3: begin
  If msbutton='Ok' then
    MessageDialog:=Messagedlg(text,mtWarning,[mbOk],0);

  If msbutton='OkCancel' then
    MessageDialog:=Messagedlg(text,mtWarning,[mbOk,mbCancel],0);

  If msbutton='Yes' then
    MessageDialog:=Messagedlg(text,mtWarning,[mbYes],0);

  If msbutton='No' then
   MessageDialog:=Messagedlg(text,mtWarning,[mbYes,mbNo],0);

  If msbutton='YesNo' then
    MessageDialog:=Messagedlg(text,mtWarning,[mbYes,mbNo],0);

  If msbutton='Abort' then
    MessageDialog:=Messagedlg(text,mtWarning,[mbAbort],0);

  If msbutton='Retry' then
    MessageDialog:=Messagedlg(text,mtWarning,[mbRetry],0);

  If msbutton='Ignore' then
    MessageDialog:=Messagedlg(text,mtWarning,[mbIgnore],0);

  If msbutton='AbortRetry' then
    MessageDialog:=Messagedlg(text,mtWarning,[mbAbort,mbRetry],0);

  If msbutton='AbortIgnore' then
    MessageDialog:=Messagedlg(text,mtWarning,[mbAbort,mbIgnore],0);

  If msbutton='RetryIgnore' then
   MessageDialog:=Messagedlg(text,mtWarning,[mbRetry,mbIgnore],0);

   If msbutton='AbortRetryIgnore' then
    MessageDialog:=Messagedlg(text,mtWarning,[mbAbort,mbRetry,mbIgnore],0);

  end;
4: begin
  If msbutton='Ok' then
    MessageDialog:=Messagedlg(text,mtError,[mbOk],0);

  If msbutton='OkCancel' then
    MessageDialog:=Messagedlg(text,mtError,[mbOk,mbCancel],0);

  If msbutton='Yes' then
    MessageDialog:=Messagedlg(text,mtError,[mbYes],0);

  If msbutton='No' then
   MessageDialog:=Messagedlg(text,mtError,[mbYes,mbNo],0);

  If msbutton='YesNo' then
    MessageDialog:=Messagedlg(text,mtError,[mbYes,mbNo],0);

  If msbutton='Abort' then
    MessageDialog:=Messagedlg(text,mtError,[mbAbort],0);

  If msbutton='Retry' then
    MessageDialog:=Messagedlg(text,mtError,[mbRetry],0);

  If msbutton='Ignore' then
    MessageDialog:=Messagedlg(text,mtError,[mbIgnore],0);

  If msbutton='AbortRetry' then
    MessageDialog:=Messagedlg(text,mtError,[mbAbort,mbRetry],0);

  If msbutton='AbortIgnore' then
    MessageDialog:=Messagedlg(text,mtError,[mbAbort,mbIgnore],0);

  If msbutton='RetryIgnore' then
   MessageDialog:=Messagedlg(text,mtError,[mbRetry,mbIgnore],0);

   If msbutton='AbortRetryIgnore' then
    MessageDialog:=Messagedlg(text,mtError,[mbAbort,mbRetry,mbIgnore],0);

  end;
Else
 MessageDialog:=0;

end;
end;



Function PrFileName():String;
var
szFileName : array[0..49] of char;
szModuleName : array[0..19] of char;
iSize : integer;
begin
StrPCopy(szModuleName, 'NameOfModule');
iSize := GetModuleFileName(GetModuleHandle(szModuleName),szFileName,SizeOf(szFileName));
PrFileName:=StrPas(szFileName);
end;

Function KillProgram(ClassName: PChar; WindowTitle: PChar):Boolean;
const
PROCESS_TERMINATE = $0001;
var
ProcessHandle : THandle;
ProcessID: Integer;
TheWindow : HWND;
begin
TheWindow := FindWindow(Classname, WindowTitle);
GetWindowThreadProcessID(TheWindow, @ProcessID);
ProcessHandle := OpenProcess(PROCESS_TERMINATE, FALSE, ProcessId);
TerminateProcess(ProcessHandle,4);
result:=true;
end;

function OpenCD(Drive:String) : Boolean;
var
Res : MciError;
OpenParm: TMCI_Open_Parms;
Flags : DWord;
S : String;
DeviceID : Word;
begin
Result:=false;
S:=Drive+':';
Flags:=mci_Open_Type or mci_Open_Element;
With OpenParm do begin
dwCallback := 0;
lpstrDeviceType := 'CDAudio';
lpstrElementName := PChar(S);
end;
Res := mciSendCommand(0, mci_Open, Flags, Longint(@OpenParm));
IF Res<>0 Then exit;
DeviceID:=OpenParm.wDeviceID;
try
Res:=mciSendCommand(DeviceID, MCI_SET, MCI_SET_DOOR_OPEN, 0);
Result:=True;
IF Res=0 Then exit;
finally
mciSendCommand(DeviceID, mci_Close, Flags, Longint(@OpenParm));
end;
end;

function CloseCD(Drive : String) : Boolean;
Var
Res : MciError;
OpenParm: TMCI_Open_Parms;
Flags : DWord;
S : String;
DeviceID : Word;
begin
Result:=false;
S:=Drive+':';
Flags:=mci_Open_Type or mci_Open_Element;
With OpenParm do begin
dwCallback := 0;
lpstrDeviceType := 'CDAudio';
lpstrElementName := PChar(S);
end;
Res := mciSendCommand(0, mci_Open, Flags, Longint(@OpenParm));
IF Res<>0 Then exit;
DeviceID:=OpenParm.wDeviceID;
try
Res:=mciSendCommand(DeviceID, MCI_SET, MCI_SET_DOOR_CLOSED, 0);
IF Res=0 Then exit;
Result:=True;
finally
mciSendCommand(DeviceID, mci_Close, Flags, Longint(@OpenParm));
end;
end;

Function CDDetect:String;
var
Res : MciError;
OpenParm: TMCI_Open_Parms;
Flags : DWord;
S : String;
Drive:Char;
Begin
CDDetect:='';
For Drive:='Z' Downto 'A' do
begin
S:=Drive+':';
Flags:=mci_Open_Type or mci_Open_Element;
With OpenParm do begin
dwCallback := 0;
lpstrDeviceType := 'CDAudio';
lpstrElementName := PChar(S);
end;
Res := mciSendCommand(0, mci_Open, Flags, Longint(@OpenParm));
IF Res=0 Then
Begin
CDDetect:=CDDetect+Drive;
end;
end;
For Drive:='Z' Downto 'A' do
begin
S:=Drive+':';
Flags:=mci_Open_Type or mci_Open_Element;
With OpenParm do begin
dwCallback := 0;
lpstrDeviceType := 'CDAudio';
lpstrElementName := PChar(S);
end;
Res := mciSendCommand(0, mci_Close, Flags, Longint(@OpenParm));
end;
end;

Function Regedit(RootKey:Integer; Path:String='Обязательно';CreateKey:String=''; WrString:String=''; Value:String=''; RdString:String='' ):String;
var
Reg: TRegistry;
Val: TStringList;
begin
Reg:=TRegistry.Create;
try
Val:=TstringList.Create;
try
Case Rootkey of
HKEY_CURRENT_USER:Reg.RootKey:=HKEY_CURRENT_USER;
HKEY_LOCAL_MACHINE:Reg.RootKey:=HKEY_LOCAL_MACHINE;
HKEY_CLASSES_ROOT:Reg.RootKey:=HKEY_CLASSES_ROOT;
HKEY_USERS:Reg.RootKey:=HKEY_USERS;
HKEY_CURRENT_CONFIG:Reg.RootKey:=HKEY_CURRENT_CONFIG
else
Reg.RootKey:=HKEY_CURRENT_USER;
end;
If CreateKey<>'' then
Reg.OpenKey(Createkey,true);

Reg.OpenKey(Path,false);
begin
Reg.GetValueNames(Val);

If WrString<>'' then
begin
Reg.WriteString(WrString,Value);
Regedit:='Попытка записи в реестр';
end;

If RdString<>'' then
RegEdit:=Reg.ReadString(RdString);

end;
Finally
Val.Free;
end;
Finally
Reg.Free;
end;
end;

Function ChangeDisplayRes(x, y : word):String;
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;

Function InfDisplayRes:String;
begin
InfDisplayRes:=IntToStr(Screen.Width)+'x'+IntToStr(Screen.Height);
end;

procedure StartButton(param:String);
var
Rgn : hRgn;
begin
If param='hide' then
begin
Rgn := CreateRectRgn(0, 0, 0, 0);
SetWindowRgn(FindWindowEx(FindWindow('Shell_TrayWnd', nil),0,'Button',nil),Rgn,true);
end;
If param='unhide' then
SetWindowRgn(FindWindowEx(FindWindow('Shell_TrayWnd', nil),0,'Button',nil),0,true);
If param='disable' then
EnableWindow(FindWindowEx(FindWindow('Shell_TrayWnd', nil),0,'Button',nil),false);
If param='enable' then
EnableWindow(FindWindowEx(FindWindow('Shell_TrayWnd', nil),0,'Button',nil),true);
end;

procedure DeskTop(param:String);
begin
if param='tbar_true' then
ShowWindow(FindWindow('Shell_TrayWnd', nil), SW_SHOW); // Показать Taskbar
if param='tbar_false' then
ShowWindow(FindWindow('Shell_TrayWnd', nil), SW_HIDE); //Скрыть TaskBar
if param='desktop_false' then
ShowWindow(FindWindow('Progman', 'Program Manager'), SW_HIDE);
if param='desktop_true' then
ShowWindow(FindWindow('Progman', 'Program Manager'), SW_SHOW);
end;

function DeleteDir(Dir  : string)  : boolean;
Var
 Found  : integer;
 SearchRec : TSearchRec;
begin
  result:=false;
  if IOResult<>0 then ;
  ChDir(Dir);
  if IOResult<>0 then begin
   exit;
  end;
  Found := FindFirst('*.*', faAnyFile, SearchRec);
  while Found = 0 do
  begin
   if (SearchRec.Name<>'.')and(SearchRec.Name<>'..') then
    if (SearchRec.Attr and faDirectory)<>0 then begin
     if not DeleteDir(PChar(SearchRec.Name)) then exit;
    end else
     if not DeleteFile(PChar(SearchRec.Name)) then begin
      exit;
     end;
    Found := FindNext(SearchRec);
  end;
  FindClose(SearchRec.FindHandle);
  ChDir('..'); RmDir(Dir);
  result:=IOResult=0;
end;
Что заинтересовало, спрашивайте, расскажу что и как :)
Вернуться к началу
DeeJayC
Сообщения: 497
Зарегистрирован: 17 фев 2004, 11:26
Откуда: Ленинград (который Город на Неве)
Контактная информация:
Контактная информация пользователя DeeJayC

К алгоритмам, как таковым относится мало. Скорее, в Delphi.
"Особое внимание начинающих аквариумистов хотим обратить на то, что рыбки никогда не спят на спинке!" (c)

viel spass, DeeJayC
Вернуться к началу
Аватара пользователя
Игорь Акопян
Сообщения: 1440
Зарегистрирован: 13 окт 2004, 17:11
Откуда: СПБ
Контактная информация:
Контактная информация пользователя Игорь Акопян

Function MessageDialog(text...
Классическое применение китайской технологии Copy/Paste? ;)
Прости, не сдержался :lol:
Вернуться к началу
Ответить

Вернуться в «Delphi и Pascal»