Советы по Delphi


XWindows - FAQ


Артем Федюк прислал свой сборник любимых функций:

    (*
Функции собрал Артем Федюк (Киев, 27.11.2000) E-Mail: xartrain@hotmail.com сообщите, пожалуйста о найденных ошибках *)
{H+}//use huge strings
unit XWindows;

INTERFACE
uses

classes,windows,shellApi,shlobj,sysUtils, forms,mmsystem,controls,Messages,Registry,IniFiles;
{***************************ПРОЦЕССЫ И УПРАВЛЕНИЕ ИМИ**************************}
procedure execWait(const comLine:string);
procedure shellExec(const fileName:string);
//также можно использовать Sleep(ms:DWORD);
procedure Delay(msecs : DWORD);
//фактически определяется запущена ли сейчас среда Delphi
function isDelphiRunning:boolean;
function RegisterServiceProcess(dwProcessID, dwType: Integer): Integer;
stdcall; external 'KERNEL32.DLL'; procedure applicationInCtrlAltDelList(visi:boolean);
procedure applicationInTaskBar(visi:boolean);
//Запретить/разрешить Ctrl-Alt-Del
procedure CtrlAltDel(state:boolean);
//Окно без закладки в TaskBar
procedure noAppInTaskbar;
//Определение какие приложения уже запущены
procedure ApplicationList(formHandle:THandle; var stringList:TStringList);

{***************************ВРЕМЯ**********************************************}
function SetTime(DateTime:TDateTime):Boolean;
//обновить часы - SendMessage(HWND_TOPMOST,WM_TIMECHANGE,0,0);

{***************************ИНТЕРФЕЙС WINDOWS**********************************}
//Cache,Cookies,Desktop,Favorites,Fonts,Personal,Programs,SendTo,Start Menu,Startup
function ShellFolder(const folderType:string):string;
procedure refreshWindowsDesktop;
procedure Startbutton(visi:boolean);
//убрать/показать TaskBar
procedure TaskBar(visi:boolean);
//оч2истить меню "Документы"
procedure clearDocuments;
//добавить документ в меню 'Документы'
// Для данного файла должно быть зарегистрировано средство просмотра
procedure addFileToDocuments(const fileName:string);
//Значение функции TRUE если мелкий шрифт
function SmallFonts:Boolean;
{! проверить}procedure setWallPaper(const fileName:string; tile:boolean);

{***************************МОНИТОР********************************************}
procedure RunCurrentScreenSaver;
//use application:TApplication object
procedure monitorState(state:boolean);

{***************************КЛАВИАТУРА*****************************************}
procedure RussianKbdLayout;
procedure EnglishKbdLayout;
procedure UkrainianKbdLayout;

{***************************МЫШЬ***********************************************}
//относительные координаты в абсолютные - function ClientToScreen(Pt:TPoint):TPoint;
procedure mouseEmul(absPoint:TPoint; up,down:boolean);
procedure mouseCursor(visi:boolean);
//просимулировать нажатие клавиши мыши
{! Не проверено}procedure SendMouseClick(x,y:integer;wHandle:THandle);

{**8*************************ДИСКОВЫЕ ФУНКЦИИ**********************************}
//8FAT,FAT32,CDFS,NWCOMPA
//0-"A",1-"B",2-"C"
function GetFileSysName(Drive : Byte) : String;
function GetVolumeName(Drive : Byte) : String;
function DriveExists(Drive : Byte) : Boolean;
//'?';'Path2 does not exists';'Removable';'Fixed';'Remote';'CD-ROM';'RAMDISK'
function CheckDriveType(Drive : Byte) : String;
//Определение готовности дисковода к работе
function DiskInDrive(const Drive: char): Boolean;
function HDDSerialNum(const drivePath:string{'C:\'}):integer;

{***************************CD-ROM*********************************************}
function getCdromPath:string;
procedure CDROMOpen;
procedure CDROMClose;

{***************************REGISTRY*******************************************}
procedure StartFromRegistry(appName,appPath:string);
//запускается до WindowsLogon
procedure StartServiceFromRegistry(appName,appPath:string);
procedure StartFromWinIni(appPath:string);
function IsInstalled (FileExe: String): Boolean;

IMPLEMENTATION
(*
Вопрос:
Можно ли как-то уменьшить мерцание при перерисовке компонента?

Ответ:
Если добавить флаг csOpaque (непрозрачный) к свойству ControlStyle
компонента - то фон компонента перерисовываться не будет.

Пример:

constructor TMyControl.Create;
begin
inherited; //проверка "if not inIDE" должна быть вставлена в том случае,когда TMyControl - компонент //чтобы среда IDE Delphi не глючила на этапе разработки if not inIDE then ControlStyle := ControlStyle + [csOpaque]; end;
...
procedure Register;
begin
RegisterComponents('MyGraphics', [TMyControl]); inIDE:=True; end;

*)


procedure mouseCursor(visi:boolean);
Var CState:Integer; Begin
CState:= ShowCursor(True); if visi then begin //Включение курсора while CState<0 do CState:=ShowCursor(True); end else begin //Выключение курсора while Cstate >= 0 do Cstate := ShowCursor(False); end; End;


//Cache,Cookies,Desktop,Favorites,Fonts,Personal,Programs,SendTo,Start Menu,Startup
function ShellFolder(const folderType:string):string;
var registry:TRegistry; begin
result:=''; Registry := TRegistry.Create; try Registry.RootKey := HKey_Current_User; Registry.OpenKey('Software\Microsoft\Windows\CurrentVersion\Explorer\Shell Folders', False); result:= Registry.ReadString(folderType); finally Registry.Free; end; end;

procedure SetWallpaper(const fileName:string;tile:boolean);
var Reg: TRegIniFile; begin
Reg:=TRegIniFile.Create('Control Panel'); Reg.WriteString('desktop', 'Wallpaper', fileName); if tile then Reg.WriteString('desktop', 'TileWallpaper', '1') else Reg.WriteString('desktop', 'TileWallpaper', '0'); Reg.Free; SystemParametersInfo(SPI_SETDESKWALLPAPER, 0, nil,SPIF_SENDWININICHANGE); end;

{procedure setWallPaper(fileName:string);
begin
SystemParametersInfo(SPI_SETDESKWALLPAPER,0,pChar(fileNAme),0); end;}

procedure refreshWindowsDesktop;
begin
SendMessage(FindWindow('Progman', 'Program Manager'), WM_COMMAND, $A065, 0); end;

procedure mouseEmul(absPoint:TPoint; up,down:boolean);
begin
//Положение курсора мыши задается в "абсолютных" координатах ("Mickeys"), //где 65535 "Mickeys" равно ширине экрана. absPoint.x := Round(absPoint.x * (65535 / Screen.Width)); absPoint.y := Round(absPoint.y * (65535 / Screen.Height)); {Переместим курсор мыши} Mouse_Event(MOUSEEVENTF_ABSOLUTE or MOUSEEVENTF_MOVE, absPoint.x, absPoint.y, 0, 0); if down then Mouse_Event(MOUSEEVENTF_ABSOLUTE or MOUSEEVENTF_LEFTDOWN, absPoint.x, absPoint.y, 0, 0); if up then Mouse_Event(MOUSEEVENTF_ABSOLUTE or MOUSEEVENTF_LEFTUP, absPoint.x, absPoint.y, 0, 0); end;

//просимулировать нажатие клавиши мыши
procedure SendMouseClick(x,y:integer;wHandle:THandle);
begin
sendmessage(wHandle,WM_LBUTTONDOWN,MK_LBUTTON,x+(y shl 16)); sendmessage(wHandle,WM_LBUTTONUP,MK_LBUTTON,x+(y shl 16)); application.processMessages; end;

procedure monitorState(state:boolean);
begin
if
state then
SendMessage(Application.Handle, wm_SysCommand, SC_MonitorPower, -1) else
SendMessage(Application.Handle, wm_SysCommand, SC_MonitorPower, 0); end;

procedure execWait(const comLine:string);
var
si:Tstartupinfo; p:Tprocessinformation; begin
fillChar( Si, SizeOf( Si ) , 0 ); with Si do  begin cb := SizeOf( Si); dwFlags := startf_UseShowWindow; wShowWindow := 4; end; Createprocess(nil,pChar(comLine),nil,nil,false,Create_default_error_mode,nil,nil,si,p); Waitforsingleobject(p.hProcess,infinite); end;

procedure shellExec(const fileName:string);
begin
shellExecute(0,Nil,pChar(fileName),Nil,Nil,SW_NORMAL); end;

procedure Delay(msecs : DWORD);
var
FirstTick : DWORD; begin
FirstTick:=GetTickCount; repeat Application.ProcessMessages; until GetTickCount-FirstTick >= msecs; end;

function HDDSerialNum(const drivePath:string{'C:\'}):integer;
var SerialNum:Pdword; a,b:Dword; buffer:array [0..255] of char; begin
result:=0; new(SerialNum); if getVolumeInformation(pChar(drivePath),buffer,sizeof(buffer),SerialNum,a,b,nil,0) then result:=SerialNum^; Dispose(SerialNum); end;

//фактически определяется запущена ли сейчас среда Delphi
function isDelphiRunning:boolean;
var H1, H2, H3, H4 : Hwnd; const A1 : array[0..12] of char = 'TApplication'#0; A2 : array[0..15] of char = 'TAlignPalette'#0; A3 : array[0..18] of char = 'TPropertyInspector'#0; A4 : array[0..11] of char = 'TAppBuilder'#0; begin
result:=false; H1 := FindWindow(A1, nil); H2 := FindWindow(A2, nil); H3 := FindWindow(A3, nil); H4 := FindWindow(A4, nil); if (H1 <> 0) and (H2 <> 0) and (H3 <> 0) and (H4 <> 0) then result:=true; end;

function getCdromPath:string;
var w:dword; Root:string; i:integer; begin
result:=''; w:=GetLogicalDrives; Root := '#:\'; for i := 0 to 25 do begin Root[1] := Char(Ord('A')+i); if (W and (1 shl i))>0 then if GetDriveType(Pchar(Root))=DRIVE_CDROM then begin result:=Root; exit; end; end; end;

//Определение готовности дисковода к работе
function DiskInDrive(const Drive: char): Boolean;
var DrvNum: byte; EMode: Word; begin
result := false; DrvNum := ord(Drive); if DrvNum >= ord('a') then dec(DrvNum,$20); EMode := SetErrorMode(SEM_FAILCRITICALERRORS); try if DiskSize(DrvNum-$40) <> -1 then result := true else messagebeep(0); finally SetErrorMode(EMode); end; end;

function soundCardExists:boolean;
begin
if
WaveOutGetNumDevs>0 then result:=true else result:=false; end;

function SetTime(DateTime:TDateTime):Boolean;
var st:TSystemTime; ZoneTime: TTimeZoneInformation; begin
GetTimeZoneInformation(ZoneTime); DateTime:=DateTime+ZoneTime.Bias/1440; with st do begin DecodeDate(DateTime,wYear,wMonth,wDay); DecodeTime(DateTime,wHour,wMinute,wSecond,wMilliseconds); end; result:=SetSystemTime(st); SendMessage(HWND_TOPMOST,WM_TIMECHANGE,0,0); end;

//Окно без закладки в TaskBar
procedure noAppInTaskbar;
begin
ShowWindow(Application.Handle,sw_Hide); end;

//Определение какие приложения уже запущены
procedure ApplicationList(formHandle:THandle; var stringList:TStringList);
var Wnd : hWnd; buff: ARRAY [0..127] OF Char; begin
stringList.Clear; Wnd := GetWindow(formHandle, gw_HWndFirst); WHILE Wnd <> 0 DO BEGIN {Не показываем:} IF (Wnd <> Application.Handle) AND {-Собственное окно} IsWindowVisible(Wnd) AND {-Невидимые окна} (GetWindow(Wnd, gw_Owner) = 0) AND {-Дочернии окна} (GetWindowText(Wnd, buff, sizeof(buff)) <> 0) {-Окна без заголовков} THEN BEGIN GetWindowText(Wnd, buff, sizeof(buff)); stringList.Add(StrPas(buff)); END; Wnd := GetWindow(Wnd, gw_hWndNext); END; end;

procedure CDROMOpen;
begin
mciSendString('Set cdaudio door open wait', nil, 0, 0); end;

procedure CDROMClose;
begin
mciSendString('Set cdaudio door closed wait', nil, 0, 0); end;

//Запретить/разрешить Ctrl-Alt-Del
procedure CtrlAltDel(state:boolean);
var old:Boolean; begin
old:=True;
if state then //Восстановить SystemParametersInfo(SPI_SCREENSAVERRUNNING,0,@old,0) else
//Убрать SystemParametersInfo(SPI_SCREENSAVERRUNNING,1,@old,0); end;


procedure StartButton(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 If Visi then ShowWindow(Child, 1) else ShowWindow(Child, 0); end; End; Child := GetWindow(Child, GW_HWNDNEXT); End; End;

//убрать/показать TaskBar
procedure TaskBar(visi:boolean);
begin
if
visi then ShowWindow(FindWindow('Shell_TrayWnd', nil), SW_SHOW) // Показать Taskbar else ShowWindow(FindWindow('Shell_TrayWnd', nil), SW_HIDE); //Скрыть TaskBar end;

procedure applicationInCtrlAltDelList(visi:boolean);
begin
if
visi then begin //Show RegisterServiceProcess(GetCurrentProcessID, 0); end else begin //Hide RegisterServiceProcess(GetCurrentProcessID, 1); end; end;

procedure applicationInTaskBar(visi:boolean);
begin
if
visi then windows.ShowWindow(FindWindow(nil, @Application.Title[1]), SW_SHOW) else windows.ShowWindow(FindWindow(nil, @Application.Title[1]), SW_HIDE); end;

procedure RussianKbdLayout;//На русский
var Layout: array[0.. KL_NAMELENGTH] of char; begin
LoadKeyboardLayout( StrCopy(Layout,'00000419'),KLF_ACTIVATE); end;

procedure EnglishKbdLayout;//На английский
var Layout: array[0.. KL_NAMELENGTH] of char; begin
LoadKeyboardLayout(StrCopy(Layout,'00000409'),KLF_ACTIVATE); end;

procedure UkrainianKbdLayout;//На украинский
var Layout: array[0.. KL_NAMELENGTH] of char; begin
LoadKeyboardLayout(StrCopy(Layout, pChar(intToHex(LANG_UKRAINIAN+$400,8))), KLF_ACTIVATE); end;

//запустить текущий ScreenSaver
procedure RunCurrentScreenSaver;
begin
SendMessage(Application.Handle,WM_SYSCOMMAND,SC_SCREENSAVE,0); end;

//очистить меню "Документы"
procedure clearDocuments;
begin
SHAddToRecentDocs(SHARD_PATH,nil); end;

//добавить документ в меню 'Документы'
// Для данного файла должно быть зарегистрировано средство просмотра
procedure addFileToDocuments(const fileName:string);
begin
SHAddToRecentDocs(SHARD_PATH,pchar(fileName)); end;

//Значение функции TRUE если мелкий шрифт
function SmallFonts:Boolean;
var DC:HDC; begin
DC:=GetDC(0); Result:=(GetDeviceCaps(DC, LOGPIXELSX) = 96); { В случае крупного шрифта будет 120} ReleaseDC(0, DC); end;

function DriveExists(Drive : Byte) : Boolean;
begin
Result := Boolean(GetLogicalDrives AND(1 SHL Drive)) end;

//'?';'Path does not exists';'Removable';'Fixed';'Remote';'CD-ROM';'RAMDISK'
function CheckDriveType(Drive : Byte) : String;
var DriveLetter : Char; DriveType   : UInt; begin
DriveLetter := Char(Drive + $41); DriveType   := GetDriveType(PChar(DriveLetter + ':\')); Case DriveType of 0               : Result := '?'; 1                : Result := 'Path does not exists'; DRIVE_REMOVABLE : Result := 'Removable'; DRIVE_FIXED     : Result := 'Fixed'; DRIVE_REMOTE    : Result := 'Remote'; DRIVE_CDROM     : Result := 'CD-ROM'; DRIVE_RAMDISK   : Result := 'RAMDISK' Else  Result := 'Unknown'; end; end;

//GetVolumeInformation
function GetFileSysName(Drive : Byte) : String;
var DriveLetter  : Char; NoMatter     : DWORD; FileSysName  : Array[0..MAX_PATH] of Char; begin
DriveLetter  := Char(Drive + $41); GetVolumeInformation(PChar(DriveLetter + ':\'), Nil, 0, nil, NoMatter, NoMatter, FileSysName, SizeOf(FileSysName)); Result := FileSysName; end;


function GetVolumeName(Drive : Byte) : String;
var DriveLetter  : Char; NoMatter     : DWORD; VolumeName   : Array[0..MAX_PATH] of Char; begin
DriveLetter  := Char(Drive + $41); GetVolumeInformation(PChar(DriveLetter + ':\'), VolumeName, SizeOf(VolumeName), nil, NoMatter, NoMatter, Nil, 0); Result := VolumeName; end;

procedure StartFromRegistry(appName,appPath:string);
var
reg: TRegistry; begin
reg := TRegistry.Create; reg.RootKey := HKEY_LOCAL_MACHINE; reg.LazyWrite := false; reg.OpenKey('Software\Microsoft\Windows\CurrentVersion\Run', true{canCreate}); reg.WriteString(appname,appPath); reg.CloseKey; reg.free; end;

procedure StartServiceFromRegistry(appName,appPath:string);
var
reg: TRegistry; begin
reg := TRegistry.Create; reg.RootKey := HKEY_LOCAL_MACHINE; reg.LazyWrite := false; reg.OpenKey('Software\Microsoft\Windows\CurrentVersion\RunServices', true{canCreate}); reg.WriteString(appname,appPath); reg.CloseKey; reg.free; end;

procedure StartFromWinIni(appPath:string);
var
WinIni : TIniFile; WinIniFileName : array[0..MAX_PATH] of char; s : string; begin
GetWindowsDirectory(WinIniFileName, sizeof(WinIniFileName)); StrCat(WinIniFileName, '\win.ini'); WinIni := TIniFile.Create(WinIniFileName); s := WinIni.ReadString('windows', 'run', ''); if s = '' then s := appPath else s := s + ';' + appPath; WinIni.WriteString('windows', 'run', s); WinIni.Free; end;

function IsInstalled (FileExe: String): Boolean;
var
reg : TRegistry; temp: String; begin
result:=False; reg:= Tregistry.Create; try reg.RootKey:= HKEY_LOCAL_MACHINE; if reg.OpenKey ('\Software\Microsoft\Windows\CurrentVersion\App Paths\' +FileExe, false) then begin if reg.ValueExists('') then begin temp := reg.readString('Path'); result := FileExists(temp+'\'+FileExe); end; end; finally reg.Free; end; end;



END.

[001462]




Начало  Назад  Вперед