Чтиво - Программирование На Delphi

[Sascha]

Чтиво - программирование на Delphi

01. Узнаем путь к Windows и System32 в Delphi

var
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. Как получить путь к запущенной программе из нее самой?

Application.EXEName

03. Каким образом можно убрать приложение из Task Bar?

ShowWindow(Application.Handle,SW_HIDE);

04. Как можно сделать форму прозрачной?

Для этого необходимо пеpеопpеделить обpаботчик события OnCreate:

procedure TForm1.FormCreate(Sender: TObject);
begin
Brush.Style:=bsClear;
end;

05. Как рисовать прямо на экране?

Procedure DrawOnScreen;
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. Как использовать анимированные курсоры в программе?

procedure TForm1.Button1Click(Sender: TObject);
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. Как скопировать файл?

Эта процедура позволяет скопиpовать как весь файл пpи From и Count = 0, так и пpоизвольный его кусок.

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. Как скопировать директорию с файлами?

unit FilesOp;

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. Как программно создать ярлык?

uses ShlObj, ComObj, ActiveX;

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, но и за любое другое место?

TForm1 = class(TForm)
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?

function GetWinVersion: string;
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

В Delphi 2 и выше появился объект TRegistry при помощи которого очень просто работать с реестром. Но мы здесь рассмотрим функции API, которые доступны и в 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 файлами.

Почему иногда лучше использовать 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. Как выдать текст под наклоном?

Чтобы вывести под любым углом текст необходимо использовать TrueType Fonts (например "Arial"). Например:

var
LogFont : TLogFont;

...
GetObject(Canvas.Font.Handle, SizeOf(TLogFont), @LogFont);
{ Вывести текст 1/10 градуса против часовой стрелки }
LogFont.lfEscapement := Angle*10;
Canvas.Font.Handle := CreateFontIndirect(LogFont);

15. Как экспортировать таблицу базы данных в ASCII-файл?

procedure TMyTable.ExportToASCII;

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.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.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-поля?

Следующая функция поможет определить размер BLOB-поля.

Function GetBlobSize(Field: TBlobField): LongInt;
begin
with TBlobStream.Create(Field, bmRead) do
try
Result := Seek(0, 2);
finally
Free;
end;
end;

17. Как сравнить bookmarks в таблице?

function TBDEDirect.CompareBookmarks(Bookmark1,
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 другим цветом?

Необходимо обработать событие "OnDrawCellData". Например для того, чтобы пометить выбранное окошко красным фоном, необходимо сделать следующее:

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. Как закрыть окно подсказки если пользователь закончил приложение?

procedure TMainForm.FormClose(Sender: TObject;
var Action: TCloseAction);
begin
Winhelp(Handle, 'WINHELP.HLP', HELP_QUIT, 0);
Action := caFree;
end;

20. Как установить количество цветов в системной палитре?

Функция GetNumColors возвращает количество цветов для актуально выбранного разрешения экрана.

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. Как через индекс обратиться к нескольким компонентам?

Чтобы найти и сделать видимыми, например, компоненты с именами от "Label1" и до "Label5" можно использовать следующий вариант:

for t := 1 to 5 do
FindComponent('Label' + IntToStr(t)).Visible := TRUE;

22. Как копировать и вставлять Bitmap через буфер обмена?

Некоторые функции для копирования и вставки 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. Как выяснить положение курсора в МЕМО?

Необходимо вызвать дважды API-функцию "SendMessage":

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. Как проверять корректность доступа к базе данных?

Следующая функция проверяет доступ к базе данных и выдает возможные причины, если доступ не удается осуществить. Функция возвращает значение True в случае успешной операции и False в противном случае.

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. Как узнать, находится ли дискета в дисководе?

type
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-файла во время работы приложения

uses DB, DBTables, StdCtrls;

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. Как узнать имя компьютера?

Function ReadComputerName:string;
var
i:DWORD;
p:PChar;
begin
i:=255;
GetMem(p, i);
GetComputerName(p, i);
Result:=String(p);
FreeMem(p);
end;

31. Как изменить имя компьютера?

SetComputerName(PChar(Edit1.text));

32. Работа с корзиной в Windows

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. Как сменить обои на рабочем столе?

program change;
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
{ 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. Как выключить звук?

uses
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',

); 
end; 

// Example: 

procedure TForm1.Button1Click(Sender: TObject); 
begin 
SetMasterMuteValue(0, CheckBox1.Checked); // Mixer device #0 mute on/off 
end;

[COLOR=#59b300]36. Flash SWF --> EXE[/COLOR]


function 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; 
[COLOR=#59b300]
37. CopyFile для Linux[/COLOR]

Function CopyFile(Org, Dest:string):boolean; 
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; 

[COLOR=#59b300]38.Перетаскивание файла[/COLOR]

{ На эту форму можно бросить файл (например из проводника) и он будет открыт }
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.

[COLOR=#59b300]39.Список всех запущенных приложений[/COLOR]

Для того, чтобы получить список всех запущенных приложений, поместите на форму ListBox и Button, обработчик события которой должен иметь примерно такой вид. 

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;

[COLOR=#59b300]40. Как закрыть приложение или как завершить указанный процесс?[/COLOR]

В данном примере мы закрываем нашу любимую Аську(ICQlite.exe)
winexec('Cmd /x/c taskkill /f /im ICQlite.exe',SW_SHOWMINIMIZED);

[COLOR=#59b300]41. Вставить какую-нибудь программу внутрь EXE файла[/COLOR]

1. Пишем в блокноте RC-файл, куда прописываем все нужные нам программы, например:
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;

[COLOR=#59b300]42. Копирование экрана[/COLOR]


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.

[COLOR=#59b300]43. Как менять разрешение экрана по ходу выполнения программы[/COLOR]

function SetFullscreenMode:Boolean;
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;

[COLOR=#59b300]44. Как поместить картинку из базы данных, например MsSQL, в компонент TIMAGE ?[/COLOR]

1) Предполагается, что поле BLOB (например, Pict)
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.

[COLOR=#59b300]45. Как получить горизонтальную прокрутку (scrollbar) в ListBox?[/COLOR]

Так же как в случае с TMemo, здесь можно использовать сообщения. Например, сообщение может быть отослано в момент создания формы:

procedure TForm1.FormCreate(Sender: TObject);
begin
ListBox1.Perform(LB_SETHORIZONTALEXTENT, 1000, Longint(0));
end;

Второй параметр в вызове - ширина прокрутки в точках.

[COLOR=#59b300]46. Как вставить еще несколько строк в середину StringGrid или после определенной строки?[/COLOR]

Имеется StringGrid с n-ым количеством строк. Как вставить еще несколько строк в середину StringGrid или после определенной строки? 
По-видимому, надо добавить строк в конец, изменив Grid.RowCount, а потом раздвинуть строки циклом снизу вверх:
Grid.Rows.Strings[i] := Grid.Rows.Strings[i - 1]; 

Или я бы сделал метод рисования этой таблицы, а данные хранил бы в отдельном stringList-е, там есть методы вставки, а вообще-то для этих целей предпочитаю DrawGrid: переопределяю метод onDrawCell, всё же объектная модель лучше и данные проще контролировать. 

[COLOR=#59b300]47. Пример получения позиции курсора из компоненты TMemo.[/COLOR]

procedure TForm1.Memo1KeyUp(Sender: TObject; var Key: Word; Shift: TShiftState);
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;

[COLOR=#59b300]48. Функция Undo в TMemo[/COLOR]

В компоненте TMemo предусмотрена функция отмены последней правки (Undo). Ее можно вызвать следующим образом:
Memo1.Perform(EM_UNDO,0,0);
Узнать о том, возможна ли отмена (т.е. есть ли что отменять) можно следующим образом:
UndoEnabled:=(Memo1.Perform(EM_CAUNDO,0,0)<>0);

[COLOR=#59b300]49. Как прокрутить текст в Tmemo или в TRichEdit[/COLOR]

Я добавляю програмно несколько строк в конец поля Memo, а их не видно. Как прокрутить Memo, чтобы было видно последние строки ? 

Примерно так:
SendMessage(Memo1.Handle, EM_LINESCROLL, 0, Memo1.Lines.Count-1);

[COLOR=#59b300]50. Как определить работает ли уже данное приложение или это первая его копия?[/COLOR]

Для Delphi 1. Каждый экземпляр программы имеет ссылку на свою предыдущую копию - hPrevInst: hWnd. Ее можно проверить перед созданием приложения и при необходимости отреагировать соответствующим образом. Если запущена только одна копия, то эта ссылка равна нулю. 
Пример:


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.

[COLOR=#59b300]51. Обработка событий от клавиатуры[/COLOR]

I. Эмуляция нажатия клавиши.

Внутри приложения это выполняется достаточно просто с помощью вызова функции 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".

[COLOR=#59b300]52. Как сделать так, что при нажатии на Enter происходил переход к следующему элементу формы[/COLOR]

Ставите у формы KeyPreview = true и создаете событие KeyPress следующего вида: 

procedure TForm1.FormKeyPress(Sender: TObject; var Key: Char);
begin
if (Key = #13) then begin
Key:=#0;
Perform(WM_NEXTDLGCTL,0,0);
end;
end;

[COLOR=#59b300]53. Перетаскивание файла drag-drop[/COLOR]

{ На эту форму можно бросить файл (например из проводника) 
и он будет открыт }
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.

[COLOR=#59b300]54. Привлечение внимания к окну[/COLOR]

Часто возникает проблема - в многооконном приложении необходимо обратить внимание пользователя на то, что какое-то из окон требует внимания (например, к нему пришло сообщение по DDE, в нем завершился какой-либо процесс, произошла ошибка ...). Это легко сделать, используя команду API FlashWindow: 

procedure TForm1.Timer1Timer(Sender: TObject);
begin
FlashWindow(Handle,true);
end;

В данном примере FlashWindow вызывается по таймеру ежесекундно, что приводит к миганию заголовка окна.

[COLOR=#59b300]55. Заставка для программы[/COLOR]

Сведения о программе, авторские права и т.д., лучше оформить в виде отдельной формы и показывать ее при запуске программы (как это сделано в Word). 
Сделать это не сложно:
[COLOR=#b3b300]1. Создаете форму (например SplashForm).
2. Объявляете ее свободной (availableForms).
3. В Progect Source вставляете следующее (например):[/COLOR]


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 в главной форме. Но иногда она появляется и пропадает очень быстро, поэтому нужно сделать задержку: 
[COLOR=#b3b300]1. Добавляете на форму таймер с событием: [/COLOR]


procedure TSplashForm.Timer1Timer(Sender: TObject);
begin
Timer1.Enabled := False;
end;


[COLOR=#b3b300]2. Событие onCloseQuery для формы:[/COLOR]


procedure TSplashForm.FormCloseQuery(Sender: TObject; var CanClose: Boolean);
begin
CanClose := Not Timer1.Enabled;
end;


[COLOR=#b3b300]3. И перед SplashForm.Hide; ставите цикл:[/COLOR]

repeat
Application.ProcessMessages;
until SplashForm.CloseQuery;

[COLOR=#b3b300]4. Все! Осталось установить на таймере период задержки 3-4 секунды.
5. На последок, у такой формы желательно убрать Caption:[/COLOR]
SetWindowLong (Main.Handle,GWL_STYLE, GetWindowLong(Main.Handle, GWL_STYLE) AND NOT WS_CAPTION OR WS_SIZEBOX);

[COLOR=#59b300]55. Как получить короткий путь файла если имеется длинный ("c:\Program Files" ==> "c:\progra~1")[/COLOR]

GetShortPathName() 

[COLOR=#59b300]56. Как создать свою кнопку в заголовке формы (на Caption Bar)[/COLOR]

Непосредственно такой функции вроде нет, но можно изловчиться. Нарисовать там кнопку вручную и обрабатывать команды нажатия мышки на 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.

[COLOR=#59b300]57. Преобразование текста OEM у Ansi[/COLOR]


Эта версия работает под любым 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 }

[COLOR=#59b300]58. Состояние кнопки insert (Insert/Overwrite)[/COLOR]

{------------------------------------------}
{ Returns the status of the Insert key. }
{------------------------------------------}

function InsertOn: Boolean;
begin
if LowOrderBitSet(GetKeyState(VK_INSERT))
then InsertOn := true
else InsertOn := false
end;

[COLOR=#59b300]59. IRC клиент на Delphi[/COLOR]

Автор статьи: Лозовский Александр

Если помнишь, пару месяцев назад я предложил читателям придумать свою тему для кодинга. И, соответственно, удовлетворить самые популярные требования в своей статье. Настало время воплотить этот план в жизнь. Сегодня мне в руки попало письмо от "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). Эта коллекция - просто красивые аналоги дельфийских компонентов, но их отсутствие грозит тебе изрядными проблемами с запуском его демы.

[COLOR=#59b300]60. Работа с Word'om в Делфи[/COLOR]

[COLOR=#b3b300]60.1 Запуск MS Word из Delphi[/COLOR]
===============================================================
Инициализация и запуск
---------------------------------------------------------------
Во-первых, в разделе 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

[COLOR=#b3b300]60.2 Программирование закладок в Word с помощью Delphi[/COLOR]
===============================================================
Закладка - это элемент документа, которому присвоено уникальное имя.

Это имя можно использовать для последующих ссылок. Например, можно использовать закладку для определения текста, который необходимо проверить (вставить, заменить) позже. 

Ниже представлен программный код, позволяющий устанавливать, удалять закладки, а так же осуществлять переход к существующей закладке. 

Естественно, перед применением описанных команд, нужно выполнить инициализацию переменной Word, а затем открыть или создать новый документ. Подробнее смотри выши 

[COLOR=#b35900]1. Добавление закладки[/COLOR]
---------------------------------------------------------------
Word.ActiveDocument.Bookmarks.Add(BookMarkName);

где BookMarkName - переменная типа string, содержащая имя закладки.

[COLOR=#b35900]2. Переход к закладке[/COLOR]
---------------------------------------------------------------

Переход к закладке можно осуществить по ее имени:

Word.ActiveDocument.Bookmarks.Item(BookMarkName).Select;

либо по порядковому номеру:

Word.ActiveDocument.Bookmarks.Item(1).Select;

[COLOR=#b35900]3. Удаление закладки[/COLOR]
---------------------------------------------------------------
Удаление производится аналогично переходу к закладке, соответственно, можно использовать два варианта: через имя или индекс закладки. 

Word.ActiveDocument.Bookmarks.Item(BookMarkName).Delete;
Word.ActiveDocument.Bookmarks.Item(1).Delete; 

[COLOR=#b35900]4. Отображение закладок в документе[/COLOR]
---------------------------------------------------------------

Word.ActiveWindow.View.ShowBookmarks:=True; // отобразить закладки
Word.ActiveWindow.View.ShowBookmarks:=False; // скрыть закладки 

[COLOR=#b35900]5. Скрытые (зарезервированные) закладки[/COLOR]
---------------------------------------------------------------

MS Word автоматически устанавливает следующие закладки:
\StartOfDoc - начало документа;
\EndOfDoc - конец документа;
\Sel - переход к текущей позиции ввода. 

Например, переход в начало документа.

Word.ActiveDocument.Bookmarks.Item('\StartOfDoc').Select;

Примечания:
Название закладки должно начинаться с буквы. 
Чтобы отобразить закладки в документе, выберите в Word в меню Сервис команду Параметры, а затем на вкладке Вид установите флажок Закладки. 


Автор статьи: Нечаев Андрей
Сайт автора: http://nech.tamb.ru

[COLOR=#b3b300]60.2 MS Word и рисование[/COLOR]
===============================================================

В статье рассмотрены основные способы рисования из Delphi на листе MS Word.

[COLOR=#b35900]0. Запуск MS Word[/COLOR]
---------------------------------------------------------------

Подключаем необходимый для работы модуль и объявляем переменную:

uses ComObj;
...
var MsWord: variant; 

Запускаем MS Word и показываем на экране:

MsWord:= CreateOleObject('Word.Application');
MsWord.Visible := True; 

Создание нового документа:

MsWord.Documents.Add;

[COLOR=#b35900]1. Линия[/COLOR]
---------------------------------------------------------------
Рисуем линию в документе MS Word на текущем листе:

MsWord.ActiveDocument.Shapes.AddLine(x1, y1, x2, y2);

где x1, y1 - координаты начала, а x2, y2 - координаты конца линии.

Линия, выделенная для редактирования (форматирования):

MsWord.ActiveDocument.Shapes.AddLine(x1, y1, x2, y2).Select;

[COLOR=#b35900]2. Прямоугольник[/COLOR]
---------------------------------------------------------------
MsWord.ActiveDocument.Shapes.AddShape(1, x1, y1, x2, y2);

где x1,y1,x2,y2 - координаты прямоугольника.

[COLOR=#b35900]3. Произвольная фигура[/COLOR]
---------------------------------------------------------------
(или автофигура в терминологии MS Word)

В общем случае, произвольная фигура рисуется так:

MsWord.ActiveDocument.Shapes.AddShape(i, x1, y1, x2, y2);

где i: номер фигуры (соответствует порядку следования фигур в MS Word на панели рисования), x1, y1, x2, y2 координаты прямоугольника в который будет вписан объект. 

[COLOR=#b35900]4. Вставка картинки (произвольного изображения) в текущее положение курсора[/COLOR]
---------------------------------------------------------------

MsWord.Selection.InlineShapes.AddPicture(FileName:='C:\WINDOWS\Пузыри.bmp', LinkToFile:=False, SaveWithDocument:=True);

При выполнении данной команды нужно определить следующие праметры:
FileName - путь к графическому файлу;
LinkToFile - булевский флаг, указывающий на необходимость связи с источником;
SaveWithDocument - булевский флаг, указывающий на свойства рисунка при сохранении документа. 

[COLOR=#b35900]5. Манипулцяции (форматирование) с фигурами[/COLOR]
---------------------------------------------------------------

Выбор фигуры можно осуществить следующим образом:

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 - порядковый номер фигуры.

[COLOR=#b35900]6. Блокировка механизма вывода на экран отрисовки[/COLOR]
---------------------------------------------------------------

В случае, если вы не хотите наблюдать как на листе отрисовываются ваши манипуляции с графическими объектами, то можно воспользоваться ниже приведенными командами.

// Выключение обновления экрана
MsWord.ScreenUpdating := False;

// Обновление экрана
MsWord.Application.ScreenRefresh;

// Включение обновления экрана
MsWord.ScreenUpdating := True;

Примечания:
Рисование осуществляется на актвином листе. 
Координаты действуют только для текущего листа. 

Удачной работы!

Автор статьи: Нечаев Андрей
Сайт автора: http://nech.tamb.ru

[COLOR=#59b300]61. Вывод диалога для выбора каталога - Делфи[/COLOR]


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;

[COLOR=#59b300]62. Как спрятать кнопки в заголовке окна - Делфи[/COLOR]

procedure TForm1.FormCreate(Sender: TObject);
var
Style: Longint;
begin
Style := GetWindowLong(Handle, GWL_STYLE);
SetWindowLong(Handle, GWL_STYLE, Style and not WS_SYSMENU);
end;

[COLOR=#59b300]63. Сколько файлов есть в определённой папке - Делфи[/COLOR]

function GetFileCount(Dir: string): integer;
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;

[COLOR=#59b300]64. Выключение монитора - Делфи[/COLOR]

function MonitorOff(off:boolean;hWnd:HWND):boolean;
begin
if off = true then
SendMessage(hWnd,wm_SysCommand,
SC_MonitorPower,
1) else
SendMessage(hWnd,wm_SysCommand,
SC_MonitorPower,
0);
end;

[COLOR=#59b300]65. Как с помощью Проводника открыть конкретный каталог? - Делфи[/COLOR]

uses ShellApi;
procedure TForm1.Button1Click(Sender: TObject); 
begin 
ShellExecute(0, 'explore', 'C:\WINDOWS', nil, nil, SW_SHOWNORMAL); 
end;

[COLOR=#59b300]66. Запуск приложения - Делфи[/COLOR]

WinExec('C:\WINDOWS\CONTROL.EXE', sw_ShowNormal); [/I][/I]

 

[Lomanu4]

Круто, будет продолжение?

 

[Mazahaka_lab]

Печально , но пример не работает , хоть и компилируется

10. Как перетаскивать форму не только за Caption, но и за любое другое место?

TForm1 = class(TForm)
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;

 

[Mazahaka_lab]

Рабочий пример

''''
 procedure FormMouseDown(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
  private
    { Private declarations }
    procedure WMNCHitTest(var M: TWMNCHitTest); message wm_NCHitTest

''''
procedure TForm1.FormMouseDown(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
ReleaseCapture;
(Sender as TControl).Perform(WM_SYSCOMMAND, SC_MOVE or HTCAPTION, 0); // original von Frühlingsrolle
end;

procedure TForm1.WMNCHitTest(var M: TWMNCHitTest);
begin
inherited;
 if ((ControlAtPos(ScreenToClient(M.Pos), True, True, True) = nil) and (M.Result = htClient))
    then
     M.Result := htCaption;
end;
end.