|
|
|||||||||||||||||||
|
WinAPI FAQ Программное выключение монитора.
Button1: TButton; Timer1: TTimer; procedure FormCreate(Sender: TObject); procedure Timer1Timer(Sender: TObject); procedure Button1Click(Sender: TObject); private { Private declarations } public MonitorOff : bool; { Public declarations } end; var Form1: TForm1; implementation {$R *.DFM} procedure TForm1.FormCreate(Sender: TObject); begin Timer1.Enabled := false; Timer1.Interval := 10000; MonitorOff := false; end; procedure TForm1.Timer1Timer(Sender: TObject); begin if MonitorOff then begin MonitorOff := false; SendMessage(Application.Handle, wm_SysCommand, SC_MonitorPower, -1); Timer1.Enabled := false; end; end; procedure TForm1.Button1Click(Sender: TObject); begin MonitorOff := true; Timer1.Enabled := true; SendMessage(Application.Handle, wm_SysCommand, SC_MonitorPower, 0); end; Вопрос : procedure TForm1.Timer1Timer(Sender: TObject); begin FlashWindow(Form1.Handle, Flash); FlashWindow(Application.Handle, Flash); Flash := not Flash; end; procedure TForm1.FormCreate(Sender: TObject); begin Flash := False; end; Вопрос : var p : TPoint; begin case Msg.Msg of WM_USER + 1: case Msg.lParam of WM_RBUTTONDOWN: begin SetForegroundWindow(Handle); GetCursorPos(p); PopupMenu1.Popup(p.x, p.y); PostMessage(Handle, WM_NULL, 0, 0); end; end; end; inherited; end; Вопрос : var lt : TSYSTEMTIME; st : TSYSTEMTIME; begin GetLocalTime(lt); GetSystemTime(st); Memo1.Lines.Add('LocalTime = ' + IntToStr(lt.wmonth) + '/' + IntToStr(lt.wDay) + '/' + IntToStr(lt.wYear) + ' ' + IntToStr(lt.wHour) + ':' + IntToStr(lt.wMinute) + ':' + IntToStr(lt.wSecond)); Memo1.Lines.Add('UTCTime = ' + IntToStr(st.wmonth) + '/' + IntToStr(st.wDay) + '/' + IntToStr(st.wYear) + ' ' + IntToStr(st.wHour) + ':' + IntToStr(st.wMinute) + ':' + IntToStr(st.wSecond)); end; Вопрос : begin PatBlt(Form1.Canvas.Handle, 0, 0, Form1.ClientWidth, Form1.ClientHeight, WHITENESS); end; Вопрос : begin InvalidateRect(Form1.Handle, nil, false); end; Вопрос : begin ShowMessage('Button 1 clicked'); end; procedure TForm1.Button2Click(Sender: TObject); var Pt : TPoint; begin {Позволим кнопке Button2 перерисоваться} Application.ProcessMessages; {Найдем координаты центра button 1} Pt.x := Button1.Left + (Button1.Width div 2); Pt.y := Button1.Top + (Button1.Height div 2); {Преобразуем Pt к координатам экрана} Pt := ClientToScreen(Pt); {Преобразуем Pt к "mickeys" (аболютным координатам курсора мышки} Pt.x := Round(Pt.x * (65535 / Screen.Width)); Pt.y := Round(Pt.y * (65535 / Screen.Height)); {Переместим курсор мыши} Mouse_Event(MOUSEEVENTF_ABSOLUTE or MOUSEEVENTF_MOVE, Pt.x, Pt.y, 0, 0); {Имитируем нажатие левой кнопки мыши} Mouse_Event(MOUSEEVENTF_ABSOLUTE or MOUSEEVENTF_LEFTDOWN, Pt.x, Pt.y, 0, 0);; {Имитируем отпускание левой кнопки мыши} Mouse_Event(MOUSEEVENTF_ABSOLUTE or MOUSEEVENTF_LEFTUP, Pt.x, Pt.y, 0, 0);; end; Вопрос : PostMessage(FindWindow(Nil, 'Заголовок окна'), WM_QUIT, 0, 0); Где "Заголовок окна" - заголовок окна, которому Вы посылаете сообщение. Вопрос : const SHFMT_DRV_B = 1; const SHFMT_ID_DEFAULT = $FFFF; const SHFMT_OPT_QUICKFORMAT = 0; const SHFMT_OPT_FULLFORMAT = 1; const SHFMT_OPT_SYSONLY = 2; const SHFMT_ERROR = -1; const SHFMT_CANCEL = -2; const SHFMT_NOFORMAT = -3; function SHFormatDrive(hWnd : HWND; Drive : Word; fmtID : Word; Options : Word) : Longint stdcall; external 'Shell32.dll' name 'SHFormatDrive'; procedure TForm1.Button1Click(Sender: TObject); var FmtRes : longint; begin try FmtRes:= ShFormatDrive(Handle, SHFMT_DRV_A, SHFMT_ID_DEFAULT, SHFMT_OPT_QUICKFORMAT); case FmtRes of SHFMT_ERROR : ShowMessage('Error formatting the drive'); SHFMT_CANCEL : ShowMessage('User canceled formatting the drive'); SHFMT_NOFORMAT : ShowMessage('No Format') else ShowMessage('Disk has been formatted'); end; except end; end; Вопрос : var Rgn : hRgn; begin {Cпрятать кнопку "Пуск"} Rgn := CreateRectRgn(0, 0, 0, 0); SetWindowRgn(FindWindowEx(FindWindow('Shell_TrayWnd', nil), 0, 'Button', nil), Rgn, true); end; procedure TForm1.Button2Click(Sender: TObject); begin {Показать кнопку "Пуск"} SetWindowRgn(FindWindowEx(FindWindow('Shell_TrayWnd', nil), 0, 'Button', nil), 0, true); end; procedure TForm1.Button3Click(Sender: TObject); begin {Запретить кнопку "Пуск"} EnableWindow(FindWindowEx(FindWindow('Shell_TrayWnd', nil), 0, 'Button', nil), false); end; procedure TForm1.Button4Click(Sender: TObject); begin {Разрешить кнопку "Пуск"} EnableWindow(FindWindowEx(FindWindow('Shell_TrayWnd', nil), 0, 'Button', nil), true); end Вопрос : Вопрос : Пример : procedure TForm1.Button1Click(Sender: TObject);var s : array[0..64] of char; begin WriteProfileString('PrinterPorts', 'DriverName', 'DRVFILE,FILE:,15,45'); WriteProfileString('Devices', 'DriverName', 'DRVFILE,FILE:'); StrCopy(S, 'PrinterPorts'); SendMessage(HWND_BROADCAST, WM_WININICHANGE, 0, LongInt(@S)); StrCopy(S, 'Devices'); SendMessage(HWND_BROADCAST, WM_WININICHANGE, 0, LongInt(@S)); end; Вопрос : procedure TForm1.Button1Click(Sender: TObject); var PhoneNumber : string; CommPort : string; NumberWritten : LongInt; begin PhoneNumber := 'ATDT 1-555-555-1212' + #13 + #10; CommPort := 'COM2'; {Open the comm port} hCommFile := CreateFile(PChar(CommPort), GENERIC_WRITE, 0, nil, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, 0); if hCommFile=INVALID_HANDLE_VALUE then begin ShowMessage('Unable to open '+ CommPort); exit; end; {Dial the phone} NumberWritten:=0; if WriteFile(hCommFile, PChar(PhoneNumber)^, Length(PhoneNumber), NumberWritten, nil) = false then begin ShowMessage('Unable to write to ' + CommPort); end; end; procedure TForm1.Button2Click(Sender: TObject); begin {Close the port} CloseHandle(hCommFile); end; Вопрос : const TAPIERR_CONNECTED = 0; const TAPIERR_DROPPED = -1; const TAPIERR_NOREQUESTRECIPIENT = -2; const TAPIERR_REQUESTQUEUEFULL = -3; const TAPIERR_INVALDESTADDRESS = -4; const TAPIERR_INVALWINDOWHANDLE = -5; const TAPIERR_INVALDEVICECLASS = -6; const TAPIERR_INVALDEVICEID = -7; const TAPIERR_DEVICECLASSUNAVAIL = -8; const TAPIERR_DEVICEIDUNAVAIL = -9; const TAPIERR_DEVICEINUSE = -10; const TAPIERR_DESTBUSY = -11; const TAPIERR_DESTNOANSWER = -12; const TAPIERR_DESTUNAVAIL = -13; const TAPIERR_UNKNOWNWINHANDLE = -14; const TAPIERR_UNKNOWNREQUESTID = -15; const TAPIERR_REQUESTFAILED = -16; const TAPIERR_REQUESTCANCELLED = -17; const TAPIERR_INVALPOINTER = -18; {tapi size constants} const TAPIMAXDESTADDRESSSIZE = 80; const TAPIMAXAPPNAMESIZE = 40; const TAPIMAXCALLEDPARTYSIZE = 40; const TAPIMAXCOMMENTSIZE = 80; const TAPIMAXDEVICECLASSSIZE = 40; const TAPIMAXDEVICEIDSIZE = 40; function tapiRequestMakeCallA(DestAddress : PAnsiChar; AppName : PAnsiChar; CalledParty : PAnsiChar; Comment : PAnsiChar) : LongInt; stdcall; external 'TAPI32.DLL'; function tapiRequestMakeCallW(DestAddress : PWideChar; AppName : PWideChar; CalledParty : PWideChar; Comment : PWideChar) : LongInt; stdcall; external 'TAPI32.DLL'; function tapiRequestMakeCall(DestAddress : PChar; AppName : PChar; CalledParty : PChar; Comment : PChar) : LongInt; stdcall; external 'TAPI32.DLL'; procedure TForm1.Button1Click(Sender: TObject); var DestAddress : string; CalledParty : string; Comment : string; begin DestAddress := '1-555-555-1212'; CalledParty := 'Frank Borland'; Comment := 'Calling Frank'; tapiRequestMakeCall(pChar(DestAddress), PChar(Application.Title), pChar(CalledParty), PChar(Comment)); end; end. Вопрос : procedure TForm1.Button1Click(Sender: TObject); var Icon : hIcon; IconIndex : word; begin IconIndex := 1; Icon := ExtractAssociatedIcon(HInstance, Application.ExeName, IconIndex); DrawIcon(Canvas.Handle, 10, 10, Icon); end; Вопрос : uses Windows, Forms, Unit1 in 'Unit1.pas' {Form1}; {$R *.RES} begin if GetKeyState(vk_F8) < 1 then MessageBox(0, 'F8 was pressed during startup', 'MyApp', mb_ok); Application.Initialize; Application.CreateForm(TForm1, Form1); Application.Run; end. Вопрос : {$IFNDEF WIN32} var TheTime : LongInt; {$ENDIF} begin {$IFDEF WIN32} Sleep(ms); {$ELSE} TheTime := GetTickCount + ms; while GetTickCount < TheTime do Application.ProcessMessages; {$ENDIF} end; procedure TForm1.Button1Click(Sender: TObject); begin MessageBeep(word(-1)); Delay(200); MessageBeep(word(-1)); Delay(200); MessageBeep(word(-1)); end; Вопрос : var hwndHandle : THANDLE; hMenuHandle : HMENU; begin hwndHandle := FindWindow(nil, 'Untitled - Notepad'); if (hwndHandle <> 0) then begin hMenuHandle := GetSystemMenu(hwndHandle, FALSE); if (hMenuHandle <> 0) then DeleteMenu(hMenuHandle, SC_CLOSE, MF_BYCOMMAND); end; end; Вопрос : procedure TForm1.Button1Click(Sender: TObject); var reg : TRegistry; ts : TStrings; i : integer; begin reg := TRegistry.Create; reg.RootKey := HKEY_CURRENT_USER; reg.LazyWrite := false; reg.OpenKey( 'Software\Microsoft\Windows\CurrentVersion\Explorer\Shell Folders', false); ts := TStringList.Create; reg.GetValueNames(ts); for i := 0 to ts.Count -1 do begin Memo1.Lines.Add(ts.Strings[i] + ' = ' + reg.ReadString(ts.Strings[i])); end; ts.Free; reg.CloseKey; reg.free; end; Вопрос : procedure ShowDllPath stdcall; var TheFileName : array[0..MAX_PATH] of char; begin FillChar(TheFileName, sizeof(TheFileName), #0); GetModuleFileName(hInstance, TheFileName, sizeof(TheFileName)); MessageBox(0, TheFileName, 'The DLL file name is:', mb_ok); end; Вопрос : 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; Вопрос : Установите FormStyle формы в fsMDIForm Разместите Image на форме и загрузите в него картинку. Найдите { Private Declarations } в обьявлении формы и добаьте следующие строки: FClientInstance : TFarProc; FPrevClientProc : TFarProc; procedure ClientWndProc(var Message: TMessage); Добаьте следующие строки в разделе implementation: procedure TMainForm.ClientWndProc(var Message: TMessage); var Dc : hDC; Row : Integer; Col : Integer; begin with Message do case Msg of WM_ERASEBKGND: begin Dc := TWMEraseBkGnd(Message).Dc; for Row := 0 to ClientHeight div Image1.Picture.Height do for Col := 0 to ClientWidth div Image1.Picture.Width do BitBlt(Dc, Col * Image1.Picture.Width, Row * Image1.Picture.Height, Image1.Picture.Width, Image1.Picture.Height, Image1.Picture.Bitmap.Canvas.Handle, 0, 0, SRCCOPY); Result := 1; end; else Result := CallWindowProc(FPrevClientProc, ClientHandle, Msg, wParam, lParam); end; end; В методе формы OnCreate добавьте: FClientInstance := MakeObjectInstance(ClientWndProc); FPrevClientProc := Pointer(GetWindowLong(ClientHandle, GWL_WNDPROC)); SetWindowLong(ClientHandle, GWL_WNDPROC, LongInt(FClientInstance)); Добавьте к проекту новую форму и установите ее свойство FormStyle в fsMDIChild. У Вас получился MDI-проект с "обоями" в клиентской области MDI формы. Вопрос : procedure FormCreate(Sender: TObject); procedure FormDestroy(Sender: TObject); private { Private declarations } procedure WMHotKey(var Msg : TWMHotKey); message WM_HOTKEY; public { Public declarations } end; var Form1: TForm1; implementation {$R *.DFM} const id_SnapShot = 101; procedure TForm1.WMHotKey (var Msg : TWMHotKey); begin if Msg.HotKey = id_SnapShot then ShowMessage('GotIt'); end; procedure TForm1.FormCreate(Sender: TObject); begin RegisterHotKey(Form1.Handle, id_SnapShot, 0, VK_SNAPSHOT); end; procedure TForm1.FormDestroy(Sender: TObject); begin UnRegisterHotKey (Form1.Handle, id_SnapShot); end; Вопрос : Label1: TLabel; private { Private declarations } procedure WM_SpoolerStatus(var Msg : TWMSPOOLERSTATUS); message WM_SPOOLERSTATUS; public { Public declarations } end; var Form1: TForm1; implementation {$R *.DFM} procedure TForm1.WM_SpoolerStatus(var Msg : TWMSPOOLERSTATUS); begin Lable1.Caption := IntToStr(msg.JobsLeft) + ' Jobs currenly in spooler'; msg.Result := 0; end; Вопрос : procedure TForm1.Button1Click(Sender: TObject); var reg : TRegistry; ts : TStrings; i : integer; begin reg := TRegistry.Create; reg.RootKey := HKEY_LOCAL_MACHINE; reg.OpenKey('hardware\devicemap\serialcomm', false); ts := TStringList.Create; reg.GetValueNames(ts); for i := 0 to ts.Count -1 do begin Memo1.Lines.Add(reg.ReadString(ts.Strings[i])); end; ts.Free; reg.CloseKey; reg.free; end; Вопрос : type PhIconArray = ^ThIconArray; function ExtractIconExA(lpszFile: PAnsiChar; nIconIndex: Integer; phiconLarge : PhIconArray; phiconSmall: PhIconArray; nIcons: UINT): UINT; stdcall; external 'shell32.dll' name 'ExtractIconExA'; function ExtractIconExW(lpszFile: PWideChar; nIconIndex: Integer; phiconLarge: PhIconArray; phiconSmall: PhIconArray; nIcons: UINT): UINT; stdcall; external 'shell32.dll' name 'ExtractIconExW'; function ExtractIconEx(lpszFile: PAnsiChar; nIconIndex: Integer; phiconLarge : PhIconArray; phiconSmall: PhIconArray; nIcons: UINT): UINT; stdcall; external 'shell32.dll' name 'ExtractIconExA'; procedure TForm1.Button1Click(Sender: TObject); var NumIcons : integer; pTheLargeIcons : phIconArray; pTheSmallIcons : phIconArray; LargeIconWidth : integer; SmallIconWidth : integer; SmallIconHeight : integer; i : integer; TheIcon : TIcon; TheBitmap : TBitmap; begin NumIcons := ExtractIconEx('C:\Program Files\Borland\Delphi 3\BIN\delphi32.exe', -1, nil, nil, 0); if NumIcons > 0 then begin LargeIconWidth := GetSystemMetrics(SM_CXICON); SmallIconWidth := GetSystemMetrics(SM_CXSMICON); SmallIconHeight := GetSystemMetrics(SM_CYSMICON); GetMem(pTheLargeIcons, NumIcons * sizeof(hIcon)); GetMem(pTheSmallIcons, NumIcons * sizeof(hIcon)); FillChar(pTheLargeIcons^, NumIcons * sizeof(hIcon), #0); FillChar(pTheSmallIcons^, NumIcons * sizeof(hIcon), #0); ExtractIconEx('C:\Program Files\Borland\Delphi 3\BIN\delphi32.exe', 0, pTheLargeIcons, pTheSmallIcons, numIcons); {$IFOPT R+} {$DEFINE CKRANGE} {$R-} {$ENDIF} for i := 0 to (NumIcons - 1) do begin DrawIcon(Form1.Canvas.Handle, i * LargeIconWidth, 0, pTheLargeIcons^[i]); TheIcon := TIcon. Create; TheBitmap := TBitmap.Create; TheIcon.Handle := pTheSmallIcons^[i]; TheBitmap.Width := TheIcon.Width; TheBitmap.Height := TheIcon.Height; TheBitmap.Canvas.Draw(0, 0, TheIcon); TheIcon.Free; Form1.Canvas.StretchDraw(Rect(i * SmallIconWidth, 100, (i + 1) * SmallIconWidth, 100 + SmallIconHeight), TheBitmap); TheBitmap.Free; end; {$IFDEF CKRANGE} {$UNDEF CKRANGE} {$R+} {$ENDIF} FreeMem(pTheLargeIcons, NumIcons * sizeof(hIcon)); FreeMem(pTheSmallIcons, NumIcons * sizeof(hIcon)); end; end; end. Вопрос : begin SendMessage(FindWindow('Progman', 'Program Manager'), WM_COMMAND, $A065, 0); end; Вопрос : var b : bool; begin SystemParametersInfo(SPI_GETDRAGFULLWINDOWS, 0, @b, 0); if not b then ShowMessage('Full Window Drag is not enabled') else ShowMessage('Full Window Drag is enabled'); end; Вопрос : Вопрос : {For Win32} IniFiles; {For Win16} {$IFNDEF WIN32} const MAX_PATH = 144; {$ENDIF} {For Win32} procedure TForm1.Button1Click(Sender: TObject); var reg: TRegistry; begin reg := TRegistry.Create; reg.RootKey := HKEY_LOCAL_MACHINE; reg.LazyWrite := false; reg.OpenKey('Software\Microsoft\Windows\CurrentVersion\Run', false); reg.WriteString('My App', Application.ExeName); reg.CloseKey; reg.free; end; {For Win16} procedure TForm1.Button2Click(Sender: TObject); 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 := Application.ExeName else s := s + ';' + Application.ExeName; WinIni.WriteString('windows', 'run', s); WinIni.Free; end; Вопрос : var ProcessID : DWORD; ProcessHandle : THandle; ThreadHandle : THandle; begin ProcessID := GetCurrentProcessID; ProcessHandle := OpenProcess(PROCESS_SET_INFORMATION, false, ProcessID); SetPriorityClass(ProcessHandle, REALTIME_PRIORITY_CLASS); ThreadHandle := GetCurrentThread; SetThreadPriority(ThreadHandle, THREAD_PRIORITY_TIME_CRITICAL); end; Вопрос : private { Private declarations } public procedure WMEXITSIZEMOVE(var Message: TMessage); message WM_EXITSIZEMOVE; { Public declarations } end; var Form1: TForm1; implementation {$R *.DFM} procedure TForm1.WMEXITSIZEMOVE(var Message: TMessage); begin Form1.Caption := 'Finished Moving and sizing'; end; Вопрос : var SearchRec : TSearchRec; Success : integer; DT : TFileTime; ST : TSystemTime; begin Success := SysUtils.FindFirst('C:\autoexec.bat', faAnyFile, SearchRec); if (Success = 0) and (( SearchRec.FindData.ftLastAccessTime.dwLowDateTime <> 0) or ( SearchRec.FindData.ftLastAccessTime.dwHighDateTime <> 0)) then begin FileTimeToLocalFileTime(SearchRec.FindData.ftLastAccessTime,DT); FileTimeToSystemTime(DT,ST); Memo1.Lines.Clear; Memo1.Lines.Add('AutoExec.Bat was last accessed at:'); Memo1.Lines.Add('Year := ' + IntToStr(st.wYear)); Memo1.Lines.Add('Month := ' + IntToStr(st.wMonth)); Memo1.Lines.Add('DayOfWeek := ' + IntToStr(st.wDayOfWeek)); Memo1.Lines.Add('Day := ' + IntToStr(st.wDay)); Memo1.Lines.Add('Hour := ' + IntToStr(st.wHour)); Memo1.Lines.Add('Minute := ' + IntToStr(st.wMinute)); Memo1.Lines.Add('Second := ' + IntToStr(st.wSecond)); Memo1.Lines.Add('Milliseconds := ' + IntToStr(st.wMilliseconds)); end; SysUtils.FindClose(SearchRec); end; Вопрос : 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; Вопрос : procedure TForm1.Button1Click(Sender: TObject);
var info : TOSVersionInfo; ClassName : string; Title : string; begin {Проверяем - Win95 или NT.} info.dwOSVersionInfoSize := sizeof(info); GetVersionEx(info); if (info.dwPlatformId = VER_PLATFORM_WIN32_NT) then begin ClassName := 'ConsoleWindowClass'; Title := 'Command Prompt'; end else begin ClassName := 'tty'; Title := 'MS-DOS Prompt'; end; ShowMessage(IntToStr(FindWindow(PChar(ClassName), PChar(Title)))); end; Вопрос : TForm1 = class(TForm) private { Private declarations } procedure WMTIMECHANGE(var Message: TWMTIMECHANGE); message WM_TIMECHANGE; public { Public declarations } end; var Form1: TForm1; implementation {$R *.DFM} procedure TForm1.WMTIMECHANGE(var Message: TWMTIMECHANGE); begin Form1.Caption := 'Time Changed'; end; Вопрос : procedure TForm1.Button1Click(Sender: TObject); begin SHAddToRecentDocs(SHARD_PATH, nil); end; Вопрос : var CommPort : string; hCommFile : THandle; ModemStat : DWord; begin CommPort := 'COM2'; {Open the comm port} hCommFile := CreateFile(PChar(CommPort), GENERIC_READ, 0, nil, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, 0); if hCommFile = INVALID_HANDLE_VALUE then begin ShowMessage('Unable to open '+ CommPort); exit; end; {Get the Modem Status} if GetCommModemStatus(hCommFile, ModemStat) <> false then begin if ModemStat and MS_CTS_ON <> 0 then ShowMessage('The CTS (clear-to-send) is on.'); if ModemStat and MS_DSR_ON <> 0 then ShowMessage('The DSR (data-set-ready) is on.'); if ModemStat and MS_RING_ON <> 0 then ShowMessage('The ring indicator is on.'); if ModemStat and MS_RLSD_ON <> 0 then ShowMessage('The RLSD (receive-line-signal-detect) is on.'); end; {Close the comm port} CloseHandle(hCommFile); end; Вопрос : procedure FormCreate(Sender: TObject); private { Private declarations } procedure WMSysCommand(var Msg: TWMSysCommand); message WM_SYSCOMMAND; public { Public declarations } end; var Form1: TForm1; implementation {$R *.DFM} const SC_MyMenuItem = WM_USER + 1; procedure TForm1.FormCreate(Sender: TObject); begin AppendMenu(GetSystemMenu(Handle, FALSE), MF_SEPARATOR, 0, ''); AppendMenu(GetSystemMenu(Handle, FALSE), MF_STRING, SC_MyMenuItem, 'My Menu Item'); end; procedure TForm1.WMSysCommand(var Msg: TWMSysCommand); begin if Msg.CmdType = SC_MyMenuItem then ShowMessage('Got the message') else inherited; end; Вопрос : OriginalWordBreakProc : pointer; NewWordBreakProc : pointer; function MyWordBreakProc(LPTSTR : pchar; ichCurrent : integer; cch : integer; code : integer) : integer {$IFDEF WIN32} stdcall; {$ELSE} ; export; {$ENDIF} begin result := 0; end; procedure TForm1.FormCreate(Sender: TObject); begin OriginalWordBreakProc := Pointer( SendMessage(Memo1.Handle, EM_GETWORDBREAKPROC, 0, 0)); {$IFDEF WIN32} NewWordBreakProc := @MyWordBreakProc; {$ELSE} NewWordBreakProc := MakeProcInstance(@MyWordBreakProc, hInstance); {$ENDIF} SendMessage(Memo1.Handle, EM_SETWORDBREAKPROC, 0, longint(NewWordBreakProc)); end; procedure TForm1.FormDestroy(Sender: TObject); begin SendMessage(Memo1.Handle, EM_SETWORDBREAKPROC, 0, longint(@OriginalWordBreakProc)); {$IFNDEF WIN32} FreeProcInstance(NewWordBreakProc); {$ENDIF} end; Вопрос : Примечание: буфер, содержащий имена файлов для копирования должен заканчиваться двумя нулевыми символами. 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; Вопрос : var VolumeName, FileSystemName : array [0..MAX_PATH-1] of Char; VolumeSerialNo : DWord; MaxComponentLength, FileSystemFlags : Integer; begin GetVolumeInformation('C:\',VolumeName,MAX_PATH,@VolumeSerialNo, MaxComponentLength,FileSystemFlags, FileSystemName,MAX_PATH); Memo1.Lines.Add('VName = '+VolumeName); Memo1.Lines.Add('SerialNo = $'+IntToHex(VolumeSerialNo,8)); Memo1.Lines.Add('CompLen = '+IntToStr(MaxComponentLength)); Memo1.Lines.Add('Flags = $'+IntToHex(FileSystemFlags,4)); Memo1.Lines.Add('FSName = '+FileSystemName); end; Вопрос : begin case GetDriveType('C:\') of 0 : ShowMessage('The drive type cannot be determined'); 1 : ShowMessage('The root directory does not exist'); DRIVE_REMOVABLE:ShowMessage('The disk can be removed'); DRIVE_FIXED : ShowMessage('The disk cannot be removed'); DRIVE_REMOTE : ShowMessage('The drive is remote (network) drive'); DRIVE_CDROM : ShowMessage('The drive is a CD-ROM drive'); DRIVE_RAMDISK : ShowMessage('The drive is a RAM disk'); end; end; Вопрос : var OldErrorMode : Word; OldDirectory : string; begin OldErrorMode := SetErrorMode(SEM_NOOPENFILEERRORBOX); GetDir(0, OldDirectory); {$I-} ChDir(DriveLetter + ':\'); {$I+} if IoResult <> 0 then Result := False else Result := True; ChDir(OldDirectory); SetErrorMode(OldErrorMode); end; procedure TForm1.Button1Click(Sender: TObject); begin if not IsDriveReady('A') then ShowMessage('Drive Not Ready') else ShowMessage('Drive is Ready'); end; Вопрос : Result := SysUtils.FindFirst(Path, Attr, SearchRec); while Result = 0 do begin ProcessSearchRec(SearchRec); Result := SysUtils.FindNext(SearchRec); end; SysUtils.FindClose(SearchRec); end; Вопрос : PFindWindowStruct = ^TFindWindowStruct; TFindWindowStruct = record Caption : string; ClassName : string; WindowHandle : THandle; end; function EnumWindowsProc(hWindow : hWnd; lParam : LongInt) : Bool {$IFDEF Win32} stdcall; {$ELSE} ; export; {$ENDIF} var lpBuffer : PChar; WindowCaptionFound : bool; ClassNameFound : bool; begin GetMem(lpBuffer, 255); Result := True; WindowCaptionFound := False; ClassNameFound := False; try if GetWindowText(hWindow, lpBuffer, 255) > 0 then if Pos(PFindWindowStruct(lParam).Caption, StrPas(lpBuffer)) > 0 then WindowCaptionFound := true; if PFindWindowStruct(lParam).ClassName = '' then ClassNameFound := True else if GetClassName(hWindow, lpBuffer, 255) > 0 then if Pos(PFindWindowStruct(lParam).ClassName, StrPas(lpBuffer)) > 0 then ClassNameFound := True; if (WindowCaptionFound and ClassNameFound) then begin PFindWindowStruct(lParam).WindowHandle := hWindow; Result := False; end; finally FreeMem(lpBuffer, sizeof(lpBuffer^)); end; end; function FindAWindow(Caption : string; ClassName : string) : THandle; var WindowInfo : TFindWindowStruct; begin with WindowInfo do begin Caption := Caption; ClassName := ClassName; WindowHandle := 0; EnumWindows(@EnumWindowsProc, LongInt(@WindowInfo)); FindAWindow := WindowHandle; end; end; procedure TForm1.Button1Click(Sender: TObject); var TheWindowHandle : THandle; begin TheWindowHandle := FindAWindow('Netscape - ', ''); if TheWindowHandle = 0 then ShowMessage('Window Not Found!') else BringWindowToTop(TheWindowHandle); end; Вопрос : {$R *.RES} uses SysUtils; var f : TextFile; begin AssignFile(f, 'TestFile.Txt'); ReWrite(f); Writeln(f, 'Test'); Close(f); end. Вопрос : При приеме значений типа boolean из внешних программ Вам следует всегда проверять его на значение "False". Эта техника всегда работает, поскольку "False" всегда представляется нулем. if BoolValPassed <> False then DoSomething.Вопрос : var SearchRec : TSearchRec; Success : integer; begin Success := SysUtils.FindFirst('C:\DownLoad\dial-u~1.htm', faAnyFile, SearchRec); if Success = 0 then begin ShowMessage(SearchRec.FindData.CFileName); end; SysUtils.FindClose(SearchRec); end; Вопрос : PSomeArray = ^TSomeArray; TSomeArray = array[0..0] of integer; procedure TForm1.Button1Click(Sender: TObject); var p : PSomeArray; i : integer; begin {$IFOPT R+} {$DEFINE CKRANGE} {$R-} {$ENDIF} GetMem(p, sizeof(integer) * 200); try for i := 1 to 200 do p[i] := i; finally FreeMem(p, sizeof(integer) * 200); end; {$IFDEF CKRANGE} {$UNDEF CKRANGE} {$R+} {$ENDIF} end; Вопрос : {$R *.DFM} uses DbiTypes, DbiProcs; function fDbiFormFullName(Tbl: TTable): String; var Props: CurProps; Buffer1 : array[0..DBIMAXPATHLEN] of char; Buffer2 : array[0..DBIMAXPATHLEN] of char; begin Check(DbiGetCursorProps(Tbl.Handle,Props)); StrPCopy(Buffer1, Tbl.TableName); Check(DbiFormFullName(Tbl.DBHandle, @Buffer1, Props.szTableType, @Buffer2)); Result := StrPas(Buffer2); end; procedure TForm1.Button1Click(Sender: TObject); begin Memo1.Lines.Add(fDbiFormFullName(Table1)); end; Примечание: Таблица должна быть открытой. Работает с локальными таблицами. Вопрос : Вопрос : 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; Вопрос : var {$IFDEF WIN32} rs : TRasterizerStatus; {$ELSE} rs : TRasterizer_Status; {$ENDIF} begin result := false; if not GetRasterizerCaps(rs, sizeof(rs)) then exit; if rs.WFlags and TT_AVAILABLE <> TT_AVAILABLE then exit; if rs.WFlags and TT_ENABLED <> TT_ENABLED then exit; result := true; end; Вопрос : procedure SendToRecycleBin(FileName: string); var SHF: TSHFileOpStruct; begin with SHF do begin Wnd := Application.Handle; wFunc := FO_DELETE; pFrom := PChar(FileName); fFlags := FOF_SILENT or FOF_ALLOWUNDO; end; SHFileOperation(SHF); end; procedure TForm1.Button1Click(Sender: TObject); begin SendToRecycleBin('c:\DownLoad\Test.gif'); end; Вопрос : Вопрос : Вопрос : function GetVersionEx(lpOs : pointer) : BOOL; stdcall; external 'kernel32' name 'GetVersionExA'; {$ENDIF} procedure GetWindowsVersion(var Major : integer; var Minor : integer); var {$IFDEF WIN32} lpOS, lpOS2 : POsVersionInfo; {$ELSE} l : longint; {$ENDIF} begin {$IFDEF WIN32} GetMem(lpOS, SizeOf(TOsVersionInfo)); lpOs^.dwOSVersionInfoSize := SizeOf(TOsVersionInfo); while getVersionEx(lpOS) = false do begin GetMem(lpos2, lpos^.dwOSVersionInfoSize + 1); lpOs2^.dwOSVersionInfoSize := lpOs^.dwOSVersionInfoSize + 1; FreeMem(lpOs, lpOs^.dwOSVersionInfoSize); lpOS := lpOs2; end; Major := lpOs^.dwMajorVersion; Minor := lpOs^.dwMinorVersion; FreeMem(lpOs, lpOs^.dwOSVersionInfoSize); {$ELSE} l := GetVersion; Major := LoByte(LoWord(l)); Minor := HiByte(LoWord(l)); {$ENDIF} end; procedure TForm1.Button1Click(Sender: TObject); var Major : integer; Minor : integer; begin GetWindowsVersion(Major, Minor); Memo1.Lines.Add(IntToStr(Major)); Memo1.Lines.Add(IntToStr(Minor)); end; Вопрос : Пример : procedure TForm1.Button1Click(Sender: TObject);var p : pChar; begin Memo1.Lines.Clear; Memo1.WordWrap := false; {$IFDEF WIN32} p := GetEnvironmentStrings; {$ELSE} p := GetDOSEnvironment; {$ENDIF} while p^ <> #0 do begin Memo1.Lines.Add(StrPas(p)); inc(p, lStrLen(p) + 1); end; {$IFDEF WIN32} FreeEnvironmentStrings(p); {$ENDIF} end; Вопрос : var dc : hdc; begin dc := GetDc(0); MoveToEx(Dc, 0, 0, nil); LineTo(Dc, 300, 300); ReleaseDc(0, Dc); end; Вопрос : const MAX_PATH = 144; {$ENDIF} procedure TForm1.Button1Click(Sender: TObject); var a : Array[0..MAX_PATH] of char; begin GetWindowsDirectory(a, sizeof(a)); ShowMessage(StrPas(a)); GetSystemDirectory(a, sizeof(a)); ShowMessage(StrPas(a)); end; Вопрос : var r : TRect; begin SystemParametersInfo(SPI_GETWORKAREA, 0, @r, 0); Memo1.Lines.Add(IntToStr(r.Top)); Memo1.Lines.Add(IntToStr(r.Left)); Memo1.Lines.Add(IntToStr(r.Bottom)); Memo1.Lines.Add(IntToStr(r.Right)); end; Вопрос : procedure CloseCD(Drive : char); var mp : TMediaPlayer; begin result := false; Application.ProcessMessages; mp := TMediaPlayer.Create(nil); mp.Visible := false; mp.Parent := Application.MainForm; mp.Shareable := true; mp.DeviceType := dtCDAudio; mp.FileName := Drive + ':'; mp.Open; Application.ProcessMessages; mciSendCommand(mp.DeviceID, MCI_SET, MCI_SET_DOOR_CLOSED, 0); Application.ProcessMessages; mp.Close; Application.ProcessMessages; mp.free; result := true; end; procedure TForm1.Button1Click(Sender: TObject); begin CloseCD('D'); end; Вопрос : procedure GetDiskSizeAvail(TheDrive : PChar; var TotalBytes : double; var TotalFree : double); var AvailToCall : integer; TheSize : integer; FreeAvail : integer; begin GetDiskFreeSpaceEx(TheDrive, AvailToCall, TheSize, FreeAvail); {$IFOPT Q+} {$DEFINE TURNOVERFLOWON} {$Q-} {$ENDIF} if TheSize >= 0 then TotalBytes := TheSize else if TheSize = -1 then begin TotalBytes := $7FFFFFFF; TotalBytes := TotalBytes * 2; TotalBytes := TotalBytes + 1; end else begin TotalBytes := $7FFFFFFF; TotalBytes := TotalBytes + abs($7FFFFFFF - TheSize); end; if AvailToCall >= 0 then TotalFree := AvailToCall else if AvailToCall = -1 then begin TotalFree := $7FFFFFFF; TotalFree := TotalFree * 2; TotalFree := TotalFree + 1; end else begin TotalFree := $7FFFFFFF; TotalFree := TotalFree + abs($7FFFFFFF - AvailToCall); end; end; procedure TForm1.Button1Click(Sender: TObject); var TotalBytes : double; TotalFree : double; begin GetDiskSizeAvail('C:\', TotalBytes, TotalFree); ShowMessage(FloatToStr(TotalBytes)); ShowMessage(FloatToStr(TotalFree)); end; Вопрос : var hTaskBar : THandle; begin hTaskbar := FindWindow('Shell_TrayWnd', Nil); ShowWindow(hTaskBar, SW_HIDE); end; procedure TForm1.Button2Click(Sender: TObject); var hTaskBar : THandle; begin hTaskbar := FindWindow('Shell_TrayWnd', Nil); ShowWindow(hTaskBar, SW_SHOWNORMAL); end; Вопрос : begin if GetSystemMetrics(SM_NETWORK) AND $01 = $01 then ShowMessage('Machine is attached to network') else ShowMessage('Machine is not attached to network'); end; Вопрос : procedure TForm1.Button1Click(Sender: TObject); var s : string; begin s := 'C:\DownLoad\ntkfaq.html'; SHAddToRecentDocs(SHARD_PATH, pChar(s)); end; Вопрос : {$IFNDEF WIN32} const MAX_PATH = 144; {$ENDIF} procedure TForm1.Button1Click(Sender: TObject); var pDevice : pChar; pDriver : pChar; pPort : pChar; hDMode : THandle; PDMode : PDEVMODE; begin if PrintDialog1.Execute then begin GetMem(pDevice, cchDeviceName); GetMem(pDriver, MAX_PATH); GetMem(pPort, MAX_PATH); Printer.GetPrinter(pDevice, pDriver, pPort, hDMode); Printer.SetPrinter(pDevice, PDriver, 'FILE:', hDMode); FreeMem(pDevice, cchDeviceName); FreeMem(pDriver, MAX_PATH); FreeMem(pPort, MAX_PATH); Printer.BeginDoc; Printer.Canvas.TextOut(100, 100, 'Delphi Is RAD!'); Printer.EndDoc; end; end; Вопрос : TForm1 = class(TForm) Button1: TButton; private { Private declarations } procedure WMDeviceChange(var Message: TMessage); message WM_DEVICECHANGE; public { Public declarations } end; var Form1: TForm1; implementation {$R *.DFM} const DBT_DEVICEARRIVAL = $8000; const DBT_DEVICEQUERYREMOVE = $8001; const DBT_DEVICEQUERYREMOVEFAILED = $8002; const DBT_DEVICEREMOVEPENDING = $8003; const DBT_DEVICEREMOVECOMPLETE = $8004; const DBT_DEVICETYPESPECIFIC = $8005; const DBT_CONFIGCHANGED = $0018; procedure TForm1.WMDeviceChange(var Message: TMessage); var s : string; begin {Do Something here} case Message.wParam of DBT_DEVICEARRIVAL : s := 'A device has been inserted and is now available'; DBT_DEVICEQUERYREMOVE: begin s := 'Permission to remove a device is requested'; ShowMessage(s); {True grants premission} Message.Result := integer(true); exit; end; DBT_DEVICEQUERYREMOVEFAILED : s := 'Request to remove a device has been canceled'; DBT_DEVICEREMOVEPENDING : s := 'Device is about to be removed'; DBT_DEVICEREMOVECOMPLETE : s := 'Device has been removed'; DBT_DEVICETYPESPECIFIC : s := 'Device-specific event'; DBT_CONFIGCHANGED : s:= 'Current configuration has changed' else s := 'Unknown Device Message'; end; ShowMessage(s); inherited; end; Вопрос : Вопрос : procedure TForm1.Button1Click(Sender: TObject); begin ShellExecute(0, 'explore', 'C:\WINDOWS', nil, nil, SW_SHOWNORMAL); end; Вопрос : begin WinExec('C:\WINDOWS\CONTROL.EXE TIMEDATE.CPL', sw_ShowNormal); WinExec('C:\WINDOWS\CONTROL.EXE MOUSE', sw_ShowNormal); WinExec('C:\WINDOWS\CONTROL.EXE PRINTERS', sw_ShowNormal); end; Вопрос : procedure TForm1.Button1Click(Sender: TObject); var Device : array[0..255] of char; Driver : array[0..255] of char; Port : array[0..255] of char; hDMode : THandle; PDMode : PDEVMODE; begin with Printer do begin PrinterIndex := PrinterIndex; GetPrinter(Device, Driver, Port, hDMode); if hDMode <> 0 then begin pDMode := GlobalLock(hDMode); if pDMode <> nil then begin pDMode.dmFields := pDMode.dmFields or dm_Color; pDMode.dmColor := DMCOLOR_COLOR; GlobalUnlock(hDMode); end; end; PrinterIndex := PrinterIndex; BeginDoc; Canvas.Font.Color := clRed; Canvas.TextOut(100,100, 'Red As A Rose!'); EndDoc; end; end; Вопрос : procedure TForm1.Button1Click(Sender: TObject); begin ShellExecute(Form1.Handle, nil, 'http://www.borland.com', nil, nil, SW_SHOWNORMAL); end; Вопрос : Пример : uses Registry;procedure TForm1.Button1Click(Sender: TObject); var reg: TRegistry; begin reg := TRegistry.Create; with reg do begin RootKey := HKEY_LOCAL_MACHINE; LazyWrite := false; OpenKey('Software\Microsoft\Windows\CurrentVersion\RunOnce', false); WriteString('Delete Me!','command.com /c del FILENAME.EXT'); CloseKey; free; end; end; Вопрос : procedure TForm1.Button1Click(Sender: TObject); var reg: TRegistry; b : bool; begin CopyFile('C:\DOWNLOAD\FP000100.TTF', 'C:\WINDOWS\FONTS\FP000100.TTF', b); reg := TRegistry.Create; reg.RootKey := HKEY_LOCAL_MACHINE; reg.LazyWrite := false; reg.OpenKey('Software\Microsoft\Windows\CurrentVersion\Fonts', false); reg.WriteString('TESTMICR (TrueType)','FP000100.TTF'); reg.CloseKey; reg.free; {Add the font resource} AddFontResource('c:\windows\fonts\FP000100.TTF'); SendMessage(HWND_BROADCAST, WM_FONTCHANGE, 0, 0); {Remove the resource lock} RemoveFontResource('c:\windows\fonts\FP000100.TTF'); SendMessage(HWND_BROADCAST, WM_FONTCHANGE, 0, 0); end; Вопрос : procedure TForm1.Button1Click(Sender: TObject); var reg : TRegistry; ts : TStrings; i : integer; begin reg := TRegistry.Create; reg.RootKey := HKEY_LOCAL_MACHINE; reg.OpenKey( 'SOFTWARE\Microsoft\Windows\CurrentVersion\Time Zones', false); if reg.HasSubKeys then begin ts := TStringList.Create; reg.GetKeyNames(ts); reg.CloseKey; for i := 0 to ts.Count -1 do begin reg.OpenKey( 'SOFTWARE\Microsoft\Windows\CurrentVersion\Time Zones\' + ts.Strings[i], false); Memo1.Lines.Add(ts.Strings[i]); Memo1.Lines.Add(reg.ReadString('Display')); Memo1.Lines.Add(reg.ReadString('Std')); Memo1.Lines.Add(reg.ReadString('Dlt')); Memo1.Lines.Add('----------------------'); reg.CloseKey; end; ts.Free; end else reg.CloseKey; reg.free; end; Вопрос : const TIME_ZONE_ID_STANDARD = 1; const TIME_ZONE_ID_DAYLIGHT = 2; Вопрос : var OldBkMode : integer; begin with Form1.Canvas do begin Brush.Color := clRed; FillRect(Rect(0, 0, 100, 100)); Brush.Color := clBlue; TextOut(10, 20, 'Not Transparent!'); OldBkMode := SetBkMode(Handle, TRANSPARENT); TextOut(10, 50, 'Transparent!'); SetBkMode(Handle, OldBkMode); end; end; Вопрос : procedure GetFileVersion(FileName: string; var Major1, Major2, Minor1, Minor2: Integer); { Helper function to get the actual file version information } var Info: Pointer; InfoSize: DWORD; FileInfo: PVSFixedFileInfo; FileInfoSize: DWORD; Tmp: DWORD; begin // Get the size of the FileVersionInformatioin InfoSize := GetFileVersionInfoSize(PChar(FileName), Tmp); // If InfoSize = 0, then the file may not exist, or // it may not have file version information in it. if InfoSize = 0 then raise Exception.Create('Can''t get file version information for ' + FileName); // Allocate memory for the file version information GetMem(Info, InfoSize); try // Get the information GetFileVersionInfo(PChar(FileName), 0, InfoSize, Info); // Query the information for the version VerQueryValue(Info, '\', Pointer(FileInfo), FileInfoSize); // Now fill in the version information Major1 := FileInfo.dwFileVersionMS shr 16; Major2 := FileInfo.dwFileVersionMS and $FFFF; Minor1 := FileInfo.dwFileVersionLS shr 16; Minor2 := FileInfo.dwFileVersionLS and $FFFF; finally FreeMem(Info, FileInfoSize); end; end; var tmpBuffer: PChar; Shell32Path: string; VersionMajor: Integer; VersionMinor: Integer; Blank: Integer; begin tmpBuffer := AllocMem(MAX_PATH); // Get the shell32.dll path try GetSystemDirectory(tmpBuffer, MAX_PATH); Shell32Path := tmpBuffer + '\shell32.dll'; finally FreeMem(tmpBuffer); end; // Check to see if it exists if FileExists(Shell32Path) then begin // Get the file version GetFileVersion(Shell32Path, VersionMajor, VersionMinor, Blank, Blank); // Do something, such as require a certain version // (such as greater than 4.71) if (VersionMajor >= 4) and (VersionMinor >= 71) then Result := True else Result := False; end else Result := False; end; Вопрос : var IconSizeX : integer; IconSizeY : integer; AndMask : TBitmap; XOrMask : TBitmap; IconInfo : TIconInfo; Icon : TIcon; begin {Get the icon size} IconSizeX := GetSystemMetrics(SM_CXICON); IconSizeY := GetSystemMetrics(SM_CYICON); {Create the "And" mask} AndMask := TBitmap.Create; AndMask.Monochrome := true; AndMask.Width := IconSizeX; AndMask.Height := IconSizeY; {Draw on the "And" mask} AndMask.Canvas.Brush.Color := clWhite; AndMask.Canvas.FillRect(Rect(0, 0, IconSizeX, IconSizeY)); AndMask.Canvas.Brush.Color := clBlack; AndMask.Canvas.Ellipse(4, 4, IconSizeX - 4, IconSizeY - 4); {Draw as a test} Form1.Canvas.Draw(IconSizeX * 2, IconSizeY, AndMask); {Create the "XOr" mask} XOrMask := TBitmap.Create; XOrMask.Width := IconSizeX; XOrMask.Height := IconSizeY; {Draw on the "XOr" mask} XOrMask.Canvas.Brush.Color := ClBlack; XOrMask.Canvas.FillRect(Rect(0, 0, IconSizeX, IconSizeY)); XOrMask.Canvas.Pen.Color := clRed; XOrMask.Canvas.Brush.Color := clRed; XOrMask.Canvas.Ellipse(4, 4, IconSizeX - 4, IconSizeY - 4); {Draw as a test} Form1.Canvas.Draw(IconSizeX * 4, IconSizeY, XOrMask); {Create a icon} Icon := TIcon.Create; IconInfo.fIcon := true; IconInfo.xHotspot := 0; IconInfo.yHotspot := 0; IconInfo.hbmMask := AndMask.Handle; IconInfo.hbmColor := XOrMask.Handle; Icon.Handle := CreateIconIndirect(IconInfo); {Destroy the temporary bitmaps} AndMask.Free; XOrMask.Free; {Draw as a test} Form1.Canvas.Draw(IconSizeX * 6, IconSizeY, Icon); {Assign the application icon} Application.Icon := Icon; {Force a repaint} InvalidateRect(Application.Handle, nil, true); {Free the icon} Icon.Free; end; Вопрос : var Gray : byte; begin Gray := Round((0.30 * GetRValue(RGBColor)) + (0.59 * GetGValue(RGBColor)) + (0.11 * GetBValue(RGBColor ))); Result := RGB(Gray, Gray, Gray); end; procedure TForm1.FormCreate(Sender: TObject); begin Shape1.Brush.Color := RGB(255, 64, 64); Shape2.Brush.Color := RgbToGray(Shape1.Brush.Color); end; Вопрос : procedure WMQueryOpen(VAR Msg : TWMQueryOpen); message WM_QUERYOPEN; {Place this code in the Form implementation section} procedure TForm1.WMQueryOpen(VAR Msg : TWMQueryOpen); begin Msg.Result := 0; end; Вопрос : wc : TWndClass; begin Windows.RegisterClass(wc) end; Вопрос : interface uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls; type TForm1 = class(TForm) Memo1: TMemo; procedure FormCreate(Sender: TObject); private procedure WMDROPFILES(var Message: TWMDROPFILES); message WM_DROPFILES; { Private declarations } public { Public declarations } end; var Form1: TForm1; implementation {$R *.DFM} uses ShellApi; procedure TForm1.FormCreate(Sender: TObject); begin {Let Windows know we accept dropped files} DragAcceptFiles(Form1.Handle, True); end; procedure TForm1.WMDROPFILES(var Message: TWMDROPFILES); var NumFiles : longint; i : longint; buffer : array[0..255] of char; begin {How many files are being dropped} NumFiles := DragQueryFile(Message.Drop, -1, nil, 0); {Accept the dropped files} for i := 0 to (NumFiles - 1) do begin DragQueryFile(Message.Drop, i, @buffer, sizeof(buffer)); Form1.Memo1.Lines.Add(buffer); end; end; end. Вопрос : var TheTime : LongInt; begin TheTime := GetTickCount + ms; while GetTickCount < TheTime do Application.ProcessMessages; end; procedure TForm1.Button1Click(Sender: TObject); begin ShowMessage('Start Test'); Delay(2000); ShowMessage('End Test'); end; Вопрос :
|
|
|||||||||||||||||
Web дизайн: Бурлаков Михаил
Web программирование: Бурлаков Михаил
|
