Çeşitli kod ipuçları

Delphi'de kod yazma ile ilgili sorularınızı bu foruma yazabilirsiniz.
ikutluay
Üye
Mesajlar: 2341
Kayıt: 03 Tem 2007 10:13

yazıcı özelliklerini sys info gibi bulma

Mesaj gönderen ikutluay »

Kod: Tümünü seç

uses
  Printers;

//------------------------------------------------------------------------------
// Printer Device Debugging Code to TMemo Componenet
// (c) - 1999 / by A. Weidauer
// alex.weiauer@huckfinn.de
//------------------------------------------------------------------------------

procedure GetDeviceSettings(DevCtrl: TMemo);
var
  Sep: string;
  //-----------------------------------------------
  procedure MakeInt(S: string; key: Integer);
  begin
    S := UpperCase(S);
    DevCtrl.Lines.Add(UpperCase(Format(' %36S = %d ',
      [s, GetDeviceCaps(Printer.Handle, Key)])));
  end;
  //-----------------------------------------------
  function StringToBits(S: string): string;
  var
    H: string;
    i: Integer;
    //-----------------------------------------------
    function SubStr(C: Char): string;
    begin
      if c = '0' then SubStr := '0000';
      if c = '1' then SubStr := '0001';
      if c = '2' then SubStr := '0010';
      if c = '3' then SubStr := '0011';
      if c = '4' then SubStr := '0100';
      if c = '5' then SubStr := '0101';
      if c = '6' then SubStr := '0110';
      if c = '7' then SubStr := '0111';
      if c = '8' then SubStr := '1000';
      if c = '9' then SubStr := '1001';
      if c = 'A' then SubStr := '1010';
      if c = 'B' then SubStr := '1011';
      if c = 'C' then SubStr := '1100';
      if c = 'D' then SubStr := '1101';
      if c = 'E' then SubStr := '1110';
      if c = 'F' then SubStr := '1111';
    end;
    //-----------------------------------------------
  begin
    StringToBits := '';
    S := UpperCase(s);
    H := '';
    if Length(S) = 0 then Exit;
    if Length(S) = 1 then S := '0000' + S;
    if Length(S) = 2 then S := '000' + S;
    if Length(S) = 3 then S := '00' + S;
    if Length(S) = 4 then S := '0' + S;
    for i := 1 to Length(s) do
      H := H + ' ' + SubStr(S[i]);
    StringToBits := H;
  end;
  //-----------------------------------------------
  procedure MakeHex(S: string; key: Cardinal);
  var
    h: string;
  begin
    S := UpperCase(S);
    h := Format('%X', [GetDeviceCaps(Printer.Handle, Key)]);
    if Length(H) = 0 then Exit;
    if Length(H) = 1 then H := '0000' + H;
    if Length(H) = 2 then H := '000' + H;
    if Length(H) = 3 then H := '00' + H;
    if Length(H) = 4 then H := '0' + H;
    DevCtrl.Lines.Add('');
    DevCtrl.Lines.Add(SEP);
    DevCtrl.Lines.Add('');
    DevCtrl.Lines.Add(Format('%37S = Flags(%S) Key(%S)',
      [s, h, StringToBits(H)]
      ));
    // (( GetDeviceCaps(Printer.Handle,Key),
  end;
  //----------------------------------------------------
  procedure MakeFlag(S: string; key, subKey: Cardinal);
  var
    i: Cardinal;
  begin
    S := UpperCase(S);
    i := GetDeviceCaps(Printer.Handle, Key);
    if i and SubKey <> 0 then
      DevCtrl.Lines.Add(Format(' %34S = Flag(%4S) Key(%6D,%S)',
        [s, 'ON ', SubKey, StringToBits(Format('%x', [SubKey]))]))
    else
      DevCtrl.Lines.Add(Format(' %34S = Flag(%4S) Key(%6D,%S)',
        [s, 'OFF', SubKey, StringToBits(Format('%x', [SubKey]))]))
  end;
  //----------------------------------------------------
  function TechnoToStr(i: Integer): string;
  begin
    TechnoToStr := '#ERROR# is Unknwon';
    case i of
      DT_PLOTTER: TechnoToStr    := 'Vector Plotter';
      DT_RASDISPLAY: TechnoToStr := 'Raster Display';
      DT_RASPRINTER: TechnoToStr := 'Raster Printer';
      DT_RASCAMERA: TechnoToStr  := 'Raster Camera';
      DT_CHARSTREAM: TechnoToStr := 'Character Stream';
      DT_METAFILE: TechnoToStr   := 'Metafile';
      DT_DISPFILE: TechnoToStr   := 'Display file';
    end;
  end;

  //--Main Procedure
  //----------------------------------------------------------
begin
  DevCtrl.SetFocus;
  DevCtrl.Visible := False;
  if Printer.PrinterIndex < 0 then Exit;
  // Device Organisation
  try

    if not (GetMapMode(Printer.Handle) = MM_TEXT) then
      SetMapMode(Printer.Handle, MM_Text);
    DevCtrl.Clear;

    Sep := '______________________________________________________________________________________________';
    DevCtrl.Lines.Add(sep);
    DevCtrl.Lines.Add('');
    DevCtrl.Lines.Add(' PRINTER : ' + Printer.Printers[Printer.PrinterIndex]);
    DevCtrl.Lines.Add(sep);
    DevCtrl.Lines.Add('');

    DevCtrl.Lines.Add(sep);
    DevCtrl.Lines.Add('');
    DevCtrl.Lines.Add(Format('%36S = %D', ['NUMBER Of COPIES', Printer.Copies]));
    if Printer.Orientation = poLandscape then
      DevCtrl.Lines.Add(Format('%36S = LANDSCAPE', ['ORIENTATION']));
    if Printer.Orientation = poPortrait then
      DevCtrl.Lines.Add(Format('%36S = PORTRAIT', ['ORIENTATION']));


    DevCtrl.Lines.Add(sep);
    DevCtrl.Lines.Add('');
    MakeInt('DRIVERVERSION', DRIVERVERSION);
    DevCtrl.Lines.Add(Format(' %36S = %S', ['TECHNOLOGY',
      UpperCase(TechnoToStr(GetDeviceCaps(Printer.Handle, Technology)))]));
    DevCtrl.Lines.Add(sep);
    DevCtrl.Lines.Add('');
    MakeInt('WIDTH [mm]', HORZSIZE);
    MakeInt('HEIGHT [mm]', VERTSIZE);
    MakeInt('WIDTH [pix]', HORZRES);
    MakeInt('HEIGHT [pix]', VERTRES);
    DevCtrl.Lines.Add(sep);
    DevCtrl.Lines.Add('');
    MakeInt('Physical Width [pix]', PHYSICALWIDTH);
    MakeInt('Physical Height[pix]', PHYSICALHEIGHT);
    MakeInt('Physical Offset X [pix]', PHYSICALOFFSETX);
    MakeInt('Physical Offset Y [pix]', PHYSICALOFFSETY);
    MakeInt('SCALING FACTOR X', SCALINGFACTORX);
    MakeInt('SCALING FACTOR Y', SCALINGFACTORY);
    DevCtrl.Lines.Add(sep);
    DevCtrl.Lines.Add('');
    MakeInt('horizontal [DPI]', LOGPIXELSX);
    MakeInt('vertial [DPI]', LOGPIXELSY);
    MakeInt('BITS PER PIXEL', BITSPIXEL);
    MakeInt('COLOR PLANES', PLANES);
    DevCtrl.Lines.Add(sep);
    DevCtrl.Lines.Add('');
    MakeInt('NUMBER OF BRUSHES', NUMBRUSHES);
    MakeInt('NUMBER OF PENS', NUMPENS);
    MakeInt('NUMBER OF FONTS', NUMFONTS);
    MakeInt('NUMBER OF COLORS', NUMCOLORS);
    DevCtrl.Lines.Add(sep);
    DevCtrl.Lines.Add('');
    MakeInt('ASPECT Ratio X [DPI]', ASPECTX);
    MakeInt('ASPECT Ratio Y [DPI]', ASPECTY);
    MakeInt('ASPECT Ratio XY [DPI]', ASPECTXY);
    DevCtrl.Lines.Add(sep);
    DevCtrl.Lines.Add('');
    MakeInt('SIZE OF PALETTE', SIZEPALETTE);
    MakeInt('RESERVED TO SYSTEM PALETTE **', NUMRESERVED);
    MakeInt('ACTUAL RASTER RESOLUTION **', COLORRES);
    DevCtrl.Lines.Add('');
    DevCtrl.Lines.Add(' **...only true if KEY RASTERCAPS(RC_PALETTE)= ON');
    MakeFlag('... KEY RASTERCAPS (RC_PALETTE)', RasterCaps, RC_PALETTE);
    DevCtrl.Lines.Add('');

    MakeHex('Clipping Capablities ', ClipCaps);
    DevCtrl.Lines.Add(sep);
    DevCtrl.Lines.Add('');
    MakeFlag('No Support ', ClipCaps, CP_NONE);
    MakeFlag('Support Rectangles', ClipCaps, CP_RECTANGLE);
    MakeFlag('Support PolyRegion 32 Bit', ClipCaps, CP_REGION);

    MakeHex('Raster Printing Flags ', RasterCaps);
    DevCtrl.Lines.Add(sep);
    DevCtrl.Lines.Add('');
    MakeFlag('Support Bitmap Transfer', RasterCaps, RC_BITBLT);
    MakeFlag('Support Banding', RasterCaps, RC_BANDING);
    MakeFlag('Support Scaling', RasterCaps, RC_SCALING);
    MakeFlag('Support Bitmaps > 64 kByte', RasterCaps, RC_BITMAP64);
    MakeFlag('Support features of Win 2.0', RasterCaps, RC_GDI20_OUTPUT);
    MakeFlag('Support Set~/GetDIBITS()', RasterCaps, RC_DI_BITMAP);
    MakeFlag('Support Palette Devices', RasterCaps, RC_PALETTE);
    MakeFlag('Support SetDIBitsToDevice()', RasterCaps, RC_DIBTODEV);
    MakeFlag('Support Floodfill', RasterCaps, RC_FLOODFILL);
    MakeFlag('Support StretchBlt()', RasterCaps, RC_STRETCHBLT);
    MakeFlag('Support StretchBID()', RasterCaps, RC_STRETCHDIB);
    MakeFlag('Support DIBS', RasterCaps, RC_DEVBITS);

    MakeHex('Curve Printion Flages', CurveCaps);
    DevCtrl.Lines.Add(sep);
    DevCtrl.Lines.Add('');
    MakeFlag('No Curve support', CurveCaps, CC_NONE);
    MakeFlag('Support Circles', CurveCaps, CC_Circles);
    MakeFlag('Support Pie', CurveCaps, CC_PIE);
    MakeFlag('Support Arces', CurveCaps, CC_CHORD);
    MakeFlag('Support Ellipses', CurveCaps, CC_ELLIPSEs);
    MakeFlag('Support WIDE FRAMES', CurveCaps, CC_WIDE);
    MakeFlag('Support STYLED FRAMES', CurveCaps, CC_STYLED);
    MakeFlag('Support WIDE&STYLED FRAMES', CurveCaps, CC_WIDESTYLED);
    MakeFlag('Support INTERIORS', CurveCaps, CC_INTERIORS);
    MakeFlag('Support ROUNDRECT', CurveCaps, CC_ROUNDRECT);

    MakeHex('Line & Polygon Printing Flags', LineCaps);
    DevCtrl.Lines.Add(sep);
    DevCtrl.Lines.Add('');
    MakeFlag('No Line Support', LineCaps, LC_NONE);
    MakeFlag('Support Polylines', LineCaps, LC_PolyLine);
    MakeFlag('Support Marker', LineCaps, LC_Marker);
    MakeFlag('Support PolyMarker', LineCaps, LC_PolyMarker);
    MakeFlag('Support Wide Lines', LineCaps, LC_WIDE);
    MakeFlag('Support STYLED Lines', LineCaps, LC_STYLED);
    MakeFlag('Support WIDE&STYLED Lines', LineCaps, LC_WIDESTYLED);
    MakeFlag('Support Lines Interiors', LineCaps, LC_INTERIORS);

    MakeHex('Polygon (Areal) Printing Flags', POLYGONALCAPS);
    DevCtrl.Lines.Add(sep);
    DevCtrl.Lines.Add('');
    MakeFlag('No Polygon Support', PolygonalCaps, PC_NONE);
    MakeFlag('Filling Alternate Polygons', PolygonalCaps, PC_POLYGON);
    MakeFlag('Drawing Rectangles', PolygonalCaps, PC_RECTANGLE);
    MakeFlag('Filling Winding Polygons', PolygonalCaps, PC_WINDPOLYGON);
    MakeFlag('Drawing Trapezoid (??Flag)', PolygonalCaps, PC_Trapezoid);
    MakeFlag('Drawing a ScanLine', PolygonalCaps, PC_SCANLINE);
    MakeFlag('Drawing Wide Border', PolygonalCaps, PC_WIDE);
    MakeFlag('Drawing Styled Border', PolygonalCaps, PC_STYLED);
    MakeFlag('Drawing WIDE&STYLED Border', PolygonalCaps, PC_WIDESTYLED);
    MakeFlag('Drawing Interiors', PolygonalCaps, PC_INTERIORS);

    MakeHex('Text Printing Flags', TEXTCAPS);
    DevCtrl.Lines.Add(sep);
    DevCtrl.Lines.Add('');
    MakeFlag('Support Character Output Precision', TextCaps, TC_OP_CHARACTER);
    MakeFlag('Support Stroke Output Precision', TextCaps, TC_OP_STROKE);
    MakeFlag('Support Stroke Clip Precision', TextCaps, TC_CP_STROKE);
    MakeFlag('Support 90° Character Rotation', TextCaps, TC_CR_90);
    MakeFlag('Support any Character Rotaion', TextCaps, TC_CR_ANY);
    MakeFlag('Support Character Scaling in X&Y', TextCaps, TC_SF_X_YINDEP);
    MakeFlag('Support Character Scaling REAL', TextCaps, TC_SA_DOUBLE);
    MakeFlag('Support Character Scaling RATIONAL', TextCaps, TC_SA_INTEGER);
    MakeFlag('Support Character Scaling EXACT', TextCaps, TC_SA_CONTIN);
    MakeFlag('Support Character Weight REAL', TextCaps, TC_EA_DOUBLE);
    MakeFlag('Support Character Italic', TextCaps, TC_IA_ABLE);
    MakeFlag('Support Character Underline', TextCaps, TC_UA_ABLE);
    MakeFlag('Support Character Strikeout', TextCaps, TC_SO_ABLE);
    MakeFlag('Support Character as RASTER FONT', TextCaps, TC_RA_ABLE);
    MakeFlag('Support Character as VECTOR FONT', TextCaps, TC_VA_ABLE);
    MakeFlag('Reserved Flag ???', TextCaps, TC_Reserved);
    MakeFlag('DEVICE NOT USE a SCROLLBIT BLOCK ?', TextCaps, TC_SCROLLBLT);
    DevCtrl.Lines.Insert(0, '..THE RESULTS ARE:');
  except
    // MessageDlg('The Current Printer is not valid ! ',
    // mtError,[mbok],0);
    Printer.PrinterIndex := -1;
    DevCtrl.Lines.Add(' ! The Printer is not valid !');
  end;
  DevCtrl.Visible := True;
  DevCtrl.SetFocus;
end;


procedure TForm1.Button1Click(Sender: TObject);
begin
  GetDeviceSettings(Memo1);
end;
Kişi odur ki, koyar dünyada bir eser. Eseri olmayanın yerinde yeller eser./Muhammed Hadimi
http://www.ibrahimkutluay.net
http://www.ibrahimkutluay.net/blog
ikutluay
Üye
Mesajlar: 2341
Kayıt: 03 Tem 2007 10:13

yazıcı portu ve adını bulmak

Mesaj gönderen ikutluay »

Kod: Tümünü seç

type
  TPrinterDevice = class   {type definition NOT interfaced by Printers.pas}
    Driver, Device, Port: string;
  end;
  
{ .... }

uses Printers;

{ .... }

function GetCurrentPrinterPort: string;
begin
  Result := TPrinterDevice(Printer.Printers.Objects[Printer.PrinterIndex]).Port;
end;

{The exact printer's name known to Windows for use in API calls can be obtained by:}
function GetCurrentPrinterName: string;
begin
  Result := TPrinterDevice(Printer.Printers.Objects[Printer.PrinterIndex]).Device;
end;


// Example:
procedure TForm1.Button1Click(Sender: TObject);
begin
  Label1.Caption := GetCurrentPrinterPort;
  Label2.Caption := GetCurrentPrinterName;
end;
Kişi odur ki, koyar dünyada bir eser. Eseri olmayanın yerinde yeller eser./Muhammed Hadimi
http://www.ibrahimkutluay.net
http://www.ibrahimkutluay.net/blog
ikutluay
Üye
Mesajlar: 2341
Kayıt: 03 Tem 2007 10:13

TMemo, TStringlist, TStrings kodla yazdırma

Mesaj gönderen ikutluay »

Kod: Tümünü seç

{
  The following example project
  shows how to print a memos lines, but you can as well use
  listbox.items, it will work with every TStrings descendent, even a
  TStirnglist.
}

unit PrintStringsUnit1;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,
  Dialogs,
  StdCtrls;

type
  TForm1 = class(TForm)
    Memo1: TMemo;
    Button1: TButton;
    procedure Button1Click(Sender : TObject);
  private
    { Private declarations }
    procedure PrintHeader(aCanvas : TCanvas; aPageCount : integer;
      aTextrect : TRect; var Continue : boolean);
    procedure PrintFooter(aCanvas : TCanvas; aPageCount : integer;
      aTextrect : TRect; var Continue : boolean);
  public
    { Public declarations }
  end;

var
  Form1 : TForm1;

implementation

uses Printers;
{$R *.DFM}

type
  THeaderFooterProc =
    procedure(aCanvas : TCanvas; aPageCount : integer;
    aTextrect : TRect; var Continue : boolean) of object;
   { Prototype for a callback method that PrintString will call
     when it is time to print a header or footer on a page. The
     parameters that will be passed to the callback are:
     aCanvas   : the canvas to output on
     aPageCount: page number of the current page, counting from 1
     aTextRect : output rectangle that should be used. This will be
                 the area available between non-printable margin and
                 top or bottom margin, in device units (dots). Output
                 is not restricted to this area, though.
     continue  : will be passed in as True. If the callback sets it
                 to false the print job will be aborted. }

{+------------------------------------------------------------
 | Function PrintStrings
 |
 | Parameters :
 |   lines:
 |     contains the text to print, already formatted into
 |     lines of suitable length. No additional wordwrapping
 |     will be done by this routine and also no text clipping
 |     on the right margin!
 |   leftmargin, topmargin, rightmargin, bottommargin:
 |     define the print area. Unit is inches, the margins are
 |     measured from the edge of the paper, not the printable
 |     area, and are positive values! The margin will be adjusted
 |     if it lies outside the printable area.
 |   linesPerInch:
 |     used to calculate the line spacing independent of font
 |     size.
 |   aFont:
 |     font to use for printout, must not be Nil.
 |   measureonly:
 |     If true the routine will only count pages and not produce any
 |     output on the printer. Set this parameter to false to actually
 |     print the text.
 |   OnPrintheader:
 |     can be Nil. Callback that will be called after a new page has
 |     been started but before any text has been output on that page.
 |     The callback should be used to print a header and/or a watermark
 |     on the page.
 |   OnPrintfooter:
 |     can be Nil. Callback that will be called after all text for one
 |     page has been printed, before a new page is started. The  callback
 |     should be used to print a footer on the page.
 | Returns:
 |   number of pages printed. If the job has been aborted the return
 |   value will be 0.
 | Description:
 |   Uses the Canvas.TextOut function to perform text output in
 |   the rectangle defined by the margins. The text can span
 |   multiple pages.
 | Nomenclature:
 |   Paper coordinates are relative to the upper left corner of the
 |   physical page, canvas coordinates (as used by Delphis  Printer.Canvas)
 |   are relative to the upper left corner of the printable area. The
 |   printorigin variable below holds the origin of the canvas  coordinate
 |   system in paper coordinates. Units for both systems are printer
 |   dots, the printers device unit, the unit for resolution is dots
 |   per inch (dpi).
 | Error Conditions:
 |   A valid font is required. Margins that are outside the printable
 |   area will be corrected, invalid margins will raise an EPrinter
 |   exception.
 | Created: 13.05.99 by P. Below
 +------------------------------------------------------------}
function PrintStrings(Lines : TStrings;
  const leftmargin, rightmargin,
  topmargin, bottommargin: single;
  const linesPerInch: single;
  aFont: TFont;
  measureonly: Boolean;
  OnPrintheader,
  OnPrintfooter: THeaderFooterProc): Integer;
var
  continuePrint: Boolean;     { continue/abort flag for callbacks }
  pagecount: Integer;     { number of current page }
  textrect: TRect;       { output area, in canvas coordinates }
  headerrect: TRect;       { area for header, in canvas
coordinates }
  footerrect: TRect;       { area for footes, in canvas
coordinates }
  lineheight: Integer;     { line spacing in dots }
  charheight: Integer;     { font height in dots  }
  textstart: Integer;     { index of first line to print on
                                  current page, 0-based. }

  { Calculate text output and header/footer rectangles. }
  procedure CalcPrintRects;
  var
    X_resolution : Integer;  { horizontal printer resolution, in dpi }
    Y_resolution : Integer;  { vertical printer resolution, in dpi }
    pagerect : TRect;    { total page, in paper coordinates }
    printorigin : TPoint;   { origin of canvas coordinate system in
                                paper coordinates. }

    { Get resolution, paper size and non-printable margin from
      printer driver. }
    procedure GetPrinterParameters;
    begin
      with Printer.Canvas do
      begin
        X_resolution := GetDeviceCaps(Handle, LOGPIXELSX);
        Y_resolution := GetDeviceCaps(Handle, LOGPIXELSY);
        printorigin.X := GetDeviceCaps(Handle, PHYSICALOFFSETX);
        printorigin.Y := GetDeviceCaps(Handle, PHYSICALOFFSETY);
        pagerect.Left := 0;
        pagerect.Right := GetDeviceCaps(Handle, PHYSICALWIDTH);
        pagerect.Top := 0;
        pagerect.Bottom := GetDeviceCaps(Handle, PHYSICALHEIGHT);
      end; { With }
    end; { GetPrinterParameters }

    { Calculate area between the requested margins, paper-relative.
      Adjust margins if they fall outside the printable area.
      Validate the margins, raise EPrinter exception if no text area
      is left. }
    procedure CalcRects;
    var
      max : integer;
    begin
      with textrect do
      begin
        { Figure textrect in paper coordinates }
        Left := Round(leftmargin * X_resolution);
        if Left < printorigin.x then
          Left := printorigin.x;

        Top := Round(topmargin * Y_resolution);
        if Top < printorigin.y then
          Top := printorigin.y;

          { Printer.PageWidth and PageHeight return the size of the
            printable area, we need to add the printorigin to get the
            edge of the printable area in paper coordinates. }
        Right := pagerect.Right - Round(rightmargin * X_resolution);
        max := Printer.PageWidth + printorigin.X;
        if Right > max then
          Right := max;

        Bottom := pagerect.Bottom - Round(bottommargin *
          Y_resolution);
        max := Printer.PageHeight + printorigin.Y;
        if Bottom > max then
          Bottom := max;

        { Validate the margins. }
        if (Left >= Right) or (Top >= Bottom) then
          raise EPrinter.Create('PrintString: the supplied margins are too large, there
            ' +
            'is no area to print left on the page.');
      end; { With }

      { Convert textrect to canvas coordinates. }
      OffsetRect(textrect, - printorigin.X, - printorigin.Y);

      { Build header and footer rects. }
      headerrect := Rect(textrect.Left, 0,
        textrect.Right, textrect.Top);
      footerrect := Rect(textrect.Left, textrect.Bottom,
        textrect.Right, Printer.PageHeight);
    end; { CalcRects }
  begin { CalcPrintRects }
    GetPrinterParameters;
    CalcRects;
    lineheight := round(Y_resolution / linesPerInch);
  end; { CalcPrintRects }

  { Print a page with headers and footers. }
  procedure PrintPage;
    procedure FireHeaderFooterEvent(event : THeaderFooterProc; r : TRect);
    begin
      if Assigned(event) then
      begin
        event(Printer.Canvas,
          pagecount,
          r,
          ContinuePrint);
          { Revert to our font, in case event handler changed
            it. }
        Printer.Canvas.Font := aFont;
      end; { If }
    end; { FireHeaderFooterEvent }

    procedure DoHeader;
    begin
      FireHeaderFooterEvent(OnPrintHeader, headerrect);
    end; { DoHeader }

    procedure DoFooter;
    begin
      FireHeaderFooterEvent(OnPrintFooter, footerrect);
    end; { DoFooter }

    procedure DoPage;
    var
      y : integer;
    begin
      y := textrect.Top;
      while (textStart < Lines.Count) and
        (y <= (textrect.Bottom - charheight)) do
      begin
          { Note: use TextRect instead of TextOut to effect clipping
            of the line on the right margin. It is a bit slower,
            though. The clipping rect would be
            Rect( textrect.left, y, textrect.right, y+charheight). }
        printer.Canvas.TextOut(textrect.Left, y, Lines[textStart]);
        Inc(textStart);
        Inc(y, lineheight);
      end; { While }
    end; { DoPage }
  begin { PrintPage }
    DoHeader;
    if ContinuePrint then
    begin
      DoPage;
      DoFooter;
      if (textStart < Lines.Count) and ContinuePrint then
      begin
        Inc(pagecount);
        Printer.NewPage;
      end; { If }
    end;
  end; { PrintPage }
begin { PrintStrings }
  Assert(Assigned(afont),
    'PrintString: requires a valid aFont parameter!');

  continuePrint := True;
  pagecount := 1;
  textstart := 0;
  Printer.BeginDoc;
  try
    CalcPrintRects;
    {$IFNDEF WIN32}
    { Fix for Delphi 1 bug. }
    Printer.Canvas.Font.PixelsPerInch := Y_resolution;
    {$ENDIF }
    Printer.Canvas.Font := aFont;
    charheight := printer.Canvas.TextHeight('Äy');
    while (textstart < Lines.Count) and ContinuePrint do
      PrintPage;
  finally
    if continuePrint and not measureonly then
      Printer.EndDoc
    else
    begin
      Printer.Abort;
    end;
  end;

  if continuePrint then
    Result := pagecount
  else
    Result := 0;
end; { PrintStrings }


procedure TForm1.Button1Click(Sender : TObject);
begin
  ShowMessage(Format('%d pages printed',
    [PrintStrings(memo1.Lines,
    0.75, 0.5, 0.75, 1,
    6,
    memo1.Font,
    False,
    PrintHeader, PrintFooter)
    ]));
end;

procedure TForm1.PrintFooter(aCanvas : TCanvas; aPageCount : integer;
  aTextrect : TRect; var Continue : boolean);
var
  S: string;
  res: integer;
begin
  with aCanvas do
  begin
    { Draw a gray line one point wide below the text }
    res := GetDeviceCaps(Handle, LOGPIXELSY);
    pen.Style := psSolid;
    pen.Color := clGray;
    pen.Width := Round(res / 72);
    MoveTo(aTextRect.Left, aTextRect.Top);
    LineTo(aTextRect.Right, aTextRect.Top);
    { Print the page number in Arial 8pt, gray, on right side of
      footer rect. }
    S := Format('Page %d', [aPageCount]);
    Font.Name := 'Arial';
    Font.Size := 8;
    Font.Color := clGray;
    TextOut(aTextRect.Right - TextWidth(S), aTextRect.Top + res div
      18,
      S);
  end;
end;

procedure TForm1.PrintHeader(aCanvas : TCanvas; aPageCount : integer;
  aTextrect : TRect; var Continue : boolean);
var
  res: Integer;
begin
  with aCanvas do
  begin
    { Draw a gray line one point wide 4 points above the text }
    res := GetDeviceCaps(Handle, LOGPIXELSY);
    pen.Style := psSolid;
    pen.Color := clGray;
    pen.Width := Round(res / 72);
    MoveTo(aTextRect.Left, aTextRect.Bottom - res div 18);
    LineTo(aTextRect.Right, aTextRect.Bottom - res div 18);
    { Print the company name in Arial 8pt, gray, on left side of
      footer rect. }
    Font.Name := 'Arial';
    Font.Size := 8;
    Font.Color := clGray;
    TextOut(aTextRect.Left, aTextRect.Bottom - res div 10 -
      TextHeight('W'),
      'W. W. Shyster & Cie.');
  end;
end;

end.
Kişi odur ki, koyar dünyada bir eser. Eseri olmayanın yerinde yeller eser./Muhammed Hadimi
http://www.ibrahimkutluay.net
http://www.ibrahimkutluay.net/blog
ikutluay
Üye
Mesajlar: 2341
Kayıt: 03 Tem 2007 10:13

bir klasörü ftp ile upload

Mesaj gönderen ikutluay »

Kod: Tümünü seç

procedure UploadPerFTP;
  procedure GetDir(dir: string);
  var
    SearchRec: TSearchRec;
    details, nodetails: TStringList;
    k: Integer;
  begin
    //iterate through directory given
    //schleife über alle dateien im ordner
    if FindFirst(dir + '*.*', faAnyFile, SearchRec) = 0 then
    begin
      repeat

        //get rid of the both "dummy-directories" '.' and '..'
        //die ordner '.' und '..' brauchen man nicht
        if (SearchRec.Name <> '.') and (SearchRec.Name <> '..') then
        begin
          //if we found a folder
          //falls wir einen ordner haben
          if (SearchRec.Attr and faDirectory) = faDirectory then
          begin
            //get folder contents from ftp. one with details, one without
            //holen wir uns den ordnerinhalt mit details und einmal ohne vom server
            details   := TStringList.Create;
            nodetails := TStringList.Create;
            FTPClient.List(details, '', True);
            FTPClient.List(nodetails, '', False);

            //we only want to have directories in the list (without '.' and '..')
            //nun filtern wir das nach den ordnern (ohne '.' und '..')
            for k := details.Count - 1 downto 0 do
            begin
              if details.Strings[k] <> '' then
              begin
                if (details.Strings[k][1] <> 'd') or
                  (nodetails.Strings[k] = '.') or
                  (nodetails.Strings[k] = '..') then
                begin
                  details.Delete(k);
                  nodetails.Delete(k);
                end;
              end;
            end;

            //if our directory does not exists on the server, create it
            //falls unser ordner auf dem server noch nicht existiert, legen wir ihn an
            if nodetails.IndexOf(SearchRec.Name) = -1 then
            begin
              FTPClient.MakeDir(SearchRec.Name);
            end;

            //change into next directory on server
            //nun wechseln wir in den nächsten ordner
            FTPClient.ChangeDir(SearchRec.Name);
            details.Free;
            nodetails.Free;

            //and also locally go into the next subfolder
            //und suchen lokal im nächsten unterordner weiter
            GetDir(dir + SearchRec.Name + '\');

            //we have to go one directory up after leaving the recursion
            //wenn die rekursion zurück ist, müssen wir wieder eine ordnerstufe hochgehen
            FTPClient.ChangeDirUp;
          end 
          else 
          begin
            //if it's only a file, upload it to the current directory
            //falls wir eine datei angetroffen haben, können wir diese uploaden
            FTPClient.Put(dir + SearchRec.Name, SearchRec.Name);
          end;
        end;
      until FindNext(SearchRec) <> 0;
      FindClose(SearchRec);
    end;
  end;
var
  dir: string;
  details, nodetails: TStringList;
  k: Integer;
begin
  //set some basic settings on your ftp client (TIdFTPClient)
  //hier kommen die grundangaben für unseren ftp client hin (TIdFTPClient)
  with FTPClient do
  begin
    Host     := 'your_server.com';            // Adjust your data here / Hier gwünschte Daten eintragen
    Username := 'your_username';
    // Adjust your data here / Hier gwünschte Daten eintragen
    Password := 'your_password';
    // Adjust your data here / Hier gwünschte Daten eintragen
    Passive := True;                      // Adjust your data here / Hier gwünschte Daten eintragen
  end;
  FTPClient.Connect;

  //if you want to upload you data to an remote-directory, enter it below (does not matter if 'dir\dir' or 'dir/dir')
  //falls die daten in ein remote-directory heraufgeladen werden sollen, kann es hier angegeben werden (egal ob 'dir\dir' oder 'dir/dir')
  dir := StringReplace('your/remote_directory', '\', '/', [rfReplaceAll]);
  // Adjust your data here / Hier gwünschte Daten eintragen

  //remove first '/' if there's one
  //wir löschen das erste '/', falls eines existiert
  if dir <> '' then
  begin
    if dir[1] = '/' then Delete(dir, 1, 1);

    //but add a '/' at the end
    //aber am ende fügen wir ein '/' hinzu
    if dir[Length(dir)] <> '/' then dir := dir + '/';

    //loop through our remote-directories
    //schleife über alle remote-directories
    while Pos('/', dir) > 0 do
    begin
      //get folder contents from ftp. one with details, one without
      //runterladen der aktuellen ordnerinhalte vom server (mit und ohne details)
      details   := TStringList.Create;
      nodetails := TStringList.Create;
      FTPClient.List(details, '', True);
      FTPClient.List(nodetails, '', False);

      //we only want to have directories in the list (without '.' and '..')
      //wir wollen wieder nur ordner ohne '.' und '..'
      for k := details.Count - 1 downto 0 do
      begin
        if details.Strings[k] <> '' then
        begin
          if (details.Strings[k][1] <> 'd') or
            (nodetails.Strings[k] = '.') or
            (nodetails.Strings[k] = '..') then
          begin
            details.Delete(k);
            nodetails.Delete(k);
          end;
        end;
      end;

      //if our directory does not exists on the server, create it
      //falls der ordner nicht existiert, legen wir ihn an
      if nodetails.IndexOf(Copy(dir, 1, Pos('/', dir) - 1)) = -1 then
      begin
        FTPClient.MakeDir(Copy(dir, 1, Pos('/', dir) - 1));
      end;

      //change to our directory on server
      //nun wechseln wir in den nächsten ordner auf dem server
      FTPClient.ChangeDir(Copy(dir, 1, Pos('/', dir) - 1));

      //remove first directory from path ('your/directory/subdir/' --> 'directory/subdir/')
      //wir schneiden den ersten ordner vom pfad ab ('dein/ordner/unterordner/' --> 'ordner/unterordner/')
      Delete(dir, 1, Pos('/', dir));
      details.Free;
      nodetails.Free;
    end;
  end;

  //ftp client is ready in your remote-directory
  //begin to upload our local directory
  //der ftp client ist nun im remote-directory bereit
  //wür können anfangen unseren lokalen ordner raufzuladen
  dir := 'C:\your\local\directory\';
  // Adjust your data here / Hier gwünschte Daten eintragen
  if dir[Length(dir)] <> '\' then dir := dir + '\';
  GetDir(dir);
  FTPClient.Disconnect;
end;
Kişi odur ki, koyar dünyada bir eser. Eseri olmayanın yerinde yeller eser./Muhammed Hadimi
http://www.ibrahimkutluay.net
http://www.ibrahimkutluay.net/blog
ikutluay
Üye
Mesajlar: 2341
Kayıt: 03 Tem 2007 10:13

html içindeki resim linklerini bulmak

Mesaj gönderen ikutluay »

Kod: Tümünü seç

uses mshtml, ActiveX, COMObj, IdHTTP, idURI;

{ .... }

procedure GetImageLinks(AURL: string; AList: TStrings);
var
  IDoc: IHTMLDocument2;
  strHTML: string;
  v: Variant;
  x: Integer;
  ovLinks: OleVariant;
  DocURL: string;
  URI: TidURI;
  ImgURL: string;
  idHTTP: TidHTTP;
begin
  AList.Clear;
  URI := TidURI.Create(AURL);
  try
    DocURL := 'http://' + URI.Host;
    if URI.Path <> '/' then
      DocURL := DocURL + URI.Path;
  finally
    URI.Free;
  end;
  Idoc := CreateComObject(Class_HTMLDocument) as IHTMLDocument2;
  try
    IDoc.designMode := 'on';
    while IDoc.readyState <> 'complete' do
      Application.ProcessMessages;
    v      := VarArrayCreate([0, 0], VarVariant);
    idHTTP := TidHTTP.Create(nil);
    try
      strHTML := idHTTP.Get(AURL);
    finally
      idHTTP.Free;
    end;
    v[0] := strHTML;
    IDoc.Write(PSafeArray(System.TVarData(v).VArray));
    IDoc.designMode := 'off';
    while IDoc.readyState <> 'complete' do
      Application.ProcessMessages;
    ovLinks := IDoc.all.tags('IMG');
    if ovLinks.Length > 0 then
    begin
      for x := 0 to ovLinks.Length - 1 do
      begin
        ImgURL := ovLinks.Item(x).src;
        // The stuff below will probably need a little tweaking
        // Deteriming and turning realtive URLs into absolute URLs
        // is not that difficult but this is all I could come up with
        // in such a short notice.
        if (ImgURL[1] = '/') then
        begin
          // more than likely a relative URL so
          // append the DocURL
          ImgURL := DocURL + ImgUrl;
        end
        else
        begin
          if (Copy(ImgURL, 1, 11) = 'about:blank') then
          begin
            ImgURL := DocURL + Copy(ImgUrl, 12, Length(ImgURL));
          end;
        end;
        AList.Add(ImgURL);
      end;
    end;
  finally
    IDoc := nil;
  end;
end;


// Beispiel:
// Example:
procedure TForm1.Button1Click(Sender: TObject);
begin
  GetImageLinks('http://www.swissdelphicenter.ch', Memo1.Lines);
end;

Kişi odur ki, koyar dünyada bir eser. Eseri olmayanın yerinde yeller eser./Muhammed Hadimi
http://www.ibrahimkutluay.net
http://www.ibrahimkutluay.net/blog
Cevapla