Delphi - база знаний

  35790931     

Как сделать окно системно-модальным?


Как сделать окно системно-модальным?




Используйте функцию Windows API SetSysModalWindow(). Код ниже демонстрирует технологию работы с этой функцией. В любой момент времени может быть возможен только один модально-системны диалог, чей дескриптор возвращается функцией SetSysModalWindow(). Вам необходимо запомнить возвращаемую функцией величину для того, чтобы завершить показ диалога таким образом. Вот как примерно это должно выглядеть:



procedureTForm1.Button1Click(Sender: TObject);
var
  x: word ;
begin
  x := SetSysModalWindow(AboutBox.handle) ;
  AboutBox.showmodal ;
  SetSysModalWindow(x) ;
end;





Взято с





Как сделать откат внутри триггера


Как сделать откат внутри триггера




Внутри триггера нельзя управлять транзакциями, поэтому генерируешь там исключение а откат транзакции делаешь в приложении, пославшем запрос. Естественно exception должен предварительно создан



SETTERM !!;

CREATE TRIGGER " DELETE_INV"  FOR " TINV"
    ACTIVE BEFORE DELETE
    POSITION 10
    AS
    BEGIN
        IF (EXISTS (SELECT tOst.Id FROM tOst
                    WHERE tOst.Id = tInv.Id))
        THEN
            EXCEPTION EST_OSTATOK;
    END !!

SET TERM ;!!


DBase.StartTransaction;
try
  Query.ExecSQL;
  DBase.Commit;
except
  DBase.Rollback;
  raise;    // Для последующей обработки
end;



Взято из





Как сделать отступ в Memo?


Как сделать отступ в Memo?



С помощью API-функции SendMessage можно задать поля в Memo-компоненте. Если необходимо, например, сделать отступ в 20 пикселей слева то можно это сделать следующим образом:


var Rect: TRect;
begin
  SendMessage( Memo1.Handle, EM_GETRECT, 0, LongInt(@Rect));
  Rect.Left:= 20;
  SendMessage(Memo1.Handle, EM_SETRECT, 0, LongInt(@Rect));
  Memo1.Refresh;
end;




Как сделать PING?


Как сделать PING?



Протокол Ping предназначен для тестирования компьютерных соединений в Интернете путём посылки через протокол Internet Protocol (IP) по обределённому адресу сообщения и ожидания от него ответа.

ICMP - Internet Control Message Protocol. ICMP служит для передачи сообщений об ошибках а так же управляющих сообщений . ICMP-тест может показать насколько быстро проходит информация между двумя узлами в Интернете.


1. Запускаем Delphi;
2. В Новом проекте добавляем в форму Tbutton, Tedit и Tmemo;
3. Вставляем "winsock";
4. объявляем структурку для IP-заголовка:

type
IPINFO = record
    Ttl: char;
    Tos: char;
    IPFlags: char;
    OptSize: char;
    Options: ^char;
  end;

5. объявляем структурку для хранения ICMP пакета:

type
  ICMPECHO = record
    Source: longint;
    Status: longint;
    RTTime: longint;
    DataSize: Shortint;
    Reserved: Shortint;
    pData: ^variant;
    i_ipinfo: IPINFO;
  end;

6. Объявляем функции и процедуры, которые мы будем вызывать из ICMP.DLL
TIcmpCreateFile = function():integer; {$IFDEF WIN32} stdcall; {$ENDIF} 
TIcmpCloseHandle = procedure(var handle:integer);{$IFDEF WIN32} stdcall; {$ENDIF} 
TIcmpSendEcho = function(var handle:integer; endereco:DWORD; buffer:variant; tam:WORD; IP:IPINFO; ICMP:ICMPECHO; tamicmp:DWORD; tempo:DWORD):DWORD;{$IFDEF WIN32} stdcall; {$ENDIF} 

7. В Tbutton в событие Onclick вставляем следующий код:

procedure TForm1.Button1Click(Sender: TObject);
var
  wsadt: wsadata;
  icmp: icmpecho;
  HNDicmp: integer;
  hndFile: integer;
  Host: PHostEnt;
  Destino: in_addr;
  Endereco: ^DWORD;
  IP: ipinfo;
  Retorno: integer;
  dwRetorno: DWORD;
  x: integer;

  IcmpCreateFile: TIcmpCreateFile;
  IcmpCloseHandle: TIcmpCloseHandle;
  IcmpSendEcho: TIcmpSendEcho;

begin
  if (edit1.Text = '') then
    begin
      Application.MessageBox('Enter a HostName ro a IP Adress',
        'Error', MB_OK);
      exit;
    end;
  HNDicmp := LoadLibrary('ICMP.DLL');
  if (HNDicmp <> 0) then
    begin
      @IcmpCreateFile := GetProcAddress(HNDicmp, 'IcmpCreateFile');
      @IcmpCloseHandle := GetProcAddress(HNDicmp, 'IcmpCloseHandle');
      @IcmpSendEcho := GetProcAddress(HNDicmp, 'IcmpSendEcho');
      if (@IcmpCreateFile = nil) or (@IcmpCloseHandle = nil) or (@IcmpSendEcho = nil) then
        begin
          Application.MessageBox('Error getting ICMP Adress', 'Error', MB_OK);
          FreeLibrary(HNDicmp);
        end;
    end;
  Retorno := WSAStartup($0101, wsadt);

  if (Retorno <> 0) then
    begin
      Application.MessageBox('Canґt Load WinSockets', 'WSAStartup', MB_OK);
      WSACleanup();
      FreeLibrary(HNDicmp);
    end;

  Destino.S_addr := inet_addr(Pchar(Edit1.text));
  if (Destino.S_addr = 0) then
    begin
      Host := GetHostbyName(PChar(Edit1.text));
    end
  else
    begin
      Host := GetHostbyAddr(@Destino, sizeof(in_addr), AF_INET);
    end;

  if (host = nil) then
    begin
      Application.MessageBox('Host not found', 'Error', MB_OK);
      WSACleanup();
      FreeLibrary(HNDicmp);
      exit;
    end;
  memo1.Lines.Add('Pinging ' + Edit1.text);

  Endereco := @Host.h_addr_list;

  HNDFile := IcmpCreateFile();
  for x := 0 to 4 do
    begin
      Ip.Ttl := char(255);
      Ip.Tos := char(0);
      Ip.IPFlags := char(0);
      Ip.OptSize := char(0);
      Ip.Options := nil;

      dwRetorno := IcmpSendEcho(
        HNDFile,
        Endereco^,
        null,
        0,
        Ip,
        Icmp,
        sizeof(Icmp),
        DWORD(5000));
      Destino.S_addr := icmp.source;
      Memo1.Lines.Add('Ping ' + Edit1.text);
    end;

  IcmpCLoseHandle(HNDFile);
  FreeLibrary(HNDicmp);
  WSACleanup();
end;


У данного примера есть один недостаток - программа не воспримет доменное имя, только IP-адресс. Для пользователей NT не используйте функцию IcmpCloseHandle.

Это всё…..

Ну и в конце полный исходный код примера:

unit Unit1;

interface

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

type
  IPINFO = record
    Ttl: char;
    Tos: char;
    IPFlags: char;
    OptSize: char;
    Options: ^char;
  end;

type
  ICMPECHO = record
    Source: longint;
    Status: longint;
    RTTime: longint;
    DataSize: Shortint;
    Reserved: Shortint;
    pData: ^variant;
    i_ipinfo: IPINFO;
  end;

  TIcmpCreateFile = function(): integer; {$IFDEF WIN32}stdcall; {$ENDIF}
  TIcmpCloseHandle = procedure(var handle: integer); {$IFDEF WIN32}stdcall; {$ENDIF}
  TIcmpSendEcho = function(var handle: integer; endereco: DWORD; buffer: variant; tam: WORD; IP: IPINFO; ICMP: ICMPECHO; tamicmp: DWORD; tempo: DWORD): DWORD; {$IFDEF WIN32}stdcall; {$ENDIF}

type
  TForm1 = class(TForm)
    Button1: TButton;
    Button2: TButton;
    Edit1: TEdit;
    Memo1: TMemo;
    procedure Button1Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);
  private
{ Private declarations }
  public

  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.Button1Click(Sender: TObject);
var
  wsadt: wsadata;
  icmp: icmpecho;
  HNDicmp: integer;
  hndFile: integer;
  Host: PHostEnt;
  Destino: in_addr;
  Endereco: ^DWORD;
  IP: ipinfo;
  Retorno: integer;
  dwRetorno: DWORD;
  x: integer;

  IcmpCreateFile: TIcmpCreateFile;
  IcmpCloseHandle: TIcmpCloseHandle;
  IcmpSendEcho: TIcmpSendEcho;

begin
  if (edit1.Text = '') then
    begin
      Application.MessageBox('Digite um HostName ou um End. IP',
        'Error', MB_OK);
      exit;
    end;
  HNDicmp := LoadLibrary('ICMP.DLL');
  if (HNDicmp <> 0) then
    begin
      @IcmpCreateFile := GetProcAddress(HNDicmp, 'IcmpCreateFile');
      @IcmpCloseHandle := GetProcAddress(HNDicmp, 'IcmpCloseHandle');
      @IcmpSendEcho := GetProcAddress(HNDicmp, 'IcmpSendEcho');
      if (@IcmpCreateFile = nil) or (@IcmpCloseHandle = nil) or (@IcmpSendEcho = nil) then
        begin
          Application.MessageBox('Erro pegando endereзos ICMP', 'Error', MB_OK);
          FreeLibrary(HNDicmp);
        end;
    end;
  Retorno := WSAStartup($0101, wsadt);

  if (Retorno <> 0) then
    begin
      Application.MessageBox('Nгo foi possнvel carregar WinSockets', 'WSAStartup', MB_OK);
      WSACleanup();
      FreeLibrary(HNDicmp);
    end;

  Destino.S_addr := inet_addr(Pchar(Edit1.text));
  if (Destino.S_addr = 0) then
    begin
      Host := GetHostbyName(PChar(Edit1.text));
    end
  else
    begin
      Host := GetHostbyAddr(@Destino, sizeof(in_addr), AF_INET);
    end;

  if (host = nil) then
    begin
      Application.MessageBox('Host nгo encontrado', 'Error', MB_OK);
      WSACleanup();
      FreeLibrary(HNDicmp);
      exit;
    end;
  memo1.Lines.Add('Pinging ' + Edit1.text);

  Endereco := @Host.h_addr_list;

  HNDFile := IcmpCreateFile();
  for x := 0 to 4 do
    begin
      Ip.Ttl := char(255);
      Ip.Tos := char(0);
      Ip.IPFlags := char(0);
      Ip.OptSize := char(0);
      Ip.Options := nil;

      dwRetorno := IcmpSendEcho(
        HNDFile,
        Endereco^,
        null,
        0,
        Ip,
        Icmp,
        sizeof(Icmp),
        DWORD(5000));
      Destino.S_addr := icmp.source;
      Memo1.Lines.Add('Pingou ' + Edit1.text);
    end;

  IcmpCLoseHandle(HNDFile);
  FreeLibrary(HNDicmp);
  WSACleanup();
end;

end.



Взято с Исходников.ru




Как сделать плавную прокрутку?


Как сделать плавную прокрутку?



В RxLib есть компонент SecretPanel для этого..

Автор ответа: Vit
Взято с Vingrad.ru





Как сделать поиск/замену в документе?


Как сделать поиск/замену в документе?






You should use a variant because the Find.Execute method is a bit buggy. Something like this, for example:

{... }
var
  Rnge: OleVariant;
{ ... }

Rnge := Doc.Content;
Rnge.Find.Execute('old', Wrap := wdFindContinue, ReplaceWith := 'new', Replace :=
  wdReplaceAll);
{ ... }


{ ... }
  { Create the OLE Object }
WordApp := CreateOLEObject('Word.Application');
WordApp.Documents.Open(yourDocFile);
WordApp.Selection.Find.ClearFormatting;
WordApp.Selection.Find.Text := yourOldStr;
WordApp.Selection.Find.Replacement.Text := yourNewStr;
WordApp.Selection.Find.Forward := True;
WordApp.Selection.Find.Wrap := 1; {wdFindContinue}
WordApp.Selection.Find.Format := False;
WordApp.Selection.Find.MatchCase := False;
WordApp.Selection.Find.MatchWholeWord := False;
WordApp.Selection.Find.MatchWildcards := True;
WordApp.Selection.Find.MatchSoundsLike := False;
WordApp.Selection.Find.MatchAllWordForms := False;
WordApp.Selection.Find.Execute(Replace := 2); {wdReplaceAll}
{Or as alternative:  WordApp.Selection.Find.Execute(Replace := 1); for one replace}
WordApp.ActiveDocument.SaveAs(yourNewDocFile);
WordApp.Quit;
WordApp := Unassigned;
{ ... }


Взято с

Delphi Knowledge Base






Как сделать pop-up Combobox по позиции курсора в Memo?


Как сделать pop-up Combobox по позиции курсора в Memo?





unitCBoxInMemo;

interface

uses
  Windows, Classes, Controls, Graphics, Forms, StdCtrls;

type
  TFrmCboxInMemo = class(TForm)
    Button1: TButton;
    Memo1: TMemo;
    Label1: TLabel;
    ComboBox1: TComboBox;
    procedure Button1Click(Sender: TObject);
    procedure ComboBox1Exit(Sender: TObject);
    procedure ComboBox1Click(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  FrmCboxInMemo: TFrmCboxInMemo;

implementation

{$R *.DFM}

procedure TFrmCboxInMemo.Button1Click(Sender: TObject);
var
  clientPos: TPoint;
  lineHeight: Integer;
  tmpFont: TFont;
begin
  GetCaretPos(clientPos);
  {Use the following calculation of line height only if you want your combobox
  to appear below the char position you are referencing.}
  tmpFont := Canvas.Font;
  Canvas.Font := Memo1.Font;
  lineHeight := Canvas.TextHeight('Xy');
  Canvas.Font := tmpFont;
  with ComboBox1 do
  begin
    {Adjustment of Top by lineHeight only necessary if combobox is to appear below line.}
    Top := clientPos.Y + Memo1.Top + lineHeight;
    Left := clientPos.X + Memo1.Left;
    Visible := true;
    SetFocus;
  end;
end;

procedure TFrmCboxInMemo.ComboBox1Exit(Sender: TObject);
begin
  ComboBox1.Visible := false;
end;

procedure TFrmCboxInMemo.ComboBox1Click(Sender: TObject);
begin
  ComboBox1.Visible := false;
end;

end.

Взято с

Delphi Knowledge Base






Как сделать Pop-Up меню при щелчке иконке в Sys tray?


Как сделать Pop-Up меню при щелчке иконке в Sys tray?




Многие программы показывают Pop-Up меню при щелчке на их иконке, помещенной на Tray, как этого добиться ?

Вы должны обрабатывать сообщение, указанное вами при добавлении иконки на Tray. При значении (UINT)lParam, равном WM_RBUTTONDOWN (это обычно дял Pop-Up меню по правой кнопке), или любому другому необходимому вам, вы должны вызовом функции GetCursorPos() получить позицию курсора в момент события (вряд ли пользователь успеет убрать мышь за время обработки сообщения, особенно если он ожидает меню), получить вескриптор Pop-Up меню одним из многих способов (LoadMenu(), GetSubMenu(), CreateMenu(), и т.д.) и выполнить следующий код:

SetForegroundWindow(hWnd);
TrackPopupMenuEx(hMenu,TPM_HORIZONTAL|TPM_LEFTALIGN,x, y,hWnd, NULL);
DestroyMenu(hMenu);
PostMessage(hWnd,WM_USER,0,0);

где hWnd - дескриптор окна, которое будет обрабатывать команду меню,
hMenu - дескриптор меню,
x и y - позиция курсора.

Для подробностей смотрите Win32 SDK Help по функции TrackPopupMenuEx.

Взято из FAQ:






Как сделать предпросмотр?


Как сделать предпросмотр?





unitprintpreview;

interface

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

type
  TForm1 = class(TForm)
    Panel1: TPanel;
    Panel2: TPanel;
    PreviewPaintbox: TPaintBox;
    Label1: TLabel;
    Label2: TLabel;
    LeftMarginEdit: TEdit;
    TopMarginEdit: TEdit;
    Label3: TLabel;
    Label4: TLabel;
    RightMarginEdit: TEdit;
    Label5: TLabel;
    BottomMarginEdit: TEdit;
    ApplyMarginsButton: TButton;
    OrientationRGroup: TRadioGroup;
    Label6: TLabel;
    ZoomEdit: TEdit;
    ZoomUpDown: TUpDown;
    procedure LeftMarginEditKeyPress(Sender: TObject; var Key: Char);
    procedure FormCreate(Sender: TObject);
    procedure PreviewPaintboxPaint(Sender: TObject);
    procedure ApplyMarginsButtonClick(Sender: TObject);
  private
    { Private declarations }
    PreviewText: string;
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

uses printers;

{$R *.DFM}

procedure TForm1.LeftMarginEditKeyPress(Sender: TObject; var Key: Char);
begin
  if not (Key in ['0'..'9', #9, DecimalSeparator]) then
    Key := #0;
end;

procedure TForm1.FormCreate(Sender: TObject);
var
  S: string;

  procedure loadpreviewtext;
  var
    sl: TStringList;
  begin
    sl := TStringList.Create;
    try
      sl.Loadfromfile(Extractfilepath(application.exename) + 'printpreview.pas');
      PreviewText := sl.Text;
    finally
      sl.free
    end;
  end;

begin
  {Initialize the margin edits with a margin of 0.75 inch}
  S := FormatFloat('0.00', 0.75);
  LeftMarginEdit.Text := S;
  TopMarginEdit.Text := S;
  RightMarginEdit.Text := S;
  BottomMarginEdit.Text := S;
  {Initialize the orientation radio group}
  if Printer.Orientation = poPortrait then
    OrientationRGroup.ItemIndex := 0
  else
    OrientationRGroup.ItemIndex := 1;
  {load test text for display}
  LoadPreviewtext;
end;

procedure TForm1.PreviewPaintboxPaint(Sender: TObject);
var
  pagewidth, pageheight: Double; {printer page dimension in inch}
  printerResX, printerResY: Integer; {printer resolution in dots/inch}
  minmarginX, minmarginY: Double; {nonprintable margin in inch}
  outputarea: TRect; {print area in 1/1000 inches}
  scale: Double; {conversion factor, pixels per 1/1000 inch}

  procedure InitPrintSettings;
    function GetMargin(S: string; inX: Boolean): Double;
    begin
      Result := StrToFloat(S);
      if InX then
      begin
        if Result < minmarginX then
          Result := minmarginX;
      end
      else
      begin
        if Result < minmarginY then
          Result := minmarginY;
      end;
    end;
  begin
    printerResX := GetDeviceCaps(printer.handle, LOGPIXELSX);
    printerResY := GetDeviceCaps(printer.handle, LOGPIXELSY);
    pagewidth := GetDeviceCaps(printer.handle, PHYSICALWIDTH) / printerResX;
    pageheight := GetDeviceCaps(printer.handle, PHYSICALHEIGHT) / printerResY;
    minmarginX := GetDeviceCaps(printer.handle, PHYSICALOFFSETX) / printerResX;
    minmarginY := GetDeviceCaps(printer.handle, PHYSICALOFFSETY) / printerResY;
    outputarea.Left := Round(GetMargin(LeftMarginEdit.Text, true) * 1000);
    outputarea.Top := Round(GetMargin(TopMarginEdit.Text, false) * 1000);
    outputarea.Right := Round((pagewidth - GetMargin(RightMarginEdit.Text, true)) *
      1000);
    outputarea.Bottom := Round((pageheight - GetMargin(BottomMarginEdit.Text, false))
      * 1000);
  end;

  procedure ScaleCanvas(Canvas: TCanvas; widthavail, heightavail: Integer);
  var
    needpixelswidth, needpixelsheight: Integer;
    {dimensions of preview at current zoom factor in pixels}
    orgpixels: TPoint;
    {origin of preview in pixels}
  begin
    {set up a coordinate system for the canvas that uses 1/1000 inch as unit,
    honors the zoom factor and maintains the MM_TEXT orientation of the
    coordinate axis (origin in top left corner, positive Y axis points down}
    scale := Screen.PixelsPerInch / 1000;
    {Apply zoom factor}
    scale := scale * StrToInt(Zoomedit.text) / 100;
    {figure out size of preview}
    needpixelswidth := Round(pagewidth * 1000 * scale);
    needpixelsheight := Round(pageheight * 1000 * scale);
    if needpixelswidth >= widthavail then
      orgpixels.X := 0
    else
      orgpixels.X := (widthavail - needpixelswidth) div 2;
    if needpixelsheight >= heightavail then
      orgpixels.Y := 0
    else
      orgpixels.Y := (heightavail - needpixelsheight) div 2;
    {change mapping mode to MM_ISOTROPIC}
    SetMapMode(canvas.handle, MM_ISOTROPIC);
    {move viewport origin to orgpixels}
    SetViewportOrgEx(canvas.handle, orgpixels.x, orgpixels.y, nil);
    {scale the window}
    SetViewportExtEx(canvas.handle, Round(1000 * scale), Round(1000 * scale), nil);
    SetWindowExtEx(canvas.handle, 1000, 1000, nil);
  end;

begin
  if OrientationRGroup.ItemIndex = 0 then
    Printer.Orientation := poPortrait
  else
    Printer.Orientation := poLandscape;
  InitPrintsettings;
  with Sender as TPaintBox do
  begin
    ScaleCanvas(Canvas, ClientWidth, ClientHeight);
    {specify font height in 1/1000 inch}
    Canvas.Font.Height := Round(font.height / font.pixelsperinch * 1000);
    {paint page white}
    Canvas.Brush.Color := clWindow;
    Canvas.Brush.Style := bsSolid;
    Canvas.FillRect(Rect(0, 0, Round(pagewidth * 1000), Round(pageheight * 1000)));
    {draw the text}
    DrawText(canvas.handle, PChar(PreviewText), Length(PreviewText),
      outputarea, DT_WORDBREAK or DT_LEFT);
    {Draw thin gray lines to mark borders}
    Canvas.Pen.Color := clGray;
    Canvas.Pen.Style := psSolid;
    Canvas.Pen.Width := 10;
    with Canvas do
    begin
      MoveTo(outputarea.left - 100, outputarea.top);
      LineTo(outputarea.right + 100, outputarea.top);
      MoveTo(outputarea.left - 100, outputarea.bottom);
      LineTo(outputarea.right + 100, outputarea.bottom);
      MoveTo(outputarea.left, outputarea.top - 100);
      LineTo(outputarea.left, outputarea.bottom + 100);
      MoveTo(outputarea.right, outputarea.top - 100);
      LineTo(outputarea.right, outputarea.bottom + 100);
    end;
  end;
end;

procedure TForm1.ApplyMarginsButtonClick(Sender: TObject);
begin
  PreviewPaintbox.Invalidate;
end;

end.



object Form1: TForm1
  Left = 192
  Top = 128
  Width = 696
  Height = 480
  Caption = 'Form1'
  Color = clBtnFace
  Font.Charset = ANSI_CHARSET
  Font.Color = clWindowText
  Font.Height = -15
  Font.Name = 'Arial'
  Font.Style = []
  OldCreateOrder = False
  OnCreate = FormCreate
  PixelsPerInch = 120
  TextHeight = 17
  object Panel1: TPanel
    Left = 503
    Top = 0
    Width = 185
    Height = 453
    Align = alRight
    TabOrder = 0
    object Label1: TLabel
      Left = 8
      Top = 8
      Width = 92
      Height = 17
      Caption = 'Margins (inch)'
    end
    object Label2: TLabel
      Left = 8
      Top = 45
      Width = 24
      Height = 17
      Caption = 'Left'
    end
    object Label3: TLabel
      Left = 8
      Top = 77
      Width = 25
      Height = 17
      Caption = 'Top'
    end
    object Label4: TLabel
      Left = 8
      Top = 109
      Width = 34
      Height = 17
      Caption = 'Right'
    end
    object Label5: TLabel
      Left = 8
      Top = 141
      Width = 47
      Height = 17
      Caption = 'Bottom'
    end
    object Label6: TLabel
      Left = 8
      Top = 261
      Width = 64
      Height = 17
      Caption = 'Zoom (%)'
    end
    object LeftMarginEdit: TEdit
      Left = 60
      Top = 40
      Width = 100
      Height = 25
      TabOrder = 0
      OnKeyPress = LeftMarginEditKeyPress
    end
    object TopMarginEdit: TEdit
      Left = 60
      Top = 72
      Width = 100
      Height = 25
      TabOrder = 1
      OnKeyPress = LeftMarginEditKeyPress
    end
    object RightMarginEdit: TEdit
      Left = 60
      Top = 104
      Width = 100
      Height = 25
      TabOrder = 2
      OnKeyPress = LeftMarginEditKeyPress
    end
    object BottomMarginEdit: TEdit
      Left = 60
      Top = 136
      Width = 100
      Height = 25
      TabOrder = 3
      OnKeyPress = LeftMarginEditKeyPress
    end
    object ApplyMarginsButton: TButton
      Left = 24
      Top = 304
      Width = 137
      Height = 25
      Caption = 'Apply'
      TabOrder = 4
      OnClick = ApplyMarginsButtonClick
    end
    object OrientationRGroup: TRadioGroup
      Left = 8
      Top = 176
      Width = 161
      Height = 65
      Caption = 'Orientation'
      Items.Strings = (
        'Portrait'
        'Landscape')
      TabOrder = 5
    end
    object ZoomEdit: TEdit
      Left = 80
      Top = 256
      Width = 40
      Height = 25
      TabOrder = 6
      Text = '50'
    end
    object ZoomUpDown: TUpDown
      Left = 120
      Top = 256
      Width = 17
      Height = 25
      Associate = ZoomEdit
      Min = 0
      Increment = 10
      Position = 50
      TabOrder = 7
      Wrap = False
    end
  end
  object Panel2: TPanel
    Left = 0
    Top = 0
    Width = 503
    Height = 453
    Align = alClient
    Font.Charset = ANSI_CHARSET
    Font.Color = clWindowText
    Font.Height = -17
    Font.Name = 'Times New Roman'
    Font.Style = []
    ParentFont = False
    TabOrder = 1
    object PreviewPaintbox: TPaintBox
      Left = 1
      Top = 1
      Width = 501
      Height = 451
      Align = alClient
      OnPaint = PreviewPaintboxPaint
    end
  end
end

Взято с

Delphi Knowledge Base






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


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



В Windows2000 есть для этого ф-я SetLayeredWindowAttributes, вот пример её использования:

unit Win2k;
interface
uses Graphics, Windows;

function SetLayeredWindowAttributes(
hwnd : HWND; // handle to the layered window
crKey : TColor; // specifies the color key
bAlpha : byte; // value for the blend function
dwFlags : DWORD // action
): BOOL; stdcall;

function SetLayeredWindowAttributes; external 'user32.dll';
implementation

end.

program WinLayer;

uses
Windows, SysUtils,  
Win2k in 'Win2k.pas';  

const
WS_EX_LAYERED= $80000;  
LWA_COLORKEY = 1;  
LWA_ALPHA = 2;  

var
Hndl : THandle;  
Transp : Byte;  

begin
Writeln('Windows2000 Layer <- build by AK ->');  
Writeln(' Usage: WINLAYER.EXE [window name] [Transp (0-255)]');  
Writeln(' Example: WINLAYER "Calculator" 200');  
Writeln;  
if ParamCount <> 2 then exit;  
Hndl := FindWindow(nil, PChar(ParamStr(1)));  
Transp := StrToIntDef(ParamStr(2), 128);  
if SetWindowLong(Hndl, GWL_EXSTYLE, GetWindowLong(Hndl, GWL_EXSTYLE) or WS_EX_LAYERED) = 0 then  
Writeln('Error !');  
 
if not SetLayeredWindowAttributes(Hndl, 0, Transp, LWA_ALPHA) then  
// ^^^ степень прозрачности  
// 0 - полная прозрачность  
// 255 - полная непрозрачность  
Writeln('Error !');  
end.

Взято с Исходников.ru



Как сделать пункты меню с картинками?


Как сделать пункты меню с картинками?



Следующий код показывает, как добавить картинку в виде объекта TImage в объект TMenuItem.

var 
   hHandle: THandle; 
   x: integer; 
   // visual controls: 
   hMenu: TMenuItem; 
   Image1: TImage; 

... 

  x:= 10; // десятый пункт меню
  hHandle := GetMenuItemID(hMenu.handle, x); 
  ModifyMenu(hMenu.handle, hHandle, MF_BYCOMMAND Or MF_BITMAP, hHandle, 
             PChar(Image1.picture.bitmap.handle)) 



Взято с Исходников.ru



Как сделать различные подсказки для каждой ячейки в StringGrid?


Как сделать различные подсказки для каждой ячейки в StringGrid?



Следующий пример демонстрирует отслеживаение движения мышки в компоненте TStringGrid. Если мышка переместится на другую ячейку в гриде, то будет показано новое окно подсказки с номером колонки и строки данной ячейки:

type
  TForm1 = class(TForm)
    StringGrid1: TStringGrid;
    procedure StringGrid1MouseMove(Sender: TObject;
      Shift: TShiftState; X, Y: Integer);
    procedure FormCreate(Sender: TObject);
  private
    { Private declarations }
      Col : integer;
      Row : integer;
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.FormCreate(Sender: TObject);
begin
  StringGrid1.Hint := '0 0';
  StringGrid1.ShowHint := True;
end;

procedure TForm1.StringGrid1MouseMove(Sender: TObject;
Shift: TShiftState; X, Y: Integer);
var
  r : integer;
  c : integer;
begin
  StringGrid1.MouseToCell(X, Y, C, R);
  if ((Row <> r) or
      (Col <> c)) then begin
    Row := r;
    Col := c;
    Application.CancelHint;
    StringGrid1.Hint := IntToStr(r) + #32 + IntToStr(c);
  end;
end;

Взято с Исходников.ru



Как сделать регулятор громкости?


Как сделать регулятор громкости?



ВОТ нашел в Интернете:

Эта программа увеличивает громкость выбранного канала на 1000.

uses MMSystem;

procedure TForm1.Button1Click(Sender: TObject);
var
  vol: longint;
  LVol, RVol: integer;
begin
  AuxGetVolume(ListBox1.ItemIndex, @Vol);
  LVol := Vol shr 16;
  if LVol < MaxWord - 1000
    then LVol := LVol + 1000
    else LVol := MaxWord;
  RVol := (Vol shl 16) shr 16;
  if RVol < MaxWord - 1000
    then RVol := RVol + 1000
    else RVol := MaxWord;
  AuxSetVolume(ListBox1.ItemIndex, LVol shl 16 + RVol);
end;

procedure TForm1.FormCreate(Sender: TObject);
var
  i: integer;
  cap: TAuxCaps;
begin
  for i := 0 to auxGetNumDevs - 1 do begin
    auxGetDevCaps(i, Addr(cap), SizeOf(cap));
    ListBox1.Items.Add(cap.szPname)
  end;
end; 

Второй вариант:

uses mmsystem;

function GetWaveVolume: DWord;
var
Woc : TWAVEOUTCAPS;  
Volume : DWord;  
begin
result:=0;  
if WaveOutGetDevCaps(WAVE_MAPPER, @Woc, sizeof(Woc)) = MMSYSERR_NOERROR then  
if Woc.dwSupport and WAVECAPS_VOLUME = WAVECAPS_VOLUME then  
begin  
WaveOutGetVolume(WAVE_MAPPER, @Volume);  
Result := Volume;  
end;  
end;

procedure SetWaveVolume(const AVolume: DWord);
var Woc : TWAVEOUTCAPS;  
begin
if WaveOutGetDevCaps(WAVE_MAPPER, @Woc, sizeof(Woc)) = MMSYSERR_NOERROR then  
if Woc.dwSupport and WAVECAPS_VOLUME = WAVECAPS_VOLUME then WaveOutSetVolume(WAVE_MAPPER, AVolume);  
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
Beep;  
end;

procedure TForm1.Button2Click(Sender: TObject);
var
LeftVolume: Word;  
RightVolume: Word;  
begin
LeftVolume := StrToInt(Edit1.Text);  
RightVolume := StrToInt(Edit2.Text);  
SetWaveVolume(MakeLong(LeftVolume, RightVolume));  
end;

procedure TForm1.Button3Click(Sender: TObject);
begin
Caption := IntToStr(GetWaveVolume);  
end;

Автор MMM
Взято с Vingrad.ru




Как сделать roll-up форму?


Как сделать roll-up форму?





unittestmain;

interface

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

type
  TForm1 = class(TForm)
    procedure FormCreate(Sender: TObject);
  private
    { Private declarations }
    FOldHeight: Integer;
    procedure WMNCRButtonDown(var Msg: TWMNCRButtonDown);
      message WM_NCRBUTTONDOWN;
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.FormCreate(Sender: TObject);
begin
  FOldHeight := ClientHeight;
end;

procedure TForm1.WMNCRButtonDown(var Msg: TWMNCRButtonDown);
var
  I: Integer;
begin
  if (Msg.HitTest = HTCAPTION) then
    if (ClientHeight = 0) then
    begin
      I := 0;
      while (I < FOldHeight) do
      begin
        I := I + 40;
        if (I > FOldHeight) then
          I := FOldHeight;
        ClientHeight := I;
        Application.ProcessMessages;
      end;
    end
    else
    begin
      FOldHeight := ClientHeight;
      I := ClientHeight;
      while (I > 0) do
      begin
        I := I - 40;
        if (I < 0) then
          I := 0;
        ClientHeight := I;
        Application.ProcessMessages;
      end;
    end;
end;

end.

First, by way of synopsis, the roll-up/down occurs in response to a WM_NCRBUTTONDOWN message firing off and the WMNCRButtonDown procedure handling the message, telling the window to roll up/down depending upon the height of the client area. WM_NCRBUTTONDOWN fires whenever the right mouse button is clicked in a "non-client" area, such as a border, menu or, for our purposes, the caption bar of a form. (The client area of a window is the area within the border where most of the interesting activity usually occurs. In general, the Windows API restricts application code to drawing only within the client area.)

Delphi encapsulates the WM_NCRBUTTONDOWN in a TWMNCRButtonDown type, which is actually an assignment from a TWMNCHitMessage type that has the following structure:

type
  TWMNCHitMessage = record
    Msg: Cardinal;
    HitTest: Integer;
    XCursor: SmallInt;
    YCursor: SmallInt;
    Result: Longint;
  end;

It's easy to create message wrappers in Delphi to deal with messages that aren't handled by an object by default. Since a right-click on the title bar of a form isn't handled by default, I had to create a wrapper. The procedure procedure WMNCRButtonDown(var Msg : TWMNCRButtonDown); message WM_NCRBUTTONDOWN; is the wrapper I created. All that goes on in the procedure is the following:

In order to make this work, I had to create a variable called FOldHeight and set its value at FormCreate whenever the form was to be rolled up. FOldHeight is used as a place for the form to remember what size it was before it was re-sized to 0. When a form is to be rolled up, FOldHeight is immediately set to the current ClientHeight, which means you can interactively set the form's size, and the function will always return the form's ClientHeight to what it was before you rolled it up.

So what use is this? Well, sometimes I don't want to iconize a window; I just want to get it out of the way so I can see what's underneath. Having the capability to roll a form up to its title bar makes it a lot easier to see underneath a window without iconizing it, then having to Alt-tab back to it. (If you are familiar with the Macintosh platform, the System 7.5 environment offers a very similar facility called a "window shade," and makes a roll-up sound when the shade goes up.)

Взято с

Delphi Knowledge Base






Как сделать список всех пользователей BDE?


Как сделать список всех пользователей BDE?



With Paradox:

procedureBDEGetPDXUserList(AList: TStrings);
var
  hCur: hDBICur;
  UDesc: USERDesc;
begin
  AList.Clear;
  Check(DBIOpenUserList(hCur));
  try
    while DBIGetNextRecord(hCur, dbiNOLOCK, @UDesc, nil) <> DBIERR_EOF do
    begin
      AList.Add(StrPas(UDesc.szUserName));
    end;
  finally
    DBICloseCursor(hCur);
  end;
end;



Взято с

Delphi Knowledge Base




Как сделать стандартные цвета в Delphi светлее или темнее


Как сделать стандартные цвета в Delphi светлее или темнее



Автор: Den Bedard

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

Итак, немного теории:
Каждый из трёх основных цветов (Красный,Зелёный,Синий) могут иметь значение от 0 до 255, соответственно скомбинировав их мы можем получить 16,777,216 возможных цветов. Визуально это можно предствить как три оси куба, в котором направления x, y и z отвечают за цвета красный, зелёный и синий. В сочетании эти направления дают точку в кубе, представляющую один цвет из 16 миллионов. Точка куба, в которой значение равняется 0 (0,0,0) соответствует чёрному цвету, значение (255,255,255) - белому цвету, (255,0,0) - чисто красному, и т.д.

Если визуально провести линию между каким-либо цветом (r,g,b) и белым цветом (255,255,255), то получится, что на этой линии будут лежать все значения данного цвета (r,g,b). Если мы будем двигаться по линии в сторону белого цвета, то яркость будет увеличиваться до тех пор пока не получим чисто белый цвет.

То же самое можно сделать и для уменьшения яркости цвета. Достаточно провести линию из цвета (r,g,b) в чёрный (0,0,0). То есть при движении по линии к чёрному цвету мы будем уменьшать яркость до тех пор, пока не получим чёрный цвет.

Функция "Darker" возвращает новое значение цвета, которое будет на сколько-то процентов темнее. Естевственно, что при 100% мы получим чёрный цвет.
Функция "Lighter" возвращает цвет, который светлее на сколько-то процентов исходного. 100% - белый цвет.

Функции Darker и Lighter требуют 2 параметра и используются примерно так:
Panel1.Color := Darker(clBlue,20);
Получется панель цветов, которая на 20% темнее обычного синего цвета.

Теперь давайте посмотрим, как выглядят внутри наши функции:

function Darker(Color:TColor; Percent:Byte):TColor; 
var 
  r,g,b:Byte; 
begin 
Color:=ColorToRGB(Color); 
r:=GetRValue(Color); 
g:=GetGValue(Color); 
b:=GetBValue(Color); 
r:=r-muldiv(r,Percent,100);  //процент% уменьшения яркости
g:=g-muldiv(g,Percent,100); 
b:=b-muldiv(b,Percent,100); 
result:=RGB(r,g,b); 
end; 

function Lighter(Color:TColor; Percent:Byte):TColor; 
var 
  r,g,b:Byte; 
begin 
Color:=ColorToRGB(Color); 
r:=GetRValue(Color); 
g:=GetGValue(Color); 
b:=GetBValue(Color); 
r:=r+muldiv(255-r,Percent,100); //процент% увеличения яркости
g:=g+muldiv(255-g,Percent,100); 
b:=b+muldiv(255-b,Percent,100); 
result:=RGB(r,g,b); 
end; 

Так же я добавил некоторые функции, в которых уже добавлены стандартные значения процентов. Это для тех, кому некогда задумываться над процентами :)

Panel1.Color := Light(clBlue); 
Panel1.Color := SlightlyDark(clRed); 
Panel1.Color := VeryLight(clMagenta); 
etc. 

function SlightlyDark(Color:TColor):TColor; 
begin 
  Result := Darker(Color,25); 
end; 

function Dark(Color:TColor):TColor; 
begin 
  Result := Darker(Color,50); 
end; 

function VeryDark(Color:TColor):TColor; 
begin 
  Result := Darker(Color,75); 
end; 

function SlightlyLight(Color:TColor):TColor; 
begin 
  Result := Lighter(Color,25); 
end; 

function Light(Color:TColor):TColor; 
begin 
  Result := Lighter(Color,50); 
end; 

function VeryLight(Color:TColor):TColor; 
begin 
  Result := Lighter(Color,75); 
end;


Взято с Исходников.ru




Как сделать subform?


Как сделать subform?





Those programmers who use the Win API in their programs know that Win32 allows you to insert one dialog box into another one and you'll can deal with subdialog's controls as them were in parent dialog. The good example of it is PropertySheet. I don't know why Borland hided this ability from us and why didn't it insert 'subforming' ability in TForm control. Here I can tell how to use a form as control (subform) in other one and how to create subform controls. It will work in D2, D3 and may be D4 (unfortunatelly, I have not it and can't check). The next steps shows how to make subform component:

First, we have to make the form to be a child. For this we need to override the method CreateParams.

type
TSubForm = class(TForm)
  protected
    procedure CreateParams(var Params: TCreateParams); override;
  end;

procedure TSubForm.CreateParams(var Params: TCreateParams);
begin
  inherited CreateParams(Params);
  Params.Style := WS_CHILD or WS_DLGFRAME or WS_VISIBLE or DS_CONTROL;
end;

It's enough if you will not register this control into Delphi IDE. Now you can insert TSubForm control into a form at run time as shown below:

{ ... }
with TSubForm.Create(YourForm) do
begin
  Parent := YourForm;
  Left := 8;
  Top := 8;
end;
{ ... }

Unfortunately, it's not enough if you want insert this control into Delphi IDE. You have to do next two important things for it. Override TSubForm's destructor for prevent Delphi from break when subform will be deleted at design time (by user or Delphi). It can be fixed with next code:

destructor TSubForm.Destroy;
begin
  SetDesigning(False);
  inherited Destroy;
end;

Now your subform (sure inserted into form) looks like gray rectangle. The good deal is to make subform to show it's components at design time:

constructor TSubForm.Create(aOwner: TComponent);
begin
  inherited Create(aOwner);
  if csDesigning in ComponentState then
    ReadComponentRes(Self.ClassName, Self);
end;

Now you have a nice subform control which can be used at run time or design time. You can do it with any form which you wish see as subform.

Note: You can define events handler for subform and them will work. In case subform already has some event handler defined and you try redefine it, only subform's event handler will work at run time!

Full source code of the subform control:

unit SubForm;

interface

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

type
  TSubForm = class(TForm)
  protected
    procedure CreateParams(var Params: TCreateParams); override;
  public
    constructor Create(aOwner: TComponent); override;
    destructor Destroy; override;
  end;

procedure Register;

implementation

{$R *.DFM}

procedure Register;
begin
  RegisterComponents('SubForms', [TSubForm]);
end;

constructor TSubForm.Create(aOwner: TComponent);
begin
  inherited Create(aOwner);
  if (csDesigning in ComponentState) then
    ReadComponentRes(Self.ClassName, Self);
end;

destructor TSubForm.Destroy;
begin
  SetDesigning(False);
  inherited Destroy;
end;

procedure TSubForm.CreateParams(var Params: TCreateParams);
begin
  inherited CreateParams(Params);
  Params.Style := WS_CHILD or WS_DLGFRAME or WS_VISIBLE or DS_CONTROL;
end;

end.


Взято с

Delphi Knowledge Base






Как сделать свои собственные сообщения при компилляции?


Как сделать свои собственные сообщения при компилляции?




Формат команды:
{$MESSAGE HINT|WARN|ERROR|FATAL 'text string' }

Например, добавление следующих строк приведёт к появлению:

{$MESSAGE 'Появился новый hint!'}
{$MESSAGE Hint 'И это тоже hint!'}
{$MESSAGE Warn 'А это уже Warning'}
{$MESSAGE Error 'Эта строка вызовет ошибку компиляции!'}
{$MESSAGE Fatal 'А это фатальная ошибка компиляции!'}

Пример:

destructor TumbSelectionTempTable.Destroy;
begin
  // Clear the temp tables.
{$MESSAGE Warn ' - remember to free all allocated objects'}
  ClearAllOuterWorldFold;
  if FSubjectsTempTableCreated then
    DropTempTable(FTableName);

  FOuterWorldsFolded.Free;
  FQuery.Free;
  inherited;
end;

Работает только в Дельфи 6/7



Как сделать текстовый список всех доступных свойств перечисляемого типа?


Как сделать текстовый список всех доступных свойств перечисляемого типа?





I need to get a list of strings (like a StringList) with the possible values for a TBrushStyle property (bsSolid, bsClear, bsHorizontal, for example). I want to build a ComboBox with this options. How can I set the property Items of my ComboBox directly with all the values from the enumerated type TBrushStyle? My ComboBox will be alike the Property Editor for this type.

You can use runtime type information (RTTI) to do that. Below is an example:

uses
  {...}, TypInfo

procedure BrushStylesAsStrings(AList: TStrings);
var
  a: integer;
  pInfo: PTypeInfo;
  pEnum: PTypeData;
begin
  AList.Clear;
  pInfo := PTypeInfo(TypeInfo(TBrushStyle));
  pEnum := GetTypeData(pInfo);
  with pEnum^ do
  begin
    for a := MinValue to MaxValue do
      AList.Add(GetEnumName(pInfo, a));
  end;
end; 



Tip by Sen



Взято из






Как сделать ToolBar как в среде Delphi с возможностью вытаскивания кнопок?


Как сделать ToolBar как в среде Delphi с возможностью вытаскивания кнопок?



Смотри пример $Delphi\Demos\Docking\

Автор SmaLL
Взято с Vingrad.ru




Как сделать Twist / Swirl эффект


Как сделать Twist / Swirl эффект





{... }
try
  try
    begin
      b := TBitmap.Create;
      tBufr := TBitmap.Create;
      CopyMe(b, Image1.Picture.Graphic); {copy image to b}
      Twist(100);
    end;
  finally
    begin
      b.Free;
      tBufr.Free;
    end;
  end;
except
  raise ESomeErrorWarning.Create('Kaboom!');
end;
{ ... }


Hope this is what you were looking for:


{A procedure to copy a graphic to a bitmap}

procedure TForm1.CopyMe(tobmp: TBitmap; frbmp: TGraphic);
begin
  tobmp.PixelFormat := pf24bit;
  tobmp.Width := frbmp.Width;
  tobmp.Height := frbmp.Height;
  tobmp.Canvas.Draw(0, 0, frbmp);
end;

procedure TForm1.Twist(Amount: integer);
var
  fxmid, fymid: Single;
  txmid, tymid: Single;
  fx, fy: Single;
  tx2, ty2: Single;
  r: Single;
  theta: Single;
  ifx, ify: Integer;
  dx, dy: Single;
  K: integer;
  Offset: Single;
  ty, tx: Integer;
  weight_x, weight_y: array[0..1] of Single;
  weight: Single;
  new_red, new_green: Integer;
  new_blue: Integer;
  total_red, total_green: Single;
  total_blue: Single;
  ix, iy: Integer;
  sli, slo: pRGBArray;

  function ArcTan2(xt, yt: Single): Single;
  begin
    if xt = 0 then
      if yt > 0 then
        Result := Pi / 2
      else
        Result := -(Pi / 2)
    else
    begin
      Result := ArcTan(yt / xt);
      if xt < 0 then
        Result := Pi + ArcTan(yt / xt);
    end;
  end;

begin
  Screen.Cursor := crHourGlass;
  CopyMe(tBufr, b);
  K := Amount; {Adjust this for 'amount' of twist}
  Offset := -(Pi / 2);
  dx := b.Width - 1;
  dy := b.Height - 1;
  r := Sqrt(dx * dx + dy * dy);
  tx2 := r;
  ty2 := r;
  txmid := (b.Width - 1) / 2; {Adjust these to move center of rotation}
  tymid := (b.Height - 1) / 2; {Adjust these to move}
  fxmid := (b.Width - 1) / 2;
  fymid := (b.Height - 1) / 2;
  if tx2 >= b.Width then
    tx2 := b.Width - 1;
  if ty2 >= b.Height then
    ty2 := b.Height - 1;
  for ty := 0 to Round(ty2) do
  begin
    for tx := 0 to Round(tx2) do
    begin
      dx := tx - txmid;
      dy := ty - tymid;
      r := Sqrt(dx * dx + dy * dy);
      if r = 0 then
      begin
        fx := 0;
        fy := 0;
      end
      else
      begin
        theta := ArcTan2(dx, dy) - r / K - Offset;
        fx := r * Cos(theta);
        fy := r * Sin(theta);
      end;
      fx := fx + fxmid;
      fy := fy + fymid;
      ify := Trunc(fy);
      ifx := Trunc(fx);
      {Calculate the weights}
      if fy >= 0 then
      begin
        weight_y[1] := fy - ify;
        weight_y[0] := 1 - weight_y[1];
      end
      else
      begin
        weight_y[0] := -(fy - ify);
        weight_y[1] := 1 - weight_y[0];
      end;
      if fx >= 0 then
      begin
        weight_x[1] := fx - ifx;
        weight_x[0] := 1 - weight_x[1];
      end
      else
      begin
        weight_x[0] := -(fx - ifx);
        Weight_x[1] := 1 - weight_x[0];
      end;
      if ifx < 0 then
        ifx := b.Width - 1 - (-ifx mod b.Width)
      else if ifx > b.Width - 1 then
        ifx := ifx mod b.Width;
      if ify < 0 then
        ify := b.Height - 1 - (-ify mod b.Height)
      else if ify > b.Height - 1 then
        ify := ify mod b.Height;
      total_red := 0.0;
      total_green := 0.0;
      total_blue := 0.0;
      for ix := 0 to 1 do
      begin
        for iy := 0 to 1 do
        begin
          if ify + iy < b.Height then
            sli := tBufr.Scanline[ify + iy]
          else
            sli := tBufr.ScanLine[b.Height - ify - iy];
          if ifx + ix < b.Width then
          begin
            new_red := sli[ifx + ix].rgbtRed;
            new_green := sli[ifx + ix].rgbtGreen;
            new_blue := sli[ifx + ix].rgbtBlue;
          end
          else
          begin
            new_red := sli[b.Width - ifx - ix].rgbtRed;
            new_green := sli[b.Width - ifx - ix].rgbtGreen;
            new_blue := sli[b.Width - ifx - ix].rgbtBlue;
          end;
          weight := weight_x[ix] * weight_y[iy];
          total_red := total_red + new_red * weight;
          total_green := total_green + new_green * weight;
          total_blue := total_blue + new_blue * weight;
        end;
      end;
      slo := b.ScanLine[ty];
      slo[tx].rgbtRed := Round(total_red);
      slo[tx].rgbtGreen := Round(total_green);
      slo[tx].rgbtBlue := Round(total_blue);
    end;
  end;
  Image1.Picture.Assign(b);
  Screen.Cursor := crDefault;
end;

Взято с

Delphi Knowledge Base






Как сделать виртуальный диск?


Как сделать виртуальный диск?





{... }
if DefineDosDevice(DDD_RAW_TARGET_PATH, 'P:', 'F:\Backup\Music\Modules') then
  ShowMessage('Drive was created successfully')
else
  ShowMessage('Error creating drive");
    { ... }


Взято с

Delphi Knowledge Base






Как сделать выделение "резиновым прямоугольником"?


Как сделать выделение "резиновым прямоугольником"?



Cтатья Даниила Карапетяна ( )

как реализовать выделение "резиновым прямоугольником". Иными словами, когда пользоватьль нажимает на левую кнопку мыши и сдвигает ее, на экране появляется прямоугольник, изменяющий размеры при движении мыши, причем все объекты, попавшие в этот прямоугольник выделяются.
В качестве объекта я взял Label, меняющий цвет в зависимости от того, выделен он или нет. При нажатии мышью на форме в FirstPoint кладутся координата курсора. При дальнейшем движении мыши координаты прямоугольника будут высчитываться по FirstPoint и текущим координатам курсора. Причем, чтобы программа нормально отрабатывала случай, когда высота или ширина прямоугольника отрицательная (это произойдет, если увести мышь левее или выше начальной точки), создана процедура NormalRect. NormalRect устанавливает координаты прямоугольника sel по координатам двух протвоположенных углов прямоугольника, вне зависимости от порядка. DrawRect рисует на форме прямоугольник, использую режим XOR. Благодаря этому режиму, чтобы стереть такой прямоугольник, достаточно нарисовать его повторно.
Скачать необходимые для компиляции файлы проекта можно на program.dax.ru/subscribe/.

uses stdctrls;
var
Selecting: boolean = false;  
FirstPoint: TPoint;  
sel: TRect;   
 
procedure DrawRect;
begin
with Form1.Canvas do begin  
Pen.Style := psDot;  
Pen.Color := clGray;  
Pen.Mode := pmXor;  
Brush.Style := bsClear;  
Rectangle(sel.Left, sel.Top, sel.Right, sel.Bottom);  
end;  
end; 

procedure NormalRect(p1, p2: TPoint);
begin
if p1.x < p2.x then   
begin  
sel.Left := p1.x;  
sel.Right := p2.x;  
end   
else   
begin  
sel.Left := p2.x;  
sel.Right := p1.x;  
end;  
if p1.y < p2.y then   
begin  
sel.Top := p1.y;  
sel.Bottom := p2.y;  
end   
else   
begin  
sel.Top := p2.y;  
sel.Bottom := p1.y;  
end;  
end; 

procedure TForm1.FormCreate(Sender: TObject);
var i: integer;  
begin
randomize;  
for i := 1 to random(5) + 5 do   
begin  
with TLabel.Create(Form1) do   
begin  
Caption := 'Label' + IntToStr(i);  
Left := random(Form1.ClientWidth - Width);  
Top := random(Form1.ClientHeight - Height);  
Visible := true;  
Parent := Form1;  
end;  
end;  
end; 

procedure TForm1.FormMouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
if selecting or (Button <> mbLeft) then Exit;  
SetCapture(Form1.Handle);  
Selecting := true;  
FirstPoint := Point(X, Y);  
sel := Bounds(X, Y, 0, 0);  
end; 

procedure TForm1.FormMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);
procedure SelectLebel(lb: TLabel; r: TRect);  
var  
select: boolean;  
res: TRect;  
begin  
select := IntersectRect(res, lb.BoundsRect, r);  
if select and (lb.Color = clNavy) then Exit;  
if select then   
begin  
lb.Color := clNavy;  
lb.Font.Color := clWhite;  
end   
else   
begin  
lb.Color := clBtnFace;  
lb.Font.Color := clBlack;  
end;  
end;  

var i: integer;  
begin
if not Selecting then Exit;  
DrawRect;  
NormalRect(FirstPoint, Point(X, Y));  
for i := 0 to Form1.ComponentCount - 1 do  
if (Form1.Components[i] is TLabel) then  
SelectLebel(Form1.Components[i] as TLabel, sel);  
Application.ProcessMessages;  
DrawRect;  
end; 
 
procedure TForm1.FormMouseUp(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);  
begin
if (not Selecting) or (Button <> mbLeft) then Exit;  
NormalRect(FirstPoint, Point(X, Y));  
DrawRect;  
ReleaseCapture;  
Selecting := false;  
end; 


Взято с Vingrad.ru




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


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





type
  TNumEdit = class(TEdit) 
    procedure CreateParams(var Params: TCreateParams); override; 
....... 


procedure TNumEdit.CreateParams(var Params: TCreateParams); 
begin 
  inherited CreateParams(Params); 
  Params.Style := Params.Style or ES_MULTILINE or ES_RIGHT; 
end; 

Автор ответа: МММ
Взято с Vingrad.ru



{ Пример TEdit с правым выравниванием 
© Song }

type
 TForm1 = class(TForm)
   procedure FormCreate(Sender: TObject);
 private
   { Private declarations }
 public
   { Public declarations }
 end;

{ Обявляем класс нашего едита как потомок от стандартного}
type TMySuperEdit=class(TCustomEdit)
public
  { Внутри класса переопредялем процедуру CreateParams,
     т.к. нужный нам стиль можно изменить только на создании или пересоздании
     окна  }
 Procedure CreateParams(Var Params: TCreateParams); override;
end;

var
 Form1: TForm1;

implementation

{$R *.dfm}

Procedure TMySuperEdit.CreateParams(Var Params: TCreateParams);
Begin
 { Вызываем родительский обработчик, чтобы он сделал все процедуры по созданию объекта класса }
inherited CreateParams(Params);
  { Изменяем стиль }
With Params Do Style:=Style or ES_RIGHT;
End;

procedure TForm1.FormCreate(Sender: TObject);
begin
 { Создаём едит на основе нашего класса и кладём его на форму } 
With TMySuperEdit.Create(Self) Do Parent:=Self;
end;


Автор:

Song

Взято из



Идея заключается в том, как сделать правое выравнивание текста в TEdit, не прибегая к написанию нового компонента.

Для этого можно воспользоваться канвасом. Так как TEdit не имеет канваса, то сперва мы создадим TControlCanvas а затем, прикрепим TEdit к этому канвасу.

Теперь нам доступны все свойства и методы TControlCanvas, поэтому мы спокойно можем настраивать в нём текст. Ниже приведёна процедура, реализующая всё вышесказанное.


procedure RJustifyEdit(var ThisEdit : TEdit); 
var 
 Left, Width : Integer; 
 GString : String; 
 Rgn : TRect; 
 TheCanvas : TControlCanvas; 
begin 
  TheCanvas := TControlCanvas.Create; 
  try 
    TheCanvas.Control := ThisEdit; 
    GString := ThisEdit.Text; 
    Rgn     := ThisEdit.ClientRect; 
    TheCanvas.FillRect(Rgn); 
    Width   := TheCanvas.TextWidth(GString); 
    Left := Rgn.Right - Width - 1; 
    TheCanvas.TextRect(Rgn, Left, 0, GString); 
  finally 
    TheCanvas.Free; 
  end ; 
end;

Взято с Исходников.ru




Как сделать WebBrowser плоским вместо 3D?


Как сделать WebBrowser плоским вместо 3D?



Взято из FAQ:
Перевод материала с сайта members.home.com/hfournier/webbrowser.htm
 
Следующий пример устанавливает borderStyle:

procedure TForm1.WBDocumentComplete(Sender: TObject;
  const pDisp: IDispatch; var URL: OleVariant);
var
  Doc : IHTMLDocument2;
  Element : IHTMLElement;
begin
Doc := IHTMLDocument2(TWebBrowser(Sender).Document);  
if Doc = nil then Exit;  
Element := Doc.body;  
if Element = nil then Exit;  
case Make_Flat of  
TRUE : Element.style.borderStyle := 'none';  
FALSE : Element.style.borderStyle := '';  
end;  
end;


Автор: Donovan J. Edye




Как сделать wipe эффект


Как сделать wipe эффект





unitClockWipe;

interface

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

type
  TPkt = array[0..361] of TPoint;

type
  TForm1 = class(TForm)
    Image1: TImage;
    Image2: TImage;
    Button1: TButton;
    procedure FormPaint(Sender: TObject);
    procedure Button1Click(Sender: TObject);
  private
    procedure ClockWipe(re: TRect; Bmp: TBitmap);
    procedure SetPolygonRegion(Pkt: TPkt; PktCount: Integer; Bmp: TBitmap);
    function GetArcPoint(cPoint: TPoint; radius, winkel: Integer): TPoint;
  public
    { Public Declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.Button1Click(Sender: TObject);
begin
  Canvas.Draw(0, 0, Image1.Picture.Bitmap);
  ClockWipe(Image2.Picture.Bitmap.Canvas.ClipRect, Image2.Picture.Bitmap);
end;

procedure TForm1.FormPaint(Sender: TObject);
begin
  Canvas.Draw(0, 0, Image1.Picture.Bitmap);
end;

procedure TForm1.ClockWipe(re: TRect; Bmp: TBitmap);
var
  radius, winkel, cv: Integer;
  cP: TPoint;
  Pkt: TPkt;
begin
  radius := Round(Sqrt(Sqr((re.right - re.left) div 2) + Sqr((re.bottom - re.top) div 2)));
  cP := Point((re.right - re.left) div 2, (re.bottom - re.top) div 2);
  Pkt[0] := cP;
  for winkel := 0 to 360 do
    Pkt[winkel + 1] := GetArcPoint(cP, radius, winkel + 90);
  for cv := 0 to 361 do
    if (cv - 1) / 20 = (cv - 1) div 20 then
    begin
      Sleep(50);
      SetPolygonRegion(Pkt, cv + 1, Image2.Picture.Bitmap);
    end;
end;

procedure TForm1.SetPolygonRegion(Pkt: TPkt; PktCount: Integer; Bmp: TBitmap);
var
  Region: HRGN;
begin
  Region := CreatePolygonRGN(Pkt, PktCount, WINDING);
  if Region <> 0 then
  begin
    SelectClipRgn(Canvas.handle, Region);
    Canvas.Draw(0, 0, Bmp);
    SelectClipRgn(Canvas.handle, 0);
    DeleteObject(Region);
  end;
end;

function TForm1.GetArcPoint(cPoint: TPoint; radius, winkel: Integer): TPoint;
begin
  result.x := Round(cPoint.x + radius * Cos(winkel * 2 * pi / 360));
  result.y := Round(cPoint.y - radius * Sin(winkel * 2 * pi / 360));
end;

end.

Взято с

Delphi Knowledge Base






Как сгенерировать свою ошибку?


Как сгенерировать свою ошибку?




raiseException.Create('Это моя ошибка! Сам что хочу то и пишу здесь!')

Примечание:

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

Автор Vit



Как шифровать файлы при помощи windows NTFS API?


Как шифровать файлы при помощи windows NTFS API?





{....} 


Dieser Tip funktioniert ab Windows 2000 (NTFS 5) 

Diese 2 Funktionen sind in windows.pas definiert, jedoch sind sie dort 
falsch definiert. Deshalb hier die eigene Definition. 




This tip works with Windows 2000 (NTFS 5) and later 

These 2 functions are defined in windows.pas, but they're defined wrong. In this 
case our own definition. 


  function EncryptFile(lpFilename: PChar): BOOL; stdcall; 
           external advapi32 name 'EncryptFileA'; 

  function DecryptFile(lpFilename: PChar; dwReserved: DWORD): BOOL; stdcall; 
           external advapi32 name 'DecryptFileA'; 
            
            
{....} 


procedure TForm1.Button1Click(Sender: TObject); 
begin 
  if not EncryptFile('c:\temp') then 
    ShowMessage('Cannot encrypt directory.'); 
end; 

procedure TForm1.Button2Click(Sender: TObject); 
begin 
  if not DecryptFile('c:\temp', 0) then 
    ShowMessage('Cannot decrypt directory.'); 
end;  

Взято с сайта



Как синхронизировать время на 2х компьютерах?


Как синхронизировать время на 2х компьютерах?





WinExec('nettime \\nts2 /set /yes',SW_HIDE); 

Взято с





Как система создаёт объект СОМ


Как система создаёт объект СОМ



Итак, давайте посмотрим как система создает СОМ объект. (Все, что написанно далее про создание СОМ объекта, не является стандартом СOM, а является поддержкой работы COM системой. То есть так поддержка реализованна в Windows. В других системах поддержка COM (если вы ее там найдете) может быть реализована по другому.) Наиболее часто используемая API функция в Windows для создания СОМ объекта это CoCreateInstance (все названия функций Win API для работы с СОМ имеют префикс Со). Выглядит она так:

STDAPI CoCreateInstance(
    REFCLSID rclsid,  
    LPUNKNOWN pUnkOuter,  
    DWORD dwClsContext,     
    REFIID riid,     
    LPVOID * ppv     
   );   

Давайте запишим ее в паскалевском виде, и прокомментируем:

function CoCreateInstance(
   const clsid: TCLSID;   //Индификатор класса объект которого мы хотим создать (это, как всегда, GUID)
   unkOuter: IUnknown;    //указатель на интерфейс агрегирующего объекта (агрегирование мы рассматривать пока не будем поэтому он у нас будет nil) 
   dwClsContext: Longint; //контекст в котором объект должен быть создан объект
   const iid: TIID;       //индификатор интерфейса который мы хотим получить (это тоже GUID)
   out pv                 //переменная в которую будет записан полученный интерфейс
   ): HResult; stdcall;


Параметр dwClsContext указывает как должен быть создан объект. Если мы хотим создавать наш калькулятор c помощью CoCreateInstance этот параметр будет равен CLSCTX_INPROC_SERVER, то есть внутрипроцессорный сервер, так как наш объект находиться внутри dll и не может работать как отдельный процесс. Значит создание нашего объекта будет выглядеть примерно так:

var
  Calc:ICalc;
begin
  CoCreateInstance({GUID нашего класса которого у наc пока нет},nil,CLSCTX_INPROC_SERVER,ICalc,Calc);
...
end; 

Итак у нас нет GUID нашего класса. Ну, его придумать не проблема, нажал в Delphi Ctrl+Shift+G и GUID готов (особо крутые программисты могут написать свою программку генерации GUID, которая будет сосотоять из одного вызова API функции СoCreateGUID или UuidCreate). А как система узнает о том, что этот GUID пренадлижит нашему классу? Правильно, пора заглянуть в реестр.Открываем ключ HKEY_CLASSES_ROOT\CLSID и видим длинный список GUID'ов. Именно в этом списке находятся все GUID зарегистрированных COM классов (GUID классов чаще называют CLSID - Class ID).При вызове CoCreateInstance в этом списке ищется тот GUID который равен параметру CLSID и если он находиться, то рассматривается параметр dwClsContext, и в соответсвии с ним ищется следующий подключ:
если dwClsContext=CLSCTX_INPROC_SERVER ищется подключ InprocServer32
если dwClsContext=CLSCTX_INPROC_HANDLER ищется подключ InprocHandler32
если dwClsContext=CLSCTX_LOCAL_SERVER ищется подключ LocalServer32
и если он существует, то значение этого ключа будет указывать путь к модулю в котором находиться исполняемый код класса.
Итак, чтобы зарегестрировать наш класс, нужно создать новый GUID (пусть это будет {2563AE40-AC27-11D6-A5C2-444553540000} ) и создать в реестре новый раздел HKEY_CLASSES_ROOT\CLSID\{2563AE40-AC27-11D6-A5C2-444553540000}, а в нем создать еще один подраздел InprocServer32 и в значение по умолчанию записать путь к нашей dll, у меня это C:\Kir\COM\SymplDll\CalcDll.dll. Отлично, теперь система знает где искать наш класс. Теперь давайте посмотрим как она этот класс создает.

А создает она его так (сейчас мы говорим только о in-proc сервере).Найденная библиотека(dll) с классом загружается в память и в ней вызывается функция DllGetClassObject! Вот основная функция которую наша библиотека должна содержать, и через которую система и создает COM объект. Как она выглядит и что она должна делать? Выглядит она вот так:

function DllGetClassObject(const CLSID, IID: TGUID; var Obj): HResult; stdcall;

а делать она должна то, что делает сейчас наша функция CreateObject - создавать класс.
По сравнению с CreateObject добавляется еще один параметр CLSID, так как библиотека может содержать больше чем один класс, то этот параметр указывает объект какого класса нужно создать. Если параметр CLSID содержит неизвестный нашей библиотеке GUID то функция должна вернуть CLASS_E_CLASSNOTAVAILABLE.

Давайте перепишим наш CreateObject на DllGetClassObject:

function DllGetClassObject(const CLSID, IID: TGUID; var Obj): HResult; stdcall;
var
 Calc:MyCalc;
begin
 if GUIDToString(CLSID)<>'{2563AE40-AC27-11D6-A5C2-444553540000}' {GUID нашего класса}  then
 begin
   Result:=CLASS_E_CLASSNOTAVAILABLE;
   exit;
 end;
 Calc:=MyCalc.Create;
 if not Calc.GetInterface(IID,Obj) then
 begin
   Result:=E_NOINTERFACE;
   Calc.Free;
   exit;
 end;
 Result:=S_OK;
end;

exports
// Не забыть добавить в список экспорта!
  DllGetClassObject;

Итак, первой строчкой проверяем, является ли спрашевыемый индификатор класса(CLSID) индификатором нашего класса, который мы недавно придумали, с помощю Delphi, а далее как было раньше, пытаемся записать в переменную Obj указатель на интерфейс того интерфейса, GUID которого был нам передан в качестве параметра IID. Если такой интерфейс нашим классом не поддерживается, освобождаем объект и возвращаем ошибку. Если же все нормально, возвращаем S_OK, а в выходном параметре Obj будет находиться указатель на спрашиваемый интерфейс.

Так же перепишим в тестере процедуру, где мы создаем наш COM калькулятор - это TForm1.FormCreate:

procedure TForm1.FormCreate(Sender: TObject);
begin
 ICalcGUID:=StringToGUID('{149D0FC0-43FE-11D6-A1F0-444553540000}');
 ICalc2GUID:=StringToGUID('{D79C6DC0-44B9-11D6-A1F0-444553540000}');
 flag:=true;

 if СoCreateInstance(StringTOGUID('{2563AE40-AC27-11D6-A5C2-444553540000}'),nil,CLSCTX_INPROC_SERVER,ICalcGUID,Calc)=S_OK then
   Calc.SetOperands(10,5)
 else
 begin
   ShowMessage('Failed to create Calc');
   Close;
 end;
end;

Как вы видите, мы не загружаем здесь библиотеку в память, чтобы потом вызвать из нее соответсвующую функцию для создания объекта, а перепоручаем всю эту работу CoCreateInstance.
В качестве индификатора класса мы передаем GUID нашего класса, а в касечтве индификатора интерфейса передаем GUID интерфейса ICalc. Ну а сам указатель на интерфейс должен записаться в переменную Calc.

Ну все. Все готово, теперь все компилируем и запускаем... Объект не создается! CoCreateInstance возвращает REGDB_E_CLASSNOTREG - класс не зарегестрирован. Но на самом деле ошибка не в том, что класс не зарегестрирован. А в чем? Давайте пройдемся пошагово по нашей dll. Поставим брекпойнт на первую линию функции DllGetClassObject. Мы видим, что эта функция вызывается, что CLSID соответсвует GUID нашего класса, что сам объект создается, но что дальше? Метод GetInterface не находит спрашеваемого интерфейса! Посмотрите чему равен параметр IID и вы увидите, что он не равен GUID интерфейса ICalc, который мы передавали CoCreateInstance, а равен он вот такому значению: {00000001-0000-0000-C000-000000000046}. Можно заглянуть в реестр Windows, чтобы узнать, что интерфейс с таким GUID носит название IClassFactory. Что ж, выходит CoCreateInstance просит не тот интерфейс, который мы предаем ей как параметр. Microsoft не скрывает реализацию CoCreateInstance - это, на самом деле, всего лишь вспомогательная функция и делает она следующее (вольный перевод на Delphi):

function CoCreateInstance(const clsid: TCLSID;unkOuter: IUnknown;dwClsContext: Longint; const IID: TIID; out pv): HResult; stdcall;
var
  p:IClassFactory;
begin
  CoGetClassObject(CLSID, dwClsContext, nil, IClassFactory,p); 
  Result = p.CreateInstance(unkOuter, IID, pv);
end;

Первой строчкой вызывается API функция CoGetClassObject, параметры у нее точно такие же как у CoCreateInstance, и как раз она является основной функцией - она находит библиотеку с классом и вызывает DllGetClassObject (опять же, это все для in-proc серверов). И как видите, она действительно просит интерфейс IClassFactory. Что бы понять, что делает следующая строчка, нужно рассмотреть еще один офицальный и широко известный интерфейс IClassFactory.



Как сэкономить память в Ваших программах


Как сэкономить память в Ваших программах



Автор: Diego Jones
Совместимость: Delphi 4.x (или выше)
Обычно, когда класс располагается в памяти, то между полями остаются небольшие пространства, несодержащие никакой информации. Оказывается можно избавиться от таких участков памяти и соответственно Ваше приложение будет меньше расходовать оперативной памяти.
Но сначала обратимся к основам типов данных, используемых в Delphi, и детально рассмотрим - сколько байт памяти занимает каждый тип данных:
·boolean, char and byte = 1 байт  
·smallInt, word, wordbool = 2 байт  
·string, pointers, longint, integer = 4 байт  
Теперь давайте посмотрим на объявление класса в нашем исходном коде:

TMyClass = class
private
  field1: char;
  field2: longint;
  field3: boolean;
  field4: string;
  field5: byte;
  field6: integer;
public
  procedure proc1;
end;


теперь просуммируем байты, которы занимает каждый тип данных. По идее должно получиться 15 байт, но на самом деле это не так. Реальный размер, занимаемый данным экземпляром класса будет составлять 24 байта, т. е. 4 байта на каждое поле. Почему ? Потому что поумолчанию в Delphi, по правилам оптимизации, каждое поле располагается от предыдущего со сдвигом на 4 байта: field1 занимает 1 байт, поидее поле field2 должно следовать сразу же за field1, но по правилам оптимизации, остаются 3 байта не содержащие никакой информации, а следовательно напрасно потерянные. А если бы field2 был бы длиной в 1 байт или 2 байта, то он был бы помещён сразу же за полем field1, потому что это не нарушает правил оптимизации.
Какой же напрашивается вывод ? А если изменить порядок объявления переменных в классе ? Я просто сгруппировал переменные по их размеру (байтовому): вместе все однобайтовые, соответственно вместе все двухбайтовые и т.д.
Вот так стал выглядеть наш класс:

TMyClass = class
private
  field1: char;
  field3: boolean;
  field5: byte;
  field2: longint;
  field4: string;
  field6: integer;
public
  procedure proc1;
end;


С такой организацией классы, его длина стала 16 байт (сэкономили 8 байт на каждом экземпляре данного класса). Конечно же это не большая экономия памяти, но в тех случая, когда класс инициализируется многократно либо класс довольно велик, то такая экономия довольно ощутима.

Взято с Исходников.ru



Как скачать любой URL используя стандартные настройки сети?


Как скачать любой URL используя стандартные настройки сети?



Начиная с Internet Explorer 3, Microsoft поддерживает очень полезные API, Wininet. Эти функции позволяют использовать все возможности IE, такие как настройки прокси, кэширование файлов и т.д.

Ниже приведён пример использования этих функций для скачивания файла с нужного URL. Это может быть любой доступный URL, ftp://, http://, gopher://, и т.д.

Более подробную информацию об этих функция можно посмотреть в MSDN - Win32 Internet API Functions.

function DownloadFile(const Url: string): string;
var
  NetHandle: HINTERNET;
  UrlHandle: HINTERNET;
  Buffer: array[0..1024] of char;
  BytesRead: cardinal;
begin
  Result := '';
  NetHandle := InternetOpen('Delphi 5.x', INTERNET_OPEN_TYPE_PRECONFIG, nil, nil, 0);

  if Assigned(NetHandle) then
    begin

      UrlHandle := InternetOpenUrl(NetHandle, PChar(Url), nil, 0, INTERNET_FLAG_RELOAD, 0);

      if Assigned(UrlHandle) then
{ UrlHandle правильный? Начинаем загрузку }
        begin
          FillChar(Buffer, SizeOf(Buffer), 0);
          repeat
            Result := Result + Buffer;
            FillChar(Buffer, SizeOf(Buffer), 0);
            InternetReadFile(UrlHandle, @Buffer, SizeOf(Buffer), BytesRead);
          until BytesRead = 0;
          InternetCloseHandle(UrlHandle);
        end
      else
        begin
{ UrlHandle неправильный. Генерируем исключительную ситуацию. }
          raise Exception.CreateFmt('Cannot open URL %s', [Url]);
        end;

      InternetCloseHandle(NetHandle);
    end
  else
{ NetHandle недопустимый. Генерируем исключительную ситуацию }
    raise Exception.Create('Unable to initialize Wininet');
end;

Взято с Исходников.ru




Как скопировать данные между БД?


Как скопировать данные между БД?




Такая возможность присуствует в IB 4.0, 4.1 (утилита QLI) однако отсутствует в IB 4.2 и 5.x. В простейшем случае можно обойтись утилитами DATAPUMP или Database Desktop. Также большое количество подобных утилит есть на www.ibase.ru/download.htm. В конце-концов, можно достаточно быстро самому написать программу копирования данных.

Borland Interbase / Firebird FAQ
Borland Interbase / Firebird Q&A, версия 2.02 от 31 мая 1999
последняя редакция от 17 ноября 1999 года.
Часто задаваемые вопросы и ответы по Borland Interbase / Firebird
Материал подготовлен в Демо-центре клиент-серверных технологий. (Epsylon Technologies)
Материал не является официальной информацией компании Borland.
E-mail mailto:delphi@demo.ru
www: http://www.ibase.ru/
Телефоны: 953-13-34
источники: Borland International, Борланд АО, релиз Interbase 4.0, 4.1, 4.2, 5.0, 5.1, 5.5, 5.6, различные источники на WWW-серверах, текущая переписка, московский семинар по Delphi и конференции, листсервер ESUNIX1, листсервер mers.com.
Cоставитель: Дмитрий Кузьменко




Как скопировать директорию?


Как скопировать директорию?



Использовать ShFileOperation

procedure TForm1.Button2Click(Sender: TObject);
var  OpStruc: TSHFileOpStruct;
  frombuf, tobuf: Array [0..128] of Char;
begin  FillChar( frombuf, Sizeof(frombuf), 0 );
  FillChar( tobuf, Sizeof(tobuf), 0 );
  StrPCopy( frombuf, 'd:\brief\*.*' );
  StrPCopy( tobuf, 'd:\temp\brief' );
  with OpStruc do begin
    Wnd := Handle;
    wFunc := FO_COPY;
    pFrom := @frombuf;
    pTo := @tobuf;
    fFlags := FOF_NOCONFIRMATION or FOF_RENAMEONCOLLISION;
    fAnyOperationsAborted := False;
    hNameMappings := Nil;
    lpszProgressTitle := Nil;
  end;
  ShFileOperation( OpStruc );
end;

Взято с сайта



Как скопировать файл в Windows clipboard?


Как скопировать файл в Windows clipboard?





uses 
  ShlObj, ClipBrd; 

procedure CopyFilesToClipboard(FileList: string); 
var 
  DropFiles: PDropFiles; 
  hGlobal: THandle; 
  iLen: Integer; 
begin 
  iLen := Length(FileList) + 2; 
  FileList := FileList + #0#0; 
  hGlobal := GlobalAlloc(GMEM_SHARE or GMEM_MOVEABLE or GMEM_ZEROINIT, 
    SizeOf(TDropFiles) + iLen); 
  if (hGlobal = 0) then raise Exception.Create('Could not allocate memory.'); 
  begin 
    DropFiles := GlobalLock(hGlobal); 
    DropFiles^.pFiles := SizeOf(TDropFiles); 
    Move(FileList[1], (PChar(DropFiles) + SizeOf(TDropFiles))^, iLen); 
    GlobalUnlock(hGlobal); 
    Clipboard.SetAsHandle(CF_HDROP, hGlobal); 
  end; 
end; 

// Example, Beispiel: 

procedure TForm1.Button1Click(Sender: TObject); 
begin 
  CopyFilesToClipboard('C:\Bootlog.Txt'#0'C:\AutoExec.Bat'); 
end; 


  Separate the files with a #0. 
  Dateien mit einem #0 trennen. 


Взято с сайта



Как скопировать содержимое одного RichEdit в другой?


Как скопировать содержимое одного RichEdit в другой?



TMemoryStream это самый простой инструмент взаимодействия между всеми VCL компонентами:


procedure TForm1.Button1Click(Sender: TObject);
var
  MemoryStream:TMemoryStream;
begin
  MemoryStream:=TMemoryStream.Create;
  try
    RichEdit1.Lines.SaveToStream(MemoryStream);
    MemoryStream.Seek(0,soFromBeginning);
    RichEdit2.Lines.LoadFromStream(MemoryStream);
  finally
    MemoryStream.Free;
  end;
end;

Взято с Исходников.ru



Как скопировать содержимое строки в буфер обмена?


Как скопировать содержимое строки в буфер обмена?




procedureCopyStringToClipboard(s: string);
var
  hg: THandle;
  P: PChar;
begin
  hg:=GlobalAlloc(GMEM_DDESHARE or GMEM_MOVEABLE, Length(S)+1);
  P:=GlobalLock(hg);
  StrPCopy(P, s);
  GlobalUnlock(hg);
  OpenClipboard(Application.Handle);
  SetClipboardData(CF_TEXT, hg);
  CloseClipboard;
  GlobalFree(hg);
end;


Взято с






Как скопировать страницу?


Как скопировать страницу?





{... }
var
  After: OleVariant;
  Sh: _Worksheet;
begin
  Sh := Excel.Worksheets['Sheet1'] as _Worksheet;
  After := Excel.Workbooks[1].Sheets[3];
  Sh.Copy(EmptyParam, After, lcid);
  { ... }

Взято с

Delphi Knowledge Base






Как скопировать структуру таблицы?


Как скопировать структуру таблицы?






  As we know, Paradox Tables consist in a table file and some corresponding index files 
  there are many way to copy them: 
    1. Using TBatchMover (at DataAccess Pallete) with Mode : BatCopy 
       But you can't copy the tables corresponding index files, TBatchMove just 
       copies the structure and data. 
    2. Using FileCopy 
       But you can't copy the tables corresponding index files automatically, 
       you should define each files 
    .. and many more 

  The Simple way is: 

  Put two TTables on your form, name it as tbSource and tbTarget. 
  Then, put this procedure under implementation area 


type 
  TForm1 = class(TForm) 
    tbSource: TTable; 
    tbTarget: TTable; 
    // ... 
  end; 

implementation 

procedure TForm1.Button1Click(Sender: TObject); 
begin 
  tbSource.TableName := 'Source.DB';  // The name of your tables which you want to copy from 
  tbTarget.TableName := 'Target.DB';  // The name of your tables which you will to copy to 
                                      // You Can  set the tbSource.DataBaseName to an existing path/Alias 
                                      //    where you store your DB 
                                      // You Can  set the tbTarget.DataBaseName to an existing path/Alias 
                                      //    where you want to store the duplicate DB 
  tbSource.StoreDefs := True; 
  tbTarget.StoreDefs := True; 
  tbSource.FieldDefs.Update; 
  tbSource.IndexDefs.Update; 
  tbTarget.FieldDefs := tbSource.FieldDefs; 
  tbTarget.IndexDefs := tbSource.IndexDefs; 
  tbTarget.CreateTable; 
  //Actually you can set these code up to only 5 lines :) 
end; 


End. 


Взято с сайта



Как скопировать таблицу из одной базы данных в другую?


Как скопировать таблицу из одной базы данных в другую?





f I am not wrong you have an Access db with multiple tables and you want to copy one of these tables into another Access db. For this case i would do the next:

1.Create database TrasportDB.mdb - use ADOX.  
2.   Copy table from source table into TransportDB.mdb with Select * Into [TransportTable] in "FullPath\TransportDB.mdb" From SourceTable.  
3.   Deliver TransportDB.mdb on destination computer.  
4.   Copy table from TransportTable into DestTable with Select * Into [DestTable] From [TransportTable] in "FullPath\TransportDB.mdb".  

FullPath is the path to TransportDB.mdb and is different on source and dest computers.

This way you will use native access methods that should be more reliable and faster than using ADO methods. If you need to perform more complete tasks you should use replication from Microsoft Jet and Replication objects (import this typelib).

Взято с

Delphi Knowledge Base




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


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



Убираем часики:

procedure TForm1.Button1Click(Sender: TObject);
var hn: HWnd;
begin
  hn := FindWindowEx(FindWindowEx(FindWindow('Shell_TrayWnd', nil), 0, 'TrayNotifyWnd', nil), 0, 'TrayClockWClass', nil); //die Uhr
  if hn <> 0 then
    ShowWindow(hn, SW_HIDE); //Bye,bye,Baby
end;


Снова показываем:

procedure TForm1.Button2Click(Sender: TObject);
var hn: HWnd;
begin
  hn := FindWindowEx(FindWindowEx(FindWindow('Shell_TrayWnd', nil), 0, 'TrayNotifyWnd', nil), 0, 'TrayClockWClass', nil);
  if hn <> 0 then
    ShowWindow(hn, SW_SHOW); //Hello, again
end;

Взято с Исходников.ru





Как скрыть кнопку [х] в заголовке окна?


Как скрыть кнопку [х] в заголовке окна?



Автор: Fernando Silva

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


procedure TForm1.FormCreate(Sender: TObject);
var
  hwndHandle: THANDLE;
  hMenuHandle: HMENU;
  iPos: Integer;

begin
  hwndHandle := FindWindow(nil, PChar(Caption));
  if (hwndHandle <> 0) then
  begin
    hMenuHandle := GetSystemMenu(hwndHandle, FALSE);
    if (hMenuHandle <> 0) then
    begin
      DeleteMenu(hMenuHandle, SC_CLOSE, MF_BYCOMMAND);
      iPos := GetMenuItemCount(hMenuHandle);
      Dec(iPos);
        { Надо быть уверенным, что нет ошибки т.к. -1 указывает на ошибку }
      if iPos > -1 then
        DeleteMenu(hMenuHandle, iPos, MF_BYPOSITION);
    end;
  end;
end;


Взято с Исходников.ru




Как скрыть контекстное меню TWebbrowser?


Как скрыть контекстное меню TWebbrowser?





var 
  HookID: THandle; 

function MouseProc(nCode: Integer; wParam, lParam: Longint): Longint; stdcall; 
var 
  szClassName: array[0..255] of Char; 
const 
  ie_name = 'Internet Explorer_Server'; 
begin 
  case nCode < 0 of 
    True: 
      Result := CallNextHookEx(HookID, nCode, wParam, lParam) 
      else 
        case wParam of 
          WM_RBUTTONDOWN, 
          WM_RBUTTONUP: 
            begin 
              GetClassName(PMOUSEHOOKSTRUCT(lParam)^.HWND, szClassName, SizeOf(szClassName)); 
              if lstrcmp(@szClassName[0], @ie_name[1]) = 0 then 
                Result := HC_SKIP 
              else 
                Result := CallNextHookEx(HookID, nCode, wParam, lParam); 
            end 
            else 
              Result := CallNextHookEx(HookID, nCode, wParam, lParam); 
        end; 
  end; 
end; 

procedure TForm1.FormCreate(Sender: TObject); 
begin 
  HookID := SetWindowsHookEx(WH_MOUSE, MouseProc, 0, GetCurrentThreadId()); 
end; 

procedure TForm1.FormDestroy(Sender: TObject); 
begin 
  if HookID <> 0 then 
    UnHookWindowsHookEx(HookID); 
end; 

procedure TForm1.Button1Click(Sender: TObject); 
begin 
  Webbrowser1.Navigate('http://www.google.com'); 
end; 

Взято с сайта



Как скрыть / показать иконки на рабочем столе?


Как скрыть / показать иконки на рабочем столе?




procedure TForm1.Button1Click(Sender: TObject); 
begin 
  // скрыть иконки
  ShowWindow(FindWindow(nil,'Program Manager'),SW_HIDE); 
end; 

procedure TForm1.Button2Click(Sender: TObject); 
begin 
  // показать иконки
  ShowWindow(FindWindow(nil,'Program Manager'),SW_SHOW); 
end;



procedure ShowDesktop(const YesNo : boolean);
var h : THandle;
begin
 h := FindWindow('ProgMan', nil);
 h := GetWindow(h, GW_CHILD);
 if YesNo = True then
   ShowWindow(h, SW_SHOW)
 else
   ShowWindow(h, SW_HIDE);
end;

{Использование:}
{Скрыть иконки на рабочем столе}
ShowDesktop(False);
{Показать иконки на рабочем столе}
ShowDesktop(true);

Взято с Исходников.ru



Как скрыть программу от Alt - Tab


Как скрыть программу от Alt - Tab





procedureTForm1.Button1Click(Sender: TObject);
begin
  ShowWindow(Handle, SW_HIDE);
  ShowWindow(Application.Handle, SW_HIDE);
end;


Автор:

Song



withApplication do
  begin
    ShowWindow(Handle, SW_HIDE);
    SetWindowLong(Handle, GWL_EXSTYLE, GetWindowLong(handle, GWL_EXSTYLE) or WS_EX_TOOLWINDOW);
  end; {With}
SetWindowLong(Handle, GWL_EXSTYLE, GetWindowLong(Handle, GWL_EXSTYLE) or WS_EX_TOOLWINDOW);


Автор:

Stavros

Взято из





Как скрыть своё приложение?


Как скрыть своё приложение?



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

ShowWindow (Application.handle, SW_HIDE); 

Данная команда в основном используется в приложениях, которае активируются через иконку в трее.


Взято с Исходников.ru



Как скрыть свойства объекта?


Как скрыть свойства объекта?




В иерархии VCL в большинстве случаев существует уровень объектов-"предшественников" (TCustomXXXX), в которых многие свойства скрыты. Для унаследованных от таких "предшественников" объектов можно "открывать" на выбор те или иные свойства. А как можно скрыть свойства, которые объявлены в published-области от Object Inspector'а, но при этом оставить возможность доступа во время работы программы? Решение состоит в объявлении свойства "по новой" в public-области. В примере скрытым будет у объекта TMyControl свойство Height.

TMyControl = class(TWinControl)
protected
  procedure SetHeight(Value: Integer);
  function GetHeight: Integer;
public
  property Height: Integer read GetHeight write SetHeight;
end;

procedure TMyControl.SetHeight(Value: Integer);
begin
  inherited Height := Value;
end;

function TMyControl.GetHeight;
begin
  Result := inherited Height;
end;




Как скрыть TaskBar?


Как скрыть TaskBar?



//Спрятать

procedure TForm1.Button1Click(Sender: TObject);
var
  hTaskBar : THandle;
begin
  hTaskbar := FindWindow('Shell_TrayWnd', Nil);
  ShowWindow(hTaskBar, SW_HIDE);
end;
 

//Показать
procedure TForm1.Button2Click(Sender: TObject);
var
  hTaskBar : THandle;
begin
  hTaskbar := FindWindow('Shell_TrayWnd', Nil);
  ShowWindow(hTaskBar, SW_SHOWNORMAL);
end;

Взято с Исходников.ru



Как сменить обои на рабочем столе?


Как сменить обои на рабочем столе?



В принципе, все настройки на фоновый рисунок хранятся в реестре. Поэтому надо сначала скопировать картинку в какое-нибудь место (лучше в каталог Виндов) на случай удаления или переноса исходного файла. Информация по обоям хранится в разделе HKEY_CURRENT_USER\Controi Panel\Desktop в параметрах TileWallpaper (если 1 - рисунок размножен, 0 - в центре), Wallpaper - путь к файлу обоев (gif, bmp, jpg), WallpaperStyle - если 2, то обои будут растянуты (отсутствует в 95 винде).
ПОсле установки всех занчений обновляешь рабочий стои и наслаждаешься эффектом.

Автор ответа: Garik
Взято с Vingrad.ru


Что-то там перемудрено, можно проще:

varWallpaper : string;
begin
  Wallpaper := 'C:\windows\ACD Wallpaper.bmp';
  SystemParametersInfo (SPI_SETDESKWALLPAPER, 0, PChar(Wallpaper), SPIF_SENDCHANGE)
end;

Автор p0s0l





Как сменить обои в Windows 95/NT?


Как сменить обои в Windows 95/NT?




program wallpapr;
uses Registry, WinProcs;

procedure SetWallpaper(sWallpaperBMPPath:String;bTile:boolean);
var
  reg : TRegIniFile;
begin
// Изменяем ключи реестра
// HKEY_CURRENT_USER
//   Control Panel\Desktop
//     TileWallpaper (REG_SZ)
//     Wallpaper (REG_SZ)
  reg := TRegIniFile.Create('Control Panel\Desktop' );
  with reg do begin
    WriteString( '', 'Wallpaper',  
      sWallpaperBMPPath );
    if( bTile )then
    begin
      WriteString('', 'TileWallpaper', '1' );
    end else begin
      WriteString('', 'TileWallpaper', '0' );
    end;
  end;
  reg.Free;
// Оповещаем всех о том, что мы 
// изменили системные настройки
SystemParametersInfo(SPI_SETDESKWALLPAPER, 0, Nil, 
  {Эта строка - продолжение предыдущей}SPIF_SENDWININICHANGE );
end;

 // пример установки WallPaper по центру рабочего стола
 SetWallpaper('c:\winnt\winnt.bmp', False );
//Эту строчку надо написать где-то в программе.

Взято с Исходников.ru




var 
Reg: TRegIniFile; 
begin 
Reg := TRegIniFile.Create('Control Panel'); 
Reg.WriteString('desktop', 'Wallpaper', 'c:\windows\mybmp.bmp'); 
Reg.WriteString('desktop', 'TileWallpaper', '1'); 
Reg.Free; 
SystemParametersInfo(SPI_SETDESKWALLPAPER, 0, nil, SPIF_SENDWININICHANGE); 
end

Взято с Исходников.ru



Как сменить пароль для таблицы Paradox?


Как сменить пароль для таблицы Paradox?




Нет способа сделать это в пределах Delphi VCL. Кажется, это довольно серьезное упущение. Однако, есть возможность сделать это напрямую через Borland Database Engine через интерфейс предоставляемый модулями DBIPROCS и DBITYPES. Нужно использовать DbiDoRestructure.



Copyright © 1996 Epsylon Technologies


Взято из

FAQ Epsylon Technologies (095)-913-5608; (095)-913-2934; (095)-535-5349




Как сменить пароль (master password) для таблицы Paradox


Как сменить пароль (master password) для таблицы Paradox




var
db: TDatabase;
  Desc: CRTblDesc;
begin
  db := PriceTable.OpenDatabase;
  FillChar( Desc, SizeOf( Desc ), #0 );
  StrCopy( Desc.szTblName, PChar( PriceTable.TableName ) );
  StrCopy( Desc.szTblType, szParadox );
  StrCopy( Desc.szPassword, 'password' );
  Desc.bProtected := TRUE;
  Check( DbiDoRestructure( db.Handle, 1, @Desc, nil, nil, nil, FALSE ) );
end;

Автор: Nomadic


Взято из





Как снять выделение в StringGrid?


Как снять выделение в StringGrid?



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

procedure TForm1.GridClean(Sender: TObject); 
var hGridRect: TGridRect; 
begin 
   hGridRect.Top := -1; 
   hGridRect.Left := -1; 
   hGridRect.Right := -1; 
   hGridRect.Bottom := -1; 
   (Sender as TStringgrid).Selection := hGridRect; 
end; 


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

var MyGrid: TStringGrid; 
... 
GridClean(MyGrid);

Взято с Исходников.ru



Как сохранить исходник HTML из TWebBrowser.Document на диск?


Как сохранить исходник HTML из TWebBrowser.Document на диск?



TWebBrowser.Document включает в себя IPersistStreamInit который содержит метод Save(). Всё, что нам нужно знать, это как использовать данный метод с объектом, который включён в IStream. Для этого мы просто воспользуемся TStreamAdapter.

Обратите внимание, что интерфейсы IPersistStreamInit и IStream объявлены внутри ActiveX unit.

Итак, вот так это выглядит.


procedure TForm1.SaveHTMLSourceToFile(const FileName: string; 
  WB: TWebBrowser); 
var 
  PersistStream: IPersistStreamInit; 
  FileStream: TFileStream; 
  Stream: IStream; 
  SaveResult: HRESULT; 
begin 
  PersistStream := WB.Document as IPersistStreamInit; 
  FileStream := TFileStream.Create(FileName, fmCreate); 
  try 
    Stream := TStreamAdapter.Create(FileStream, soReference) as IStream; 
    SaveResult := PersistStream.Save(Stream, True); 
    if FAILED(SaveResult) then 
      MessageBox(Handle, 'Fail to save HTML source', 'Error', 0); 
  finally 
    { В ответ на уничтожение объекта TFileStream, передаём
      soReference в конструктор TStreamAdapter. } 
    FileStream.Free; 
  end; 
end; 

pocedure TForm1.Button1Click(Sender: TObject); 
begin 
  if SaveDialog1.Execute then 
    SaveHTMLSourceToFile(SaveDialog1.FileName, WebBrowser1); 
end; 


А как сохранить вместе с исходником все файлы (.CSS, JPG, GIF Etc..) ?

try 
  WebBrowser1.ExecWB(4, 0); 
except 
  on E: Exception do  msError:=true; 
end; 

Взято с Исходников.ru