Артем Федюк прислал свой сборник любимых функций:
(* Функции собрал Артем Федюк (Киев, 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]