vbrus.narod.ru
Последнее обновление: 3 Ноября 2007 г.
01. Узнаем путь к Windows и System32 в Delphi
Windir : String; WindirP : PChar; Res: integer; begin WinDirP := StrAlloc(MAX_PATH); Res := GetWindowsDirectory(WinDirP, MAX_PATH); if Res > 0 then WinDir := StrPas(WinDirP); Edit1.text:=WinDir; Немного другой способ: var buf: array[0..255] of char; begin GetWindowsDirectory(buf, sizeof(buf)); label1.Caption := strpas(buf); Если вы хотите узнать путь к папке System32 то тогда место: GetWindowsDirectory замените на GetSystemDirectory Наверх 02. Как получить путь к запущенной программе из нее самой?
Наверх 03. Каким образом можно убрать приложение из Task Bar?
Наверх 04. Как можно сделать форму прозрачной?
procedure TForm1.FormCreate(Sender: TObject); begin Brush.Style:=bsClear; end; Наверх 05. Как рисовать прямо на экране?
Var DC:HDC; DesktopCanvas:TCanvas; begin DC:=GetDC(0); // получили DC экрана try DesktopCanvas:=TCanvas.Create; DesktopCanvas.Handle:=DC; // здесь рисуем на Canvas экрана finally ReleaseDC(0,DC); DesktopCanvas.Free; end; end; Наверх 06. Как использовать анимированные курсоры в программе?
var h:THandle; begin h:= LoadImage(0,'C:\TheWall\Magic.ani', IMAGE_CURSOR, 0, 0, LR_DEFAULTSIZE or LR_LOADFROMFILE); if h = 0 then ShowMessage('Cursor not loaded') else begin Screen.Cursors[1] := h; Form1.Cursor := 1; end; end; Наверх 07. Как скопировать файл?
function CopyFile( InFile,OutFile: String; From,Count: Longint ): Longint; var InFS,OutFS: TFileStream; begin InFS := TFileStream.Create( InFile, fmOpenRead ); OutFS := TFileStream.Create( OutFile, fmCreate ); InFS.Seek( From, soFromBeginning ); Result := OutFS.CopyFrom( InFS, Count ); InFS.Free; OutFS.Free; end; Наверх 08. Как скопировать директорию с файлами?
interface uses Forms, SysUtils, ShellAPI, Dialogs; procedure CopyFiles(const FromFolder: string; const ToFolder: string); implementation procedure CopyFiles(const FromFolder: string; const ToFolder: string); var Fo : TSHFileOpStruct; buffer : array[0..4096] of char; p : pchar; begin FillChar(Buffer, sizeof(Buffer), #0); p := @buffer; StrECopy(p, PChar(FromFolder)); //директория, которую мы хотим скопировать FillChar(Fo, sizeof(Fo), #0); Fo.Wnd := Application.Handle; Fo.wFunc := FO_COPY; Fo.pFrom := @Buffer; Fo.pTo := PChar(ToFolder); //куда будет скопирована директория Fo.fFlags := 0; if ((SHFileOperation(Fo) <> 0) or (Fo.fAnyOperationsAborted <> false)) then ShowMessage('File copy process cancelled') end; end. Наверх 09. Как программно создать ярлык?
procedure CreateLink(const PathObj, PathLink, Desc, Param: string); var IObject: IUnknown; SLink: IShellLink; PFile: IPersistFile; begin IObject := CreateComObject(CLSID_ShellLink); SLink := IObject as IShellLink; PFile := IObject as IPersistFile; with SLink do begin SetArguments(PChar(Param)); SetDescription(PChar(Desc)); SetPath(PChar(PathObj)); end; PFile.Save(PWChar(WideString(PathLink)), FALSE); end; Наверх 10. Как перетаскивать форму не только за Caption, но и за любое другое место?
private procedure WMNCHitTest(var M: TWMNCHitTest); message wm_NCHitTest; end; procedure TForm1.WMNCHitTest(var M: TWMNCHitTest); begin inherited; { вызов унаследованного обpаботчика } if M.Result = htClient then { Мышь сидит на окне? } M.Result := htCaption; { Если да - то пусть Windows думает, что } { мышь на caption bar } end; Наверх 11. Как выключить компьютер с любой версией Windows?
var VersionInfo: TOSVersionInfo; OSName: string; begin // устанавливаем размер записи VersionInfo.dwOSVersionInfoSize := SizeOf( TOSVersionInfo ); if Windows.GetVersionEx( VersionInfo ) then begin with VersionInfo do begin case dwPlatformId of VER_PLATFORM_WIN32s: OSName := 'Win32s'; VER_PLATFORM_WIN32_WINDOWS: OSName := 'Windows 95'; VER_PLATFORM_WIN32_NT: OSName := 'Windows NT'; end; // case dwPlatformId Result := OSName + ' Version ' + IntToStr( dwMajorVersion ) + '.' + IntToStr( dwMinorVersion ) + #13#10' (Build ' + IntToStr( dwBuildNumber ) + ': ' + szCSDVersion + ')'; end; // with VersionInfo end // if GetVersionEx else Result := ''; end; procedure ShutDown; const SE_SHUTDOWN_NAME = 'SeShutdownPrivilege'; // Borland forgot this declaration var hToken: THandle; tkp: TTokenPrivileges; tkpo: TTokenPrivileges; zero: DWORD; begin if Pos('Windows NT', GetWinVersion) = 1 then // we've got to do a whole buch of things begin zero := 0; if not OpenProcessToken(GetCurrentProcess(), TOKEN_ADJUST_PRIVILEGES or TOKEN_QUERY, hToken) then begin MessageBox(0, 'Exit Error', 'OpenProcessToken() Failed', MB_OK); Exit; end; // if not OpenProcessToken( GetCurrentProcess(), TOKEN_ADJUST_PRIVILEGES or TOKEN_QUERY, hToken) if not OpenProcessToken( GetCurrentProcess(), TOKEN_ADJUST_PRIVILEGES or TOKEN_QUERY, hToken) then begin MessageBox(0, 'Exit Error', 'OpenProcessToken() Failed', MB_OK); Exit; end; // if not OpenProcessToken( GetCurrentProcess(), TOKEN_ADJUST_PRIVILEGES or TOKEN_QUERY, hToken) // SE_SHUTDOWN_NAME if not LookupPrivilegeValue( nil, 'SeShutdownPrivilege' , tkp.Privileges[0].Luid ) then begin MessageBox(0, 'Exit Error', 'LookupPrivilegeValue() Failed', MB_OK); Exit; end; // if not LookupPrivilegeValue( nil, 'SeShutdownPrivilege' , tkp.Privileges[0].Luid ) tkp.PrivilegeCount := 1; tkp.Privileges[0].Attributes := SE_PRIVILEGE_ENABLED; AdjustTokenPrivileges(hToken, False, tkp, SizeOf( TTokenPrivileges ), tkpo, zero); if Boolean(GetLastError()) then begin MessageBox(0, 'Exit Error', 'AdjustTokenPrivileges() Failed', MB_OK); Exit; end // if Boolean( GetLastError() ) else ExitWindowsEx( EWX_FORCE or EWX_SHUTDOWN, 0 ); end // if OSVersion = 'Windows NT' else begin // just shut the machine down ExitWindowsEx( EWX_FORCE or EWX_SHUTDOWN, 0 ); end; // else end; Наверх 12. Работа с реестром в Delphi 1
Реестр предназначен для хранения системных переменных и позволяет зарегистрировать файлы программы, что обеспечивает их показ в проводнике с соответствующей иконкой, вызов программы при щелчке на этом файле, добавление ряда команд в меню, вызываемое при нажатии правой кнопки мыши над файлом. Кроме того, в реестр можно внести некую свою информацию (переменные, константы, данные о инсталлированной программы ...). Программу можно добавить в список деинсталляции, что позволит удалить ее из менеджера "Установка/Удаление программ" панели управления. Для работы с реестром применяется ряд функций API : RegCreateKey (Key: HKey; SubKey: PChar; var Result: HKey): Longint; Создать подраздел в реестре. Key указывает на "корневой" раздел реестра, в Delphi1 доступен только один - HKEY_CLASSES_ROOT, в в Delphi3 - все. SubKey - имя раздела - строится по принципу пути к файлу в DOS (пример subkey1\subkey2\ ...). Если такой раздел уже существует, то он открывается (в любом случае при успешном вызове Result содержит Handle на раздел). Об успешности вызова судят по возвращаемому значению, если ERROR_SUCCESS, то успешно, если иное - ошибка. RegOpenKey(Key: HKey; SubKey: PChar; var Result: HKey): Longint; Открыть подраздел Key\SubKey и возвращает Handle на него в переменной Result. Если раздела с таким именем нет, то он не создается. Возврат - код ошибки или ERROR_SUCCESS, если успешно. RegCloseKey(Key: HKey): Longint; Закрывает раздел, на который ссылается Key. Возврат - код ошибки или ERROR_SUCCESS, если успешно. RegDeleteKey(Key: HKey; SubKey: PChar): Longint; Удалить подраздел Key\SubKey. Возврат - код ошибки или ERROR_SUCCESS, если нет ошибок. RegEnumKey(Key: HKey; index: Longint; Buffer: PChar;cb: Longint): Longint; Получить имена всех подразделов раздела Key, где Key - Handle на открытый или созданный раздел (см. RegCreateKey и RegOpenKey), Buffer - указатель на буфер, cb - размер буфера, index - индекс, должен быть равен 0 при первом вызове RegEnumKey. Типичное использование - в цикле While, где index увеличивается до тех пор, пока очередной вызов RegEnumKey не завершится ошибкой (см. пример). RegQueryValue(Key: HKey; SubKey: PChar; Value: PChar; var cb: Longint): Longint; Возвращает текстовую строку, связанную с ключом Key\SubKey.Value - буфер для строки; cb- размер, на входе - размер буфера, на выходе - длина возвращаемой строки. Возврат - код ошибки. RegSetValue(Key: HKey; SubKey: PChar; ValType: Longint; Value: PChar; cb: Longint): Longint; Задать новое значение ключу Key\SubKey, ValType - тип задаваемой переменной, Value - буфер для переменной, cb - размер буфера. В Windows 3.1 допустимо только Value=REG_SZ. Возврат - код ошибки или ERROR_SUCCESS, если нет ошибок. Примеры : { Создаем список всех подразделов указанного раздела } procedure TForm1.Button1Click(Sender: TObject); var MyKey : HKey; { Handle для работы с разделом } Buffer : array[0..1000] of char; { Буфер } Err, { Код ошибки } index : longint; { Индекс подраздела } begin Err:=RegOpenKey(HKEY_CLASSES_ROOT,'DelphiUnit',MyKey); { Открыли раздел } if Err<> ERROR_SUCCESS then begin MessageDlg('Нет такого раздела !!',mtError,[mbOk],0); exit; end; index:=0; {Определили имя первого подраздела } Err:=RegEnumKey(MyKey,index,Buffer,Sizeof(Buffer)); while err=ERROR_SUCCESS do { Цикл, пока есть подразделы } begin memo1.lines.add(StrPas(Buffer)); { Добавим имя подраздела в список } inc(index); { Увеличим номер подраздела } Err:=RegEnumKey(MyKey,index,Buffer,Sizeof(Buffer)); { Запрос } end; RegCloseKey(MyKey); { Закрыли подраздел } end; Наверх 13. Объект INIFILES - работа с INI файлами.
1. INI-файлы можно просмотреть и отредактировать в обычном блокноте. 2. Если INI-файл хранить в папке с программой, то при переносе папки на другой компьютер настройки сохраняются. (Я еще не написал ни одной программы, которая бы не поместилась на одну дискету :) 3. Новичку в реестре можно запросто запутаться или (боже упаси), чего-нибудь не то изменить. Поэтому для хранения параметров настройки программы удобно использовать стандартные INI файлы Windows. Работа с INI файлами ведется при помощи объекта TIniFiles модуля IniFiles. Краткое описание методов объекта TIniFiles дано ниже. Constructor Create('d:\test.INI'); Создать экземпляр объекта и связать его с файлом. Если такого файла нет, то он создается, но только тогда, когда произведете в него запись информации. WriteBool(const Section, Ident: string; Value: Boolean); Присвоить элементу с именем Ident раздела Section значение типа boolean WriteInteger(const Section, Ident: string; Value: Longint); Присвоить элементу с именем Ident раздела Section значение типа Longint WriteString(const Section, Ident, Value: string); Присвоить элементу с именем Ident раздела Section значение типа String ReadSection (const Section: string; Strings: TStrings); Прочитать имена всех корректно описанных переменных раздела Section (некорректно описанные опускаются) ReadSectionValues(const Section: string; Strings: TStrings); Прочитать имена и значения всех корректно описанных переменных раздела Section. Формат : имя_переменной = значение EraseSection(const Section: string); Удалить раздел Section со всем содержимым ReadBool(const Section, Ident: string; Default: Boolean): Boolean; Прочитать значение переменной типа Boolean раздела Section с именем Ident, и если его нет, то вместо него подставить значение Default. ReadInteger(const Section, Ident: string; Default: Longint): Longint; Прочитать значение переменной типа Longint раздела Section с именем Ident, и если его нет, то вместо него подставить значение Default. ReadString(const Section, Ident, Default: string): string; Прочитать значение переменной типа String раздела Section с именем Ident, и если его нет, то вместо него подставить значение Default. Free; Закрыть и освободить ресурс. Необходимо вызвать при завершении работы с INI файлом Property Values[const Name: string]: string; Доступ к существующему параметру по имени Name Пример : Procedure TForm1.FormClose(Sender: TObject); var IniFile:TIniFile; begin IniFile := TIniFile.Create('d:\test.INI'); { Создали экземпляр объекта } IniFile.WriteBool('Options', 'Sound', True); { Секция Options: Sound:=true } IniFile.WriteInteger('Options', 'Level', 3); { Секция Options: Level:=3 } IniFile.WriteString('Options' , 'Secret password', Pass); { Секция Options: в Secret password записать значение переменной Pass } IniFile.ReadSection('Options ', memo1.lines); { Читаем имена переменных} IniFile.ReadSectionValues('Options ', memo2.lines); { Читаем имена и значения } IniFile.Free; { Закрыли файл, уничтожили объект и освободили память } end; Наверх 14. Как выдать текст под наклоном?
var LogFont : TLogFont; ... GetObject(Canvas.Font.Handle, SizeOf(TLogFont), @LogFont); { Вывести текст 1/10 градуса против часовой стрелки } LogFont.lfEscapement := Angle*10; Canvas.Font.Handle := CreateFontIndirect(LogFont); Наверх 15. Как экспортировать таблицу базы данных в ASCII-файл?
var I: Integer; Dlg: TSaveDialog; ASCIIFile: TextFile; Res: Boolean; begin if Active then if (FieldCount > 0) and (RecordCount > 0) then begin Dlg := TSaveDialog.Create(Application); Dlg.FileName := FASCIIFileName; Dlg.Filter := 'ASCII-Fiels (*.asc)|*.asc'; Dlg.Options := Dlg.Options+[ofPathMustExist, ofOverwritePrompt, ofHideReadOnly]; Dlg.Title := 'Экспоритровать данные в ASCII-файл'; try Res := Dlg.Execute; if Res then FASCIIFileName := Dlg.FileName; finally Dlg.Free; end; if Res then begin AssignFile(ASCIIFile, FASCIIFileName); Rewrite(ASCIIFile); First; if FASCIIFieldNames then begin for I := 0 to FieldCount-1 do begin Write(ASCIIFile, Fields[I].FieldName); if I <> FieldCount-1 then Write(ASCIIFile, FASCIISeparator); end; Write(ASCIIFile, #13#10); end; while not EOF do begin for I := 0 to FieldCount-1 do begin Write(ASCIIFile, Fields[I].Text); if I <> FieldCount-1 then Write(ASCIIFile, FASCIISeparator); end; Next; if not EOF then Write(ASCIIFile, #13#10); end; CloseFile(ASCIIFile); if IOResult <> 0 then MessageDlg('Ошибка при создании или переписывании '+ 'в ASCII-файл', mtError, [mbOK], 0); end; end else MessageDlg('Нет данных для экспортирования.', mtInformation, [mbOK], 0) else MessageDlg('Таблица должна быть открытой, чтобы данные '+ 'можно было экспортировать в ASCII-формат.', mtError, [mbOK], 0); end; Наверх 16. Как выяснить размер BLOB-поля?
Function GetBlobSize(Field: TBlobField): LongInt; begin with TBlobStream.Create(Field, bmRead) do try Result := Seek(0, 2); finally Free; end; end; Наверх 17. Как сравнить bookmarks в таблице?
Bookmark2: TBookmark): Boolean; var Res: DBIResult; CompareRes: Word; begin Result := False; if CheckDatabase then begin Res := DbiCompareBookmarks(FDataLink.DataSource.DataSet.Handle, Bookmark1, Bookmark2, CompareRes); if Res = 0 then if CompareRes = 0 then Result := True else else Check(Res); end; end; Наверх 18. Как выделить окошко DBGrid другим цветом?
procedure TForm1.DBGridDrawDataCell(Sender:TObject; const Rect:TRect; Field:TField; State:TGridDrawState); begin if gdFocused in State then with (Sender as TDBGrid).Canvas do begin Brush.Color := clRed; FillRect(Rect); TextOut(Rect.Left, Rect.Top, Field.AsString); end; end; Наверх 19. Как закрыть окно подсказки если пользователь закончил приложение?
var Action: TCloseAction); begin Winhelp(Handle, 'WINHELP.HLP', HELP_QUIT, 0); Action := caFree; end; Наверх 20. Как установить количество цветов в системной палитре?
function GetNumColors: LongInt; var BPP: Integer; DC: HDC; begin DC := CreateDC('DISPLAY', nil, nil, nil); if DC <> 0 then begin try BPP := GetDeviceCaps(DC, BITPIXEL) * GetDeviceCaps(DC, PLANES); finally DeleteDC(DC); end; case BPP of 1: Result := 2; 4: Result := 16; 8: Result := 256; 15: Result := 32768; 16: Result := 65536; 24: Result := 16777216; end; end else Result := 0; end; Наверх 21. Как через индекс обратиться к нескольким компонентам?
for t := 1 to 5 do FindComponent('Label' + IntToStr(t)).Visible := TRUE; Наверх 22. Как копировать и вставлять Bitmap через буфер обмена?
function CopyClipToBuf(DC: HDC; Left, Top, Width, Height: Integer; Rop: LongInt; var CopyDC: HDC; var CopyBitmap: HBitmap): Boolean; var TempBitmap: HBitmap; begin Result := False; CopyDC := 0; CopyBitmap := 0; if DC <> 0 then begin CopyDC := CreateCompatibleDC(DC); if CopyDC <> 0 then begin CopyBitmap := CreateCompatibleBitmap(DC, Width, Height); if CopyBitmap <> 0 then begin TempBitmap := CopyBitmap; CopyBitmap := SelectObject(CopyDC, CopyBitmap); Result := BitBlt(CopyDC, 0, 0, Width, Height, DC, Left, Top, Rop); CopyBitmap := TempBitmap; end; end; end; end; function CopyBufToClip(DC: HDC; var CopyDC: HDC; var CopyBitmap: HBitmap; Left, Top, Width, Height: Integer; Rop: LongInt; DeleteObjects: Boolean): Boolean; var TempBitmap: HBitmap; begin Result := False; if (DC <> 0) and (CopyDC <> 0) and (CopyBitmap <> 0) then begin TempBitmap := CopyBitmap; CopyBitmap := SelectObject(DC, CopyBitmap); Result := BitBlt(DC, Left, Top, Width, Height, CopyDC, 0, 0, Rop); CopyBitmap := TempBitmap; if DeleteObjects then begin DeleteDC(CopyDC); DeleteObject(CopyBitmap); end; end; end; Наверх 23. Как выяснить положение курсора в МЕМО?
var xChr, xRow, xCol: LongInt; ... xRow := SendMessage(Memo1.Handle, EM_LINEFROMCHAR, Memo1.SelStart, 0); xChr := SendMessage(Memo1.Handle, EM_LINEINDEX, Zeile, 0); xCol := Memo1.SelStart - xChr + 1; Наверх 24. Как узнать содержание активной записи в БД?
function TBDEDirect.GetCurRecord(Lock: DBILockType): PChar; var Res: DBIResult; RecSize: Word; RecBuf: PChar; Bookmark: TBookmark; begin Result := StrNew(''); if CheckDatabase then begin RecSize := GetPhysicalRecSize; RecBuf := StrAlloc(RecSize+1); FillChar(RecBuf^, RecSize+1, #0); Bookmark := FDataLink.DataSource.DataSet.GetBookmark; DbiSetToBookmark(FDataLink.DataSource.DataSet.Handle, Bookmark); FDataLink.DataSource.DataSet.FreeBookmark(Bookmark); Res := DbiGetRecord(FDataLink.DataSource.DataSet.Handle, Lock, RecBuf, nil); if Res = 0 then Result := RecBuf else Check(Res); end; end; Наверх 25. Как выяснить дату последнего изменения файла?
function GetFileDate(FileName: string): string; var FHandle: Integer; begin FHandle := FileOpen(FileName, 0); try Result := DateTimeToStr(FileDateToDateTime(FileGetDate(FHandle))); finally FileClose(FHandle); end; end; Наверх 26. Как проверять корректность доступа к базе данных?
function TBDEDirect.CheckDatabase: Boolean; var DS: TDataSource; begin Result := False; DS := GetDataSource; if DS = nil then begin MessageDlg('Не установлена связь с элементом-источником данных.'+ 'Проверьте установку свойства DataSource.', mtError, [mbOK], 0); Exit; end; if DS.DataSet = nil then begin MessageDlg('Доступ к базе данных невозможен.', mtError, [mbOK], 0); Exit; end; if TDBDataSet(DS.DataSet).Database = nil then begin MessageDlg('Доступ к базе данных невозможен.', mtError, [mbOK], 0); Exit; end; if TDBDataSet(DS.DataSet).Database.Handle = nil then begin MessageDlg('Дескриптор (Handle) БД недоступен.', mtError, [mbOK], 0); Exit; end; if DS.DataSet.Handle = nil then begin MessageDlg('Дескриптор курсора (Cursor-Handle) недоступен.', mtError, [mbOK], 0); Exit; end; Result := True; end; Наверх 27. Как узнать, находится ли дискета в дисководе?
TDriveState(DS_NO_DISK, DS_UNFORMATTED_DISK, DS_EMPTY_DISK, DS_DISK_WITH_FILES); function DriveState(DrvLetter: Char): TDriveState; var Mask: String[6]; SearchRec: TSearchRec; oldMode: Cardinal; ReturnCode: Integer; begin oldMode: = SetErrorMode(SEM_FAILCRITICALERRORS); Mask:= '?:\*.*'; Mask[1] := DrvLetter; {$I-} { отключить обработку исключительных ситуаций } ReturnCode := FindFirst(Mask, faAnyfile, SearchRec); FindClose(SearchRec); {$I+} case ReturnCode of { как минимум один файл был найден } 0: Result := DS_DISK_WITH_FILES; { файлов не найдено и дискета в порядке } -18: Result := DS_EMPTY_DISK; { DS_NO_DISK для DOS, ERROR_NOT_READY для WinNT, ERROR_PATH_NOT_FOUND для Win 3.1 } -21, -3: Result := DS_NO_DISK; else { дискета лежит в дисководе но она не форматировнная } Result := DS_UNFORMATTED_DISK; end; SetErrorMode(oldMode); end; { DriveState } Наверх 28. Как перейти к указанной записи в БД?
function TBDEDirect.GoToRecord(RecNo: LongInt): Boolean; var RecCount: LongInt; Bookmark: TBookmark; Res: DBIResult; begin Result := False; if CheckDatabase then begin if RecNo < 1 then RecNo := 1; RecCount := GetRecordCount; if RecNo > RecCount then RecNo := RecCount; Res := DbiSetToRecordNo(FDataLink.DataSource.DataSet.Handle, RecNo); if Res = 0 then begin Bookmark := StrAlloc(GetBookmarkSize); DbiGetBookmark(FDataLink.DataSource.DataSet.Handle, Bookmark); FDataLink.DataSource.DataSet.GoToBookmark(Bookmark); FDataLink.DataSource.DataSet.FreeBookmark(Bookmark); Result := True; end else Check(Res); end; end; Наверх 29. Создание db-файла во время работы приложения
procedure TForm1.Button1Click(Sender: TObject); var tSource, TDest: TTable; begin TSource := TTable.create(self); with TSource do begin DatabaseName := 'dbdemos'; TableName := 'customer.db'; open; end; TDest := TTable.create(self); with TDest do begin DatabaseName := 'dbdemos'; TableName := 'MyNewTbl.db'; FieldDefs.Assign(TSource.FieldDefs); IndexDefs.Assign(TSource.IndexDefs); CreateTable; end; TSource.close; end; Наверх 30. Как узнать имя компьютера?
var i:DWORD; p:PChar; begin i:=255; GetMem(p, i); GetComputerName(p, i); Result:=String(p); FreeMem(p); end; Наверх 31. Как изменить имя компьютера?
Наверх 32. Работа с корзиной в Windows
32.02 Просмотр состояния корзины 32.03 Очистка корзины 32.04 Удаление файла в корзину 32.01 Как получить количество файлов в корзине и их размер? =============================================================== type PSHQueryRBInfo = ^TSHQueryRBInfo; TSHQueryRBInfo = packed record cbSize: DWORD; // Size of the structure, in bytes. // This member must be filled in prior to calling the function. i64Size: Int64; // Total size of all the objects in the specified Recycle Bin, in bytes. i64NumItems: Int64; // Total number of items in the specified Recycle Bin. end; const shell32 = 'shell32.dll'; function SHQueryRecycleBin(szRootPath: PChar; SHQueryRBInfo: PSHQueryRBInfo): HResult; stdcall; external shell32 Name 'SHQueryRecycleBinA'; function GetDllVersion(FileName: string): Integer; var InfoSize, Wnd: DWORD; VerBuf: Pointer; FI: PVSFixedFileInfo; VerSize: DWORD; begin Result := 0; InfoSize := GetFileVersionInfoSize(PChar(FileName), Wnd); if InfoSize <> 0 then begin GetMem(VerBuf, InfoSize); try if GetFileVersionInfo(PChar(FileName), Wnd, InfoSize, VerBuf) then if VerQueryValue(VerBuf, '\', Pointer(FI), VerSize) then Result := FI.dwFileVersionMS; finally FreeMem(VerBuf); end; end; end; procedure TForm1.Button1Click(Sender: TObject); var DllVersion: integer; SHQueryRBInfo: TSHQueryRBInfo; r: HResult; begin DllVersion := GetDllVersion(PChar(shell32)); if DllVersion >= $00040048 then begin FillChar(SHQueryRBInfo, SizeOf(TSHQueryRBInfo), #0); SHQueryRBInfo.cbSize := SizeOf(TSHQueryRBInfo); R := SHQueryRecycleBin(nil, @SHQueryRBInfo); if r = s_OK then begin label1.Caption := Format('Size:%d Items:%d', [SHQueryRBInfo.i64Size, SHQueryRBInfo.i64NumItems]); end else label1.Caption := Format('Err:%x', [r]); end; end; { The SHQueryRecycleBin API used in this method is only available on systems with the latest shell32.dll installed with IE4 / Active Desktop. } 32.02 Просмотр состояния корзины ============================================== unit Unit1; interface uses Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls, ShellAPI; const SHERB_NOCONFIRMATION = $1; SHERB_NOPROGRESSUI = $2; SHERB_NOSOUND = $4; type TForm1 = class(TForm) btnGetRecicleBinFileCount: TButton; btnEmptyRecicleBin: TButton; btnDelToReciclebin: TButton; procedure btnGetRecicleBinFileCountClick(Sender: TObject); procedure btnEmptyRecicleBinClick(Sender: TObject); procedure btnDelToReciclebinClick(Sender: TObject); end; type TSHQueryRBInfo = packed record cbSize : DWORD; i64Size, i64NumItems : TLargeInteger; end; PSHQueryRBInfo = ^TSHQueryRBInfo; function SHEmptyRecycleBin(hwnd: HWND; pszRootPath: PChar; dwFlags: DWORD): HRESULT; stdcall; external 'shell32.dll' name 'SHEmptyRecycleBinA'; function SHQueryRecycleBin (pszRootPath: PChar; var SHQueryRBInfo: TSHQueryRBInfo): HRESULT; stdcall; external 'Shell32.dll' name 'SHQueryRecycleBinA'; var Form1: TForm1; implementation {$R *.dfm} // Просмотр состояния корзины (краткая информация) procedure TForm1.btnGetRecicleBinFileCountClick(Sender: TObject); var Info: TSHQueryRBInfo; Err: HRESULT; begin ZeroMemory(@Info, SizeOf(Info)); Info.cbSize := SizeOf(Info); Err := SHQueryRecycleBin(nil, Info); if Err = S_OK then ShowMessage(Format('Всего в корзине %d эелементов, их общий размер: %d', [Info.i64NumItems, Info.i64Size])) else ShowMessage(SysErrorMessage(Err)); end; end. 32.03 Очистка корзины ========================================================== unit Unit1; interface uses Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls, ShellAPI; const SHERB_NOCONFIRMATION = $1; SHERB_NOPROGRESSUI = $2; SHERB_NOSOUND = $4; type TForm1 = class(TForm) btnGetRecicleBinFileCount: TButton; btnEmptyRecicleBin: TButton; btnDelToReciclebin: TButton; procedure btnGetRecicleBinFileCountClick(Sender: TObject); procedure btnEmptyRecicleBinClick(Sender: TObject); procedure btnDelToReciclebinClick(Sender: TObject); end; type TSHQueryRBInfo = packed record cbSize : DWORD; i64Size, i64NumItems : TLargeInteger; end; PSHQueryRBInfo = ^TSHQueryRBInfo; function SHEmptyRecycleBin(hwnd: HWND; pszRootPath: PChar; dwFlags: DWORD): HRESULT; stdcall; external 'shell32.dll' name 'SHEmptyRecycleBinA'; function SHQueryRecycleBin (pszRootPath: PChar; var SHQueryRBInfo: TSHQueryRBInfo): HRESULT; stdcall; external 'Shell32.dll' name 'SHQueryRecycleBinA'; var Form1: TForm1; implementation {$R *.dfm} // Очистка корзины procedure TForm1.btnEmptyRecicleBinClick(Sender: TObject); var Err: HRESULT; begin Err := SHEmptyRecycleBin(Handle, 'c:\', SHERB_NOSOUND); if Err <> S_OK then ShowMessage(SysErrorMessage(Err)); end; end. 32.04 Удаление файла в корзину ========================================================== unit Unit1; interface uses Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls, ShellAPI; const SHERB_NOCONFIRMATION = $1; SHERB_NOPROGRESSUI = $2; SHERB_NOSOUND = $4; type TForm1 = class(TForm) btnGetRecicleBinFileCount: TButton; btnEmptyRecicleBin: TButton; btnDelToReciclebin: TButton; procedure btnGetRecicleBinFileCountClick(Sender: TObject); procedure btnEmptyRecicleBinClick(Sender: TObject); procedure btnDelToReciclebinClick(Sender: TObject); end; type TSHQueryRBInfo = packed record cbSize : DWORD; i64Size, i64NumItems : TLargeInteger; end; PSHQueryRBInfo = ^TSHQueryRBInfo; function SHEmptyRecycleBin(hwnd: HWND; pszRootPath: PChar; dwFlags: DWORD): HRESULT; stdcall; external 'shell32.dll' name 'SHEmptyRecycleBinA'; function SHQueryRecycleBin (pszRootPath: PChar; var SHQueryRBInfo: TSHQueryRBInfo): HRESULT; stdcall; external 'Shell32.dll' name 'SHQueryRecycleBinA'; var Form1: TForm1; implementation {$R *.dfm} // Удаление файла в корзину... procedure TForm1.btnDelToReciclebinClick(Sender: TObject); var Struct: TSHFileOpStruct; Err: HRESULT; begin with Struct do begin Wnd := Handle; wFunc := FO_DELETE; pFrom := 'c:\1.txt'; pTo := nil; fFlags := FOF_ALLOWUNDO; fAnyOperationsAborted := True; hNameMappings := nil; lpszProgressTitle := nil; end; Err := SHFileOperation(Struct); if Err <> S_OK then ShowMessage(SysErrorMessage(Err)); end; end. Наверх 33. Как сменить обои на рабочем столе?
uses windows; var s: string; begin s := paramStr(1); SystemParametersInfo(SPI_SETDESKWALLPAPER, 0, @S[1], SPIF_UPDATEINIFILE OR SPIF_SENDWININICHANGE); end. // Запускаешь: // change.exe "имя файла с картинкой" Наверх 34. Снимок рабочего стола
{ Public declarations } procedure GrabScreen; ... implementation {$R *.DFM} procedure TForm1.GrabScreen; var DeskTopDC: HDc; DeskTopCanvas: TCanvas; DeskTopRect: TRect; begin DeskTopDC := GetWindowDC(GetDeskTopWindow); DeskTopCanvas := TCanvas.Create; DeskTopCanvas.Handle := DeskTopDC; DeskTopRect := Rect(0, 0, Screen.Width, Screen.Height); Form1.Canvas.CopyRect(DeskTopRect, DeskTopCanvas, DeskTopRect); ReleaseDC(GetDeskTopWindow, DeskTopDC); end; procedure TForm1.Button1Click(Sender: TObject); begin GrabScreen; end; Наверх 35. Как выключить звук?
MMSystem; function GetMasterMute( Mixer: hMixerObj; var Control: TMixerControl): MMResult; // Returns True on success var Line: TMixerLine; Controls: TMixerLineControls; begin ZeroMemory(@Line, SizeOf(Line)); Line.cbStruct := SizeOf(Line); Line.dwComponentType := MIXERLINE_COMPONENTTYPE_DST_SPEAKERS; Result := mixerGetLineInfo(Mixer, @Line, MIXER_GETLINEINFOF_COMPONENTTYPE); if Result = MMSYSERR_NOERROR then begin ZeroMemory(@Controls, SizeOf(Controls)); Controls.cbStruct := SizeOf(Controls); Controls.dwLineID := Line.dwLineID; Controls.cControls := 1; Controls.dwControlType := MIXERCONTROL_CONTROLTYPE_MUTE; Controls.cbmxctrl := SizeOf(Control); Controls.pamxctrl := @Control; Result := mixerGetLineControls(Mixer, @Controls, MIXER_GETLINECONTROLSF_ONEBYTYPE); end; end; procedure SetMasterMuteValue( Mixer: hMixerObj; Value: Boolean); var MasterMute: TMixerControl; Details: TMixerControlDetails; BoolDetails: TMixerControlDetailsBoolean; Code: MMResult; begin Code := GetMasterMute(0, MasterMute); if Code = MMSYSERR_NOERROR then begin with Details do begin cbStruct := SizeOf(Details); dwControlID := MasterMute.dwControlID; cChannels := 1; cMultipleItems := 0; cbDetails := SizeOf(BoolDetails); paDetails := @BoolDetails; end; LongBool(BoolDetails.fValue) := Value; Code := mixerSetControlDetails(0, @Details, MIXER_SETCONTROLDETAILSF_VALUE); end; if Code <> MMSYSERR_NOERROR then raise Exception.CreateFmt('SetMasterMuteValue failure, '+ 'multimedia system error #%d', [Code]); end; // Example: procedure TForm1.Button1Click(Sender: TObject); begin SetMasterMuteValue(0, CheckBox1.Checked); // Mixer device #0 mute on/off end; Наверх 36. Flash SWF --> EXEfunction Swf2Exe(S, D, F: string): string; //S = Source file (swf) //D = Destionation file (exe) //F = Flash Player var SourceStream, DestinyStream, LinkStream: TFileStream; flag: Cardinal; SwfFileSize: Integer; begin Result := 'something error'; DestinyStream := TFileStream.Create(D, fmCreate); try LinkStream := TFileStream.Create(F, fmOpenRead or fmShareExclusive); try DestinyStream.CopyFrom(LinkStream, 0); finally LinkStream.Free; end; SourceStream := TFileStream.Create(S, fmOpenRead or fmShareExclusive); try DestinyStream.CopyFrom(SourceStream, 0); flag := $FA123456; DestinyStream.WriteBuffer(flag, SizeOf(Integer)); SwfFileSize := SourceStream.Size; DestinyStream.WriteBuffer(SwfFileSize, SizeOf(Integer)); Result := ''; finally SourceStream.Free; end; finally DestinyStream.Free; end; end; procedure TForm1.Button1Click(Sender: TObject); begin Swf2Exe('c:\somefile.swf', 'c:\somefile.exe', 'c:\Program Files\Macromedia\Flash MX\Players\SAFlashPlayer.exe'); end; Наверх 37. CopyFile для Linux
var Source, Target:TFileStream; begin Result:=false; try try Source:=TFileStream.Create(Org, fmShareDenyNone or fmOpenRead); try Target:=TFileStream.Create(Dest, fmOpenWrite or fmCreate); Target.CopyFrom(Source,Source.Size); Result:=true; finally Target.Free; end; finally Source.Free; end; except end; end; Наверх 38.Перетаскивание файла
unit Unit1; interface uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,StdCtrls, ShellAPI {обязательно!}; type TForm1 = class(TForm) Memo1: TMemo; FileNameLabel: TLabel; procedure FormCreate(Sender: TObject); procedure FormDestroy(Sender: TObject); protected {Это и есть самая главная процедура} procedure WMDropFiles(var Msg: TMessage); message wm_DropFiles; end; var Form1: TForm1; implementation {$R *.DFM} procedure TForm1.WMDropFiles(var Msg: TMessage); var Filename: array[0 .. 256] of Char; Count : integer; begin { Получаем количество файлов (просто пример) } nCount := DragQueryFile( msg.WParam, $FFFFFFFF, acFileName, cnMaxFileNameLen); { Получаем имя первого файла } DragQueryFile( THandle(Msg.WParam), 0, { это номер файла } Filename,SizeOf(Filename) ) ; { Открываем его } with FileNameLabel do begin Caption := LowerCase(StrPas(FileName)); Memo1.Lines.LoadfromFile(Caption); end; { Отдаем сообщение о завершении процесса } DragFinish(THandle(Msg.WParam)); end; procedure TForm1.FormCreate(Sender: TObject); begin { Говорим Windows, что на нас можно бросать файлы } DragAcceptFiles(Handle, True); end; procedure TForm1.FormDestroy(Sender: TObject); begin { Закрываем за собой дверь золотым ключиком} DragAcceptFiles(Handle, False); end; end. Наверх 39.Список всех запущенных приложений
procedure TForm1.Button1Click(Sender: TObject); VAR Wnd : hWnd; buff: ARRAY [0..127] OF Char; begin ListBox1.Clear; Wnd := GetWindow(Handle, gw_HWndFirst); WHILE Wnd <> 0 DO BEGIN {Hе показываем:} IF (Wnd <> Application.Handle) AND {-Собственное окно} IsWindowVisible(Wnd) AND {-Hевидимые окна} (GetWindow(Wnd, gw_Owner) = 0) AND {-Дочернии окна} (GetWindowText(Wnd, buff, sizeof(buff)) <> 0) THEN BEGIN GetWindowText(Wnd, buff, sizeof(buff)); ListBox1.Items.Add(StrPas(buff)); END; Wnd := GetWindow(Wnd, gw_hWndNext); END; ListBox1.ItemIndex := 0; end; Наверх 40. Как закрыть приложение или как завершить указанный процесс?
winexec('Cmd /x/c taskkill /f /im ICQlite.exe',SW_SHOWMINIMIZED); Наверх 41. Вставить какую-нибудь программу внутрь EXE файла
ARJ EXEFILE C:\UTIL\ARJ.EXE 2. Компилируем его в ресурс при помощи Brcc32.exe. Получаем RES-файл. 3. Далее в тексте нашей программы: implementation {$R *.DFM} {$R test.res} //Это наш RES-файл procedure ExtractRes(ResType, ResName, ResNewName : String); var Res : TResourceStream; begin Res := TResourceStream.Create(Hinstance, Resname, Pchar(ResType)); Res.SavetoFile(ResNewName); Res.Free; end; procedure TForm1.BitBtn1Click(Sender: TObject); begin // Записывает в текущую папку arj.exe ExtractRes('EXEFILE', 'ARJ', 'ARJ.EXE'); end; Наверх 42. Копирование экранаunit ScrnCap; interface uses WinTypes, WinProcs, Forms, Classes, Graphics, Controls; { Копирует прямоугольную область экрана } function CaptureScreenRect(ARect : TRect) : TBitmap; { Копирование всего экрана } function CaptureScreen : TBitmap; { Копирование клиентской области формы или элемента } function CaptureClientImage(Control : TControl) : TBitmap; { Копирование всей формы элемента } function CaptureControlImage(Control : TControl) : TBitmap; {===============================================================} implementation function GetSystemPalette : HPalette; var PaletteSize : integer; LogSize : integer; LogPalette : PLogPalette; DC : HDC; Focus : HWND; begin result:=0; Focus:=GetFocus; DC:=GetDC(Focus); try PaletteSize:=GetDeviceCaps(DC, SIZEPALETTE); LogSize:=SizeOf(TLogPalette)+(PaletteSize-1)*SizeOf(TPaletteEntry); GetMem(LogPalette, LogSize); try with LogPalette^ do begin palVersion:=$0300; palNumEntries:=PaletteSize; GetSystemPaletteEntries(DC, 0, PaletteSize, palPalEntry); end; result:=CreatePalette(LogPalette^); finally FreeMem(LogPalette, LogSize); end; finally ReleaseDC(Focus, DC); end; end; function CaptureScreenRect(ARect : TRect) : TBitmap; var ScreenDC : HDC; begin Result:=TBitmap.Create; with result, ARect do begin Width:=Right-Left; Height:=Bottom-Top; ScreenDC:=GetDC(0); try BitBlt(Canvas.Handle, 0,0,Width,Height,ScreenDC, Left, Top, SRCCOPY ); finally ReleaseDC(0, ScreenDC); end; Palette:=GetSystemPalette; end; end; function CaptureScreen : TBitmap; begin with Screen do Result:=CaptureScreenRect(Rect(0,0,Width,Height)); end; function CaptureClientImage(Control : TControl) : TBitmap; begin with Control, Control.ClientOrigin do result:=CaptureScreenRect(Bounds(X,Y,ClientWidth,ClientHeight)); end; function CaptureControlImage(Control : TControl) : TBitmap; begin with Control do if Parent=Nil then result:=CaptureScreenRect(Bounds(Left,Top,Width,Height)) else with Parent.ClientToScreen(Point(Left, Top)) do result:=CaptureScreenRect(Bounds(X,Y,Width,Height)); end; end. Наверх 43. Как менять разрешение экрана по ходу выполнения программы
var DeviceMode : TDevMode; begin with DeviceMode do begin dmSize:=SizeOf(DeviceMode); dmBitsPerPel:=16; dmPelsWidth:=640; dmPelsHeight:=480; dmFields:=DM_BITSPERPEL or DM_PELSWIDTH or DM_PELSHEIGHT; result:=False; if ChangeDisplaySettings(DeviceMode,CDS_TEST or CDS_FULLSCREEN) <> DISP_CHANGE_SUCCESSFUL then Exit; Result:=ChangeDisplaySettings(DeviceMode,CDS_FULLSCREEN) = DISP_CHANGE_SUCCESSFUL; end; end; procedure RestoreDefaultMode; var T : TDevMode absolute 0; begin ChangeDisplaySettings(T,CDS_FULLSCREEN); end; procedure TForm1.Button1Click(Sender: TObject); begin if setFullScreenMode then begin sleep(7000); RestoreDefaultMode; end; end; Наверх 44. Как поместить картинку из базы данных, например MsSQL, в компонент TIMAGE ?
2) в запросе Query.SQL пишется что-то вроде 'select Pict from sometable where somefield=somevalue' 3) запрос открывается 4) делается "присваивание": Image1.Picture.Assing(TBlobField(Query.FieldByName('Pict')) или, если известно, что эта картинка - Bitmap, то можно Image1.Picture.Bitmap.Assing(TBlobField(Query.FieldByName('Pict')) А можно воспользоваться компонентом TDBImage. Наверх 45. Как получить горизонтальную прокрутку (scrollbar) в ListBox?
procedure TForm1.FormCreate(Sender: TObject); begin ListBox1.Perform(LB_SETHORIZONTALEXTENT, 1000, Longint(0)); end; Второй параметр в вызове - ширина прокрутки в точках. Наверх 46. Как вставить еще несколько строк в середину StringGrid или после определенной строки?
По-видимому, надо добавить строк в конец, изменив Grid.RowCount, а потом раздвинуть строки циклом снизу вверх: Grid.Rows.Strings[i] := Grid.Rows.Strings[i - 1]; Или я бы сделал метод рисования этой таблицы, а данные хранил бы в отдельном stringList-е, там есть методы вставки, а вообще-то для этих целей предпочитаю DrawGrid: переопределяю метод onDrawCell, всё же объектная модель лучше и данные проще контролировать. Наверх 47. Пример получения позиции курсора из компоненты TMemo.
begin Memo1Click(Self); end; procedure TForm1.Memo1Click(Sender: TObject); VAR LineNum : LongInt; CharNum : LongInt; begin LineNum := Memo1.Perform(EM_LINEFROMCHAR, Memo1.SelStart, 0); CharNum := Memo1.Perform(EM_LINEINDEX, LineNum, 0); Label1.Caption := IntToStr(LineNum+1)+' : '+IntToStr((Memo1.SelStart-CharNum)+1); end; procedure TForm1.FormCreate(Sender: TObject); begin Memo1Click(Self); end; Наверх 48. Функция Undo в TMemo
Memo1.Perform(EM_UNDO,0,0); Узнать о том, возможна ли отмена (т.е. есть ли что отменять) можно следующим образом: UndoEnabled:=(Memo1.Perform(EM_CAUNDO,0,0)<>0); Наверх 49. Как прокрутить текст в Tmemo или в TRichEdit
Примерно так: SendMessage(Memo1.Handle, EM_LINESCROLL, 0, Memo1.Lines.Count-1); Наверх 50. Как определить работает ли уже данное приложение или это первая его копия?
Пример: procedure TForm1.FormCreate(Sender: TObject); begin {Проверяем есть ли указатель на предыдущую копию приложения} IF hPrevInst <> 0 THEN BEGIN {Если есть, то выдаем сообщение и выходим} MessageDlg('Программа уже запущена!', mtError, [mbOk], 0); Halt; END; {Иначе - ничего не делаем (не мешаем созданию формы)} end; P.S. Для выхода необходимо использовать Halt, а не Close, как хотелось бы, так как форма еще не создана и закрывать нечего. Есть и другой способ - по списку загруженных приложений procedure TForm1.FormCreate(Sender: TObject); VAR Wnd : hWnd; buff : ARRAY[0.. 127] OF Char; Begin Wnd := GetWindow(Handle, gw_HWndFirst); WHILE Wnd <> 0 DO BEGIN IF (Wnd <> Application.Handle) AND (GetWindow(Wnd, gw_Owner) = 0) THEN BEGIN GetWindowText (Wnd, buff, sizeof (buff )); IF StrPas (buff) = Application.Title THEN BEGIN MessageDlg('Приложение уже загружено', mtWarning, [mbOk], 0); Halt; END; END; Wnd := GetWindow (Wnd, gw_hWndNext); END; End; Еще один интересный способ для Win32. Дело в том, что можно в памяти создавать временные файлы. При перезагрузке они теряются, а так существуют. Кстати, этот метод можно использовать и для обмена информацией между вашими приложениями. Пример: program Project1; uses Windows, // Обязательно Forms, Unit1 in 'Unit1.pas' {Form1}; {$R *.RES} Const MemFileSize = 1024; MemFileName = 'one_inst_demo_memfile'; Var MemHnd : HWND; begin { Попытаемся создать файл в памяти } MemHnd := CreateFileMapping(HWND($FFFFFFFF), nil, PAGE_READWRITE, 0, MemFileSize, MemFileName); { Если файл не существовал запускаем приложение } if GetLastError<>ERROR_ALREADY_EXISTS then begin Application.Initialize; Application.CreateForm(TForm1, Form1); Application.Run; end; CloseHandle(MemHnd); end. Часто при работе у пользователя может быть открыто 5-20 окон и сообщение о том, что программа уже запущено приводит к тому, что он вынужден полчаса искать ранее запущенную копию. Выход из положения - найдя копию программы активировать ее, для чего в последнем примере перед HALT необходимо добавить строку : SetForegroundWindow(Wnd); Например так: program Project0; uses Windows, // !!! Forms, Unit0 in 'Unit0.pas' {Form1}; var Handle1 : LongInt; Handle2 : LongInt; {$R *.RES} begin Application.Initialize; Handle1 := FindWindow('TForm1',nil); if handle1 = 0 then begin Application.CreateForm(TForm1, Form1); Application.Run; end else begin Handle2 := GetWindow(Handle1,GW_OWNER); //Чтоб заметили :) ShowWindow(Handle2,SW_HIDE); ShowWindow(Handle2,SW_RESTORE); SetForegroundWindow(Handle1); // Активизируем end; end. Наверх 51. Обработка событий от клавиатуры
Внутри приложения это выполняется достаточно просто с помощью вызова функции Windows API SendMessage() (можно воспользоваться и методом Perform того объекта (или формы), кому посылается сообщение о нажатой клавише). Код Memo1.Perform(WM_CHAR, Ord('A'), 0); или SendMessage(Memo1.Handle, WM_CHAR, Ord('A'), 0); приведет к печати символа "A" в объекте Memo1. II. Перехват нажатий клавиши внутри приложения. Задача решается очень просто. Можно у формы установить свойство KeyPreview в True и обрабатывать событие OnKeyPress. Второй способ - перехватывать событие OnMessage для объекта Application. III. Перехват нажатия клавиши в Windows. Существуют приложения, которым необходимо перехватывать все нажатия клавиш в Windows, даже если в данный момент активно другое приложение. Это может быть, например, программа, переключающая раскладку клавиатуры, резидентный словарь или программа, выполняющая иные действия по нажатию "горячей" комбинации клавиш. Перехват всех событий в Windows (в том числе и событий от клавиатуры) выполняется с помощью вызова функции SetWindowsHook(). Данная функция регистрирует в системе Windows ловушку (hook) для определенного типа событий/сообщений. Ловушка - это пользовательская процедура, которая будет обрабатывать указанное событие. Основное здесь то, что эта процедура должна всегда присутствовать в памяти Windows. Поэтому ловушку помещают в DLL и загружают эту DLL из программы. Пока хоть одна программа использует DLL, та не может быть выгружена из памяти. Приведем пример такой DLL и программы, ее использующей. В примере ловушка перехватывает нажатие клавиш на клавиатуре, проверяет их и, если это клавиши "+" или "-", посылает соответствующее сообщение в конкретное приложение (окно). Окно ищется по имени его класса ("TForm1") и заголовку (caption, "XXX"). {текст библиотеки} library SendKey; uses WinTypes, WinProcs, Messages; const {пользовательские сообщения} wm_NextShow_Event = wm_User + 133; wm_PrevShow_Event = wm_User + 134; {handle для ловушки} HookHandle: hHook = 0; var SaveExitProc : Pointer; {собственно ловушка} function Key_Hook(Code: integer; wParam: word; lParam: Longint): Longint; export; var H: HWND; begin {если Code>=0, то ловушка может обработать событие} if Code >= 0 then begin {это те клавиши?} if ((wParam = VK_ADD)or(wParam = VK_SUBTRACT)) and (lParam and $40000000 = 0) then begin {ищем окно по имени класса и по заголовку} H := FindWindow('TForm1', 'XXX'); {посылаем сообщение} if wParam = VK_ADD then SendMessage(H, wm_NextShow_Event, 0, 0) else SendMessage(H, wm_PrevShow_Event, 0, 0); end; {если 0, то система должна дальше обработать это событие} {если 1 - нет} Result:=0; end else {если Code<0, то нужно вызвать следующую ловушку} Result := CallNextHookEx(HookHandle,Code, wParam, lParam); end; {при выгрузке DLL надо снять ловушку} procedure LocalExitProc; far; begin if HookHandle<>0 then begin UnhookWindowsHookEx(HookHandle); ExitProc := SaveExitProc; end; end; {инициализация DLL при загрузке ее в память} begin {устанавливаем ловушку} HookHandle := SetWindowsHookEx(wh_Keyboard, Key_Hook, hInstance, 0); if HookHandle = 0 then MessageBox(0, 'Unable to set hook!', 'Error', mb_Ok) else begin SaveExitProc := ExitProc; ExitProc := @LocalExitProc; end; end. Размер такой DLL в скомпилированном виде будет около 3Кб, поскольку в ней не используются объекты из VCL. Далее приведен код модуля в Delphi, который загружает DLL и обрабатывает сообщения от ловушки, просто отображая их в Label1. unit Unit1; interface uses SysUtils,WinTypes,WinProcs,Messages,Classes,Graphics,Controls,Forms,Dialogs,StdCtrls; {пользовательские сообщения} const wm_NextShow_Event = wm_User + 133; wm_PrevShow_Event = wm_User + 134; type TForm1 = class(TForm) Label1: TLabel; procedure FormCreate(Sender: TObject); private {обработчики сообщений} procedure WM_NextMSG (Var M : TMessage); message wm_NextShow_Event; procedure WM_PrevMSG (Var M : TMessage); message wm_PrevShow_Event; end; var Form1: TForm1; P : Pointer; implementation {$R *.DFM} {загрузка DLL} function Key_Hook : Longint; far; external 'SendKey'; procedure TForm1.WM_NextMSG (Var M : TMessage); begin Label1.Caption:='Next message'; end; procedure TForm1.WM_PrevMSG (Var M : TMessage); begin Label1.Caption:='Previous message'; end; procedure TForm1.FormCreate(Sender: TObject); begin {если не использовать вызов процедуры из DLL в программе, то компилятор удалит загрузку DLL из программы} P:=@Key_Hook; end; end. Конечно, свойство Caption в этой форме должно быть установлено в "XXX". Наверх 52. Как сделать так, что при нажатии на Enter происходил переход к следующему элементу формы
procedure TForm1.FormKeyPress(Sender: TObject; var Key: Char); begin if (Key = #13) then begin Key:=#0; Perform(WM_NEXTDLGCTL,0,0); end; end; Наверх 53. Перетаскивание файла drag-drop
и он будет открыт } unit Unit1; interface uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,StdCtrls, ShellAPI {обязательно!}; type TForm1 = class(TForm) Memo1: TMemo; FileNameLabel: TLabel; procedure FormCreate(Sender: TObject); procedure FormDestroy(Sender: TObject); protected {Это и есть самая главная процедура} procedure WMDropFiles(var Msg: TMessage); message wm_DropFiles; end; var Form1: TForm1; implementation {$R *.DFM} procedure TForm1.WMDropFiles(var Msg: TMessage); var Filename: array[0 .. 256] of Char; Count : integer; begin { Получаем количество файлов (просто пример) } nCount := DragQueryFile( msg.WParam, $FFFFFFFF, acFileName, cnMaxFileNameLen); { Получаем имя первого файла } DragQueryFile( THandle(Msg.WParam), 0, { это номер файла } Filename,SizeOf(Filename) ) ; { Открываем его } with FileNameLabel do begin Caption := LowerCase(StrPas(FileName)); Memo1.Lines.LoadfromFile(Caption); end; { Отдаем сообщение о завершении процесса } DragFinish(THandle(Msg.WParam)); end; procedure TForm1.FormCreate(Sender: TObject); begin { Говорим Windows, что на нас можно бросать файлы } DragAcceptFiles(Handle, True); end; procedure TForm1.FormDestroy(Sender: TObject); begin { Закрываем за собой дверь золотым ключиком} DragAcceptFiles(Handle, False); end; end. Наверх 54. Привлечение внимания к окну
procedure TForm1.Timer1Timer(Sender: TObject); begin FlashWindow(Handle,true); end; В данном примере FlashWindow вызывается по таймеру ежесекундно, что приводит к миганию заголовка окна. Наверх 55. Заставка для программы
Сделать это не сложно: 1. Создаете форму (например SplashForm). 2. Объявляете ее свободной (availableForms). 3. В Progect Source вставляете следующее (например): program Splashin; uses Forms, Main in 'MAIN.PAS', Splash in 'SPLASH.PAS' {$R *.RES} begin try SplashForm := TSplashForm.Create(Application); SplashForm.Show; SplashForm.Update; Application.CreateForm(TMainForm, MainForm); SplashForm.Hide; finally SplashForm.Free; end; Application.Run; end. И форма SplashForm держится на экране пока выполняется Create в главной форме. Но иногда она появляется и пропадает очень быстро, поэтому нужно сделать задержку: 1. Добавляете на форму таймер с событием: procedure TSplashForm.Timer1Timer(Sender: TObject); begin Timer1.Enabled := False; end; 2. Событие onCloseQuery для формы: procedure TSplashForm.FormCloseQuery(Sender: TObject; var CanClose: Boolean); begin CanClose := Not Timer1.Enabled; end; 3. И перед SplashForm.Hide; ставите цикл: repeat Application.ProcessMessages; until SplashForm.CloseQuery; 4. Все! Осталось установить на таймере период задержки 3-4 секунды. 5. На последок, у такой формы желательно убрать Caption: SetWindowLong (Main.Handle,GWL_STYLE, GetWindowLong(Main.Handle, GWL_STYLE) AND NOT WS_CAPTION OR WS_SIZEBOX); Наверх 55. Как получить короткий путь файла если имеется длинный ("c:\Program Files" ==> "c:\progra~1")
Наверх 56. Как создать свою кнопку в заголовке формы (на Caption Bar)
Пример. unit Main; interface uses Windows, Buttons, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs; type TForm1 = class(TForm) procedure FormResize(Sender: TObject); private CaptionBtn : TRect; procedure DrawCaptButton; procedure WMNCPaint(var Msg : TWMNCPaint); message WM_NCPaint; procedure WMNCActivate(var Msg : TWMNCActivate); message WM_NCACTIVATE; procedure WMSetText(var Msg : TWMSetText); message WM_SETTEXT; procedure WMNCHitTest(var Msg : TWMNCHitTest); message WM_NCHITTEST; procedure WMNCLButtonDown(var Msg : TWMNCLButtonDown); message WM_NCLBUTTONDOWN; public { Public declarations } end; var Form1: TForm1; implementation const htCaptionBtn = htSizeLast + 1; {$R *.DFM} procedure TForm1.DrawCaptButton; var xFrame, yFrame, xSize, ySize : Integer; R : TRect; begin //Dimensions of Sizeable Frame xFrame := GetSystemMetrics(SM_CXFRAME); yFrame := GetSystemMetrics(SM_CYFRAME); //Dimensions of Caption Buttons xSize := GetSystemMetrics(SM_CXSIZE); ySize := GetSystemMetrics(SM_CYSIZE); //Define the placement of the new caption button CaptionBtn := Bounds(Width - xFrame - 4*xSize + 2, yFrame + 2, xSize - 2, ySize - 4); //Get the handle to canvas using Form's device context Canvas.Handle := GetWindowDC(Self.Handle); Canvas.Font.Name := 'Symbol'; Canvas.Font.Color := clBlue; Canvas.Font.Style := [fsBold]; Canvas.Pen.Color := clYellow; Canvas.Brush.Color := clBtnFace; try DrawButtonFace(Canvas, CaptionBtn, 1, bsAutoDetect, False, False, False); //Define a smaller drawing rectangle within the button R := Bounds(Width - xFrame - 4 * xSize + 2, yFrame + 3, xSize - 6, ySize - 7); with CaptionBtn do Canvas.TextRect(R, R.Left + 2, R.Top - 1, 'W'); finally ReleaseDC(Self.Handle, Canvas.Handle); Canvas.Handle := 0; end; end; procedure TForm1.WMNCPaint(var Msg : TWMNCPaint); begin inherited; DrawCaptButton; end; procedure TForm1.WMNCActivate(var Msg : TWMNCActivate); begin inherited; DrawCaptButton; end; procedure TForm1.WMSetText(var Msg : TWMSetText); begin inherited; DrawCaptButton; end; procedure TForm1.WMNCHitTest(var Msg : TWMNCHitTest); begin inherited; with Msg do if PtInRect(CaptionBtn, Point(XPos - Left, YPos - Top)) then Result := htCaptionBtn; end; procedure TForm1.WMNCLButtonDown(var Msg : TWMNCLButtonDown); begin inherited; if (Msg.HitTest = htCaptionBtn) then ShowMessage('You hit the button on the caption bar'); end; procedure TForm1.FormResize(Sender: TObject); begin //Force a redraw of caption bar if form is resized Perform(WM_NCACTIVATE, Word(Active), 0); end; end. Наверх 57. Преобразование текста OEM у AnsiЭта версия работает под любым Delphi. (Начиная с Delphi 2, это можно записать короче с использованием AnsiToOem и OemToAnsi.) Здесь все просто. function ConvertAnsiToOem(const S : string) : string; { ConvertAnsiToOem translates a string into the OEM-defined character set } {$IFNDEF WIN32} var Source, Dest : array[0..255] of Char; {$ENDIF} begin {$IFDEF WIN32} SetLength(Result, Length(S)); if Length(Result) > 0 then AnsiToOem(PChar(S), PChar(Result)); {$ELSE} if Length(Result) > 0 then begin AnsiToOem(StrPCopy(Source, S), Dest); Result := StrPas(Dest); end; {$ENDIF} end; { ConvertAnsiToOem } function ConvertOemToAnsi(const S : string) : string; { ConvertOemToAnsi translates a string from the OEM-defined character set into either an ANSI or a wide-character string } {$IFNDEF WIN32} var Source, Dest : array[0..255] of Char; {$ENDIF} begin {$IFDEF WIN32} SetLength(Result, Length(S)); if Length(Result) > 0 then OemToAnsi(PChar(S), PChar(Result)); {$ELSE} if Length(Result) > 0 then begin OemToAnsi(StrPCopy(Source, S), Dest); Result := StrPas(Dest); end; {$ENDIF} end; { ConvertOemToAnsi } Наверх 58. Состояние кнопки insert (Insert/Overwrite)
{ Returns the status of the Insert key. } {------------------------------------------} function InsertOn: Boolean; begin if LowOrderBitSet(GetKeyState(VK_INSERT)) then InsertOn := true else InsertOn := false end; Наверх 59. IRC клиент на Delphi
Если помнишь, пару месяцев назад я предложил читателям придумать свою тему для кодинга. И, соответственно, удовлетворить самые популярные требования в своей статье. Настало время воплотить этот план в жизнь. Сегодня мне в руки попало письмо от "ViT" (noginsk@rambler.ru). Он предложил мне рассказать о создании своего IRC-клиента с использованием компонента ActiveIRC. Что ж, я просто не могу ему отказать :). На самом деле, есть много способов написания IRC-клиента. Во-первых, это прямая работа с IRC-протоколом. Дело весьма напряжное, и помочь в нем тебе сможет либо старый добрый Indy, либо библа WSocket из комплекта интернет-компонентов ICS (Internet Component Suite). Собственно, если посмотреть на www.torry.net/irc.htm - список наиболее популярных IRC-компонентов, можно обнаружить, что большая их часть именно так и поступает - использует Indy либо WSocket. Заметь, при этом они не стесняются требовать у тебя десятки долларов за использование их софта. Компонент ActiveIRC лишен этого недостатка, поэтому именно про него я сегодня и расскажу. ActiveIRC Component ----------------------------------------------- Представляет он собой обычный бесплатный ActiveX компонент. В поставку компонента входит файл "ActiveIRC installer.exe" плюс документация. По большому счету, никакой документации к нему и не требуется - все предельно ясно, но для интереса можно и ознакомиться - там есть описание нескольких полезных функций. После запуска обозначенного exe-файла тут же появится сообщение... об удачной установке. Но радоваться еще рано, т.к. если ты запустишь Delphi и откроешь в компонентах вкладку "ActiveX", то, разумеется, ничего не найдешь. Почему? Да потому, что разбаловались Вы, батенька, и привыкли, что инсталлятор делает все за Вас. На самом же деле он только переносит свой OCX файл в WINDOWSSYSTEM, а регистрировать его придется уже ручками: component -> import ActiveX control -> ActiveIrc ActiveX -> выбрать файл Activeirc.ocx из системного каталога и инсталлировать его. Теперь он появится во вкладке ActiveX, и его можно смело класть на форму. Create form Наша форма будет довольно простой, состоящей из следующих элементов: 4 компонента Edit, 4 Кнопки, 3 Label, 1 Memo и собственно сам ActiveIRC. Результат формы смотри на рис.1. А теперь проставим названия: Label1 - свойство "caption" - "Сервер:" Label2 - свойство "caption" - "Порт:" Label3 - свойство "caption" - "Ник:" Button1 - свойство "caption" - "CONNECT" Button2 - свойство "сaption" - "JOIN" Button3 - свойство "caption" - "Leave" Button4 - свойство "caption" - "Сказать" Label'ы 1-3 будут сопровождать соответствующие Edit'ы. Также можешь создать Edit'ы для ввода других данных, которые могут тебе понадобиться. Для них существуют свойства Email, FullName и Ident (в последнем обычно прописано "localhost"). У каждой кнопки есть свой caption. Он соответствует назначению каждой кнопки. Например, Button1 - CONNECT, отвечает за соединение с сервером. JOIN - зайти на канал. В общем-то, можно обойтись и без батонов - вместо них написать обработчик OnKeyDown для Edit4 (в нем мы будем писать наши сообщения). Например, обработка команды "/JOIN #LOVE" сведется к удалению из строки всех символов от "/" до "#" и запуску процедуры: ActiveIrc1.Join ('#LOVE');. Коннект и общение ------------------------------------------------ Для коннекта к серверу и передачи данных о пользователе мы с тобой слепили кнопку "CONNECT". Давай посмотрим на ее событие OnClick: ActiveIrc1.server:= edit1.Text; ActiveIrc1.port:= strtoint (edit2.text); ActiveIrc1.nick:= edit3.Text; ActiveIrc1.Connect; Правда, здесь я прописываю не все свойства, а только те, без которых трудно обойтись. Далее вызовом метода Connect запускаем процесс соединения. Как ты, наверное, догадался, главным компонентом у нас будет Memo1. Именно в нем будут отображаться все сообщения. А поскольку каждое сообщение - это уже событие (я имею в виду Event), давай создадим необходимые обработчики: OnConsole - как только ты получаешь очередную порцию данных, например, служебная инфа от сервера, активизируется это событие. Единственное, что оно может дать - это переменную text, содержащую в себе само сообщение, поэтому пиши: memo1.lines.add (text);. OnIRCReady - когда IRC-сервак будет готов принимать твои команды и свойство IsConnected примет значение TRUE, вызывается этот Event. В его обработчик достаточно написать, допустим, уведомление об этом: Memo1.Lines.Add ('Готов к труду и обороне!');. OnMessage - сообщение, отправленное любым пользователем на канале, активирует этот Event. Естественно, что и возвращает он нам: channel - имя канала, user - ник юзера, text - собственно само сообщение. В его обработчик я написал: memo1.Lines.Add('('+channel+')'+user+'> '+text);. Заметь, что в этом случае к каждой мессаге будет приплюсовываться имя канала, с которого она отправлена. Это необходимо, если пользователь беседует на нескольких каналах, а при этом для чата используется всего одно окно. Вот пример такого сообщения: (#Xakep)Petrovis> Да, наш админ тоже этим страдает :). OnPrivateMessage - если какой-нибудь пользователь соизволил сделать на тебя /msg, т.е. отправить личное сообщение, придется обработать этот Event. Как это сделать - решать тебе (тут большой простор для фантазии, особенно для бывалого скриптера), но я сделал просто: memo1.Lines.Add('Приват от '+user+'--> '+text);. OnUserJoins - в его обработчик ты можешь записать реакцию на приджойнившегося к каналу юзера. Я сделал простое уведомление: memo1.Lines.Add('Пришел товарищ '+user+' на канал: '+channel+'!'); Ничто не мешает тебе сделать автоматическое приветствие в духе: if User = 'Petya' then ActiveIRC.Say (Edit5.text, 'Привет, уважаемый! Давно ждал тебя :)'); OnUserKick - когда скрипты только входили в моду, это событие было крайне необходимо для любителей сетевых разборок. После того как на канале кто-то кого-то кикнет, в твое распоряжение поступят константы: channel - канал, kickedby - имя обидчика, UserKicked - имя обиженного, Reason - основание. Как реагировать на это событие - решать тебе. OnUserQuits - твоя реакция на чей-то уход с канала. В этом событии содержится имя покинувшего IRC-сервер пользователя. События изучили, теперь перейдем к самому кодингу. Начнем с OnClick для кнопки "JOIN": ActiveIrc1.Join(edit5.Text), а в OnClick для "LEAVE", соответственно - ActiveIrc1.Leave;. Чтобы послать сообщение на канал или лично юзеру, нам понадобится кнопка "Сказать". Строчка ActiveIrc1.Say(edit5.Text,edit4.Text); позволит отправить на канал сообщение из Edit5 (Edit4 - это имя канала), но если первым аргументом будет прописан чей-то ник, то у этого пользователя откроется окно с приват-сообщением. Полезные функции ------------------------------------------------- Помимо той основы, что я описал, у этого компонента присутствуют еще несколько интересных функций: boolean Raw(string: command) - напрямую отправляет команду IRC-серверу без обработки ActiveIRC. В случае успеха возвращает TRUE. boolean CTCPRequest(string nick, string ctcp, string info) - направляет пользователю CTCP-запрос. Очень поможет, если тебе захочется узнать: VERSION - версию его IRC-софта. PING - пинг к юзеру. TIME - локальное время юзера. Действительно, это бывает полезным, особенно если ты любишь разговаривать с иностранцами. boolean CTCPReply(string nick, string ctcp, string reply) - отвечает на CTCP-запрос. boolean GetChannelMode(string channel, string mode) - возвращает тебе режим, в котором работает канал. Например: i - invite only. Если ты не относишься к приглашенным - извини. Вход закрыт. M - Moderated. N - No external messages. T - только ОПы могут устанавливать темы. boolean GetUserMode(string channel, string user, string mode); - то же самое, но для пользователя. В данном случае он может быть либо о (ОП), либо v (войс). И вновь продолжается бой! ------------------------------------------------- Что ж, теперь у тебя в руках есть все необходимое. Осталось только напрячь свою фантазию, сделать красивый интерфейс и выложить полученный результат в инет для общего скачивания. Не будь жадным - выкладывай все бесплатно, а по возможности давай и сорсы. Так у тебя больше шансов быть замеченным. Вдруг ты задвинешь mIRC своим супернавороченным клиентом :). Альтернативный вариант ------------------------------------------------- Как я уже говорил, этот компонент далеко не единственный. Их довольно много, правда, практически все они плохие. Но один из них все-таки стоит выделить - компонент XiRC от простого мексиканского парня Martin Bleakley. Дело в том, что этот господин выбрал верный путь - он программил свой компонент с использованием Indy 8.0. Это его первый компонент и к тому же freeware. Качай его с http://www.torry.net/vcl/internet/irc/mbxirc.zip , т.к. собственный сайт и мейл этого господина накрылись еще года полтора назад, и все мои попытки сказать ему пару ласковых не увенчались успехом. К компоненту прилагаются 2 демы, причем вторая - практически готовый IRC-клиент. Но учти, что работать он у тебя не будет. Просто потому, что Мартин забыл сказать, что для его оформления он использовал компоненты FlatStyle (их я тоже положил на диск, а вообще их можно качать с www.torry.net/vcl/packs/interfacemiddle/flatstyl.zip). Эта коллекция - просто красивые аналоги дельфийских компонентов, но их отсутствие грозит тебе изрядными проблемами с запуском его демы. Наверх 60. Работа с Word'om в Делфи
60.2 Программирование закладок в Word с помощью Delphi 60.3 MS Word и рисование 60.1 Запуск MS Word из Delphi =============================================================== Инициализация и запуск --------------------------------------------------------------- Во-первых, в разделе uses нужно подключить модуль ComObj. Во-вторых объявляем переменную типа variant для обращения к MS Word. Инициализацию и запуск MS Word иллюстрирует следующий пример: uses ComObj; ... procedure RunWord; var Word: variant; begin try Word := CreateOleObject('Word.Application'); except ShowMessage('Не могу запустить MS Word'); end; end; // отображение на экране MsWord.Visible := True; // создание нового документа MsWord.Documents.Add; // открытие существующего документа MsWord.Documents.Open('c:\test.doc'); Добавление (запись) текста в документ MS Word --------------------------------------------------------------- Все покажу на примере: Word.Selection.TypeText(Text:=MyText); // где MyText - переменная, хранящая текст для записи в документ. Word.Selection.TypeParagraph; // добавление нового абзаца Стоит заметить, что запись текста производится в место позиционирования курсора. По умолчанию это начало документа. Чтение текста из документа MS Word --------------------------------------------------------------- С помощью команды Word.Selection мы можем считать символ стоящий после курсора, либо, если выполнено выделение, выделенный фрагмент текста. MyText:= Word.Selection; // где MyText - переменная для хранения считанных данных Для передвижения курсора по тексту документа можно использовать следующий набор команд: Word.Selection.MoveRight; // передвинуть курсор на символ вправо Word.Selection.MoveLeft; // передвинуть курсор на символ влево Word.Selection.MoveUp; // на строку вверх Word.Selection.MoveDown; // на строку вниз Выход (закрытие) MS Word --------------------------------------------------------------- Если есть открытый активный документ, то закрытие документа осуществляется следующим образом: // выход без сохранения MsWord.ActiveDocument.Close(SaveChanges:=0); А затем закрываем приложение MsWord.Quit; Удачной работы! Автор статьи: Нечаев Андрей Сайт автора: http://nech.tamb.ru 60.2 Программирование закладок в Word с помощью Delphi =============================================================== Закладка - это элемент документа, которому присвоено уникальное имя. Это имя можно использовать для последующих ссылок. Например, можно использовать закладку для определения текста, который необходимо проверить (вставить, заменить) позже. Ниже представлен программный код, позволяющий устанавливать, удалять закладки, а так же осуществлять переход к существующей закладке. Естественно, перед применением описанных команд, нужно выполнить инициализацию переменной Word, а затем открыть или создать новый документ. Подробнее смотри выши 1. Добавление закладки --------------------------------------------------------------- Word.ActiveDocument.Bookmarks.Add(BookMarkName); где BookMarkName - переменная типа string, содержащая имя закладки. 2. Переход к закладке --------------------------------------------------------------- Переход к закладке можно осуществить по ее имени: Word.ActiveDocument.Bookmarks.Item(BookMarkName).Select; либо по порядковому номеру: Word.ActiveDocument.Bookmarks.Item(1).Select; 3. Удаление закладки --------------------------------------------------------------- Удаление производится аналогично переходу к закладке, соответственно, можно использовать два варианта: через имя или индекс закладки. Word.ActiveDocument.Bookmarks.Item(BookMarkName).Delete; Word.ActiveDocument.Bookmarks.Item(1).Delete; 4. Отображение закладок в документе --------------------------------------------------------------- Word.ActiveWindow.View.ShowBookmarks:=True; // отобразить закладки Word.ActiveWindow.View.ShowBookmarks:=False; // скрыть закладки 5. Скрытые (зарезервированные) закладки --------------------------------------------------------------- MS Word автоматически устанавливает следующие закладки: \StartOfDoc - начало документа; \EndOfDoc - конец документа; \Sel - переход к текущей позиции ввода. Например, переход в начало документа. Word.ActiveDocument.Bookmarks.Item('\StartOfDoc').Select; Примечания: Название закладки должно начинаться с буквы. Чтобы отобразить закладки в документе, выберите в Word в меню Сервис команду Параметры, а затем на вкладке Вид установите флажок Закладки. Автор статьи: Нечаев Андрей Сайт автора: http://nech.tamb.ru 60.2 MS Word и рисование =============================================================== В статье рассмотрены основные способы рисования из Delphi на листе MS Word. 0. Запуск MS Word --------------------------------------------------------------- Подключаем необходимый для работы модуль и объявляем переменную: uses ComObj; ... var MsWord: variant; Запускаем MS Word и показываем на экране: MsWord:= CreateOleObject('Word.Application'); MsWord.Visible := True; Создание нового документа: MsWord.Documents.Add; 1. Линия --------------------------------------------------------------- Рисуем линию в документе MS Word на текущем листе: MsWord.ActiveDocument.Shapes.AddLine(x1, y1, x2, y2); где x1, y1 - координаты начала, а x2, y2 - координаты конца линии. Линия, выделенная для редактирования (форматирования): MsWord.ActiveDocument.Shapes.AddLine(x1, y1, x2, y2).Select; 2. Прямоугольник --------------------------------------------------------------- MsWord.ActiveDocument.Shapes.AddShape(1, x1, y1, x2, y2); где x1,y1,x2,y2 - координаты прямоугольника. 3. Произвольная фигура --------------------------------------------------------------- (или автофигура в терминологии MS Word) В общем случае, произвольная фигура рисуется так: MsWord.ActiveDocument.Shapes.AddShape(i, x1, y1, x2, y2); где i: номер фигуры (соответствует порядку следования фигур в MS Word на панели рисования), x1, y1, x2, y2 координаты прямоугольника в который будет вписан объект. 4. Вставка картинки (произвольного изображения) в текущее положение курсора --------------------------------------------------------------- MsWord.Selection.InlineShapes.AddPicture(FileName:='C:\WINDOWS\Пузыри.bmp', LinkToFile:=False, SaveWithDocument:=True); При выполнении данной команды нужно определить следующие праметры: FileName - путь к графическому файлу; LinkToFile - булевский флаг, указывающий на необходимость связи с источником; SaveWithDocument - булевский флаг, указывающий на свойства рисунка при сохранении документа. 5. Манипулцяции (форматирование) с фигурами --------------------------------------------------------------- Выбор фигуры можно осуществить следующим образом: MsWord.ActiveDocument.Shapes.item(n).Select; где n - порядковй номер фигуры. Заливка фона текущей фигуры MsWord.Selection.ShapeRange.Fill.ForeColor.RGB:=RGB(r, g, b); где r, g, b - соответственно красная, зеленая и синяя составляющая цвета. Толщина линий текущей фигуры MsWord.Selection.ShapeRange.Line.Weight:=5; Цвет линии текущей фигуры MsWord.Selection.ShapeRange.Line.ForeColor.RGB:=RGB(r, g, b); Группировка фигур MsWord.ActiveDocument.Shapes.Range(VarArrayOf(['3', '5', '8'])).group; где 3, 5, 8 - порядковый номер фигуры. 6. Блокировка механизма вывода на экран отрисовки --------------------------------------------------------------- В случае, если вы не хотите наблюдать как на листе отрисовываются ваши манипуляции с графическими объектами, то можно воспользоваться ниже приведенными командами. // Выключение обновления экрана MsWord.ScreenUpdating := False; // Обновление экрана MsWord.Application.ScreenRefresh; // Включение обновления экрана MsWord.ScreenUpdating := True; Примечания: Рисование осуществляется на актвином листе. Координаты действуют только для текущего листа. Удачной работы! Автор статьи: Нечаев Андрей Сайт автора: http://nech.tamb.ru Наверх 61. Вывод диалога для выбора каталога - Делфиuses ShellAPI, ShlObj; ... 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; Наверх 62. Как спрятать кнопки в заголовке окна - Делфи
var Style: Longint; begin Style := GetWindowLong(Handle, GWL_STYLE); SetWindowLong(Handle, GWL_STYLE, Style and not WS_SYSMENU); end; Наверх 63. Сколько файлов есть в определённой папке - Делфи
var fs: TSearchRec; begin Result := 0; if FindFirst(Dir + '\*.htm', faAnyFile - faDirectory - faVolumeID, fs) = 0 then repeat inc(Result); until FindNext(fs) <> 0; FindClose(fs); end; Наверх 64. Выключение монитора - Делфи
begin if off = true then SendMessage(hWnd,wm_SysCommand, SC_MonitorPower, 1) else SendMessage(hWnd,wm_SysCommand, SC_MonitorPower, 0); end; Наверх 65. Как с помощью Проводника открыть конкретный каталог? - Делфи
procedure TForm1.Button1Click(Sender: TObject); begin ShellExecute(0, 'explore', 'C:\WINDOWS', nil, nil, SW_SHOWNORMAL); end; Наверх 66. Запуск приложения - Делфи
Наверх | ||
