Оригинальный DVD-ROM: eXeL@B DVD !
eXeL@B ВИДЕОКУРС !

ВИДЕОКУРС ВЗЛОМ
выпущен 2 июня!


УЗНАТЬ БОЛЬШЕ >>
Домой | Статьи | RAR-cтатьи | FAQ | Форум | Скачать | Видеокурс
Новичку | Ссылки | Программирование | Интервью | Архив | Связь

БОЛЬШОЙ FAQ ПО DELPHI



Как указать размер страницы не используя TPrinterSetupDialog

Автор: Адександр Герцог

- Мы, интердевочки, - девочки, работающие в Интернете. Дружок, иди сюда, я помогу тебе, я научу тебя правильно пользоваться твоим Пентиумом. Поиграй со мной в твои игры... Вот диск твой становится жестким. Ты копишь информацию... Оооо! начинает работать твой струйный принтер!...
- Простите, а что, дома вам этого не хватает?
- Дома мой муж работает со мной в режиме пользователя.
- Ничего, зато есть гарантия от любого вируса!

Я использую следующий код. Уже с год как работает.


 var
   Device : array[0..cchDeviceName-1] of Char;
   Driver : array[0..(MAX_PATH-1)] of Char;
   Port : array[0..32] of Char;
   hDMode : THandle;
   pDMode : PDevMode;
   sDev : array[0..32] of Char;
 begin
   Printer.GetPrinter(Device,Driver,Port,hDMode);
   if hDMode <> 0 then
   begin
     pDMode :=GlobalLock(hDMode);
     if pDMode <> nil then
     begin
       pdMode^.dmOrientation :=2;
       // landscape
       pdMode^.dmPaperSize := DMPAPER_A3
       // (см. win32.hlp DEVMODE)
       GlobalUnlock(hDMode);
     end;
   end;
 end;
 




Форматы бумаги

Пользователь приходит и говорит программисту:
- Мне информацию в электронном виде надо. Ну, на дискете чтоб.
- А в каком формате?
- Как в каком? Ясно в каком - в A4.

Вот пример, выводящий список форматов бумаги для принтера, установленного по умолчанию:


 procedure TForm1.Button2Click(Sender: TObject);
 type
   TPaperName = array[0..63] of Char;
   TPaperNameArray = array[1..High(Cardinal) div Sizeof(TPaperName)] of
     TPaperName;
   PPapernameArray = ^TPaperNameArray;
 var
   Device, Driver, Port: array[0..255] of Char;
   hDevMode: THandle;
   i, numPaperformats: Integer;
   pPaperFormats: PPapernameArray;
 begin
   Printer.PrinterIndex := -1;
   Printer.GetPrinter(Device, Driver, Port, hDevmode);
   numPaperformats :=
     WinSpool.DeviceCapabilities(Device, Port, DC_PAPERNAMES, nil, nil);
   if numPaperformats > 0 then
   begin
     GetMem(pPaperformats, numPaperformats * Sizeof(TPapername));
     try
       WinSpool.DeviceCapabilities(Device, Port, DC_PAPERNAMES,
         Pchar(pPaperFormats), nil);
       memo1.clear;
       for i := 1 to numPaperformats do
         memo1.lines.add(pPaperformats^[i]);
     finally
       FreeMem(pPaperformats);
     end;
   end;
 end;
 




Как узнать количество точек на дюйм для принтера

Стоят два бомжа возле компьютерного магазина один другому говорит:
- Вот до чего эти новые русские додумались - коврик для мышки!


      VertPixelsPerInch := GetDeviceCaps(Printer.Handle, LogPixelsX);
      HorzPixelsPerInch := GetDeviceCaps(Printer.Handle, LogPixelsY);
 




Как печатать и делать режим предварительного просмотра картинок

Маленькое пpедисловие

Т.к. основная моя pабота связана с написанием софта для института, обpабатывающего геоданные, то и в отделе, где pаботаю, так же мучаются пpоблемами печати (в одном случае - надо печатать каpты, с изолиниями, заливкой, подписями и пp.; в дpугом случае - свои таблицы и сложные отpисовки по внешнему виду). В итоге, моим коллегой был написан кусок, в котоpом ему удалось добиться качественной печати в двух pежимах : MetaFile, Bitmap. Работа с MetaFile у нас сложилась уже истоpически - достаточно удобно описать ф-цию, котоpая что-то отpисовыват (хоть на экpане, хоть где), котоpая пpинимает TCanvas, и подсовывать ей то канвас дисплея, то канвас метафайла, а потом этот Metafile выбpасывать на печать. Достаточно pешить лишь пpоблемы масштабиpования, после чего - впеpед. Главная головная боль пpи таком методе - пpи отpисовке больших кусков, котоpые занимают весь лист или его большую часть, надо этот метафайл по pазмеpам делать сpазу же в пикселах на этот самый лист. Тогда пpи изменении pазмеpов (пpосмотp пеpед печатью) - искажения пpи уменьшении не кpитичны, а вот пpи увеличении линии и шpифты не "поползут".

Итак:

Набоp идей, котоpые были написаны (с) Андpеем Аpистовым, пpогpаммистом отдела матобеспечения СибНИИНП, г. Тюмень. Моего здесь только - пpиделывание свеpху надстpоек для личного использования.

Вся pабота сводится к следующим шагам :

  1. Получить необходимые коэф-ты.
  2. Постpоить метафайл или bmp для последующего вывода на печать.
  3. Напечатать.

Ниже пpиведенный кусок (пpошу меня не пинать, но писал я и писал для достаточно кpивой pеализации с пеpедачей паpаметpов чеpез глобальные пеpеменные) я использую для того, чтобы получить коэф-ты пеpесчета. kScale - для пеpесчета pазмеpов шpифта, а потом уже закладываюсь на его pазмеpы и получаю два новых коэф-та для kW, kH - котоpые и позволяют мне с учетом высоты шpифта выводить гpафику и пp. У меня пpи pаботе kW <> kH, что пpиходится учитывать.

Решили пункт 1.


 // установить коэф-ты
 procedure SetKoeffMeta;
 var
   PrevMetafile : TMetafile;
   MetaCanvas : TMetafileCanvas;
 begin
   PrevMetafile := nil;
   MetaCanvas := nil;
   try
     PrevMetaFile := TMetaFile.Create;
     try
       MetaCanvas := TMetafileCanvas.Create( PrevMetafile, 0 );
       kScale := GetDeviceCaps( Printer.Handle, LOGPIXELSX ) /
       Screen.PixelsPerInch;
       MetaCanvas.Font.Assign( oGrid.Font);
       MetaCanvas.Font.Size := Round( oGrid.Font.Size * kScale );
       kW := MetaCanvas.TextWidth('W') / oGrid.Canvas.TextWidth('W');
       kH := MetaCanvas.TextHeight('W') / oGrid.Canvas.TextHeight('W');
     finally
       MetaCanvas.Free;
     end;
   finally
     PrevMetafile.Free;
   end;
 end;
 

Решаем 2.


 ...
 var
   PrevMetafile : TMetafile;
   MetaCanvas : TMetafileCanvas;
 begin
   PrevMetafile := nil;
   MetaCanvas := nil;
 
 try
   PrevMetaFile := TMetaFile.Create;
 
   PrevMetafile.Width := oWidth;
   PrevMetafile.Height := oHeight;
 
   try
     MetaCanvas := TMetafileCanvas.Create( PrevMetafile, 0 );
 
 // здесь должен быть ваш код - с учетом масштабиpования.
 // я эту вещь вынес в ассигнуемую пpоцедуpу, и данный блок
 // вызываю лишь для отpисовки целой стpаницы.
 

см. PS1.


 finally
   MetaCanvas.Free;
 end;
 ...
 

PS1. Код, котоpый используется для отpисовки. oCanvas - TCanvas метафайла.


 ...
 var
   iHPage: integer; // высота страницы
 begin
   with oCanvas do
   begin
     iHPage := 3000;
 
     // залили область метайфайла белым - для дальнейшей pаботы
     Pen.Color := clBlack;
     Brush.Color := clWhite;
     FillRect( Rect( 0, 0, 2000, iHPage ) );
 
     // установили шpифты - с учетом их дальнейшего масштабиpования
     oCanvas.Font.Assign( oGrid.Font);
     oCanvas.Font.Size := Round( oGrid.Font.Size * kScale );
 
     ...
     xEnd := xBegin;
     iH := round( RowHeights[ iRow ] * kH );
     for iCol := 0 to ColCount - 1 do
     begin
       x := xEnd;
       xEnd := x + round( ColWidths[ iCol ] * kW );
       Rectangle( x, yBegin, xEnd, yBegin + iH );
       r := Rect( x + 1, yBegin + 1, xEnd - 1, yBegin + iH - 1 );
       s := Cells[ iCol, iRow ];
 
       // выписали в полученный квадрат текст
       DrawText( oCanvas.Handle, PChar( s ), Length( s ), r,
       DT_WORDBREAK or DT_CENTER );
 

Главное, что важно помнить на этом этапе - это не забывать, что все выводимые объекты должны пользоваться описанными коэф-тами (как вы их получите - это уже ваше дело). В данном случае - я pаботаю с пеpеделанным TStringGrid, котоpый сделал для многостpаничной печати.

Последний пункт - надо сфоpмиpованный метафайл или bmp напечатать.


 ...
 var
   Info: PBitmapInfo;
   InfoSize: Integer;
   Image: Pointer;
   ImageSize: DWORD;
   Bits: HBITMAP;
   DIBWidth, DIBHeight: Longint;
   PrintWidth, PrintHeight: Longint;
 begin
   ...
 
   case ImageType of
     itMetafile:
     begin
       if Picture.Metafile<>nil then
         Printer.Canvas.StretchDraw( Rect(aLeft, aTop, aLeft+fWidth,
         aTop+fHeight), Picture.Metafile);
     end;
 
     itBitmap:
     begin
       if Picture.Bitmap<>nil then
       begin
         with Printer, Canvas do
         begin
           Bits := Picture.Bitmap.Handle;
           GetDIBSizes(Bits, InfoSize, ImageSize);
           Info := AllocMem(InfoSize);
           try
             Image := AllocMem(ImageSize);
             try
               GetDIB(Bits, 0, Info^, Image^);
               with Info^.bmiHeader do
               begin
                 DIBWidth := biWidth;
                 DIBHeight := biHeight;
               end;
               PrintWidth := DIBWidth;
               PrintHeight := DIBHeight;
               StretchDIBits(Canvas.Handle, aLeft, aTop, PrintWidth,
               PrintHeight, 0, 0, DIBWidth, DIBHeight, Image, Info^,
               DIB_RGB_COLORS, SRCCOPY);
             finally
               FreeMem(Image, ImageSize);
             end;
           finally
             FreeMem(Info, InfoSize);
           end;
         end;
       end;
     end;
   end;
 end;
 

В чем заключается идея PreView ? Остается имея на pуках Metafila, Bmp - отpисовать с пеpесчетом внешний вид изобpажения (надо высчитать левый веpхний угол и pазмеpы "пpедваpительно пpосматpиваемого" изобpажения. Для показа изобpажения достаточно использовать StretchDraw. После того, как удалось вывести объекты на печать, пpоблему создания PreView pешили как "домашнее задание". Кстати, когда мы pаботаем с Bmp, то для пpосмотpа используем следующий хинт - записываем битовый обpаз чеpез такую пpоцедуpу :


 w:=MulDiv(Bmp.Width,GetDeviceCaps(Printer.Handle,LOGPIXELSX),
 Screen.PixelsPerInch);
 h:=MulDiv(Bmp.Height,GetDeviceCaps(Printer.Handle,LOGPIXELSY),
 Screen.PixelsPerInch);
 PrevBmp.Width:=w;
 PrevBmp.Height:=h;
 PrevBmp.Canvas.StretchDraw(Rect(0,0,w,h),Bmp);
 
 aPicture.Assign(PrevBmp);
 

Пpи этом масштабиpуется битовый обpаз с минимальными искажениями, а вот пpи печати - пpиходится bmp печатать именно так, как описано выше. Итог - наша bmp пpи печати чуть меньше, чем печатать ее чеpез WinWord, но пpи этом - внешне - без каких-либо искажений и пp.




Как узнать края печати в Win16 и Win32

В Win16, для этого используется API функция Escape() с константой GETPRINTINGOFFSET. В Win32, используется API функция GetDeviceCaps() с константами PHYSICALOFFSETX и PHYSICALOFFSETY. Однако, нет гарантии, что данная последовательность кодов поддерживается принтером, поэтому для проверки желательно всегда вызывать функцию Escape с константой QUERYESCSUPPORT.

Следующий пример возвращает отступы печати как в WIN16, так и в WIN32, учитывая тот факт, что не все принтеры поддерживают код GETPRINTINGOFFSET (в WIN16). Если дело обстоит так, то смещение печати вычисляется приближённо, получая размер страницы, вычитая физическую разрешающую способность устройства, и деля пополам.

Пример:


 uses Printers;
 
 procedure TForm1.Button1Click(Sender: TObject);
 var
   EscapeCode: integer;
   Margin: TPoint;
 begin
   if PrintDialog1.Execute then begin
 {$IFDEF WIN32}
     Margin.x := GetDeviceCaps(Printer.Handle, PHYSICALOFFSETX);
     Margin.y := GetDeviceCaps(Printer.Handle, PHYSICALOFFSETY);
 {$ELSE}
     EscapeCode := GETPRINTINGOFFSET;
     if Escape(Printer.Handle,
       QUERYESCSUPPORT,
       sizeof(EscapeCode),
       @EscapeCode,
       nil) <> 0 then
       if Escape(Printer.Handle,
         GETPRINTINGOFFSET,
         0,
         nil,
         @Margin) < 1 then begin
         EscapeCode := GETPHYSPAGESIZE;
         if Escape(Printer.Handle,
           QUERYESCSUPPORT,
           sizeof(EscapeCode),
           @EscapeCode,
           nil) <> 0 then
           if Escape(Printer.Handle,
             GETPHYSPAGESIZE,
             0,
             nil,
             @Margin) > 0 then begin
             Margin.x := (Margin.x -
               GetDeviceCaps(Printer.Handle, HorzRes)) div 2;
             Margin.y := (Margin.y -
               GetDeviceCaps(Printer.Handle, VertRes)) div 2;
           end else begin
             Margin.x := 0;
             Margin.y := 0;
           end;
       end;
 {$ENDIF}
     Memo1.Lines.Add(IntToStr(Margin.x));
     Memo1.Lines.Add(IntToStr(Margin.y));
   end;
 end;
 
 




Построчная печать

В Delphi 1 (а затем и в Delphi 2) я попытался написать программу, печатающую построчно на принтере (любого типа), после выхода из которой принтер НЕ выплевывает лист, а продолжает на нем печатать в случае повторного использования программы, то есть программа позволяет печатать строчку за строчкой, не удаляя при этом лист в случае завершения задачи.

Это противоречит неписанным законам Microsoft, поскольку нарушает режим многозадачности, и все же именно для моей задачи мне необходимо именно такое решение.

Я создал клон объекта TPrinter, назначение которого вы поймете ниже. Это работает со всеми матричными принтерами.

Вот пример объекта:


 var
   Myprinter: TRawPrinter;
   oldprinter: TPrinter;
 begin
   MyPrinter := TRawPrinter.Create;
   oldprinter := setprinter(MyPrinter);
   try
     if Printdialog1.execute then
     begin
       myprinter.startraw;
       myprinter.write('Delphi World is the best!');
       myprinter.writeln;
       myprinter.endraw;
     end
   finally
     setprinter(oldprinyter);
     myprinter.free;
   end
 end;
 

Вот пример использования объекта:


 unit Rawprinter;
 
 interface
 uses printers, windows;
 
 type
   TRawprinter = class(TPrinter)
 
   public
     dc2: HDC;
     procedure startraw;
     procedure endraw;
     procedure write(const s: string);
     procedure writeln;
   end;
 
 implementation
 uses sysutils, forms;
 
 function AbortProc(Prn: HDC; Error: Integer): Bool; stdcall;
 begin
 
   Application.ProcessMessages;
   Result := not Printer.Aborted;
 end;
 
 type
 
   TPrinterDevice = class
     Driver, Device, Port: string;
     constructor Create(ADriver, ADevice, APort: PChar);
     function IsEqual(ADriver, ADevice, APort: PChar): Boolean;
   end;
 
 constructor TPrinterDevice.Create(ADriver, ADevice, APort: PChar);
 begin
 
   inherited Create;
   Driver := ADriver;
   Device := ADevice;
   Port := APort;
 end;
 
 function TPrinterDevice.IsEqual(ADriver, ADevice, APort: PChar): Boolean;
 begin
 
   Result := (Device = ADevice) and (Port = APort);
 end;
 
 procedure TRawprinter.startraw;
 var
 
   CTitle: array[0..31] of Char;
   CMode: array[0..4] of char;
   DocInfo: TDocInfo;
   r: integer;
 begin
 
   StrPLCopy(CTitle, Title, SizeOf(CTitle) - 1);
   StrPCopy(CMode, 'RAW');
   FillChar(DocInfo, SizeOf(DocInfo), 0);
   with DocInfo do
   begin
     cbSize := SizeOf(DocInfo);
     lpszDocName := CTitle;
     lpszOutput := nil;
     lpszDatatype := CMode;
   end;
   with TPrinterDevice(Printers.Objects[PrinterIndex]) do
   begin
     DC2 := CreateDC(PChar(Driver), PChar(Device), PChar(Port), nil);
   end;
   SetAbortProc(dc2, AbortProc);
   r := StartDoc(dc2, DocInfo);
 end;
 
 procedure TRawprinter.endraw;
 var
   r: integer;
 begin
 
   r := windows.enddoc(dc2);
 end;
 
 type
   passrec = packed record
 
     l: word;
     s: array[0..255] of char;
   end;
 var
   pass: Passrec;
 
 procedure TRawprinter.write(const s: string);
 begin
 
   pass.l := length(s);
   strpcopy(pass.s, s);
   escape(dc2, PASSTHROUGH, 0, @pass, nil);
 end;
 
 procedure TRawprinter.writeln;
 begin
 
   pass.l := 2;
   strpcopy(pass.s, #13#10);
   escape(dc2, PASSTHROUGH, 0, @pass, nil);
 end;
 
 end.
 




Распечатать Canvas


 uses
   Printers;
 
 procedure PrintText(Text: string);
 begin
   with Printer do
   begin
     BeginDoc;
     Canvas.TextOut(5, 50, Text);
     EndDoc;
   end;
 end;
 




Печать ячеек

Автор: Lloyd Linklater (Sysop) (Delphi Technical Support)

У кого-нибудь есть пример кода печати в заданной ячейке? Типа PrintAt(row,col,"Text")?

Вот некоторый код, который я нашел после блужданий в группах новостей. Правда сам я его не проверял, но источник утверждает, что он работает. Так что будьте внимательны!


 TForm1.PrintTableClick(Sender: TObject);
 var
   xcord: integer;
   ycord: integer;
   recordbuffer: string;
 begin
   xcord := 10;
   ycord := 10;
   Table1.First;
   Printer.BeginDoc;
   Printer.Canvas.Font.Name := 'Courier New';
   while not Table1.EOF do
   begin
     recordbuffer := concat((Table1.Fields[0].AsString), ' ',
       (Table1.Fields[1].AsString));
     recordbuffer := recordbuffer + concat(' ', (Table1.Fields[2].AsString);
       {пока все поля не будут в recordbuffer}
 
       Printer.Canvas.TextOut(xcord, ycord, recordbuffer);
       ycord := ycord + 50;
 
       Table1.next;
   end;
   Printer.Enddoc;
 end;
 




Пример вывода текста на печать, используя COM порт

Автор: Peter


 Var
   Printer: THandle;
   N      : Cardinal;
   C      : POverlapped;
 
 begin
 //Открываем порт принтера для записи
 Printer := CreateFile(PChar('LPT1'),
            GENERIC_READ or GENERIC_WRITE,0,nil,
            OPEN_EXISTING,FILE_FLAG_OVERLAPPED,0);
 
 //Печатаем слово 'Hello World';
 WriteFile(Printer,'Hello World',11,N,c);
 //Закрываем порт
 CloseHandle(Printer);
 




Печать содержимого DBGrid через QuickReport

Частенько у пользователя возникает необходимость распечатать отчёт из базы данных. Естественно, что он начинает просить Вас добавить такую возможность в приложение. Как оказалось, при помощи TQuickRep данную задачу можно очень легко решить.

Итак, приступим. Для начала создайте новую форму, назвав её TGridReport, и поместите на неё TQuickRep. Переименуйте QuickRep в GridRep. Затем сделайте следующию процедуру, которая получает в качестве параметра DBGrid:


 procedure TGridReport.Preview(Grid: TDBGrid);
 var
   i, CurrentLeft, CurrentTop : integer;
   BMark: TBookmark;
 begin
   GridRep.Dataset:=Grid.DataSource.DataSet;
 
   if not GridRep.Bands.HasColumnHeader then
     GridRep.Bands.HasColumnHeader:=true;
 
   if not GridRep.Bands.HasDetail then
     GridRep.Bands.HasDetail:=true;
 
   GridRep.Bands.ColumnHeaderBand.Height:=Abs(Grid.TitleFont.Height) + 10;
   GridRep.Bands.DetailBand.Height:=Abs(Grid.Font.Height) + 10;
   CurrentLeft := 12;
   CurrentTop := 6;
 
   {Запись, на которой пользователь останавливается в DBGrid}
   BMark:=Grid.DataSource.DataSet.GetBookmark;
   {Запретим мерцание грида в процессе работы отчёта}
   Grid.DataSource.DataSet.DisableControls;
   try
     for i:=0 to Grid.FieldCount - 1 do
     begin
       if (CurrentLeft + Canvas.TextWidth(Grid.Columns[i].Title.Caption)) >
       (GridRep.Bands.ColumnHeaderBand.Width) then
       begin
         CurrentLeft := 12;
         CurrentTop := CurrentTop + Canvas.TextHeight('A') + 6;
         GridRep.Bands.ColumnHeaderBand.Height :=
         GridRep.Bands.ColumnHeaderBand.Height + (Canvas.TextHeight('A') + 10);
         GridRep.Bands.DetailBand.Height :=
         GridRep.Bands.DetailBand.Height + (Canvas.TextHeight('A') + 10);
       end;
       {Создадим заголовок отчёта при помощи QRLabels}
       with TQRLabel.Create(GridRep.Bands.ColumnHeaderBand) do
       begin
         Parent := GridRep.Bands.ColumnHeaderBand;
         Color := GridRep.Bands.ColumnHeaderBand.Color;
         Left := CurrentLeft;
         Top := CurrentTop;
         Caption:=Grid.Columns[i].Title.Caption;
       end;
       {Создадим тело отчёта при помощи QRDBText}
       with TQRDbText.Create(GridRep.Bands.DetailBand) do
       begin
         Parent := GridRep.Bands.DetailBand;
         Color := GridRep.Bands.DetailBand.Color;
         Left := CurrentLeft;
         Top := CurrentTop;
         Alignment:=Grid.Columns[i].Alignment;
         AutoSize:=false;
         AutoStretch:=true;
         Width:=Grid.Columns[i].Width;
         Dataset:=GridRep.Dataset;
         DataField:=Grid.Fields[i].FieldName;
         CurrentLeft:=CurrentLeft + (Grid.Columns[i].Width) + 15;
       end;
     end;
 
     lblPage.Left := bdTitle.Width - lblPage.Width - 10;
     lblDate.Left := bdTitle.Width - lblDate.Width - 10;
 
     {Далее вызовем метод предварительного просмотра из QuickRep}
     GridRep.PreviewModal; {либо, если желаете, то PreviewModal}
 
   finally
     with Grid.DataSource.DataSet do
     begin
       GotoBookmark(BMark);
       FreeBookmark(BMark);
       EnableControls;
     end;
   end;
 end;
 




Распечатать Excel файл


 uses   ComObj;
 procedure TForm1.Button1Click(Sender: TObject);
 var
   ExcelApp: OLEVariant;
 begin
   // Create an Excel instance 
   // Excel Instanz erzeugen 
   ExcelApp := CreateOleObject('Excel.Application');
   try
     ExcelApp.Workbooks.Open('C:\test\xyz.xls');
     // you can also modify some settings from PageSetup 
     // Man kann auch noch einige Einstellungen von "Seite Einrichten" anpassen 
     ExcelApp.ActiveSheet.PageSetup.Orientation := xlLandscape;
     // Print it out 
     // Ausdrucken 
     ExcelApp.Worksheets.PrintOut;
   finally
     // Close Excel 
     // Excel wieder schliessen 
     if not VarIsEmpty(ExcelApp) then
     begin
       ExcelApp.Quit;
       ExcelApp := Unassigned;
     end;
   end;
 end;
 




Печать всей формы


 unit PrintF;
 
 {Печатает TLabel, TEdit, TMemo, TStringGrid, TShape и др. DB-компоненты.
 
 Установите Form H & V ScrollBar.Ranges на 768X1008 для страницы 8X10.5.
 Примечание: это не компонент. Успехов. Bill}
 
 interface
 uses
 
   SysUtils, WinTypes, WinProcs, Classes, Graphics, Controls,
   Forms, Grids, Printers, StdCtrls, ExtCtrls, Mask;
 
 function PrintForm(AForm: TForm; ATag: Longint): integer;
 
 {используйте:   PrintForm(Form2, 0);
 
 AForm - форма, которую необходимо напечатать. Если вы, к примеру,
 печатаете Form2 из обработчика события Form1, то используйте Unit2
 в списке используемых модулей в секции implementation молуля Unit1.
 ATag - поле Tag компонента, который необходимо печатать или 0 для всех.
 Если Tag компонента равен 14 (2+4+8), он буден напечатан в случае,
 когда ATag равен 0, 2, 4 или 8.
 Функция возвращает количество напечатанных компонентов. }
 
 implementation
 var
   ScaleX, ScaleY, I, Count: integer;
 
   DC: HDC;
   F: TForm;
 
 function ScaleToPrinter(R: TRect): TRect;
 begin
   R.Top := (R.Top + F.VertScrollBar.Position) * ScaleY;
   R.Left := (R.Left + F.HorzScrollBar.Position) * ScaleX;
   R.Bottom := (R.Bottom + F.VertScrollBar.Position) * ScaleY;
   R.Right := (R.Right + F.HorzScrollBar.Position) * ScaleY;
   Result := R;
 end;
 
 procedure PrintMComponent(MC: TMemo);
 var
   C: array[0..255] of char;
   CLen: integer;
   Format: Word;
   R: TRect;
 
 begin
   Printer.Canvas.Font := MC.Font;
   DC := Printer.Canvas.Handle; {так DrawText знает о шрифте}
   R := ScaleToPrinter(MC.BoundsRect);
   if (not (F.Components[I] is TCustomLabel)) and (MC.BorderStyle = bsSingle)
     then
     Printer.Canvas.Rectangle(R.Left, R.Top, R.Right, R.Bottom);
   Format := DT_LEFT;
   if (F.Components[I] is TEdit) or (F.Components[I] is TCustomMaskEdit) then
     Format := Format or DT_SINGLELINE or DT_VCENTER
   else
   begin
     if MC.WordWrap then
       Format := DT_WORDBREAK;
     if MC.Alignment = taCenter then
       Format := Format or DT_CENTER;
     if MC.Alignment = taRightJustify then
       Format := Format or DT_RIGHT;
     R.Bottom := R.Bottom + Printer.Canvas.Font.Height;
   end;
   CLen := MC.GetTextBuf(C, 255);
   R.Left := R.Left + ScaleX + ScaleX;
   WinProcs.DrawText(DC, C, CLen, R, Format);
   inc(Count);
 end;
 
 procedure PrintShape(SC: TShape);
 var
   H, W, S: integer;
   R: TRect;
 begin {PrintShape}
   Printer.Canvas.Pen := SC.Pen;
   Printer.Canvas.Pen.Width := Printer.Canvas.Pen.Width * ScaleX;
   Printer.Canvas.Brush := SC.Brush;
   R := ScaleToPrinter(SC.BoundsRect);
   W := R.Right - R.Left;
   H := R.Bottom - R.Top;
   if W < H then
     S := W
   else
     S := H;
   if SC.Shape in [stSquare, stRoundSquare, stCircle] then
   begin
     Inc(R.Left, (W - S) div 2);
     Inc(R.Top, (H - S) div 2);
     W := S;
     H := S;
   end;
   case SC.Shape of
     stRectangle, stSquare:
       Printer.Canvas.Rectangle(R.Left, R.Top, R.Left + W, R.Top + H);
     stRoundRect, stRoundSquare:
       Printer.Canvas.RoundRect(R.Left, R.Top, R.Left + W, R.Top + H, S div 4, S
         div 4);
     stCircle, stEllipse:
       Printer.Canvas.Ellipse(R.Left, R.Top, R.Left + W, R.Top + H);
   end;
   Printer.Canvas.Pen.Width := ScaleX;
   Printer.Canvas.Brush.Style := bsClear;
   inc(Count);
 end; {PrintShape}
 
 procedure PrintSGrid(SGC: TStringGrid);
 var
   J, K: integer;
   Q, R: TRect;
   Format: Word;
   C: array[0..255] of char;
   CLen: integer;
 begin
   Printer.Canvas.Font := SGC.Font;
   DC := Printer.Canvas.Handle; {так DrawText знает о шрифте}
   Format := DT_SINGLELINE or DT_VCENTER;
   Q := SGC.BoundsRect;
   Printer.Canvas.Pen.Width := SGC.GridLineWidth * ScaleX;
   for J := 0 to SGC.ColCount - 1 do
     for K := 0 to SGC.RowCount - 1 do
     begin
       R := SGC.CellRect(J, K);
       if R.Right > R.Left then
       begin
         R.Left := R.Left + Q.Left;
         R.Right := R.Right + Q.Left + SGC.GridLineWidth;
         R.Top := R.Top + Q.Top;
         R.Bottom := R.Bottom + Q.Top + SGC.GridLineWidth;
         R := ScaleToPrinter(R);
         if (J < SGC.FixedCols) or (K < SGC.FixedRows) then
           Printer.Canvas.Brush.Color := SGC.FixedColor
         else
           Printer.Canvas.Brush.Style := bsClear;
         if SGC.GridLineWidth > 0 then
           Printer.Canvas.Rectangle(R.Left, R.Top, R.Right, R.Bottom);
         StrPCopy(C, SGC.Cells[J, K]);
         R.Left := R.Left + ScaleX + ScaleX;
         WinProcs.DrawText(DC, C, StrLen(C), R, Format);
 
       end;
     end;
   Printer.Canvas.Pen.Width := ScaleX;
   inc(Count);
 end;
 
 function PrintForm(AForm: TForm; ATag: Longint): integer;
 begin {PrintForm}
 
   Count := 0;
   F := AForm;
   Printer.BeginDoc;
   try
     DC := Printer.Canvas.Handle;
     ScaleX := WinProcs.GetDeviceCaps(DC, LOGPIXELSX) div F.PixelsPerInch;
     ScaleY := WinProcs.GetDeviceCaps(DC, LOGPIXELSY) div F.PixelsPerInch;
     for I := 0 to F.ComponentCount - 1 do
       if TControl(F.Components[I]).Visible then
         if (ATag = 0) or (TControl(F.Components[I]).Tag and ATag = ATag) then
         begin
           if (F.Components[I] is TCustomLabel) or (F.Components[I] is
             TCustomEdit) then
             PrintMComponent(TMemo(F.Components[I]));
           if (F.Components[I] is TShape) then
             PrintShape(TShape(F.Components[I]));
           if (F.Components[I] is TStringGrid) then
             PrintSGrid(TStringGrid(F.Components[I]));
         end;
   finally
     Printer.EndDoc;
     Result := Count;
   end;
 end; {PrintForm}
 
 end.
 


 unit Rulers;
 { Добавьте в файл .DCR иконки для двух компонентов.
 
 Успехов, Bill}
 interface
 
 uses
 
   SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
   Forms;
 
 type
 
   THRuler = class(TGraphicControl)
   private
     { Private declarations }
     fHRulerAlign: TAlign;
     procedure SetHRulerAlign(Value: TAlign);
   protected
     { Protected declarations }
     procedure Paint; override;
   public
     { Public declarations }
     constructor Create(AOwner: TComponent); override;
   published
     { Published declarations }
     property AlignHRuler: TAlign read fHRulerAlign write SetHRulerAlign default
       alNone;
     property Color default clYellow;
     property Height default 33;
     property Width default 768;
     property Visible;
   end;
 
 type
   TVRuler = class(TGraphicControl)
   private
     { Private declarations }
     fVRulerAlign: TAlign;
     procedure SetVRulerAlign(Value: TAlign);
   protected
     { Protected declarations }
     procedure Paint; override;
   public
     { Public declarations }
     constructor Create(AOwner: TComponent); override;
   published
     { Published declarations }
     property AlignVRuler: TAlign read fVRulerAlign write SetVRulerAlign default
       alNone;
     property Color default clYellow;
     property Height default 1008;
     property Width default 33;
     property Visible;
   end;
 
 procedure Register;
 
 implementation
 
 procedure Register;
 begin
 
   RegisterComponents('Samples', [THRuler, TVRuler]);
 end;
 
 procedure THRuler.SetHRulerAlign(Value: TAlign);
 begin
 
   if Value in [alTop, alBottom, alNone] then
   begin
     fHRulerAlign := Value;
     Align := Value;
   end;
 end;
 
 constructor THRuler.Create(AOwner: TComponent);
 begin
 
   inherited Create(AOwner);
   AlignHRuler := alNone;
   Color := clYellow;
   Height := 33;
   Width := 768;
 end;
 
 procedure THRuler.Paint;
 var
   a12th, N, X: word;
 begin
 
   a12th := Screen.PixelsPerInch div 12;
   N := 0;
   X := 0;
   with Canvas do
   begin
     Brush.Color := Color;
     FillRect(ClientRect);
     with ClientRect do
       Rectangle(Left, Top, Right, Bottom);
     while X < Width do
     begin
       MoveTo(X, 1);
       LineTo(X, 6 * (1 + byte(N mod 3 = 0) +
         byte(N mod 6 = 0) +
         byte(N mod 12 = 0)));
       if (N > 0) and (N mod 12 = 0) then
         TextOut(PenPos.X + 3, 9, IntToStr(N div 12));
       N := N + 1;
       X := X + a12th;
     end;
   end;
 end;
 {*********************************************}
 
 procedure TVRuler.SetVRulerAlign(Value: TAlign);
 begin
 
   if Value in [alLeft, alRight, alNone] then
   begin
     fVRulerAlign := Value;
     Align := Value;
   end;
 end;
 
 constructor TVRuler.Create(AOwner: TComponent);
 begin
 
   inherited Create(AOwner);
   AlignVRuler := alNone;
   Color := clYellow;
   Height := 1008;
   Width := 33;
 end;
 
 procedure TVRuler.Paint;
 var
   a6th, N, Y: word;
 begin
 
   a6th := Screen.PixelsPerInch div 6;
   N := 0;
   Y := 0;
   with Canvas do
   begin
     Brush.Color := Color;
     FillRect(ClientRect);
     with ClientRect do
       Rectangle(Left, Top, Right, Bottom);
     while Y < Height do
     begin
       MoveTo(1, Y);
       LineTo(6 * (2 + byte(N mod 3 = 0) +
         byte(N mod 6 = 0)), Y);
       if (N > 0) and (N mod 6 = 0) then
         TextOut(12, PenPos.Y - 16, IntToStr(N div 6));
       N := N + 1;
       Y := Y + a6th;
     end;
   end;
 end;
 
 end.
 




Печать содержимого TMemo или TListBox

Идет Иван царевич по лесу и видит: стоит избушка на курьих ножках. Как обычно, к лесу передом к нему (ну сами знаете). Иван царевич ей и говорит:
- Избушка, избушка! Повернись ко мне передом, а к лесу задом!
А избушка ему в ответ:
- Denied of Service

Следующая функция имеет один параметр в виде объекта TStrings и печатает каждую строку на принтер, установленный в системе по умолчанию. Так как эта функция использует TStrings, то она будет работать с различными компонентами, которые содержат свойство типа TStrings, такие как TDBMemo или TOutline:


 uses Printers;
 
 procedure PrintStrings(Strings: TStrings);
 var
   Prn: TextFile;
   i: word;
 begin
   AssignPrn(Prn);
   try
     Rewrite(Prn);
     try
       for i := 0 to Strings.Count - 1 do
         writeln(Prn, Strings.Strings[i]);
     finally
       CloseFile(Prn);
     end;
   except
     on EInOutError do
       MessageDlg('Error Printing text.', mtError, [mbOk], 0);
   end;
 end;
 

Чтобы распечатать содержимое TMemo или TListbox, используйте следующие команды:


 PrintStrings(Memo1.Lines);
 

или


 PrintStrings(Listbox1.Items);
 




Как производить Печать из WebBrowsera

Есть два способа вывода на печать. Первый пример работает в IE 4.x и выше, в то время как второй пример расчитан на IE 3.x:


 var
   vaIn, vaOut: OleVariant;
 ...
 WebBrowser.ControlInterface.ExecWB(OLECMDID_PRINT,
 OLECMDEXECOPT_DONTPROMPTUSER, vaIn, vaOut);
 

либо:


 procedure TForm1.PrintIE;
 var
   CmdTarget : IOleCommandTarget;
   vaIn, vaOut: OleVariant;
 begin
   if WebBrowser1.Document <> nil then
     try
       WebBrowser1.Document.QueryInterface(IOleCommandTarget, CmdTarget);
       if CmdTarget <> nil then
         try
           CmdTarget.Exec( PGuid(nil), OLECMDID_PRINT,
                          OLECMDEXECOPT_DONTPROMPTUSER, vaIn, vaOut);
         finally
           CmdTarget._Release;
         end;
     except
       // nothing
     end;
 end;
 

Обратите внимание: Если версия Delphi ниже чем 3.02, то необходимо заменить


PGuid(nil)

на


PGuid(nil)^




Как напечатать изображение

Используйте приведенный код. И не забудьте включить Printers в список используемых модулей:

Строки, на которые вы должны обратить внимание, справа содержат комментарий // **. Данный код осуществляет корректное масштабирование изображения, в противном случае при печати вы можете получить небольшую иконку. Разрешение принтера больше, чем разрешение вашего дисплея.


 procedure AngleTextOut(CV: TCanvas; const sText: string; x, y, angle: integer);
 var
   LogFont: TLogFont;
   SaveFont: TFont;
 
   procedure TForm1.Button1Click(Sender: TObject);
   var
     ScaleX, ScaleY: Integer;
     R: TRect;
   begin
     Printer.BeginDoc; // **
     with Printer do
       try
         ScaleX := GetDeviceCaps(Handle, logPixelsX) div PixelsPerInch;
         ScaleY := GetDeviceCaps(Handle, logPixelsY) div PixelsPerInch;
         R := Rect(0, 0, Image1.Picture.Width * ScaleX,
           Image1.Picture.Height * ScaleY);
         Canvas.StretchDraw(R, Image1.Picture.Graphic); // **
       finally
         EndDoc; // **
       end;
   end;
 




Печать текста в обход Windows

Автор: Steve

ОТкройте файл типа TextFile и пишите в него напрямую:


 var
   Lst: TextFile;
 begin
   AssignFile(Lst, 'LPT1');
   Rewrite(Lst);
   WriteLn(Lst, 'Здравствуй, мир!');
   Close(Lst);
 end.
 

При этом вы должны помнить, что при данной технологии вы не можете в это же время печатать из другой программы, иначе наступит конец света, а ваша распечатка будет похожа на "запутанный беспорядк".

Если вы планируете посылать на принтер управляющие коды, вызывайте следующую функцию немедленно после перезаписи файла:


 procedure SetBinaryMode (var F: Text);  assembler;
 asm
   mov ax,$4400
   les di,F
   mov bx,word ptr es:[di]
   int $21
   or dl,$20
   xor dh,dh
   mov ax,$4401
   int $21
 end;
 




Печать на любом принтере

Автор: Mike Scott

Как лучше всего убедиться в том, что текст на странице расположен правильно вне зависимости от принтера, версии windows и т.п.?

Есть пара вызовов принтерных Escape-функций API, возвращающих физический размер страницы и отступ от края при печати (верх лево). Используя это, вы можете убедиться в том, печать начинается в одном и том же месте реального листа. Примечание: тем не менее, вы все еще зависите от точности принтера и драйвера, на практике это может вылиться в разброс 1-2 мм.

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


 var
   PhysSize, PrintingOffset : TPoint ;
 begin
   Escape( Printer.Handle, GetPhysPageSize, 0, NIL, @PhysSize ) ;
   Escape( Printer.Handle, GetPrintingOffset, 0, NIL, @PrintingOffset ) ;
 

PhysSize и PrintingOffset теперь устанавливаются в единицах устройства, т.е. в пикселях принтера. Для преобразования мм в единицы устройства используйте следующий код:


 xDevUnits := MulDiv( XXXmm,
 GetDeviceCaps( Printer.Handle, HORZRES ),
 GetDeviceCaps( Printer.Handle, HORZSIZE ) ) ;
 yDevUnits := MulDiv( YYYmm,
 GetDeviceCaps( Printer.Handle, VERTRES ),
 GetDeviceCaps( Printer.Handle, VERTSIZE ) ) ;
 

Затем, для примера, вы можете использовать эти координаты для вывода текста с помощью методов Printer.Canvas. Хорошая идея для этого метода - измерение единиц устройств, отступа и размера страниц для различных принтеров и сохранение полученной информации в базе данных. Также можно предусмотреть удобный для пользователя диалог, где он мог бы внести свои изменения и откорректировать точность своего принтера.




Печать структуры таблицы Paradox

Вот код печати структуры таблицы Paradox, состряпанный на скорую руку. Предполагается, что компонент Table имеет имя Table1.


 procedure TForm1.Button1Click(Sender: TObject);
 const
   FieldTypes: array[0..16] of string[10] = ('Unknown', 'String', 'Smallint',
     'Integer', 'Word', 'Boolean', 'Float', 'Currency', 'BCD', 'Date', 'Time',
     'DateTime', 'Bytes', 'VarBytes', 'Blob', 'Memo', 'Graphic');
 var
   i, nX, nY, nHeight, nWidth: Integer;
   rtxtMetric: TTextMetric;
   s: array[0..3] of string[10];
 begin
   with Table1.FieldDefs, Printer do
   begin
     Update;
     PrinterIndex := -1;
     Title := 'Структура ' + Table1.TableName;
     BeginDoc;
     nX := 0;
     nY := 0;
     WinProcs.GetTextMetrics(Canvas.Handle, rtxtMetric);
     nHeight := rtxtMetric.tmHeight;
     nWidth := rtxtMetric.tmAveCharWidth;
     for i := 0 to Count - 1 do
     begin
       s[0] := IntToStr(Items[i].FieldNo) + #9;
       s[1] := Items[i].Name + #9;
       s[2] := FieldTypes[Ord(Items[i].DataType)] + #9;
       s[3] := IntToStr(Items[i].Size);
       Canvas.TextOut(nX, nY, s[0]);
       Inc(nX, Length(s[0]) * nWidth);
       Canvas.TextOut(nX, nY, s[1]);
       Inc(nX, Length(s[1]) * nWidth);
       Canvas.TextOut(nX, nY, s[2]);
       Inc(nX, Length(s[2]) * nWidth);
       Canvas.TextOut(nX, nY, s[3]);
       nX := 0;
       nY := i * nHeight;
     end;
     EndDoc;
   end;
 end;
 




Как распечатать картинку

Автор: Олег Кулабухов


 uses Printers;
 
 type
   PPalEntriesArray = ^TPalEntriesArray; {for palette re-construction}
   TPalEntriesArray = array[0..0] of TPaletteEntry;
 
 procedure BltTBitmapAsDib(DestDc: hdc; {Handle of where to blt}
   x: word; {Bit at x}
   y: word; {Blt at y}
   Width: word; {Width to stretch}
   Height: word; {Height to stretch}
   bm: TBitmap); {the TBitmap to Blt}
 var
   OriginalWidth: LongInt; {width of BM}
   dc: hdc; {screen dc}
   IsPaletteDevice: bool; {if the device uses palettes}
   IsDestPaletteDevice: bool; {if the device uses palettes}
   BitmapInfoSize: integer; {sizeof the bitmapinfoheader}
   lpBitmapInfo: PBitmapInfo; {the bitmap info header}
   hBm: hBitmap; {handle to the bitmap}
   hPal: hPalette; {handle to the palette}
   OldPal: hPalette; {temp palette}
   hBits: THandle; {handle to the DIB bits}
   pBits: pointer; {pointer to the DIB bits}
   lPPalEntriesArray: PPalEntriesArray; {palette entry array}
   NumPalEntries: integer; {number of palette entries}
   i: integer; {looping variable}
 begin
   {If range checking is on - lets turn it off for now}
   {we will remember if range checking was on by defining}
   {a define called CKRANGE if range checking is on.}
   {We do this to access array members past the arrays}
   {defined index range without causing a range check}
   {error at runtime. To satisfy the compiler, we must}
   {also access the indexes with a variable. ie: if we}
   {have an array defined as a: array[0..0] of byte,}
   {and an integer i, we can now access a[3] by setting}
   {i := 3; and then accessing a[i] without error}
 {$IFOPT R+}
 {$DEFINE CKRANGE}
 {$R-}
 {$ENDIF}
 
   {Save the original width of the bitmap}
   OriginalWidth := bm.Width;
 
   {Get the screen's dc to use since memory dc's are not reliable}
   dc := GetDc(0);
   {Are we a palette device?}
   IsPaletteDevice :=
     GetDeviceCaps(dc, RASTERCAPS) and RC_PALETTE = RC_PALETTE;
   {Give back the screen dc}
   dc := ReleaseDc(0, dc);
 
   {Allocate the BitmapInfo structure}
   if IsPaletteDevice then
     BitmapInfoSize := sizeof(TBitmapInfo) + (sizeof(TRGBQUAD) * 255)
   else
     BitmapInfoSize := sizeof(TBitmapInfo);
   GetMem(lpBitmapInfo, BitmapInfoSize);
 
   {Zero out the BitmapInfo structure}
   FillChar(lpBitmapInfo^, BitmapInfoSize, #0);
 
   {Fill in the BitmapInfo structure}
   lpBitmapInfo^.bmiHeader.biSize := sizeof(TBitmapInfoHeader);
   lpBitmapInfo^.bmiHeader.biWidth := OriginalWidth;
   lpBitmapInfo^.bmiHeader.biHeight := bm.Height;
   lpBitmapInfo^.bmiHeader.biPlanes := 1;
   if IsPaletteDevice then
     lpBitmapInfo^.bmiHeader.biBitCount := 8
   else
     lpBitmapInfo^.bmiHeader.biBitCount := 24;
   lpBitmapInfo^.bmiHeader.biCompression := BI_RGB;
   lpBitmapInfo^.bmiHeader.biSizeImage :=
     ((lpBitmapInfo^.bmiHeader.biWidth *
     longint(lpBitmapInfo^.bmiHeader.biBitCount)) div 8) *
     lpBitmapInfo^.bmiHeader.biHeight;
   lpBitmapInfo^.bmiHeader.biXPelsPerMeter := 0;
   lpBitmapInfo^.bmiHeader.biYPelsPerMeter := 0;
   if IsPaletteDevice then
   begin
     lpBitmapInfo^.bmiHeader.biClrUsed := 256;
     lpBitmapInfo^.bmiHeader.biClrImportant := 256;
   end
   else
   begin
     lpBitmapInfo^.bmiHeader.biClrUsed := 0;
     lpBitmapInfo^.bmiHeader.biClrImportant := 0;
   end;
 
   {Take ownership of the bitmap handle and palette}
   hBm := bm.ReleaseHandle;
   hPal := bm.ReleasePalette;
 
   {Get the screen's dc to use since memory dc's are not reliable}
   dc := GetDc(0);
 
   if IsPaletteDevice then
   begin
     {If we are using a palette, it must be}
     {selected into the dc during the conversion}
     OldPal := SelectPalette(dc, hPal, TRUE);
     {Realize the palette}
     RealizePalette(dc);
   end;
   {Tell GetDiBits to fill in the rest of the bitmap info structure}
   GetDiBits(dc,
     hBm,
     0,
     lpBitmapInfo^.bmiHeader.biHeight,
     nil,
     TBitmapInfo(lpBitmapInfo^),
     DIB_RGB_COLORS);
 
   {Allocate memory for the Bits}
   hBits := GlobalAlloc(GMEM_MOVEABLE,
     lpBitmapInfo^.bmiHeader.biSizeImage);
   pBits := GlobalLock(hBits);
   {Get the bits}
   GetDiBits(dc,
     hBm,
     0,
     lpBitmapInfo^.bmiHeader.biHeight,
     pBits,
     TBitmapInfo(lpBitmapInfo^),
     DIB_RGB_COLORS);
 
   if IsPaletteDevice then
   begin
     {Lets fix up the color table for buggy video drivers}
     GetMem(lPPalEntriesArray, sizeof(TPaletteEntry) * 256);
 {$IFDEF VER100}
     NumPalEntries := GetPaletteEntries(hPal,
       0,
       256,
       lPPalEntriesArray^);
 {$ELSE}
     NumPalEntries := GetSystemPaletteEntries(dc,
       0,
       256,
       lPPalEntriesArray^);
 {$ENDIF}
     for i := 0 to (NumPalEntries - 1) do
     begin
       lpBitmapInfo^.bmiColors[i].rgbRed :=
         lPPalEntriesArray^[i].peRed;
       lpBitmapInfo^.bmiColors[i].rgbGreen :=
         lPPalEntriesArray^[i].peGreen;
       lpBitmapInfo^.bmiColors[i].rgbBlue :=
         lPPalEntriesArray^[i].peBlue;
     end;
     FreeMem(lPPalEntriesArray, sizeof(TPaletteEntry) * 256);
   end;
 
   if IsPaletteDevice then
   begin
     {Select the old palette back in}
     SelectPalette(dc, OldPal, TRUE);
     {Realize the old palette}
     RealizePalette(dc);
   end;
 
   {Give back the screen dc}
   dc := ReleaseDc(0, dc);
 
   {Is the Dest dc a palette device?}
   IsDestPaletteDevice :=
     GetDeviceCaps(DestDc, RASTERCAPS) and RC_PALETTE = RC_PALETTE;
 
   if IsPaletteDevice then
   begin
     {If we are using a palette, it must be}
     {selected into the dc during the conversion}
     OldPal := SelectPalette(DestDc, hPal, TRUE);
     {Realize the palette}
     RealizePalette(DestDc);
   end;
 
   {Do the blt}
   StretchDiBits(DestDc,
     x,
     y,
     Width,
     Height,
     0,
     0,
     OriginalWidth,
     lpBitmapInfo^.bmiHeader.biHeight,
     pBits,
     lpBitmapInfo^,
     DIB_RGB_COLORS,
     SrcCopy);
 
   if IsDestPaletteDevice then
   begin
     {Select the old palette back in}
     SelectPalette(DestDc, OldPal, TRUE);
     {Realize the old palette}
     RealizePalette(DestDc);
   end;
 
   {De-Allocate the Dib Bits}
   GlobalUnLock(hBits);
   GlobalFree(hBits);
 
   {De-Allocate the BitmapInfo}
   FreeMem(lpBitmapInfo, BitmapInfoSize);
 
   {Set the ownership of the bimap handles back to the bitmap}
   bm.Handle := hBm;
   bm.Palette := hPal;
 
   {Turn range checking back on if it was on when we started}
 {$IFDEF CKRANGE}
 {$UNDEF CKRANGE}
 {$R+}
 {$ENDIF}
 end;
 
 procedure TForm1.Button1Click(Sender: TObject);
 begin
   if PrintDialog1.Execute then
   begin
     Printer.BeginDoc;
     BltTBitmapAsDib(Printer.Canvas.Handle,
       0,
       0,
       Image1.Picture.Bitmap.Width,
       Image1.Picture.Bitmap.Height,
       Image1.Picture.Bitmap);
     Printer.EndDoc;
   end;
 end;
 




Как изменить размер страницы при печати

Один из способов, это перед началом печати изменить структуру devicemode у принтера.

Другие настройки, которые можно поменять, смотрите в TDEVMODE в хелпе Delphi 1.02 или DEVMODE в Delphi 2.01.

Следующий пример демонстрирует изменение размера печатаемой страницы:


 procedure TForm1.Button1Click(Sender: TObject);
 var
   Device: array[0..255] of char;
   Driver: array[0..255] of char;
   Port: array[0..255] of char;
   hDMode: THandle;
   PDMode: PDEVMODE;
 begin
   Printer.PrinterIndex := Printer.PrinterIndex;
   Printer.GetPrinter(Device, Driver, Port, hDMode);
   if hDMode <> 0 then begin
     pDMode := GlobalLock(hDMode);
     if pDMode <> nil then begin
 
      {Set to legal}
       pDMode^.dmFields := pDMode^.dmFields or dm_PaperSize;
       pDMode^.dmPaperSize := DMPAPER_LEGAL;
 
      {Set to custom size}
       pDMode^.dmFields := pDMode^.dmFields or
         DM_PAPERSIZE or
         DM_PAPERWIDTH or
         DM_PAPERLENGTH;
       pDMode^.dmPaperSize := DMPAPER_USER;
       pDMode^.dmPaperWidth := 100 {SomeValueInTenthsOfAMillimeter};
       pDMode^.dmPaperLength := 100 {SomeValueInTenthsOfAMillimeter};
 
      {Set the bin to use}
       pDMode^.dmFields := pDMode^.dmFields or DMBIN_MANUAL;
       pDMode^.dmDefaultSource := DMBIN_MANUAL;
 
       GlobalUnlock(hDMode);
     end;
   end;
   Printer.PrinterIndex := Printer.PrinterIndex;
   Printer.BeginDoc;
   Printer.Canvas.TextOut(100, 100, 'Test 1');
   Printer.EndDoc;
 end;
 




Печать повернутого текста


 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;
 




Печать повернутого текста 2


 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;
 




Печать повернутого текста 3

Некоторое время я делал так: я создавал шрифт, выбирал его в 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;
 

.... и затем использовал любую функцию рисования для вывода текста.




Печать повернутого текста 4

Приведенное выше решение (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;
 




Размер полей при печати

Мне необходимо получить значения (лево, право, верх, низ) "непечатаемой области" принтера.

Из статьи Delphi Developer "Take Control of your printer with a custom Delphi Class":

Чтобы получить левое и верхнее поле принтера, используйте Windows Escape функцию с параметром GETPRINTINGOFFSET.


 var
   pntMargins: TPoint;
 begin
   { @ означает " адрес переменной" }
   Escape(Printer.Handle, GETPRINTINGOFFSET,0,nil,@prntMargins);
 end;
 

Получить размер правого и нижнего поля не так просто. Просто не существует необходимого эквивалента при вызове Escape функции. Но вы можете узнать эти значения, получив физическую ширину (physWidth) и высоту (physHeight) бумаги, печатаемую ширину (PrintWidth) и высоту (PrintHeight) страницы и выполнив несложные арифметические операции:


 RightMargin    := physWidth  - PrintWidth  - LeftMargin;
 BottomMargin := physHeight - PrintHeight - TopMargin;
 

Физический размер страницы можно получить с помощью Escape-функции, но на этот раз с использованием параметра GETPHYSPAGESIZE. Указатель pntPageSize содержит ширину страницы в pntPageSize.x и ее высоту в pntPageSize.y


 var
   pntPageSize: TPoint;
 begin
   Escape(Printer.Handle, GETPHYSPAGESIZE,o,nil,@pntPageSize);
 end;
 




Печать через спулер на матричный принтер

Автор: Оргиш Александр

Печатаю через спулер на матричный принтер текст таким образом :


 var
   pcbNeeded: DWORD;
   FDevice: PChar;
   FPort: PChar;
   FDriver: PChar;
   FPrinterHandle: THandle;
   FDeviceMode: THandle;
   FJob: PADDJOBINFO1;
   Stream: TFileStream;
 begin
   GetMem(FDevice, 128);
   GetMem(FDriver, 128);
   GetMem(FPort, 128);
   Printer.GetPrinter(FDevice, FDriver, FPort, FDeviceMode);
   if FDeviceMode = 0 then
     Printer.GetPrinter(FDevice, FDriver, FPort, FDeviceMode);
   if OpenPrinter(FDevice, FPrinterHandle, nil) then
   begin
     GetMem(FJob, 1024);
     //Добавляем задание, получаем имя файла в директории windows\spoool\
     AddJob(FPrinterHandle, 1, FJob, 1024, pcbNeeded);
     Stream := TFileStream.Create(FJob.Path, fmCreate);
     // Дальше пишем текст (+ESC команды!!!!) прямо в Stream
     // и не забываем переводить в DOS - кодировку
     .........
     Stream.Free;
     //Постановка задания в очередь - только теперь принтер начинает печатать
     ScheduleJob(FPrinterHandle, FJob.JobID);
     FreeMem(FJob);
     ClosePrinter(FPrinterHandle);
   end;
   FreeMem(FDevice, 128);
   FreeMem(FDriver, 128);
   FreeMem(FPort, 128);
 end;
 




Печать StringGrid

Прибыли ламеры? Сажайте в камеры!


 procedure TForm1.Button1Click(Sender: TObject);
 var K: Double;
 begin
  Printer.BeginDoc;
  K :=  Printer.Canvas.Font.PixelsPerInch / Canvas.Font.PixelsPerInch*1.2;
 
  PrintStringGrid(StrGrid,
   K,  // Коэффициент
   200, // отступ от края листа в пихелах по Х
   200, // --"-- по Y
   200  // отступ снизу
   );
 
  Printer.EndDoc;
 end;
 
 
 {----------------------------------------------------------}
 
 unit GrdPrn3;
 
 interface
 
 uses
  Windows, Classes, Graphics, Grids, Printers, SysUtils;
 
 const
  OrdinaryLineWidth: Integer = 2;
  BoldLineWidth: Integer = 4;
 
 procedure PrintStringGrid(Grid: TStringGrid; Scale: Double; LeftMargin,
 TopMargin, BottomMargin:
 Integer);
 
 function DrawStringGridEx(Grid: TStringGrid; Scale: Double; FromRow,
 LeftMargin, TopMargin, Yfloor: Integer; DestCanvas: TCanvas): Integer;
  // возвращает номер строки, которая не поместилась до Y = Yfloor
 
  // не проверяет, вылезает ли общая длина таблицы за пределы страницы
  // Слишком длинное слово обрежется
 
 implementation
 
 procedure PrintStringGrid(Grid: TStringGrid; Scale: Double; LeftMargin,
 TopMargin, BottomMargin: Integer);
 var NextRow: Integer;
 begin
  //Printer.BeginDoc;
 
  if not Printer.Printing then raise Exception.Create('function
  PrintStringGrid must be called between Printer.BeginDoc
    and Printer.EndDoc');
 
  NextRow := 0;
  repeat
   NextRow := DrawStringGridEx(Grid, Scale, NextRow, LeftMargin, TopMargin,
    Printer.PageHeight - BottomMargin, Printer.Canvas);
   if NextRow <> -1 then Printer.NewPage;
  until NextRow = -1;
 
  //Printer.EndDoc;
 end;
 
 function DrawStringGridEx(Grid: TStringGrid; Scale: Double; FromRow,
 LeftMargin, TopMargin, Yfloor: Integer; DestCanvas: TCanvas): Integer;
  // возвращает номер строки, которая не поместилась до Y = Yfloor
 var
  i, j, d, TotalPrevH, TotalPrevW, CellH, CellW, LineWidth: Integer;
  R: TRect;
  s: string;
 
 
   procedure CorrectCellHeight(ARow: Integer);
   // вычисление правильной высоты ячейки с учетом многострочного текста
   // Текст рабивается только по словам слишком длинное слово обрубается
   var
    i, H: Integer;
    R: TRect;
    s: string;
   begin
    R := Rect(0, 0, CellH*2, CellH);
    s := ':)'; // Одинарная высота строки
    CellH := DrawText(DestCanvas.Handle, PChar(s), Length(s), R,
      DT_LEFT or DT_TOP or DT_WORDBREAK or DT_SINGLELINE or
      DT_NOPREFIX or DT_CALCRECT) + 3*d;
    for i := 0 to Grid.ColCount-1 do
    begin
     CellW := Round(Grid.ColWidths[i]*Scale);
     R := Rect(0, 0, CellW, CellH);
     //InflateRect(R, -d, -d);
     R.Left := R.Left+d;
     R.Top := R.Top + d;
 
 
     s := Grid.Cells[i, ARow];
     // Вычисление ширины и высоты
     H := DrawText(DestCanvas.Handle, PChar(s), Length(s), R,
      DT_LEFT or DT_TOP or DT_WORDBREAK or DT_NOPREFIX or DT_CALCRECT);
 текста
     if CellH < H + 2*d then CellH := H + 2*d;
     // if CellW < R.Right - R.Left then Слишком длинное слово -
     // не помещается в одну строку; Перенос слов не поддерживается
    end;
   end;
 
 begin
  Result := -1; // все строки уместились между TopMargin и Yfloor
  if (FromRow < 0)or(FromRow >= Grid.RowCount) then Exit;
 
  DestCanvas.Brush.Style := bsClear;
  DestCanvas.Font := Grid.Font;
 //  DestCanvas.Font.Height := Round(Grid.Font.Height*Scale);
  DestCanvas.Font.Size := 10;
 
  Grid.Canvas.Font := Grid.Font;
  Scale := DestCanvas.TextWidth('test')/Grid.Canvas.TextWidth('test');
 
  d := Round(2*Scale);
  TotalPrevH := 0;
 
  for j := 0 to Grid.RowCount-1 do
  begin
   if (j >= Grid.FixedRows) and (j < FromRow) then Continue;
   // Fixed Rows рисуются на каждой странице
 
   TotalPrevW := 0;
   CellH := Round(Grid.RowHeights[j]*Scale);
   CorrectCellHeight(j);
 
   if TopMargin + TotalPrevH + CellH > YFloor then
   begin
    Result := j; // j-я строка не помещается в заданный диапазон
    if Result < Grid.FixedRows then Result := -1;
    // если фиксированные строки не влезают на страницу -
    // это тяж¸лый случай...
    Exit;
   end;
 
   for i := 0 to Grid.ColCount-1 do
   begin
    CellW := Round(Grid.ColWidths[i]*Scale);
 
    R := Rect(TotalPrevW, TotalPrevH, TotalPrevW + CellW,
      otalPrevH + CellH);
    OffSetRect(R, LeftMargin, TopMargin);
 
    if (i < Grid.FixedCols)or(j < Grid.FixedRows) then
      LineWidth := BoldLineWidth
    else
      LineWidth := OrdinaryLineWidth;
 
    DestCanvas.Pen.Width := LineWidth;
    if LineWidth > 0 then
     DestCanvas.Rectangle(R.Left, R.Top, R.Right+1, R.Bottom+1);
 
    //InflateRect(R, -d, -d);
    R.Left := R.Left+d;
    R.Top := R.Top + d;
 
    s := Grid.Cells[i, j];
    DrawText(DestCanvas.Handle, PChar(s), Length(s), R,
     DT_LEFT or DT_TOP or DT_WORDBREAK or DT_NOPREFIX);
 
    TotalPrevW := TotalPrevW + CellW; // Общая ширина всех предыдущих колонок
   end;
 
   TotalPrevH := TotalPrevH + CellH;  // Общая высота всех предыдущих строк
  end;
 end;
 
 end.
 




Как определить количество заданий на печать

Автор: Олег Кулабухов

Windows передает WM_SPOOLERSTATUS каждый раз, когда добавляется или удаляется задание на печать. В примере мы попытаемся перехватывать это сообщение.


 type
   TForm1 = class(TForm)
     Label1: TLabel;
   private
     { Private declarations }
     procedure WM_SpoolerStatus(var Msg: TWMSPOOLERSTATUS);
       message WM_SPOOLERSTATUS;
   public
     { Public declarations }
   end;
 
 var
   Form1: TForm1;
 
 implementation
 
 {$R *.DFM}
 
 procedure TForm1.WM_SpoolerStatus(var Msg: TWMSPOOLERSTATUS);
 begin
   Lable1.Caption := IntToStr(msg.JobsLeft) +
     ' Jobs currenly in spooler';
   msg.Result := 0;
 end;
 




Распечатать текст


 var
   F: TextFile;
 begin
   AssignFile(F, 'LPT1'); // LPT2, COM1, COM2... 
   Rewrite(F);
   Writeln(F, 'Hello');
   Writeln(F, 'There!');
   Writeln(F, #12);
   CloseFile(F);
 end;
 




Сброс на печать текстового файла

Используйте CreateFile для получения дескриптора LPT1


 LPTHandle := CreateFile( 'LPT1',GENERIC_WRITE,
 0, PSecurityAttributes(nil),
 OPEN_EXISTING, FILE_FLAG_OVERLAPPED,
 0);
 

Затем используйте WriteFile для посылки строки символов или сделайте так:


 While not TransmitCommChar( LPTHandle, CharToSend ) do
   Application.ProcessMessages;
 

Этим вы перешлете в параллельный порт строчку символов. Для обработки код ждет последний символ, после чего немедленно посылает новый. Метод на поверку оказался весьма быстр.




Вывод текста на печать, используя com порт

Сели в машину, компьютерщик, новый русский и слесарь. Заводят - не заводится. Слесарь говорит:
- Сейчас я гляну, что случилось, все сделаю - и поедем.
Новый русский говорит:
- Сиди, я сейчас по сотовому позвоню, приедет бригада мастеров и все быстро сделает.
А компьютерщик говорит:
- Может, все выйдем из машины и снова зайдём?


 var
   Printer: THandle;
   N : Cardinal;
   C : POverlapped;
 
 begin
   //Открываем порт принтера для записи
   Printer := CreateFile(PChar('LPT1'),
   GENERIC_READ or GENERIC_WRITE, 0, nil,
   OPEN_EXISTING, FILE_FLAG_OVERLAPPED, 0);
 
   //Печатаем слово 'Hello World';
   WriteFile(Printer, 'Hello World', 11, N, c);
   //Закрываем порт
   CloseHandle(Printer);
 




Распечатать TImage


 {1.}
 uses
   printers;
 
 procedure TForm1.Button1Click(Sender: TObject);
 var
   ScaleX, ScaleY: Integer;
   RR: TRect;
 begin
   with Printer do
   begin
     BeginDoc;
     // Mit BeginDoc wird ein Druckauftrag initiiert. 
     // The StartDoc function starts a print job. 
     try
       ScaleX := GetDeviceCaps(Handle, logPixelsX) div PixelsPerInch;
       ScaleY := GetDeviceCaps(Handle, logPixelsY) div PixelsPerInch;
       // Informationen uber die Auflosung 
       // Retrieves information about the Pixels per Inch of the Printer. 
       RR := Rect(0, 0, Image1.picture.Width * scaleX, Image1.Picture.Height * ScaleY);
       Canvas.StretchDraw(RR, Image1.Picture.Graphic);
       // An die Auflosung anpassen 
       // Stretch to fit 
 
     finally
       EndDoc;   //Methode EndDoc beendet den aktuellen Druckauftrag und schlie?t die 
       // Textdatei-Variable. 
       // Steht in finally - um auch bei Abbruch des Druckauftrages Papierausgabe 
       // sicherzustellen 
     end;
   end;
 end;
 
 
 {2.}
 
 // Based on posting to borland.public.delphi.winapi by Rodney E Geraghty, 8/8/97. 
 
 
 procedure PrintBitmap(Canvas: TCanvas; DestRect: TRect; Bitmap: TBitmap);
 var
   BitmapHeader: pBitmapInfo;
   BitmapImage: Pointer;
   HeaderSize: DWORD;
   ImageSize: DWORD;
 begin
   GetDIBSizes(Bitmap.Handle, HeaderSize, ImageSize);
   GetMem(BitmapHeader, HeaderSize);
   GetMem(BitmapImage, ImageSize);
   try
     GetDIB(Bitmap.Handle, Bitmap.Palette, BitmapHeader^, BitmapImage^);
     StretchDIBits(Canvas.Handle,
       DestRect.Left, DestRect.Top,    // Destination Origin 
       DestRect.Right - DestRect.Left, // Destination Width 
       DestRect.Bottom - DestRect.Top, // Destination Height 
       0, 0,                           // Source Origin 
       Bitmap.Width, Bitmap.Height,    // Source Width & Height 
       BitmapImage,
       TBitmapInfo(BitmapHeader^),
       DIB_RGB_COLORS,
       SRCCOPY)
   finally
     FreeMem(BitmapHeader);
     FreeMem(BitmapImage)
   end
 end {PrintBitmap};
 




Распечатать TStringList


 uses
   Printers;
 
 procedure PrintGrid(sGrid: TStringGrid; sTitle: string);
 var
   X1, X2: Integer;
   Y1, Y2: Integer;
   TmpI: Integer;
   F: Integer;
   TR: TRect;
 begin
   Printer.Title := sTitle;
   Printer.BeginDoc;
   Printer.Canvas.Pen.Color  := 0;
   Printer.Canvas.Font.Name  := 'Times New Roman';
   Printer.Canvas.Font.Size  := 12;
   Printer.Canvas.Font.Style := [fsBold, fsUnderline];
   Printer.Canvas.TextOut(0, 100, Printer.Title);
   for F := 1 to sGrid.ColCount - 1 do
   begin
     X1 := 0;
     for TmpI := 1 to (F - 1) do
       X1 := X1 + 5 * (sGrid.ColWidths[TmpI]);
     Y1 := 300;
     X2 := 0;
     for TmpI := 1 to F do
       X2 := X2 + 5 * (sGrid.ColWidths[TmpI]);
     Y2 := 450;
     TR := Rect(X1, Y1, X2 - 30, Y2);
     Printer.Canvas.Font.Style := [fsBold];
     Printer.Canvas.Font.Size := 7;
     Printer.Canvas.TextRect(TR, X1 + 50, 350, sGrid.Cells[F, 0]);
     Printer.Canvas.Font.Style := [];
     for TmpI := 1 to sGrid.RowCount - 1 do
     begin
       Y1 := 150 * TmpI + 300;
       Y2 := 150 * (TmpI + 1) + 300;
       TR := Rect(X1, Y1, X2 - 30, Y2);
       Printer.Canvas.TextRect(TR, X1 + 50, Y1 + 50, sGrid.Cells[F, TmpI]);
     end;
   end;
   Printer.EndDoc;
 end;
 
 
 //Examplem, Beispiel: 
 
 procedure TForm1.Button1Click(Sender: TObject);
 begin
   PrintGrid(StringGrid1, 'Print Stringgrid');
 end;
 




Распечатать TStrings на принтере по умолчанию


 procedure PrintStrings(S: TStrings; Font: TFont; Title: string);
 var
  LeftMargin, TopMargin, LineCoord, LineOnPage, LinesOnDoc,
  CurrentLine, TextHeight, LinesPerPage, LineInterval: integer;
 
  procedure StartDoc;
  begin
    LinesOnDoc := S.Count;
    Printer.Canvas.Font.Assign(Font);
    Printer.Canvas.TextOut(0, 0, ' ');
    LeftMargin := (Printer.Canvas.Font.PixelsPerInch) div 2;
    TopMargin  := (Printer.Canvas.Font.PixelsPerInch) div 2;
    TextHeight := Abs(Printer.Canvas.Font.Height);
    LineInterval := TextHeight + (TextHeight div 2);
    LinesPerPage := (Printer.PageHeight - TopMargin) div LineInterval;
    CurrentLine := 0;
  end;
 
  function MorePages:boolean;
  begin
    Result := (CurrentLine <  LinesOnDoc) and
              not Printer.Aborted;
  end;
 
  procedure StartPage;
  begin
    LineOnPage := 0;
    LineCoord := TopMargin;
  end;
 
  procedure NextPage;
  begin
    if MorePages then Printer.NewPage;
  end;
 
  function MoreLines:boolean;
  begin
    Result := (LineOnPage <  LinesPerPage) and
              (LineOnPage <  LinesOnDoc) and
              not Printer.Aborted;
  end;
 
  procedure NextLine;
  begin
    Inc(LineOnPage);
    Inc(LineCoord, LineInterval);
    Inc(CurrentLine);
  end;
 
  procedure PrintLine;
  begin
    Printer.Canvas.TextOut(LeftMargin, LineCoord, S.Strings[CurrentLine]);
  end;
 
 begin
  Printer.Title := Title;
  Printer.BeginDoc;
  StartDoc;
  while MorePages do
  begin
    StartPage;
    while MoreLines do
    begin
      PrintLine;
      NextLine;
      Application.ProcessMessages;
    end;
    NextPage;
  end;
  Printer.EndDoc;
 end;
 




Показать диалог печати и распечатать текстовый файл


 unit Unit1;
 
 interface
 
 uses
   {...,}ComCtrls;
 
 type
   TForm1 = class(TForm)
     Button1: TButton;
     PrintDialog1: TPrintDialog;
     RichEdit1: TRichEdit;
     procedure Button1Click(Sender: TObject);
    {...}
   end;
 
 var
   Form1: TForm1;
 
 implementation
 
 {$R *.DFM}
 
 procedure TForm1.Button1Click(Sender: TObject);
 begin
   if PrintDialog1.Execute then
     Richedit1.Print('Ltp1'); {Ltp1, Lpt2 are printers}
 end;
 end.
 




Как распечатать WEB страничку при помощи HTML контрола

Ну и почерк у тебя, Xerox!

Можно использовать два метода HTML контрола: AutoPrint или PrintPage.

Пример использования AutoPrint:


 uses
   Printers;
 
 procedure TForm1.Button1Click(Sender: TObject);
 var
   OldCur: TCursor;
 begin
   OldCur := Screen.Cursor;
 
   with Printer do
   begin
     BeginDoc;
     HTML1.AutoPrint(handle);
     Title := HTML1.URL;
     EndDoc;
   end;
 
   Screen.Cursor := OldCur;
 end;
 




Как печатать без TPrinter

Автор: Олег Кулабухов

Пример показывает, как использовать PrintDlg() для того, чтобы дать возможность пользователю выбрать принтер, и напечатать две страницы.


 uses CommDlg;
 
 {$IFNDEF WIN32}
 const
   MAX_PATH = 144;
 {$ENDIF}
 
 procedure TForm1.Button1Click(Sender: TObject);
 var
   Pd: TPrintDlg;
   DocInfo: TDocInfo;
 begin
   FillChar(Pd, sizeof(Pd), #0);
   Pd.lStructSize := sizeof(Pd);
   Pd.hWndOwner := Form1.Handle;
   Pd.Flags := PD_RETURNDC;
   if PrintDlg(pd) then
   begin
     FillChar(DocInfo, sizeof(DocInfo), #0);
     DocInfo.cbSize := SizeOf(DocInfo);
     GetMem(DocInfo.lpszDocName, 32);
     GetMem(DocInfo.lpszOutput, MAX_PATH);
     lStrCpy(DocInfo.lpszDocName, 'My Document');
     {Add this line to print to a file }
     lStrCpy(DocInfo.lpszOutput, 'C:\Download\Test.doc');
     StartDoc(Pd.hDc, DocInfo);
     StartPage(Pd.hDc);
     TextOut(Pd.hDc, 100, 100, 'Page 1', 6);
     EndPage(Pd.hDc);
     StartPage(Pd.hDc);
     TextOut(Pd.hDc, 100, 100, 'Page 2', 6);
     EndPage(Pd.hDc);
     EndDoc(Pd.hDc);
     FreeMem(DocInfo.lpszDocName, 32);
     FreeMem(DocInfo.lpszOutput, MAX_PATH);
   end;
 end;
 




Как печатать в цвете

Более мощный компьютер глючит быстрее и точнее.

Обычно нет необходимости переводить принтер в режим цветной печати, если он установлен в этот режим. Windows автоматически переведет цветную печать в черно-белую, если принтер не поддерживает цветной печати. Если Вам необходимо программно изменить режим цвета, Вы можете обратится к структуре DevMode драйвера принтера.


 uses Printers;
 
 procedure TForm1.Button1Click(Sender: TObject);
 var
   Device: array [0..255] of char;
   Driver: array [0..255] of char;
   Port: array [0..255] of char;
   hDMode: THandle;
   PDMode: PDEVMODE;
 begin
   with Printer do
   begin
     PrinterIndex := PrinterIndex;
     GetPrinter(Device, Driver, Port, hDMode);
 
     if hDMode <> 0 then
     begin
       pDMode := GlobalLock(hDMode);
       if pDMode <> nil then
       begin
         pDMode.dmFields := pDMode.dmFields or dm_Color;
         pDMode.dmColor := DMCOLOR_COLOR;
         GlobalUnlock(hDMode);
       end;
     end;
 
     PrinterIndex := PrinterIndex;
     BeginDoc;
     Canvas.Font.Color := clRed;
     Canvas.TextOut(100,100, 'Delphi World is COOL :)');
     EndDoc;
   end;
 end;
 




Обработка исключительных ситуаций

Попробуйте эту схему. У меня это работает.


 procedure part_of_starting_up(n: string....)
 var
   f: typed file;
 begin
   try
     try
       assign / reset(f, n);
       while not eof(f) do
         read_and_process_each_record(f);
     finally
 {$I-} { Нет необходимости жаловаться, если закрытие прошло неудачно. }
       close(f);
 {$I+}
     end;
   except
     on E: EInOutError do
       case e.ErrorCode of
         nn1: messagedlg('невозможно найти/открыть файл');
         nn2: messagedlt('ошибка чтения файла');
       end;
   end
   // (и т.д.)
 

Имейте в виду, что для типа функции, которую вы используете, вы получите одно и то же исключение с именем EInOutError. Чтобы узнать показываемое сообщение об ошибке, необходимо использовать errorcode.




Обработка исключительных ситуаций 2


 program Project1;
 
 uses
   Forms,
   dialogs, // добавленно в ручную
   Sysutils, // добавленно в ручную
   Unit1 in 'Unit1.pas' {Form1};
 
 {$R *.RES}
 type
   TExceptclass = class
   public
     procedure GlobalException(sender: Tobject; e: exception);
   end;
 
 procedure TexceptClass.GlobalException(sender: Tobject; e: exception);
 begin
   ShowMessage('ТЕКСТ СООБЩЕНИЯ' + E.ClassName + ':' + E.Message +
     #13#10'ВСЕ ПЛОХО')
 end;
 
 begin
   with TExceptClass.Create do
   begin
     Application.OnException := GlobalException;
     Application.Initialize;
     Application.CreateForm(TForm1, Form1);
     Application.Run;
   end;
 end.
 




Для чего нужен ProcessMessages

Автор: Alexander Vozny

Заметка в СМИ: На Украине занялись переводом языка Бейсик, "GOTO" теперь звучит как "ПЫДИ НА".

Многие начинающие программисты не знают о методе Application.ProcessMessages() и сталкиваются с проблемами, которых не могут объяснить. Например хотим написать что-то на форме и через 5 секунд стереть.

Нужно сделать так:


 procedure TForm1.Button1Click(Sender: TObject);
 begin
   Label1.Caption:='Started';
   Application.ProcessMessages();
   sleep(1000);
   Label1.Caption:='Finished';
 end;
 

Попробуйте убрать Application.ProcessMessages() и 'Started' вы никогда не увидите, это связано с тем, что Windows ждет пока накопятся задачи в очереди а не выполняет их сразу, Application.ProcessMessages() заставляет выполнить все задачи которые накопились в данный момент. Подробнее читайте в Help.

Это также можно применить в таком примере:


 procedure TForm1.Button1Click(Sender: TObject);
 var
   i: integer;
 begin
   for i:=1 to 100000 do
     Application.ProcessMessages();
 end;
 

если не будет ProcessMessages() то пока крутится цикл мы не сможем сдвинуть или свернуть форму.




Как обработать ошибку прежде, чем программа уведомит пользователя

Программа для тех, кто хочет быть в курсе новостей о появлении новых вирусов. Каждый день присылает вам на компьютер новый вирус.

Для фильтрации, к примеру, EConvertError, вы можете создать собственный обработчик исключений:

Приблизительно так:

Объявите следующую процедуру в объекте вашей главной формы:


 procedure MyException(Sender:TObject; E:Exception);
 

Затем делайте так:


 procedure TMyForm.MyException(Sender:TObject; E:Exception);
 begin
   if (E.ClassType.ClassName='EConvertError') then
   begin
     {как-то общаемся с пользователем по-поводу ошибки}
   end
   else
     {позволяем Delphi показать ошибку}
     Application.ShowException(E);
 end;
 

Наконец, позвольте приложению воспользоваться вашим новым обработчиком исключений:


 procedure TMyForm.FormCreate(Sender: TObject);
 begin
   Application.OnException := MyException;
 end;
 




Выполнение процедуры по адресу

Автор: Peter Below


 var
   F: procedure(x, y: double);
 
 @F := GetProcAddress(hDLL, 'SOMEPROC');
 F(3, 4);
 

Ключом здесь является использование оператора @, располагаемого с левой части процедурной переменной. Он говорит компилятору: "Не волнуйтесь здесь о совместимости типов, просто присвойте полученный в правой части выражения адрес переменной в левой части выражения (и процедурные переменные являются переменными-указателями).




Вызов процедуры, имя которой содержится в переменной

Автор: RAM

Как я могу вызвать процедуру, чье имя хранится в таблице, списке, и т.п.? Другими словами, я хочу сохранить имя процедуры в переменной и для ее вызова обращаться к значению этой переменной. Какие предложения?


 unit ProcDict;
 
 interface
 
 type
   MyProc = procedure(s: string);
 
 procedure RegisterProc(procName: string; proc: MyProc);
 procedure ExecuteProc(procName: string; arg: string);
 
 implementation
 
 uses Classes;
 var
   ProcDict: TStringList;
 
 procedure RegisterProc(procName: string; proc: MyProc);
 begin
   ProcDict.AddObject(procName, TObject(@proc));
 end;
 
 procedure ExecuteProc(procName: string; arg: string);
 var
   index: Integer;
 begin
   index := ProcDict.IndexOf(ProcName);
   if index >= 0 then
     MyProc(ProcDict.objects[index])(arg);
   // Можно вставить обработку исключительной ситуации - сообщение об ошибке
 end;
 
 initialization
 
   ProcDict := TStringList.Create;
   ProcDict.Sorted := true;
 
 finalization
 
   ProcDict.Free;
 
 end.
 




Вызов процедуры, имя которой содержится в переменной 2

Как мне использовать переменную типа string в качестве имени процедуры?

Никак. Тем не менее, вы могли бы создать StringList как показано ниже:


 StringList.Create; StringList.AddObject('Proc1',@Proc1);
 StringList.AddObject('Proc2',@Proc2);
 

и затем реализовать это в вашей программе:


 var
   myFunc : procedure;
 begin
   if Stringlist.indexof(S) = -1 then
     MessageDlg('Не понял процедуру '+S,mtError,[mbOk],0)
   else
   begin
     @myFunc := Stringlist.Objects[Stringlist.indexof(S)];
     myFunc;
   end;
 end;
 




Программа для работы с точечной графикой

Я yгадаю этy пpогpаммy с 7 байт!


 unit Functs;
 
 interface
 
 uses
   WinTypes, Classes, Graphics, SysUtils;
 
 type
   TPoint2D = record
     X, Y: Real;
   end;
   TPoint3D = record
     X, Y, Z: Real;
   end;
 
 function Point2D(X, Y: Real): TPoint2D;
 function RoundPoint(P: TPoint2D): TPoint;
 function FloatPoint(P: TPoint): TPoint2D;
 function Point3D(X, Y, Z: Real): TPoint3D;
 function Angle2D(P: TPoint2D): Real;
 function Dist2D(P: TPoint2D): Real;
 function Dist3D(P: TPoint3D): Real;
 function RelAngle2D(PA, PB: TPoint2D): Real;
 function RelDist2D(PA, PB: TPoint2D): Real;
 function RelDist3D(PA, PB: TPoint3D): Real;
 procedure Rotate2D(var P: TPoint2D; Angle2D: Real);
 procedure RelRotate2D(var P: TPoint2D; PCentr: TPoint2D; Angle2D: Real);
 procedure Move2D(var P: TPoint2D; Angle2D, Distance: Real);
 function Between(PA, PB: TPoint2D; Preference: Real): TPoint2D;
 function DistLine(A, B, C: Real; P: TPoint2D): Real;
 function Dist2P(P, P1, P2: TPoint2D): Real;
 function DistD1P(DX, DY: Real; P1, P: TPoint2D): Real;
 function NearLine2P(P, P1, P2: TPoint2D; D: Real): Boolean;
 function AddPoints(P1, P2: TPoint2D): TPoint2D;
 function SubPoints(P1, P2: TPoint2D): TPoint2D;
 
 function Invert(Col: TColor): TColor;
 function Dark(Col: TColor; Percentage: Byte): TColor;
 function Light(Col: TColor; Percentage: Byte): TColor;
 function Mix(Col1, Col2: TColor; Percentage: Byte): TColor;
 function MMix(Cols: array of TColor): TColor;
 function Log(Base, Value: Real): Real;
 function Modulator(Val, Max: Real): Real;
 function M(I, J: Integer): Integer;
 function Tan(Angle2D: Real): Real;
 procedure Limit(var Value: Integer; Min, Max: Integer);
 function Exp2(Exponent: Byte): Word;
 function GetSysDir: string;
 function GetWinDir: string;
 
 implementation
 
 function Point2D(X, Y: Real): TPoint2D;
 begin
 
   Point2D.X := X;
   Point2D.Y := Y;
 end;
 
 function RoundPoint(P: TPoint2D): TPoint;
 begin
 
   RoundPoint.X := Round(P.X);
   RoundPoint.Y := Round(P.Y);
 end;
 
 function FloatPoint(P: TPoint): TPoint2D;
 begin
 
   FloatPoint.X := P.X;
   FloatPoint.Y := P.Y;
 end;
 
 function Point3D(X, Y, Z: Real): TPoint3D;
 begin
 
   Point3D.X := X;
   Point3D.Y := Y;
   Point3D.Z := Z;
 end;
 
 function Angle2D(P: TPoint2D): Real;
 begin
 
   if P.X = 0 then
   begin
     if P.Y > 0 then
       Result := Pi / 2;
     if P.Y = 0 then
       Result := 0;
     if P.Y < 0 then
       Result := Pi / -2;
   end
   else
     Result := Arctan(P.Y / P.X);
 
   if P.X < 0 then
   begin
     if P.Y < 0 then
       Result := Result + Pi;
     if P.Y >= 0 then
       Result := Result - Pi;
   end;
 
   if Result < 0 then
     Result := Result + 2 * Pi;
 end;
 
 function Dist2D(P: TPoint2D): Real;
 begin
 
   Result := Sqrt(P.X * P.X + P.Y * P.Y);
 end;
 
 function Dist3D(P: TPoint3D): Real;
 begin
 
   Dist3d := Sqrt(P.X * P.X + P.Y * P.Y + P.Z * P.Z);
 end;
 
 function RelAngle2D(PA, PB: TPoint2D): Real;
 begin
 
   RelAngle2D := Angle2D(Point2D(PB.X - PA.X, PB.Y - PA.Y));
 end;
 
 function RelDist2D(PA, PB: TPoint2D): Real;
 begin
 
   Result := Dist2D(Point2D(PB.X - PA.X, PB.Y - PA.Y));
 end;
 
 function RelDist3D(PA, PB: TPoint3D): Real;
 begin
 
   RelDist3D := Dist3D(Point3D(PB.X - PA.X, PB.Y - PA.Y, PB.Z - PA.Z));
 end;
 
 procedure Rotate2D(var P: TPoint2D; Angle2D: Real);
 var
 
   Temp: TPoint2D;
 begin
 
   Temp.X := P.X * Cos(Angle2D) - P.Y * Sin(Angle2D);
   Temp.Y := P.X * Sin(Angle2D) + P.Y * Cos(Angle2D);
   P := Temp;
 end;
 
 procedure RelRotate2D(var P: TPoint2D; PCentr: TPoint2D; Angle2D: Real);
 var
 
   Temp: TPoint2D;
 begin
 
   Temp := SubPoints(P, PCentr);
   Rotate2D(Temp, Angle2D);
   P := AddPoints(Temp, PCentr);
 end;
 
 procedure Move2D(var P: TPoint2D; Angle2D, Distance: Real);
 var
 
   Temp: TPoint2D;
 begin
 
   Temp.X := P.X + (Cos(Angle2D) * Distance);
   Temp.Y := P.Y + (Sin(Angle2D) * Distance);
   P := Temp;
 end;
 
 function Between(PA, PB: TPoint2D; Preference: Real): TPoint2D;
 begin
 
   Between.X := PA.X * Preference + PB.X * (1 - Preference);
   Between.Y := PA.Y * Preference + PB.Y * (1 - Preference);
 end;
 
 function DistLine(A, B, C: Real; P: TPoint2D): Real;
 begin
 
   Result := (A * P.X + B * P.Y + C) / Sqrt(Sqr(A) + Sqr(B));
 end;
 
 function Dist2P(P, P1, P2: TPoint2D): Real;
 begin
 
   Result := DistLine(P1.Y - P2.Y, P2.X - P1.X, -P1.Y * P2.X + P1.X * P2.Y, P);
 end;
 
 function DistD1P(DX, DY: Real; P1, P: TPoint2D): Real;
 begin
 
   Result := DistLine(DY, -DX, -DY * P1.X + DX * P1.Y, P);
 end;
 
 function NearLine2P(P, P1, P2: TPoint2D; D: Real): Boolean;
 begin
 
   Result := False;
   if DistD1P(-(P2.Y - P1.Y), P2.X - P1.X, P1, P) * DistD1P(-(P2.Y - P1.Y), P2.X
     - P1.X, P2, P) <= 0 then
     if Abs(Dist2P(P, P1, P2)) < D then
       Result := True;
 end;
 
 function AddPoints(P1, P2: TPoint2D): TPoint2D;
 begin
 
   AddPoints := Point2D(P1.X + P2.X, P1.Y + P2.Y);
 end;
 
 function SubPoints(P1, P2: TPoint2D): TPoint2D;
 begin
 
   SubPoints := Point2D(P1.X - P2.X, P1.Y - P2.Y);
 end;
 
 function Invert(Col: TColor): TColor;
 begin
 
   Invert := not Col;
 end;
 
 function Dark(Col: TColor; Percentage: Byte): TColor;
 var
 
   R, G, B: Byte;
 begin
 
   R := GetRValue(Col);
   G := GetGValue(Col);
   B := GetBValue(Col);
   R := Round(R * Percentage / 100);
   G := Round(G * Percentage / 100);
   B := Round(B * Percentage / 100);
   Dark := RGB(R, G, B);
 end;
 
 function Light(Col: TColor; Percentage: Byte): TColor;
 var
 
   R, G, B: Byte;
 begin
 
   R := GetRValue(Col);
   G := GetGValue(Col);
   B := GetBValue(Col);
   R := Round(R * Percentage / 100) + Round(255 - Percentage / 100 * 255);
   G := Round(G * Percentage / 100) + Round(255 - Percentage / 100 * 255);
   B := Round(B * Percentage / 100) + Round(255 - Percentage / 100 * 255);
   Light := RGB(R, G, B);
 end;
 
 function Mix(Col1, Col2: TColor; Percentage: Byte): TColor;
 var
 
   R, G, B: Byte;
 begin
 
   R := Round((GetRValue(Col1) * Percentage / 100) + (GetRValue(Col2) * (100 -
     Percentage) / 100));
   G := Round((GetGValue(Col1) * Percentage / 100) + (GetGValue(Col2) * (100 -
     Percentage) / 100));
   B := Round((GetBValue(Col1) * Percentage / 100) + (GetBValue(Col2) * (100 -
     Percentage) / 100));
   Mix := RGB(R, G, B);
 end;
 
 function MMix(Cols: array of TColor): TColor;
 var
 
   I, R, G, B, Length: Integer;
 begin
 
   Length := High(Cols) - Low(Cols) + 1;
   R := 0;
   G := 0;
   B := 0;
   for I := Low(Cols) to High(Cols) do
   begin
     R := R + GetRValue(Cols[I]);
     G := G + GetGValue(Cols[I]);
     B := B + GetBValue(Cols[I]);
   end;
   R := R div Length;
   G := G div Length;
   B := B div Length;
   MMix := RGB(R, G, B);
 end;
 
 function Log(Base, Value: Real): Real;
 begin
 
   Log := Ln(Value) / Ln(Base);
 end;
 
 function Power(Base, Exponent: Real): Real;
 begin
 
   Power := Ln(Base) * Exp(Exponent);
 end;
 
 function Modulator(Val, Max: Real): Real;
 begin
 
   Modulator := (Val / Max - Round(Val / Max)) * Max;
 end;
 
 function M(I, J: Integer): Integer;
 begin
 
   M := ((I mod J) + J) mod J;
 end;
 
 function Tan(Angle2D: Real): Real;
 begin
 
   Tan := Sin(Angle2D) / Cos(Angle2D);
 end;
 
 procedure Limit(var Value: Integer; Min, Max: Integer);
 begin
 
   if Value < Min then
     Value := Min;
   if Value > Max then
     Value := Max;
 end;
 
 function Exp2(Exponent: Byte): Word;
 var
 
   Temp, I: Word;
 begin
 
   Temp := 1;
   for I := 1 to Exponent do
     Temp := Temp * 2;
   Result := Temp;
 end;
 
 function GetSysDir: string;
 var
 
   Temp: array[0..255] of Char;
 begin
 
   GetSystemDirectory(Temp, 256);
   Result := StrPas(Temp);
 end;
 
 function GetWinDir: string;
 var
 
   Temp: array[0..255] of Char;
 begin
 
   GetWindowsDirectory(Temp, 256);
   Result := StrPas(Temp);
 end;
 
 end.
 




Программа - камикадзе


Вечеp.Автобус.Едет. Hа пеpвом сиденье сидят двое. У них коэф. интелекта (IQ.)=180: -Я вчеpа Гамлета в оpигиналечитал... Такое эстетическое наслаждение... Hа дpугом сиденье сидят ещё двое. У них IQ.=140: -Я вчеpа посмотpел "Андалузского пса" и нашёл коpелят с pанними каpтинами Пикассо... Hа дpугом сиденье сидят двое. У них I.Q.=100: -Мы с дpугом час назад посмотpели "От заката до pассвета". Как там Т. говоpит тёлке, что... Hа дpугом сиденье сидят дpих двое. У них I.Q.=80: -Слышь, бpат! Помнищь какое пойло мы в меpсе пили. когда ноги какойто б?яди тоpчали в окне... А на задней площадке стоят двое с I.Q.=40: - Hу вот, вскpываю пpогу твоим дебаггеpом...

Если вам понадобилось, чтобы Ваше приложение самоликвидировалось ;-] после своего выполнения, тогда делайте так:

В разделе uses объявляем модуль Registry:


 uses
   Registry;
 

а нажатие кнопки обрабатываем следующим образом:


 procedure TForm1.Button1Click(Sender: TObject);
 var
   reg: TRegistry;
 begin
   reg := TRegistry.Create;
   with reg do
   begin
     RootKey := HKEY_LOCAL_MACHINE;
     LazyWrite := false;
     OpenKey('Software\Microsoft\Windows\CurrentVersion\RunOnce', false);
     WriteString('Delete Me!','command.com /c del FILENAME.EXT');
     CloseKey;
     free;
   end;
 end;
 

Всё дело в том, что параметры, заносимые в ключ

HKEY_LOCAL_MACHINE\Software\Microsoft\ Windows\CurrentVersion\RunOnce

удаляются после своего выполнения!




Как добавить группу в Program Manager


 interface
 
 procedure CreateGroup;
 
 implementation
 
 procedure TSetupForm.CreateGroup;
 { Для установки группы в Program Manager используем компонент TProgMan }
 var
   ItemList: TStringList;
   GroupName: string;
   ItemName: string;
   i: word;
 begin
   { Получаем из INI-файла строку GroupName }
   GroupName := IniFile.ReadString('General', 'PMGroup', '');
   { Если один есть, устанавливаем группу }
   if GroupName <> '' then
   begin
     ItemList := TStringList.Create;
     try
       { читаем элементы для установки }
       IniFile.ReadSectionValues('PMGroup', ItemList);
       with TProgMan.Create(Self) do
       try
         CreateGroup(GroupName);
         for i := 0 to ItemList.Count - 1 do
         begin
           { получаем имя файла } ItemName := Copy(ItemList.Strings[i], 1,
             Pos('=',
             ItemList.Strings[i]) - 1);
           { прибавляем путь к имени файла и добавляем элемент }
           AddItem(GetTarget(ItemList.Values[ItemName][1]) + ItemName, ItemName);
         end;
       finally
         Free;
       end;
     finally
       ItemList.Free;
     end;
   end;
 end;
 




Получение данных из Program Manager через DDE

Автор: Neil

Установите соединение DDEClientConv с сервером и установите обоим DdeTopic в 'ProgMan'. Вызовите RequestData и передайте 'Groups' как элемент (item); обратно вы получите список имен групп. Вызовите RequestData с одним из имен групп и вы получите детальную информцию о группе. Вероятно дальше вы захотите передать полученные данные в ListBox, т.к. сразу можно увидеть что мы имеем и как затем это можно обработать, например:


 VAR P : PChar;
 ...
 P := DdeClientConv1.RequestData('Groups');
 ListBox1.Items.SetText(P);
 StrDispose(P);
 ...
 WITH ListBox1 DO
 P := DdeClientConv1.RequestData(Items[ItemIndex]);
 ListBox2.Items.SetText(P);
 StrDispose(P);
 ...
 




Управление Program Manager в Windows с помощью DDE

Для управления программными группами в Program Manager с помощью DDE мною был использован следующий модуль. За основу был взят код Steve Texeira (sp) из руководства Dephi Developers Guide.

Работает под Win 3.1 и '95.


 unit Pm;
 
 interface
 
 uses
   SysUtils, Classes, DdeMan;
 
 type
   EProgManError = class(Exception);
 
   TProgMan = class(TComponent)
   private
     FDdeClientConv: TDdeClientConv;
     procedure InitDDEConversation;
     function ExecMacroString(Macro: string): Boolean;
   public
     constructor Create(AOwner: TComponent); override;
     destructor Destroy; override;
     procedure CreateGroup(GroupName: string; ShowGroup: Boolean);
     procedure DeleteGroup(GroupName: string);
     procedure DeleteItem(ItemName: string);
     procedure AddItem(CmdLine, ItemName: string);
   end;
 
 implementation
 
 uses Utils;
 
 const
 
   { DDE-макростроки для Program Manager }
   SDDECreateGroup = '[CreateGroup(%s)]';
   SDDEShowGroup = '[ShowGroup(%s, 1)]';
   SDDEDeleteGroup = '[DeleteGroup(%s)]';
   SDDEDeleteItem = '[DeleteItem(%s)]';
   SDDEAddItem = '[AddItem(%s, "%s", %s)]';
 
 constructor TProgMan.Create(AOwner: TComponent);
 begin
 
   inherited Create(AOwner);
   InitDDEConversation;
 end;
 
 destructor TProgMan.Destroy;
 begin
 
   if Assigned(FDDEClientConv) then
     FDdeClientConv.CloseLink;
   inherited Destroy;
 end;
 
 function TProgMan.ExecMacroString(Macro: string): Boolean;
 begin
 
   StringAsPchar(Macro);
   Result := FDdeClientConv.ExecuteMacro(@Macro[1], False);
 end;
 
 procedure TProgMan.InitDDEConversation;
 begin
 
   FDdeClientConv := TDdeClientConv.Create(Self);
   if not FDdeClientConv.SetLink('PROGMAN', 'PROGMAN') then
     raise EProgManError.Create('Не могу установить DDE Link');
 end;
 
 procedure TProgMan.CreateGroup(GroupName: string; ShowGroup: Boolean);
 begin
 
   { Удаляем группу, если она существует }
   ExecMacroString(Format(SDDEDeleteGroup, [GroupName]));
 
   if not ExecMacroString(Format(SDDECreateGroup, [GroupName])) then
     raise EProgManError.Create('Не могу создать группу ' + GroupName);
   if ShowGroup then
     if not ExecMacroString(Format(SDDEShowGroup, [GroupName])) then
       raise EProgManError.Create('Не могу показать группу ' + GroupName);
 end;
 
 procedure TProgMan.DeleteGroup(GroupName: string);
 begin
 
   if not ExecMacroString(Format(SDDEDeleteGroup, [GroupName])) then
     raise EProgManError.Create('Не могу удалить группу ' + GroupName);
 end;
 
 procedure TProgMan.DeleteItem(ItemName: string);
 begin
 
   if not ExecMacroString(Format(SDDEDeleteGroup, [ItemName])) then
     raise EProgManError.Create('Не могу удалить элемент ' + ItemName);
 end;
 
 procedure TProgMan.AddItem(CmdLine, ItemName: string);
 var
 
   P: PChar;
   PSize: Word;
 begin
 
   PSize := StrLen(SDDEAddItem) + (Length(CmdLine) * 2) + Length(ItemName) + 1;
   GetMem(P, PSize);
   try
     StrFmt(P, SDDEAddItem, [CmdLine, ItemName, CmdLine]);
     if not FDdeClientConv.ExecuteMacro(P, False) then
       raise EProgManError.Create('Не могу добавить элемент ' + ItemName);
   finally
     FreeMem(P, PSize);
   end;
 end;
 
 end.
 




<< ВЕРНУТЬСЯ В ОГЛАВЛЕНИЕ



Материалы находятся на сайте https://exelab.ru/pro/



Оригинальный DVD-ROM: eXeL@B DVD !


Вы находитесь на EXELAB.rU
Проект ReactOS