Çeşitli kod ipuçları

[ikutluay]

Kod: Tümünü seç

uses 
  Windows, SysUtils; 

function GetShortName(sLongName: string): string; 
var 
  sShortName:    string;
  nShortNameLen: Integer; 
begin 
  SetLength(sShortName, MAX_PATH); 
  nShortNameLen := GetShortPathName(PChar(sLongName), PChar(sShortName), MAX_PATH - 1);
  if (0 = nShortNameLen) then 
  begin 
    // handle errors... 
  end; 
  SetLength(sShortName, nShortNameLen); 
  Result := sShortName; 
end; 

// Example: 

procedure TForm1.Button1Click(Sender: TObject); 
begin 
  Caption := GetShortName('C:\Program Files\Delphi6\Lib\test.cnt'); 
  // --> C:\PROGRA~1\Delphi6\Lib\test.cnt 
end;

[ikutluay]

Kod: Tümünü seç

1.}

function GetFileLastAccessTime(sFileName: string): TDateTime;
var
  ffd: TWin32FindData;
  dft: DWORD;
  lft: TFileTime;
  h:   THandle;
begin
  //
  // get file information
  h := Windows.FindFirstFile(PChar(sFileName), ffd);
  if (INVALID_HANDLE_VALUE <> h) then
  begin
    //
    // we're looking for just one file,
    // so close our "find"
    Windows.FindClose(h);
    //
    // convert the FILETIME to
    // local FILETIME
    FileTimeToLocalFileTime(ffd.ftLastAccessTime, lft);
    //
    // convert FILETIME to
    // DOS time
    FileTimeToDosDateTime(lft, LongRec(dft).Hi, LongRec(dft).Lo);
    //
    // finally, convert DOS time to
    // TDateTime for use in Delphi's
    // native date/time functions
    Result := FileDateToDateTime(dft);
  end;
end;


{********************************************************************}

{2.}

function GetFileTimes(const FileName: string; var Created: TDateTime;
var Accessed: TDateTime; var Modified: TDateTime): Boolean;
var
  h: THandle;
  Info1, Info2, Info3: TFileTime;
  SysTimeStruct: SYSTEMTIME;
  TimeZoneInfo: TTimeZoneInformation;
  Bias: Double;
begin
  Result := False;
  Bias   := 0;
  h      := FileOpen(FileName, fmOpenRead or fmShareDenyNone);
  if h > 0 then 
  begin
    try
      if GetTimeZoneInformation(TimeZoneInfo) <> $FFFFFFFF then
        Bias := TimeZoneInfo.Bias / 1440; // 60x24
      GetFileTime(h, @Info1, @Info2, @Info3);
      if FileTimeToSystemTime(Info1, SysTimeStruct) then
        Created := SystemTimeToDateTime(SysTimeStruct) - Bias;
      if FileTimeToSystemTime(Info2, SysTimeStruct) then
        Accessed := SystemTimeToDateTime(SysTimeStruct) - Bias;
      if FileTimeToSystemTime(Info3, SysTimeStruct) then
        Modified := SystemTimeToDateTime(SysTimeStruct) - Bias;
      Result := True;
    finally
      FileClose(h);
    end;
  end;
end;


procedure TForm1.Button1Click(Sender: TObject);
var
  Date1, Date2, Date3: TDateTime;
begin
  if GetFileTimes(Edit1.Text, Date1, Date2, Date3) then 
  begin
    ShowMessage('Created: ' + DateTimeToStr(Date1));
    ShowMessage('Last Accessed: ' + DateTimeToStr(Date2));
    ShowMessage('Last Modified: ' + DateTimeToStr(Date3));
  end;
end;

[ikutluay]

Kod: Tümünü seç

uses ShellAPI; 

function DeleteFileWithUndo(sFileName: string): Boolean;
var 
  fos: TSHFileOpStruct; 
begin 
  FillChar(fos, SizeOf(fos), 0); 
  with fos do 
  begin 
    wFunc  := FO_DELETE; 
    pFrom  := PChar(sFileName); 
    fFlags := FOF_ALLOWUNDO or FOF_NOCONFIRMATION or FOF_SILENT; 
  end; 
  Result := (0 = ShFileOperation(fos)); 
end;

[ikutluay]

Kod: Tümünü seç

uses Filectrl; 

{....}

procedure TForm1.Button1Click(Sender: TObject); 
var 
  Dir: String; 
begin 
  SelectDirectory('Select a directory', '', Dir); 
  ShowMessage(Dir); 
end;

[ikutluay]

Kod: Tümünü seç

//in TCustomForm class,in protected section add

    procedure ShowParam(var param : integer);dynamic;
    {
    this procedure call when form should be show,
    now you should override this method and write your option for
    ShowWindow API. see the example
    }
    function InShowFocus : boolean ;dynamic;
    //this function determine that after show the Form , focus on it or no.

//and it's code is

procedure TCustomForm.ShowParam(var param: Integer);
const
  ShowCommands: array[TWindowState] of Integer =
    (SW_SHOWNORMAL, SW_SHOWMINNOACTIVE, SW_SHOWMAXIMIZED);
begin
  param := ShowCommands[FWindowState];
end;

function TCustomForm.InShowFocus: Boolean;
begin
  Result := True;
end;
//-------------------------------------------------------
//now in your class you can use from themunit Unit2;

interface

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

type
  TForm2 = class(TForm)
  private
    { Private declarations }
  protected
    procedure ShowParam(var param: Integer); override;
    function InShowFocus: Boolean; override;
  public
    { Public declarations }
  end;

var
  Form2: TForm2;

implementation

{$R *.dfm}

{ TForm2 }

function TForm2.InShowFocus: Boolean;
begin
  Result := False;
end;

procedure TForm2.ShowParam(var param: Integer);
begin
  inherited;
  param := SW_SHOWNOACTIVATE;
end;

end.

[ikutluay]

Kod: Tümünü seç

/Windows +XP
//Form witch one button and one editbox

type 
  tagEDITBALLOONTIP = record
    cbStruct: Longword;
    pszTitle: PWChar;
    pszText: PWChar;
    ttiIcon: Integer;
  end;
type 
  PEDITBALLOONTIP = ^tagEDITBALLOONTIP;

const
  ECM_FIRST         = $00001500;
  EM_SHOWBALLOONTIP = ECM_FIRST + 3;

procedure TForm1.Button1Click(Sender: TObject);
var
  ebt: tagEDITBALLOONTIP;
  title, Text: Widestring;
  icon: Integer;
begin
  title := 'tooltip!!';
  Text  := 'in editbox :)';
  icon  := 1; //0,1,2,3
  with ebt do
  begin
    cbStruct := SizeOf(ebt);
    pszTitle := PWideChar(title);
    pszText  := PWideChar(Text);
    ttiIcon  := icon;
  end;
  SendMessage(Edit1.Handle, EM_SHOWBALLOONTIP, 0, Longint(@ebt));
end;

[ikutluay]

Kod: Tümünü seç

procedure TForm1.ToolBar1CustomDrawButton(Sender: TToolBar;
  Button: TToolButton; State: TCustomDrawState; var DefaultDraw: Boolean);
begin
  // select color
  Sender.Canvas.Brush.Color := clAqua;

  // Paint selected color
  Sender.Canvas.Rectangle(Button.BoundsRect);
end;

[ikutluay]

Kod: Tümünü seç

procedure TForm1.FormMouseDown(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
  if Form1.Left <= 0 then Form1.Left := 0;
  if Form1.Top <= 0 then Form1.Top := 0;
  if Form1.Left >= Screen.Width - Form1.Width then
    Form1.Left := Screen.Width - Form1.Width;
  if Form1.Top >= Screen.Height - Form1.Height then
    Form1.Top := Screen.Height - Form1.Height;
end;

[ikutluay]

Kod: Tümünü seç

...Highlight Text with TMemo?
Autor: Gon Perez-Jimenez
[ Print tip ]	 	 

Tip Rating (34): 	 
     


(**
  *  Highlight with TMemo Impossible?  try this...
  *                                                by Gon Perez-Jimenez May'04
  *
  *  This is a sample how to work with highlighting within TMemo component by
  *  using interjected class technique.
  *
  *  Of course, this code is still uncompleted but it works fine for my
  *  purposes, so, hope you can improve it and use it.
  *
  *  Drop onto your TForm (Form1), a TMemo (Memo1), a TLabel (Label1)
  *  and a TListBox (KeywordList)
  *
  *  Insert in the TListBox Items some Pascal keywords in lowercase !!!
  *
  *  That's all!  Enjoy
  *)

unit Unit1;

interface

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

type
  // Interjected Class
  TMemo = class(stdctrls.TMemo)
  private
    procedure WMPaint(var Message: TWMPaint); message WM_PAINT;
    procedure WMSize(var Message: TWMSize); message WM_SIZE;
    procedure WMMove(var Message: TWMMove); message WM_MOVE;
    procedure WMVScroll(var Message: TWMMove); message WM_VSCROLL;
    procedure WMMousewheel(var Message: TWMMove); message WM_MOUSEWHEEL;
  protected
    procedure Change; override;
    procedure KeyDown(var Key: Word; Shift: TShiftState); override;
    procedure KeyUp(var Key: Word; Shift: TShiftState); override;
    procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
      override;
    procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
      override;
  public
    PosLabel: TLabel;
    procedure Update_label;
    procedure GotoXY(mCol, mLine: Integer);
    function Line: Integer;
    function Col: Integer;
    function TopLine: Integer;
    function VisibleLines: Integer;
  end;


  TForm1 = class(TForm)
    Memo1: TMemo;
    Label1: TLabel;
    KeywordList: TListBox;
    procedure FormCreate(Sender: TObject);
    procedure Memo1KeyUp(Sender: TObject; var Key: Word;
      Shift: TShiftState);
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

////////////////////////////////////////////////////////////////////////////////
// functions for managing keywords and numbers of each line of TMemo ///////////
////////////////////////////////////////////////////////////////////////////////
function IsSeparator(Car: Char): Boolean;
begin
  case Car of
    '.', ';', ',', ':', '¡', '!', '·', '"', '''', '^', '+', '-', '*', '/', '\', '¨', ' ',
    '`', '[', ']', '(', ')', 'º', 'ª', '{', '}', '?', '¿', '%', '=': Result := True;
    else
      Result := False;
  end;
end;
////////////////////////////////////////////////////////////////////////////////

function NextWord(var s: string; var PrevWord: string): string;
begin
  Result   := '';
  PrevWord := '';
  if s = '' then Exit;
  while (s <> '') and IsSeparator(s[1]) do 
  begin
    PrevWord := PrevWord + s[1];
    Delete(s, 1,1);
  end;
  while (s <> '') and not IsSeparator(s[1]) do 
  begin
    Result := Result + s[1];
    Delete(s, 1,1);
  end;
end;
////////////////////////////////////////////////////////////////////////////////

function IsKeyWord(s: string): Boolean;
begin
  Result := False;
  if s = '' then Exit;
  Result := Form1.KeywordList.Items.IndexOf(lowercase(s)) <> -1;
end;
////////////////////////////////////////////////////////////////////////////////

function IsNumber(s: string): Boolean;
var 
  i: Integer;
begin
  Result := False;
  for i := 1 to Length(s) do
    case s[i] of
      '0'..'9':;
      else 
        Exit;
    end;
  Result := True;
end;
////////////////////////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////////////////////////
// New or overrided methods and properties for TMemo using Interjected Class ///
// Technique ///////////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////////////////////////

function TMemo.VisibleLines: Integer;
begin
  Result := Height div (Abs(Self.Font.Height) + 2);
end;
////////////////////////////////////////////////////////////////////////////////

procedure TMemo.GotoXY(mCol, mLine: Integer);
begin
  Dec(mLine);
  SelStart  := 0;
  SelLength := 0;
  SelStart  := mCol + Self.Perform(EM_LINEINDEX, mLine, 0);
  SelLength := 0;
  SetFocus;
end;
////////////////////////////////////////////////////////////////////////////////

procedure TMemo.Update_label;
begin
  if PosLabel = nil then Exit;
  PosLabel.Caption := '(' + IntToStr(Line + 1) + ',' + IntToStr(Col) + ')';
end;
////////////////////////////////////////////////////////////////////////////////

function TMemo.TopLine: Integer;
begin
  Result := SendMessage(Self.Handle, EM_GETFIRSTVISIBLELINE, 0, 0);
end;
////////////////////////////////////////////////////////////////////////////////

function TMemo.Line: Integer;
begin
  Result := SendMessage(Self.Handle, EM_LINEFROMCHAR, Self.SelStart, 0);
end;
////////////////////////////////////////////////////////////////////////////////

function TMemo.Col: Integer;
begin
  Result := Self.SelStart - SendMessage(Self.Handle, EM_LINEINDEX,
    SendMessage(Self.Handle,
    EM_LINEFROMCHAR, Self.SelStart, 0), 0);
end;
////////////////////////////////////////////////////////////////////////////////

procedure TMemo.WMVScroll(var Message: TWMMove);
begin
  Update_label;
  Invalidate;
  inherited;
end;
////////////////////////////////////////////////////////////////////////////////

procedure TMemo.WMSize(var Message: TWMSize);
begin
  Invalidate;
  inherited;
end;
////////////////////////////////////////////////////////////////////////////////

procedure TMemo.WMMove(var Message: TWMMove);
begin
  Invalidate;
  inherited;
end;
////////////////////////////////////////////////////////////////////////////////

procedure TMemo.WMMousewheel(var Message: TWMMove);
begin
  Invalidate;
  inherited;
end;
////////////////////////////////////////////////////////////////////////////////

procedure TMemo.Change;
begin
  Update_label;
  Invalidate;
  inherited Change;
end;
////////////////////////////////////////////////////////////////////////////////

procedure TMemo.KeyDown(var Key: Word; Shift: TShiftState);
begin
  Update_label;
  inherited KeyDown(Key, Shift);
end;
////////////////////////////////////////////////////////////////////////////////

procedure TMemo.KeyUp(var Key: Word; Shift: TShiftState);
begin
  Update_label;
  inherited KeyUp(Key, Shift);
end;
////////////////////////////////////////////////////////////////////////////////

procedure TMemo.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
  Update_label;
  inherited MouseDown(Button, Shift, X, Y);
end;
////////////////////////////////////////////////////////////////////////////////

procedure TMemo.MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
  Update_label;
  inherited MouseUp(Button, Shift, X, Y);
end;
////////////////////////////////////////////////////////////////////////////////

procedure TMemo.WMPaint(var Message: TWMPaint);
var
  PS: TPaintStruct;
  DC: HDC;
  Canvas: TCanvas;
  i: Integer;
  X, Y: Integer;
  OldColor: TColor;
  Size: TSize;
  Max: Integer;
  s, Palabra, PrevWord: string;
begin
  DC := Message.DC;
  if DC = 0 then DC := BeginPaint(Handle, PS);
  Canvas := TCanvas.Create;
  try
    OldColor         := Font.Color;
    Canvas.Handle    := DC;
    Canvas.Font.Name := Font.Name;
    Canvas.Font.Size := Font.Size;
    with Canvas do 
    begin
      Max := TopLine + VisibleLines;
      if Max > Pred(Lines.Count) then Max := Pred(Lines.Count);

      //Limpio la sección visible
      Brush.Color := Self.Color;
      FillRect(Self.ClientRect);
      Y := 1;
      for i := TopLine to Max do 
      begin
        X := 2;
        s := Lines[i];

        //Detecto todas las palabras de esta línea
        Palabra := NextWord(s, PrevWord);
        while Palabra <> '' do 
        begin
          Font.Color := OldColor;
          TextOut(X, Y, PrevWord);
          GetTextExtentPoint32(DC, PChar(PrevWord), Length(PrevWord), Size);
          Inc(X, Size.cx);

          Font.Color := clBlack;
          if IsKeyWord(Palabra) then 
          begin
            Font.Color := clHighlight;
            TextOut(X, Y, Palabra);
             {
             //Draw dot underline
             Pen.Color := clHighlight;
             Pen.Style := psDot;
             PolyLine([ Point(X,Y+13), Point(X+TextWidth(Palabra),Y+13)]);
             }
          end 
          else if IsNumber(Palabra) then 
          begin
            Font.Color := $000000DD;
            TextOut(X, Y, Palabra);
          end 
          else
            TextOut(X, Y, Palabra);

          GetTextExtentPoint32(DC, PChar(Palabra), Length(Palabra), Size);
          Inc(X, Size.cx);

          Palabra := NextWord(s, PrevWord);
          if (s = '') and (PrevWord <> '') then 
          begin
            Font.Color := OldColor;
            TextOut(X, Y, PrevWord);
          end;
        end;
        if (s = '') and (PrevWord <> '') then 
        begin
          Font.Color := OldColor;
          TextOut(X, Y, PrevWord);
        end;

        s := 'W';
        GetTextExtentPoint32(DC, PChar(s), Length(s), Size);
        Inc(Y, Size.cy);
      end;
    end;
  finally
    if Message.DC = 0 then EndPaint(Handle, PS);
  end;
  Canvas.Free;
  inherited;
end;
////////////////////////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////////////////////////

////////////////////////////////////////////////////////////////////////////////
// Procedures for Form1 ////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////////////////////////
procedure TForm1.FormCreate(Sender: TObject);
begin
  Memo1.PosLabel := Label1;
  Memo1.Update_label;
end;
////////////////////////////////////////////////////////////////////////////////

procedure TForm1.Memo1KeyUp(Sender: TObject; var Key: Word;
  Shift: TShiftState);
begin
  if Key = VK_F1 then Memo1.Invalidate;
end;
////////////////////////////////////////////////////////////////////////////////

procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
begin
  Action := caFree;
end;
////////////////////////////////////////////////////////////////////////////////

end.

[ikutluay]

Kod: Tümünü seç

(*
--- english -------------------------------------------------------------------
If you want to show your mainform as a dialog (setting BorderStyle := bsDialog)
and don't want to miss your main menu...
--- german --------------------------------------------------------------------
Wer die Hauptform auf BorderStyle := bsDialog gesetzt hat und
dennoch ein TMainMenu haben möchte kann das Handle von TMainMenu nachträglich
wieder aktivieren.
*)

procedure TMain.FormCreate(Sender: TObject);
begin
  //...
  Windows.SetMenu(Handle, MainMenu1.Handle);
end;

[ikutluay]

Kod: Tümünü seç

protected
  procedure CreateParams(var Params: TCreateParams); override;

//...

procedure TForm.CreateParams(var Params: TCreateParams);
begin
  inherited CreateParams(Params);
  if Assigned(Application.MainForm) then
  begin
    Params.WndParent := GetDesktopWindow;
    Params.Style := WS_CHILD;
  end;
end;

[ikutluay]

Kod: Tümünü seç

{
  Under windows 2000/XP,if user open a modal dialog,
  when the user click the modal form's parent form,
  windows can flash the modal form title bar,how to do it by delphi?
  you may create base form,let you modal form inherite from the base form,
  and add under codes to the base form source:
}

type
  TFrmBase = class(TForm)
  protected
    procedure CreateParams(var Para: TCreateParams); override;
    {....}
  end;

  {.....}

implementation

procedure TFrmBase.CreateParams(var Para: TCreateParams);
begin
  inherited;
  Para.WndParent := GetActiveWindow;
end;

[ikutluay]

Kod: Tümünü seç

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

[ikutluay]

Kod: Tümünü seç

uses
  printers;

ComboBox1.Items.Assign(Printer.Printers);

[ikutluay]

Kod: Tümünü seç

uses
  Printers, Messages;

function GetDefaultPrinter: string;
var
  ResStr: array[0..255] of Char;
begin
  GetProfileString('Windows', 'device', '', ResStr, 255);
  Result := StrPas(ResStr);
end;

procedure SetDefaultPrinter1(NewDefPrinter: string);
var
  ResStr: array[0..255] of Char;
begin
  StrPCopy(ResStr, NewdefPrinter);
  WriteProfileString('windows', 'device', ResStr);
  StrCopy(ResStr, 'windows');
  SendMessage(HWND_BROADCAST, WM_WININICHANGE, 0, Longint(@ResStr));
end;

procedure SetDefaultPrinter2(PrinterName: string);
var
  I: Integer;
  Device: PChar;
  Driver: PChar;
  Port: PChar;
  HdeviceMode: THandle;
  aPrinter: TPrinter;
begin
  Printer.PrinterIndex := -1;
  GetMem(Device, 255);
  GetMem(Driver, 255);
  GetMem(Port, 255);
  aPrinter := TPrinter.Create;
  try
    for I := 0 to Printer.Printers.Count - 1 do
    begin
      if Printer.Printers = PrinterName then
      begin
        aprinter.PrinterIndex := i;
        aPrinter.getprinter(device, driver, port, HdeviceMode);
        StrCat(Device, ',');
        StrCat(Device, Driver);
        StrCat(Device, Port);
        WriteProfileString('windows', 'device', Device);
        StrCopy(Device, 'windows');
        SendMessage(HWND_BROADCAST, WM_WININICHANGE,
          0, Longint(@Device));
      end;
    end;
  finally
    aPrinter.Free;
  end;
  FreeMem(Device, 255);
  FreeMem(Driver, 255);
  FreeMem(Port, 255);
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  label1.Caption := GetDefaultPrinter2;
end;

//Fill the combobox with all available printers
procedure TForm1.FormCreate(Sender: TObject);
begin
  Combobox1.Items.Clear;
  Combobox1.Items.AddStrings(Printer.Printers);
end;

//Set the selected printer in the combobox as default printer
procedure TForm1.Button2Click(Sender: TObject);
begin
  SetDefaultPrinter(Combobox1.Text);
end;