nyuuzyou/wikis huggingface dataset:
Перетасовка строк в списке

=== Перетасовка строк в списке ===
{ **** UBPFD *********** by kladovka.net.ru ****
>> Перетасовка строк в списке
Процедура тасует строки в списке.
List - Список строк
MoveCount - необязательный параметр, задающий количество перестановок, 
если этот параметр опущен, либо меньше или равен нулю, его значение 
принимается равным C*C-C, где C - количество строк в списке.
Зависимости: SysUtils, Classes
Автор: Dimka Maslov, mainbox@endimus.ru, ICQ:148442121, Санкт-Петербург
Copyright: Dimka Maslov
Дата: 18 ноября 2002 г.
********************************************** }
procedure ShuffleStrings(List: TStrings; MoveCount: Integer = 0);
var
 i, N, C: Integer;
 Index1, Index2: Integer;
 Str: string;
 Obj: TObject;
begin
 List.BeginUpdate;
 try
 C := List.Count;
 N := MoveCount;
 if N <= 0 then
 N := C * C - C;
 for i := 0 to N do
 begin
 Index1 := Random(C);
 Index2 := Random(C);
 Str := List.Strings[Index1];
 Obj := List.Objects[Index1];
 List.Strings[Index1] := List.Strings[Index2];
 List.Objects[Index1] := List.Objects[Index2];
 List.Strings[Index2] := Str;
 List.Objects[Index2] := Obj;
 end;
 finally
 List.EndUpdate;
 end;
end; 
Пример использования:
ShuffleStrings(Memo1.Lines) 
Source: kladovka.net.ru
ID: 00311
Перехват API функций, на примере MessageBoxA

=== Перехват API функций, на примере MessageBoxA ===
==== DLL ====
library Mouse_mes;
uses
 sysutils,
 windows,
 messages;
type
 TImageImportDescriptor = packed record
 OriginalFirstThunk : DWORD;
 TimeDateStamp : DWORD;
 ForwarderChain : DWORD;
 Name : DWORD;
 FirstThunk : DWORD;
 end;
 PImageImportDescriptor = ^TImageImportDescriptor;
var
 filename: array[0..max_path-1] of Char;
 hook: HHook = 0;
 PEHeader: PImageNtHeaders;
 ImageBase: Cardinal;
function MyHookProcedure(hWnd: HWND; lpText, lpCaption: PWideChar; uType: UINT): Integer; stdcall;
begin
 Result := MessageBoxA(0, 'Notepad', 'my hook', 0);
 // Но уже через нашу табл. импорта
end;
procedure ProcessImports(PImports:PImageImportDescriptor);
var
 PImport: PImageImportDescriptor;
 PRVA_Import: LPDWORD;
 ProcAddress: Pointer;
 Temp_Cardinal: Cardinal;
begin
 ProcAddress := GetProcAddress(GetModuleHandle('USER32.DLL'), 'MessageBoxA');
 PImport := PImports;
 while PImport.Name <> 0 do
 begin
 PRVA_Import := LPDWORD(pImport.FirstThunk + ImageBase);
 while PRVA_Import^ <> 0 do
 begin
 if PPointer(PRVA_Import)^ = ProcAddress then
 begin
 VirtualProtect(PPointer(PRVA_Import), 4, PAGE_READWRITE, Temp_Cardinal);
 PPointer(PRVA_Import)^ := @MyHookProcedure; // пишем свою...
 VirtualProtect(PPointer(PRVA_Import), 4, Temp_Cardinal, Temp_Cardinal);
 end;
 Inc(PRVA_Import);
 end;
 Inc(PImport);
 end;
end;
procedure DllEntryPoint(reson: LongInt); stdcall;
begin
 case reson of
 DLL_PROCESS_ATTACH:
 begin
 DisableThreadLibraryCalls(hInstance);
 ZeroMemory(@FileName, SizeOf(FileName));
 GetModuleFileName(GetModuleHandle(nil), @FileName, SizeOf(FileName));
 // сейчас я хочу попробовать все это дело над нотепадом
 if Pos('NOTEPAD.EXE', AnsiUpper(@FileName)) <> 0 then
 begin
 ImageBase := GetModuleHandle(nil);
 PEHeader := Pointer(Int64(ImageBase) + PImageDosHeader(ImageBase)._lfanew); // pe header
 ProcessImports(Pointer(PEHeader.OptionalHeader.DataDirectory[IMAGE_DIRECTORY_ENTRY_IMPORT].VirtualAddress + ImageBase));
 end;
 end;
 end;
end;
function NextHook(code: Integer; wParam, lParam: LongInt): LongInt; stdcall;
begin
 Result := CallNextHookEx(hook, code, wParam, lParam);
end;
procedure SetHook(flag: Bool); export; stdcall;
begin
 if flag then
 hook := SetWindowsHookEx(wh_getmessage, @NextHook, hInstance, 0)
 else
 begin
 UnhookWindowsHookEx(hook);
 hook := 0;
 end;
end;
exports SetHook;
begin
 DLLProc := @DllEntryPoint;
 DllEntryPoint(DLL_PROCESS_ATTACH);
end.
==== EXE ====
program Project2;
uses windows;
var
 SetHook: procedure(flag: Bool) stdcall;
 hDll: hModule;
begin
 hDll := LoadLibrary('Mouse_mes.dll');
 @SetHook := GetProcAddress(hDll, 'SetHook');
 SetHook(True);
 MessageBox(0, 'Не закрывай, пока идет работа', , 0);
 SetHook(False);
 FreeLibrary(hDll);
end.
Author: Song
Source: Взято из http://forum.sources.ru
ID: 02219
Перехват нажатия на системные кнопки формы (закрытие , минимизация окна и т.д.)

=== Перехват нажатия на системные кнопки формы (закрытие , минимизация окна и т.д.) ===
Сообщение WM_SYSCOMMAND приходит перед выполнением соответствующей команды, что дает возможность переопределить код.
Описание:
 WM_SYSCOMMAND 
 uCmdType = wParam; // type of system command requested 
 xPos = LOWORD(lParam); // horizontal postion, in screen coordinates 
 yPos = HIWORD(lParam); // vertical postion, in screen coordinates 
Например, перехват события минимизации окна приложения:
type
 TMain = class(TForm)
 protected
 procedure WMGetSysCommand(var Message: TMessage); message WM_SYSCOMMAND;
 end;
//----------------------------------------------------------------
// Обработка сообщения WM_SYSCOMMAND (перехват минимизации окна)
//----------------------------------------------------------------
procedure TMain.WMGetSysCommand(var Message : TMessage);
begin
 if (Message..wParam = SC_MINIMIZE) then
 Main.Visible := False
 else
 inherited;
end;
Source: Взято с сайта http://blackman.wp-club.net/
ID: 02023
Перехват ошибок DBEngine

=== Перехват ошибок DBEngine ===
Ошибки общего характера, типа Key Violation или конфликты блокировки лучше всего обрабатывать в обработчике события Application.OnException ...например:
procedure TForm1.HandleException(Sender: TObject; E: Exception);
var
 err: DBIResult;
begin
 if E is EDBEngineError then
 begin
 err := (E as EDBEngineError).Errors[(E as EDBEngineError).ErrorCount - 1].ErrorCode;
 if (err = DBIERR_KEYVIOL) then
 ShowMessage('Ошибка Key violation!')
 else if (err = DBIERR_LOCKED) then
 ShowMessage('Запись блокирована другим пользователем')
 else if (err = DBIERR_FILELOCKED) then
 ShowMessage('Таблица блокирована кем-то еще')
 else
 ShowMessage('Другая ошибка DB')
 end
 else
 ShowMessage('Упс!: ' + E.Message);
end;
{ 'инсталлировать' обработчик исключений можно так: }
procedure TForm1.FormCreate(Sender: TObject);
begin
 Application.OnException := HandleException;
end;
Для использования предопределенных констант ошибок ('DBIERR_etc.'), вам необходимо включить DBIERRS в список используемых модулей. Полный список кодов ошибок при работе с базами данных вы можете найти в файле DBIERRS.INT, расположенном в каталоге :\DELPHI\DOC.
Source: Взято с http://delphiworld.narod.ru
ID: 02585
Перехватить нажатие клавиши на клавиатуре

=== Перехватить нажатие клавиши на клавиатуре ===
Для того, чтобы перехватить нажатие какой-то клавиши на клавиатуре можно использовать зарегистрированную "горячую клавишу" (HotKey). Эта программа пикает при нажатии "1". 
type
 TForm1 = class(TForm)
 private
 procedure WMHotKey(var Msg: TWMHotKey); message WM_HOTKEY;
 end;
implementation
const
 MyHotKey = ord('1');
procedure TForm1.WMHotKey(var Msg: TWMHotKey);
begin
 MessageBeep(0);
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
 RegisterHotKey(Form1.Handle, MyHotKey, 0, MyHotKey);
end;
procedure TForm1.FormDestroy(Sender: TObject);
begin
 UnRegisterHotKey(Form1.Handle, MyHotKey);
end;
Source: http://delphiworld.narod.ru/
ID: 01561
Перехватывать печать на принтере

unit Unit1;
interface
uses
 Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,
 Dialogs, StdCtrls, WinSpool;
type
 TForm1 = class(TForm)
 btnStart: TButton;
 cbPrinters: TComboBox;
 procedure btnStartClick(Sender: TObject);
 procedure FormCreate(Sender: TObject);
 end;
var
 Form1: TForm1;
implementation
{$R *.dfm}
procedure TForm1.FormCreate(Sender: TObject);
var
 PrintersInfo: array of TPrinterInfo5;
 I, Needed, Returned: DWORD;
begin
 EnumPrinters(PRINTER_ENUM_LOCAL, nil, 5, nil, 0, Needed, Returned);
 SetLength(PrintersInfo, Needed div SizeOf(TPrinterInfo5));
 if EnumPrinters(PRINTER_ENUM_LOCAL, nil, 5, PrintersInfo, Needed, Needed, Returned) then
 if Returned > 0 then
 begin
 for I := 0 to Returned - 1 do
 cbPrinters.Items.Add(PrintersInfo[I].pPrinterName);
 btnStart.Enabled := True;
 cbPrinters.ItemIndex := 1;
 end;
end;
procedure TForm1.btnStartClick(Sender: TObject);
var
 hPrinter, hChanges: THandle;
 NotifyOption: TPrinterNotifyOptions;
 NotifyTipes: TPrinterNotifyOptionsType;
 Field: TPrinterNotifyInfoData;
begin
 if OpenPrinter(PChar(cbPrinters.Items.Strings[cbPrinters.ItemIndex]), hPrinter, nil) then
 try
 NotifyTipes.wType := JOB_NOTIFY_TYPE;
 NotifyTipes.Reserved0 := 0;
 NotifyTipes.Reserved1 := 0;
 NotifyTipes.Reserved2 := 0;
 NotifyTipes.Count := 1;
 NotifyTipes.pFields := @Field;
 NotifyOption.Version := 2;
 NotifyOption.Flags := PRINTER_CHANGE_ALL;
 NotifyOption.Count := 1;
 NotifyOption.pTypes := @NotifyTipes;
 hChanges := FindFirstPrinterChangeNotification(hPrinter, PRINTER_CHANGE_ALL, 0, @NotifyOption);
 if hChanges = INVALID_HANDLE_VALUE then
 RaiseLastOSError
 else
 try
 case WaitForSingleObject(hChanges, INFINITE) of
 WAIT_OBJECT_0: ShowMessage('Есть изменения');
 WAIT_FAILED: RaiseLastOSError;
 end;
 finally
 FindClosePrinterChangeNotification(hChanges);
 end;
 finally
 ClosePrinter(hPrinter);
 end;
end;
end.
Author: Rouse_
Source: Взято из http://forum.sources.ru
ID: 03255
Category:Принтер
Category:WinAPI
Переход в ждущий режим под WinNT

=== Переход в ждущий режим под WinNT ===
{ **** UBPFD *********** by delphibase.endimus.com ****
>> Переход в ждущий режим под WinNT
Зависимости: Windows
Copyright: @
Дата: 21 июня 2002 г.
***************************************************** }
procedure NTWait;
var
 hToken: THandle;
 tkp: TTokenPrivileges;
 ReturnLength: Cardinal;
begin
 if OpenProcessToken(GetCurrentProcess(), TOKEN_ADJUST_PRIVILEGES or
 TOKEN_QUERY, hToken) then
 begin
 LookupPrivilegeValue(nil, 'SeShutdownPrivilege', tkp.Privileges[0].Luid);
 tkp.PrivilegeCount := 1;
 tkp.Privileges[0].Attributes := SE_PRIVILEGE_ENABLED;
 if AdjustTokenPrivileges(hToken, False, tkp, 0, nil, ReturnLength) then
 SetSystemPowerState(true, true);
 end;
end;
Source: http://delphibase.endimus.com
ID: 01706
Переход с Oracle на Interbase

=== Переход с Oracle на Interbase ===
* Я пытаюсь преобразовать мою базу данных на Oracle в базу данных local Interbase server. Все таблицы Oracle ссылаются на имя схемы. Interbase поддерживает такого типа имена схем?
Нет, Interbase не использует понятие классификатора таблицы (владельца), как это делают другие сервера, например, Oracle или Sybase. Наилучшее решение в этом случае - использование директив компиляции, позволяющее контролировать соглашение о стиле имен Oracle или Interbase, используемое в генерируемом .exe-файле.
* Также, Delphi читает все атрибуты Oracle типа Number и конвертирует их в FloatField. Interbase при этом использует тип SmallIntField. Так, для преобразования необходимо пройтись по всем таблицам, удалить поля и затем снова их добавить. Можно это сделать как-то по-человечески?
Если я правильно понял то, что вы хотели сказать, то этот вопрос относится к специфике Interbase. Например, Interbase использует короткое поле (short field) с масштабированием вместо реального типа, если заданная при создании таблицы точность не превышает 10. [например, CREATE TABLE xxx (FLOATFIELD NUMERIC (5, 2)) обычно означает реальный тип с точностью 5 цифр с 2-мя цифрами после запятой. Но Interbase знает, что сможет поместить 5 цифр в короткое поле, поэтому она создаст короткое поле и запись и смасштабирует его с коэффициентом 2.] Проблема в следующем: BDE "спрашивает" Interbase о полях таблицы и их типах, Interbase честно рапортует, что поля имеют тип short, т.е. они "короткие". Но BDE ничего не знает о масштабировании.
Чтобы обойти этот неприятный момент, необходимо создать поле с точностью более 10, заставляя Interbase делать поля реального, а не короткого типа.
* Могу ли я менять один тип SQL на другой, или это - несбыточная мечта?
Проблема в том, что каждый производитель создал свой диалект и реализацию SQL, который не обязательно был совместимым с SQL других производителей, особенно в рамках расширений "стандартного" SQL.
* Существует ли возможность инкапсуляции общего кода для работы с базой данных от специфических реализаций конкретных версий баз, что позволило бы клиенту легко переходить от одного типа таблиц к другому?
Как я уже говорил выше: директивы компилятора.
Author: Shawn Wu 
Source: Взято с http://delphiworld.narod.ru
ID: 02926
Category:Базы данных
Category:Interbase
Перечислить все разбиения N на целые положительные слагаемые

Пример:
 N=4, разбиения: 1+1+1+1, 2+1+1, 2+2, 3+1, 4.
 First = (1, 1, ..., 1) - N единиц Last = (N)
Чтобы разбиения не повторялись, договоримся перечислять слагаемые в невозрастающем порядке. Сказать, сколько их будет всего, не так-то просто (см.следующий пункт). Для составления алгоритма Next зададимся тем же вопросом: в каком случае i-ый член разбиения можно увеличить, не меняя предыдущих?
Во-первых, должно быть X[i-1] > X[i] или i=1. Во-вторых, i должно быть не последним эле ментом (увеличение i надо компенсировать уменьшением следующих). Если такого i нет, то данное разбиение последнее. Увеличив i, все следующие элементы надо взять минимально возможными, т.е. равными единице:
procedure Next;
begin
 { найти i: (i<L) and ( (X[i-1]>X[i]) or (i=1) ) }
 X[i] := X[i] + 1;
 { L:= i + X[i+1]+...+X[L] - 1 }
 X[i+1] := ... := X[L] := 1;
end;
Через L мы обозначили количество слагаемых в текущем разбиении (понятно, что 1 <= L <= N). Программа будет выглядеть так:
program Razbieniya;
type
 TRazb = array [Byte] of Byte;
var
 N, i, L: Byte;
 X: TRazb;
procedure Next(var X: TRazb; var L: Byte);
var
 i, j: Byte;
 s: Word;
begin
 i := L-1;
 s := X[L];
 { поиск i }
 while (i > 1) and (X[i-1] <= X[i]) do
 begin
 s := s+X[i];
 Dec(i);
 end;
 Inc(X[i]);
 L := i + s - 1;
 for j := i+1 to L do
 X[j] := 1;
end;
begin
 Write('N=');
 ReadLn(N);
 L := N;
 for i := 1 to L do
 X[i] := 1;
 for i := 1 to L do
 Write(X[i]);
 WriteLn;
 repeat
 Next(X, L);
 for i := 1 to L do
 Write(X[i]);
 WriteLn;
 until L = 1;
end.
Source: http://algolist.manual.ru
ID: 04181
Category:Алгоритмы
Перечислить все расстановки 8-ми ферзей на шахматной доске, при которых они не бьют друг друга

Классической задачей, которая решается методом перебора с отходом назад считается задача о восьми ферзях: требуется перечислить все способы расстановки 8-ми ферзей на шахматной доске 8 на 8, при которых они не бьют друг друга. Эту задачу решил больше 200 лет тому назад великий математик Леонард Эйлер. Заметьте, что у него не было компьютера, но тем не менее он абсолютно верно нашел все 92 таких расстановки!
Очевидно, на каждой из 8 вертикалей должно стоять по ферзю. Каждую такую расстановку можно закодировать одномерным массивом X[1], ..., X[8], где X[i] - номер горизонтали для i-го ферзя. Поскольку никакие два ферзя не могут стоять на одной горизонтали (тогда они бьют друг друга), то все X[i] различны, т.е. образуют перестановку из чисел 1..8. Можно, конечно, перебрать все 8! таких перестановок и выбрать среди них те 92, которые нас интересуют. Hо число 8! = 40320 довольно большое.
Поэтому мы воспользуемся алгоритмом перебора с отходом назад, который позволит значительно сократить перебор и даст ответ намного быстрее:
program Queens;
const
 N = 8;
type
 TIndex = 1..N;
 TRasstanovka = array [TIndex] of 0..N;
var
 X: TRasstanovka;
 Count: Word;
function P(var X: TRasstanovka; k, y: TIndex): Boolean;
var
 i: TIndex;
begin
 i := 1;
 while (i < k) and (y <> X[i]) and (abs(k-i) <> abs(y-X[i])) do
 Inc(i);
 Result := (i = k);
end;
procedure Backtracking(k: TIndex);
var
 i, y: TIndex;
begin
 for y := 1 to N do
 if P(X, k, y) then
 begin
 X[k] := y;
 if k = N then
 begin
 for i := 1 to N do
 Write(X[i]);
 WriteLn;
 Inc(Count);
 end;
 Backtracking(k+1);
 end
end;
begin
 Count := 0;
 WriteLn('Расстановки ', N, ' ферзей:');
 Backtracking(1);
 WriteLn('Всего ', Count, ' расстановок');
end.
Source: http://algolist.manual.ru
ID: 04180
Category:Алгоритмы
Перечислить измененные ключи реестра в определенный диапазон времени

=== Перечислить измененные ключи реестра в определенный диапазон времени ===
unit Main;
interface
uses
 Windows, SysUtils, Variants, Classes, Graphics, Controls, Forms,
 Dialogs, Registry, StdCtrls, ComCtrls, ExtCtrls;
type
 TFrmMain = class(TForm)
 Memo1: TMemo;
 btEnumReg: TButton;
 dtBeginDate: TDateTimePicker;
 dtEndDate: TDateTimePicker;
 dtBeginTime: TDateTimePicker;
 dtEndTime: TDateTimePicker;
 Panel1: TPanel;
 Label1: TLabel;
 Label2: TLabel;
 procedure btEnumRegClick(Sender: TObject);
 private
 { Private declarations }
 RegDate: TDateTime;
 RegKeyInfo: TRegKeyInfo;
 TimeZoneInfo: TTimeZoneInformation;
 function DateTimeToLocalDateTime(DateTime: TDateTime): TDateTime;
 procedure FileTimeToDateTime(ft: TFileTime; var dt: TDateTime);
 public
 { Public declarations }
 end;
var
 FrmMain: TFrmMain;
implementation
{$R *.dfm}
function TFrmMain.DateTimeToLocalDateTime(DateTime: TDateTime): TDateTime;
begin
 case GetTimeZoneInformation(TimeZoneInfo) of
 TIME_ZONE_ID_STANDARD:
 Result := DateTime - (TimeZoneInfo.Bias / 60 / 24);
 TIME_ZONE_ID_DAYLIGHT:
 Result := DateTime - ((TimeZoneInfo.Bias + TimeZoneInfo.DaylightBias) / 60 / 24);
 else
 Result := 0;
 end;
end;
procedure TFrmMain.FileTimeToDateTime(ft: TFileTime; var dt: TDateTime);
var
 SystemTime: TSystemTime;
 FileTime: TFileTime;
begin
 if FileTimeToLocalFileTime(ft, FileTime) then
 begin
 FileTimeToSystemTime(ft, SystemTime);
 dt := SystemTimeToDateTime(SystemTime);
 end;
end;
procedure TFrmMain.btEnumRegClick(Sender: TObject);
var
 Inizio, Fine: TDateTime;
 procedure EnumAllKeys(hkey: THandle; KeyName: string);
 var
 l: TStringList;
 n: Integer;
 KeyName_: string;
 begin
 KeyName_ := KeyName;
 with TRegistry.Create do
 try
 RootKey := hkey;
 OpenKey(EmptyStr, False);
 l := TStringList.Create;
 try
 GetKeynames(l);
 CloseKey;
 for n := 0 to l.Count - 1 do
 begin
 if OpenKey(l[n], False) then
 begin
 GetKeyInfo(RegKeyInfo);
 with RegKeyInfo do
 begin
 FileTimeToDateTime(FileTime, RegDate);
 RegDate := DateTimeToLocalDateTime(RegDate);
 end;
 if (RegDate <= Fine) and (RegDate >= Inizio) then
 memo1.Lines.Add(DateTimeToStr(RegDate) + ' --- ' + KeyName_ + '\' + l[n]);
 EnumAllKeys(CurrentKey, KeyName_ + '\' + l[n]);
 CloseKey;
 end;
 end;
 finally
 l.Free
 end;
 finally
 Free;
 end;
 end;
begin
 Memo1.Clear;
 Memo1.Lines.BeginUpdate;
 Inizio := int(dtBeginDate.DateTime) + frac(dtBeginTime.DateTime);
 Fine := int(dtEndDate.Date) + frac(dtEndTime.DateTime);
 try
 EnumAllKeys(HKEY_CURRENT_USER, 'HKey_Current_User');
 finally
 Memo1.Lines.EndUpdate;
 end;
 MessageDlg('Enumeration ended', mtInformation, [mbOK], 0);
end;
end.
Source: Взято с сайта: http://www.swissdelphicenter.ch
ID: 02286
Перечислить ключи реестра

=== Перечислить ключи реестра ===
{
 This example demonstrates how to enumerate all registry keys from
 a certain key (here: HKEY_CURRENT_USER)
}
uses
 Registry;
procedure EnumAllKeys(hkey: THandle; Lines: TStrings; var indent: Integer);
var
 l: TStringList;
 n: Integer;
begin
 Inc(indent, 2);
 with TRegistry.Create do
 try
 RootKey := hkey;
 OpenKey(EmptyStr, False);
 l := TStringList.Create;
 try
 GetKeynames(l);
 CloseKey;
 for n := 0 to l.Count - 1 do
 begin
 Lines.Add(StringOfChar(' ', indent) + l[n]);
 if OpenKey(l[n], False) then
 begin
 EnumAllKeys(CurrentKey, Lines, indent);
 CloseKey;
 end;
 end;
 finally
 l.Free
 end;
 finally
 Free;
 end;
 Dec(indent, 2);
end;
procedure TForm1.Button1Click(Sender: TObject);
var
 indent: Integer;
begin
 Memo1.Clear;
 Memo1.Lines.Add('Keys under HKEY_CURRENT_USER');
 indent := 0;
 Memo1.Lines.BeginUpdate;
 try
 EnumAllKeys(HKEY_CURRENT_USER, Memo1.Lines, indent);
 finally
 Memo1.Lines.EndUpdate;
 end;
end;
Source: Взято с сайта: http://www.swissdelphicenter.ch
ID: 02287
Печать Dos-файла в порт напрямую

=== Печать Dos-файла в порт напрямую ===
При печати Dos-файла в порт напрямую можно это сделать.
 Например, напечатать за 2 прохода:
 ESC @ - инициализация принтера
 ESC G - включение режима печати за 2 прохода
 ESC H - выключение режима печати за 2 прохода
{ преобразование Ansi to Ascii }
function AnToAs(s: String) : String;
var
 i, kod: Integer;
begin
 Result := s;
 for i:=1 to Length(s) do
 begin
 kod := Ord(s[i]);
 if kod <> 13 then
 Result[i] := ' ';
 if (kod >= 192) and (kod = 239) then 
 Result[i] := Chr(kod - 64);
 if (kod >= 240) and (kod = 255) then 
 Result[i] := Chr(kod - 16);
 if kod = 168 then
 Result[i] := Chr(240);
 if kod = 184 then
 Result[i] := Chr(241);
 end;
end;
var
 FileOut: TextFile;
 Filename: String [128];
begin
 Filename := 'PRN';
 AssignFile(Fileout, Filename);
 Write(FileOut, Chr(27) + '@');
 Str1 := AnToAs(chr(27) + 'G' + 'Double' + chr(27) + 'H');
 Writeln(FileOut, Str1);
end;
Source: Взято с сайта http://blackman.wp-club.net/
ID: 01347
Печать повернутого текста

procedure AngleTextOut(CV: TCanvas; const sText: string; x, y, angle: integer);
var
 LogFont: TLogFont;
 SaveFont: TFont;
begin
 SaveFont := TFont.Create;
 SaveFont.Assign(CV.Font);
 GetObject(SaveFont.Handle, sizeof(TLogFont), @LogFont);
 with LogFont do
 begin
 lfEscapement := angle * 10;
 lfPitchAndFamily := FIXED_PITCH or FF_DONTCARE;
 end; {with}
 CV.Font.Handle := CreateFontIndirect(LogFont);
 SetBkMode(CV.Handle, TRANSPARENT);
 CV.TextOut(x, y, sText);
 CV.Font.Assign(SaveFont);
 SaveFont.Free;
end;
ID: 03233
----
procedure TextOutVertical(var bitmap: TBitmap; x, y: Integer; s: string);
var
 b1, b2: TBitmap;
 i, j: Integer;
begin
 with bitmap.Canvas do
 begin
 b1 := TBitmap.Create;
 b1.Canvas.Font := lpYhFont;
 b1.Width := TextWidth(s) + 1;
 b1.Height := TextHeight(s) + 1;
 b1.Canvas.TextOut(1, 1, s);
 b2 := TPackedBitmap.Create;
 b2.Width := TextHeight(s);
 b2.Height := TextWidth(s);
 for i := 0 to b1.Width - 1 do
 for j := 0 to b1.Height do
 b2.Canvas.Pixels[j, b2.Height + 1 - i] := b1.Canvas.Pixels[i, j];
 Draw(x, y, b2);
 b1.Free;
 b2.Free;
 end;
end;
ID: 03234
----
Некоторое время я делал так: я создавал шрифт, выбирал его в DC...
function CreateMyFont(degree: Integer): HFONT;
begin
 CreateMyFont := CreateFont(
 -30, 0, degree, 0, 0,
 0, 0, 0, 1, OUT_TT_PRECIS,
 0, 0, 0, szFontName);
end;
....и затем использовал любую функцию рисования для вывода текста.
ID: 03235
----
Приведенное выше решение (1) очень медленно, так как требует рисования текста и содержит, на мой взгляд, неэффективный метод вращения. Попробуйте взамен это:
procedure TForm1.TextUp(ARect: TRect; ATxt: string);
var
 LFont: TLogFont;
 hOldFont, hNewFont: HFont;
begin
 GetObject(Canvas.Font.Handle, SizeOf(LFont), Addr(LFont));
 LFont.lfEscapement := 900;
 hNewFont := CreateFontIndirect(LFont);
 hOldFont := SelectObject(Canvas.Handle, hNewFont);
 Canvas.TextOut(ARect.Left + 2, ARect.Top, ATxt);
 hNewFont := SelectObject(Canvas.Handle, hOldFont);
 DeleteObject(hNewFont);
end;
Source: Взято из Советов по Delphi от Валентина Озерова
ID: 03236
Category:Принтер
Печать с масштабированием

procedure TForm1.Button1Click(Sender: TObject);
var
 ScaleX, ScaleY: Integer;
begin
 Printer.BeginDoc;
 with Printer do
 try
 ScaleX := GetDeviceCaps(Handle, LogPixelsX) div PixelsPerInch;
 ScaleY := GetDeviceCaps(Handle, LogPixelsY) div PixelsPerInch;
 Canvas.StretchDraw(Rect(0, 0, Image1.Picture.Width * ScaleX, Image1.Picture.Height * ScaleY), Image1.Picture.Graphic);
 finally
 EndDoc;
 end;
end;
Author: Song
Source: Взято из http://forum.sources.ru
ID: 03250
Category:Принтер