Как сохранить обьект TFont в реестре/ini/файле/таблице базы данных?

Нужно сохранять атрибуты шрифта (имя, размер и т.п.) а не сам обьект TFont. После считывания этой информации следует проверить существует ли такой шрифт, прежде чем его использовать. Чтобы не показаться голословным дополню ответ Borland'а своим примером сохранения/чтения шрифта в/из реестра

uses...Registry;

procedure SaveFontToRegistry(Font: TFont; SubKey: string);
var
  R: TRegistry;
  FontStyleInt: byte;
  FS: TFontStyles;
begin
  R := TRegistry.Create;
  try

    FS := Font.Style;
    Move(FS, FontStyleInt, 1);
    R.OpenKey(SubKey, True);
    R.WriteString('Font Name', Font.Name);
    R.WriteInteger('Color', Font.Color);
    R.WriteInteger('CharSet', Font.Charset);
    R.WriteInteger('Size', Font.Size);
    R.WriteInteger('Style', FontStyleInt);
  finally
    R.Free;
  end;
end;

function ReadFontFromRegistry(Font: TFont; SubKey: string): boolean;
var
  R: TRegistry;
  FontStyleInt: byte;
  FS: TFontStyles;
begin
  R := TRegistry.Create;
  try
    result := R.OpenKey(SubKey, false); if not result then exit;
    Font.Name := R.ReadString('Font Name');
    Font.Color := R.ReadInteger('Color');
    Font.Charset := R.ReadInteger('CharSet');
    Font.Size := R.ReadInteger('Size');
    FontStyleInt := R.ReadInteger('Style');
    Move(FontStyleInt, FS, 1);
    Font.Style := FS;
  finally
    R.Free;
  end;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  if FontDialog1.Execute then
    begin
      SaveFontToRegistry(FontDialog1.Font, 'Delphi Kingdom\Fonts');
    end;
end;

procedure TForm1.Button2Click(Sender: TObject);
var
  NFont: TFont;
begin
  NFont := TFont.Create;
  if ReadFontFromRegistry(NFont, 'Delphi Kingdom\Fonts') then
    begin //здесь добавить проверку - существует ли шрифт
      Label1.Font.Assign(NFont);
      NFont.Free;
    end;
end;

Как сохранить QuickReport в stream?

uses QRPrntr;

procedure SaveQuickReportToStream(AQuickReport: TQuickRep; AStream: TStream);
var
  PL: TQRPageList;
  I: Integer;
begin
  PL := nil;
  try
    PL := TQRPageList.Create;
    PL.Stream := TQRStream.Create(100000);
    AQuickReport.Prepare;
    PL.LockList;
    try
      for I := 1 to AQuickReport.QRPrinter.PageCount do
        PL.AddPage(AQuickReport.QRPrinter.GetPage(I));
      PL.Finish;
    finally
      PL.UnlockList;
    end;
    PL.Stream.SaveToStream(AStream);
  finally
    FreeAndNil(PL);
  end;
end;

procedure TForm1.Button1Click(Sender: TObject);
var
  stream: TFileStream;
begin
  stream := TFileStream.Create('c:\quickreport.dat', fmCreate);
  QuickReportToStream(QuickRep1, stream);
  stream.Free;
end;
Взято с сайта

Как сохранить RTF в TBlobfield?

В этом примере поле 'Table1Memo' это paradox 'formatted memo'. Оно так же может быть полем blob.

Через TBlobStream содержимое контрола RichEdit можно загружать или сохранять в базу данных:

procedure TForm1.BtnGetClick(Sender: TObject);
var
  bs: TBlobStream;
begin
  bs:= Nil;
  with Table1 Do
    try
      open;
      first;
      bs:= TBlobStream.Create( table1memo, bmread );
      Richedit1.plaintext := false;
      Richedit1.Lines.Loadfromstream(bs);
    finally
      bs.free;
      close;
    end;
end;

procedure TForm1.BtnPutClick(Sender: TObject);
var
  bs: TBlobStream;
begin
  bs:= Nil;
  with Table1 Do
    try
      open;
      first;
      edit;
      bs:= TBlobStream.Create( table1memo, bmwrite );
      Richedit1.plaintext := false;
      Richedit1.Lines.Savetostream(bs);
      post;
    finally
      bs.free;
      close;
    end;
end;

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

Как сохранить содержимое таблицы в текстовый файл?

Эти небольшие функции анализирую таблицу и записывают её содержимое в TStringList. А затем просто сохраняют в файл.

procedure DatasetRecordToInfFile(aDataset: TDataSet; aStrList: TStrings);
var i: integer;
begin
  for i := 0 to (aDataset.FieldCount-1) do
    aStrList.Add(aDataset.Fields[i].FieldName + '=' +
                 aDataset.Fields[i].AsString);
end;

procedure DatasetToInfFile(aDataset: TDataSet; aStrList: TStrings);
begin
  aDataSet.First;
  while not aDataSet.EOF do
  begin
    DatasetRecordToInfFile(aDataset,aStrList);
    aDataSet.Next;
  end;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  DatasetRecordToInfFile(Table1,Memo1.Lines);
end;

procedure TForm1.Button2Click(Sender: TObject);
begin
  DatasetToInfFile(Table1,Memo1.Lines);
end;

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

Как сохранить содержимое TPaintBox в BMP

var
Bitmap: TBitmap;
  Source: TRect;
  Dest: TRect;
begin
  Bitmap := TBitmap.Create;
  try
    with Bitmap do
    begin
      Width := MyPaintBox.Width;
      Height := MyPaintBox.Height;
      Dest := Rect(0, 0, Width, Height);
    end;
    with MyPaintBox do
      Source := Rect(0, 0, Width, Height);
    Bitmap.Canvas.CopyRect(Dest, MyPaintBox.Canvas, Source);
    Bitmap.SaveToFile('MYFILE.BMP');
  finally
    Bitmap.Free;
  end;
end;

Взято из

Как сохранить текст MS Word в другом формате?

Open a new Application and place:

a button named Button3,
a RitchText object named WordEditor
and an OpenDialog component.

From now on, you can browse for any *.doc file and load it into the RitchText object.

NOTE: Format:=6 instructs Word to save the file as RTF. Extension is not enough.

Other File Formats:

Argument Format File Format
0   Normal (Word format)
1   Document Template
2   Text Only (extended characters saved in ANSI character set)
3   Text+Breaks (plain text with line breaks; extended characters saved in ANSI character set)
4   Text Only (PC-8) (extended characters saved in IBM PC character set)
5   Text+Breaks (PC-8) (text with line breaks; extended characters saved in IBM PC character set)
6   Rich-text format (RTF)

procedure TImport_Form.ToolButton3Click(Sender: TObject);
var
  WordApp: Variant;
begin
  if OpenDialog1.Execute then
  begin
    Edit1.Text := ExtractFileName(OpenDialog1.FileName);
    StatusBar1.SimpleText := OpenDialog1.FileName;
    WordApp := CreateOleObject('Word.Basic');
    if not VarIsEmpty(WordApp) then
    begin
      WordApp.FileOpen(OpenDialog1.FileName);
      WordApp.FileSaveAs(Name := 'c:\temp_bb.rtf', Format := 6);
      WordApp.AppClose;
      WordApp := Unassigned;
      WordEditor.Lines.LoadFromFile('c:\temp_bb.rtf');
    end
    else
      ShowMessage('Could not start MS Word');
  end;

end;

How to prevent word from opening password-protected files or resume wizard files and sometimes causing application to hang ?

The sollution is to add the folowing query before openning the document:

if WordApp.ActiveDocument.HasPassword = True then
  MsgBox("Password Protected");

You can even preset the password propery as:

WordApp.Password := 'mypassword";

NOTE: If the above code generates an "Undefined property: ActiveDocument" change the:

CreateOleObject('Word.Basic');

with

CreateOleObject('Word.Application');

Взято с

Delphi Knowledge Base

Как сохранить веб страничку в bitmap?

Взято из FAQ:
Перевод материала с сайта members.home.com/hfournier/webbrowser.htm

procedure TForm1.Button1Click(Sender: TObject);
var
  ViewObject: IViewObject;
  sourceDrawRect: TRect;
begin
if EmbeddedWB1.Document < > nil then
try
EmbeddedWB1.Document.QueryInterface(IViewObject, ViewObject);
if ViewObject < > nil then
try
  sourceDrawRect := Rect(0, 0, Image1.Width, Image1.Height);
  ViewObject.Draw(DVASPECT_CONTENT, 1, nil, nil, Self.Handle,
  image1.Canvas.Handle, @sourceDrawRect, nil, nil, 0);
finally
  ViewObject._Release;
end;
except
end;
end;

Автор: John

Как сохранить веб страничку в jpg?

Взято из FAQ:
Перевод материала с сайта members.home.com/hfournier/webbrowser.htm

procedure generateJPEGfromBrowser(browser: iWebBrowser2; jpegFQFilename: String;
srcHeight: Integer; srcWidth: Integer; tarHeight: Integer; tarWidth: Integer);
var
sourceDrawRect : TRect;
targetDrawRect: TRect;
sourceBitmap: TBitmap;
targetBitmap: TBitmap;
jpeg: TJPEGImage;
viewObject: IViewObject;
begin
sourceBitmap := TBitmap.Create ;
targetBitmap := TBitmap.Create ;
jpeg := TJPEGImage.Create ;
try
try
sourceDrawRect := Rect(0,0, srcWidth , srcHeight );
sourceBitmap.Width := srcWidth ;
sourceBitmap.Height := srcHeight ; viewObject := browser as IViewObject; if viewObject = nil then
Exit; OleCheck(viewObject.Draw(DVASPECT_CONTENT, 1, nil, nil, self.Handle,
sourceBitmap.Canvas.Handle, @sourceDrawRect, nil, nil, 0)); // Изменяем размер исходного битмапа для коне?ного битмапа
targetDrawRect := Rect(0,0, tarWidth, tarHeight);
targetBitmap.Height := tarHeight;
targetBitmap.Width := tarWidth;
targetBitmap.Canvas.StretchDraw(targetDrawRect, sourceBitmap); // Созда?м JPEG из Bitmap и сохраняем его
jpeg.Assign(targetBitmap) ;
makeFileWriteable(jpegFQFilename);
jpeg.SaveToFile (jpegFQFilename);
finally
jpeg.free;
sourceBitmap.free ;
targetBitmap.free;
end;
except
// Обработка ошибок
end;
end;

Автор: Donall Burns

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

How can I save properties of a TList to a stream? I need the entire list to be saved as a whole and not as individual objects.

A TList doesn't have any intrinsic streaming capability built into it, but it is very easy to stream anything that you want with a little elbow grease. Think about it: a stream is data. Classes have properties, whose values are data. It isn't too hard to write property data to a stream. Here's a simple example to get you going. This is but just one of many possible approaches to saving object property data to a stream:

unituStreamableExample;

interface

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

type
  TStreamableObject = class(TPersistent)
  protected
    function ReadString(Stream: TStream): String;
    function ReadLongInt(Stream: TStream): LongInt;
    function ReadDateTime(Stream: TStream): TDateTime;
    function ReadCurrency(Stream: TStream): Currency;
    function ReadClassName(Stream: TStream): ShortString;
    procedure WriteString(Stream: TStream; const Value: String);
    procedure WriteLongInt(Stream: TStream; const Value: LongInt);
    procedure WriteDateTime(Stream: TStream; const Value: TDateTime);
    procedure WriteCurrency(Stream: TStream; const Value: Currency);
    procedure WriteClassName(Stream: TStream; const Value: ShortString);
  public
    constructor CreateFromStream(Stream: TStream);
    procedure LoadFromStream(Stream: TStream); virtual; abstract;
    procedure SaveToStream(Stream: TStream); virtual; abstract;
  end;

  TStreamableObjectClass = class of TStreamableObject;

  TPerson = class(TStreamableObject)
  private
    FName: String;
    FBirthDate: TDateTime;
  public
    constructor Create(const AName: string; ABirthDate: TDateTime);
    procedure LoadFromStream(Stream: TStream); override;
    procedure SaveToStream(Stream: TStream); override;
    property Name: String read FName write FName;
    property BirthDate: TDateTime read FBirthDate write FBirthDate;
  end;

  TCompany = class(TStreamableObject)
  private
    FName: String;
    FRevenues: Currency;
    FEmployeeCount: LongInt;
  public
    constructor Create(const AName: string; ARevenues: Currency; AEmployeeCount: LongInt);
    procedure LoadFromStream(Stream: TStream); override;
    procedure SaveToStream(Stream: TStream); override;
    property Name: String read FName write FName;
    property Revenues: Currency read FRevenues write FRevenues;
    property EmployeeCount: LongInt read FEmployeeCount write FEmployeeCount;
  end;

  TStreamableList = class(TStreamableObject)
  private
    FItems: TObjectList;
    function Get_Count: LongInt;
    function Get_Objects(Index: LongInt): TStreamableObject;
  public
    constructor Create;
    destructor Destroy; override;
    function FindClass(const AClassName: String): TStreamableObjectClass;
    procedure Add(Item: TStreamableObject);
    procedure Delete(Index: LongInt);
    procedure Clear;
    procedure LoadFromStream(Stream: TStream); override;
    procedure SaveToStream(Stream: TStream); override;
    property Objects[Index: LongInt]: TStreamableObject read Get_Objects; default;
    property Count: LongInt read Get_Count;
  end;

  TForm1 = class(TForm)
    SaveButton: TButton;
    LoadButton: TButton;
    procedure SaveButtonClick(Sender: TObject);
    procedure LoadButtonClick(Sender: TObject);
    procedure FormCreate(Sender: TObject);
  private
    { Private declarations }
  public
    Path: String;
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

resourcestring
  DEFAULT_FILENAME = 'test.dat';

procedure TForm1.SaveButtonClick(Sender: TObject);
var
  List: TStreamableList;
  Stream: TStream;
begin
  List := TStreamableList.Create;
  try
    List.Add(TPerson.Create('Rick Rogers', StrToDate('05/20/68')));
    List.Add(TCompany.Create('Fenestra', 1000000, 7));
    Stream := TFileStream.Create(Path + DEFAULT_FILENAME, fmCreate);
    try
      List.SaveToStream(Stream);
    finally
      Stream.Free;
    end;
  finally
    List.Free;
  end;
end;

{ TPerson }

constructor TPerson.Create(const AName: string; ABirthDate: TDateTime);
begin
  inherited Create;
  FName := AName;
  FBirthDate := ABirthDate;
end;

procedure TPerson.LoadFromStream(Stream: TStream);
begin
  FName := ReadString(Stream);
  FBirthDate := ReadDateTime(Stream);
end;

procedure TPerson.SaveToStream(Stream: TStream);
begin
  WriteString(Stream, FName);
  WriteDateTime(Stream, FBirthDate);
end;

{ TStreamableList }

procedure TStreamableList.Add(Item: TStreamableObject);
begin
  FItems.Add(Item);
end;

procedure TStreamableList.Clear;
begin
  FItems.Clear;
end;

constructor TStreamableList.Create;
begin
  FItems := TObjectList.Create;
end;

procedure TStreamableList.Delete(Index: LongInt);
begin
  FItems.Delete(Index);
end;

destructor TStreamableList.Destroy;
begin
  FItems.Free;
  inherited;
end;

function TStreamableList.FindClass(const AClassName: String): TStreamableObjectClass;
begin
  Result :=  TStreamableObjectClass(Classes.FindClass(AClassName));
end;

function TStreamableList.Get_Count: LongInt;
begin
  Result := FItems.Count;
end;

function TStreamableList.Get_Objects(Index: LongInt): TStreamableObject;
begin
  Result := FItems[Index] as TStreamableObject;
end;

procedure TStreamableList.LoadFromStream(Stream: TStream);
var
  StreamCount: LongInt;
  I: Integer;
  S: String;
  ClassRef: TStreamableObjectClass;
begin
  StreamCount := ReadLongInt(Stream);
  for I := 0 to StreamCount - 1 do
  begin
    S := ReadClassName(Stream);
    ClassRef := FindClass(S);
    Add(ClassRef.CreateFromStream(Stream));
  end;
end;

procedure TStreamableList.SaveToStream(Stream: TStream);
var
  I: Integer;
begin
  WriteLongInt(Stream, Count);
  for I := 0 to Count - 1 do
  begin
    WriteClassName(Stream, Objects[I].ClassName);
    Objects[I].SaveToStream(Stream);
  end;
end;

{ TStreamableObject }

constructor TStreamableObject.CreateFromStream(Stream: TStream);
begin
  inherited Create;
  LoadFromStream(Stream);
end;

function TStreamableObject.ReadClassName(Stream: TStream): ShortString;
begin
  Result := ReadString(Stream);
end;

function TStreamableObject.ReadCurrency(Stream: TStream): Currency;
begin
  Stream.Read(Result, SizeOf(Currency));
end;

function TStreamableObject.ReadDateTime(Stream: TStream): TDateTime;
begin
  Stream.Read(Result, SizeOf(TDateTime));
end;

function TStreamableObject.ReadLongInt(Stream: TStream): LongInt;
begin
  Stream.Read(Result, SizeOf(LongInt));
end;

function TStreamableObject.ReadString(Stream: TStream): String;
var
  L: LongInt;
begin
  L := ReadLongInt(Stream);
  SetLength(Result, L);
  Stream.Read(Result[1], L);
end;

procedure TStreamableObject.WriteClassName(Stream: TStream; const Value: ShortString);
begin
  WriteString(Stream, Value);
end;

procedure TStreamableObject.WriteCurrency(Stream: TStream; const Value: Currency);
begin
  Stream.Write(Value, SizeOf(Currency));
end;

procedure TStreamableObject.WriteDateTime(Stream: TStream; const Value: TDateTime);
begin
  Stream.Write(Value, SizeOf(TDateTime));
end;

procedure TStreamableObject.WriteLongInt(Stream: TStream; const Value: LongInt);
begin
  Stream.Write(Value, SizeOf(LongInt));
end;

procedure TStreamableObject.WriteString(Stream: TStream; const Value: String);
var
  L: LongInt;
begin
  L := Length(Value);
  WriteLongInt(Stream, L);
  Stream.Write(Value[1], L);
end;

{ TCompany }

constructor TCompany.Create(const AName: string; ARevenues: Currency;
AEmployeeCount: Integer);
begin
  FName := AName;
  FRevenues := ARevenues;
  FEmployeeCount := AEmployeeCount;
end;

procedure TCompany.LoadFromStream(Stream: TStream);
begin
  FName := ReadString(Stream);
  FRevenues := ReadCurrency(Stream);
  FEmployeeCount := ReadLongInt(Stream);
end;

procedure TCompany.SaveToStream(Stream: TStream);
begin
  WriteString(Stream, FName);
  WriteCurrency(Stream, FRevenues);
  WriteLongInt(Stream, FEmployeeCount);
end;

procedure TForm1.LoadButtonClick(Sender: TObject);
var
  List: TStreamableList;
  Stream: TStream;
  Instance: TStreamableObject;
  I: Integer;
begin
  Stream := TFileStream.Create(Path + DEFAULT_FILENAME, fmOpenRead);
  try
    List := TStreamableList.Create;
    try
      List.LoadFromStream(Stream);
      for I := 0 to List.Count - 1 do
      begin
        Instance := List[I];
        if Instance is TPerson then
          ShowMessage(TPerson(Instance).Name);
        if Instance is TCompany then
          ShowMessage(TCompany(Instance).Name);
      end;
    finally
      List.Free;
    end;
  finally
    Stream.Free;
  end;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
  Path := ExtractFilePath(Application.ExeName);
end;

initialization
  RegisterClasses([TPerson, TCompany]);

end.

Tip by Rick Rogers

Answer 2:
The solution above will work, but it forces you to implement streaming support for each of the TStreamableObject objects. Delphi has already implemented this mechanism in for the TPersistent class and the TComponent class, and you can use this mechanism. The class I include here does the job. It holds classes that inherit from TUmbCollectionItem (which in turn inherits from Delphi TCollectionItem), and handles all the streaming of the items. As the items are written with the Delphi mechanism, all published data is streamed.
Notes: This class does not support working within the delphi IDE like TCollection. All objects inheriting from TUmbCollectionItem must be registered using the Classes.RegisterClass function. All objects inheriting from TUmbCollectionItem must implement the assign function. By default, the TUmbCollection owns its items (frees them when the collection is freed), but this functionality can be changed.
unit UmbCollection;

interface

uses
  Windows, Messages, SysUtils, Classes, contnrs;

type
  TUmbCollectionItemClass = Class of TUmbCollectionItem;
  TUmbCollectionItem = class(TCollectionItem)
  private
    FPosition: Integer;
  public
    {when overriding this method, you must call the inherited assign.}
    procedure Assign(Source: TPersistent); Override;
  published
    {the position property is used by the streaming mechanism to place the object in the
    right position when reading the items. do not use this property.}
    property Position: Integer read FPosition write FPosition;
  end;

  TUmbCollection = class(TObjectList)
  private
    procedure SetItems(Index: Integer; Value: TUmbCollectionItem);
    function GetItems(Index: Integer): TUmbCollectionItem;
  public
    function Add(AObject: TUmbCollectionItem): Integer;
    function Remove(AObject: TUmbCollectionItem): Integer;
    function IndexOf(AObject: TUmbCollectionItem): Integer;
    function FindInstanceOf(AClass: TUmbCollectionItemClass; AExact: Boolean = True;
                                                  AStartAt: Integer = 0): Integer;
    procedure Insert(Index: Integer; AObject: TUmbCollectionItem);

    procedure WriteToStream(AStream: TStream); virtual;
    procedure ReadFromStream(AStream: TStream); virtual;

    property Items[Index: Integer]: TUmbCollectionItem read GetItems write SetItems; default;
  published
    property OwnsObjects;
  end;

implementation

{ TUmbCollection }

function ItemsCompare(Item1, Item2: Pointer): Integer;
begin
  Result := TUmbCollectionItem(Item1).Position - TUmbCollectionItem(Item2).Position;
end;

function TUmbCollection.Add(AObject: TUmbCollectionItem): Integer;
begin
  Result := inherited Add(AObject);
end;

function TUmbCollection.FindInstanceOf(AClass: TUmbCollectionItemClass;
AExact: Boolean; AStartAt: Integer): Integer;
begin
  Result := inherited FindInstanceOf(AClass, AExact, AStartAt);
end;

function TUmbCollection.GetItems(Index: Integer): TUmbCollectionItem;
begin
  Result := inherited Items[Index] as TUmbCollectionItem;
end;

function TUmbCollection.IndexOf(AObject: TUmbCollectionItem): Integer;
begin
  Result := inherited IndexOf(AObject);
end;

procedure TUmbCollection.Insert(Index: Integer; AObject: TUmbCollectionItem);
begin
  inherited Insert(Index, AObject);
end;

procedure TUmbCollection.ReadFromStream(AStream: TStream);
var
  Reader: TReader;
  Collection: TCollection;
  ItemClassName: string;
  ItemClass: TUmbCollectionItemClass;
  Item: TUmbCollectionItem;
  i: Integer;
begin
  Clear;
  Reader := TReader.Create(AStream, 1024);
  try
    Reader.ReadListBegin;
    while not Reader.EndOfList do
    begin
      ItemClassName := Reader.ReadString;
      ItemClass := TUmbCollectionItemClass(FindClass(ItemClassName));
      Collection := TCollection.Create(ItemClass);
      try
        Reader.ReadValue;
        Reader.ReadCollection(Collection);
        for i := 0 to Collection.Count - 1 do
        begin
          item := ItemClass.Create(nil);
          item.Assign(Collection.Items[i]);
          Add(Item);
        end;
      finally
        Collection.Free;
      end;
    end;
    Sort(ItemsCompare);
    Reader.ReadListEnd;
  finally
    Reader.Free;
  end;
end;

function TUmbCollection.Remove(AObject: TUmbCollectionItem): Integer;
begin
  Result := inherited Remove(AObject);
end;

procedure TUmbCollection.SetItems(Index: Integer; Value: TUmbCollectionItem);
begin
  inherited Items[Index] := Value;
end;

procedure TUmbCollection.WriteToStream(AStream: TStream);
var
  Writer: TWriter;
  CollectionList: TObjectList;
  Collection: TCollection;
  ItemClass: TUmbCollectionItemClass;
  ObjectWritten: array of Boolean;
  i, j: Integer;
begin
  Writer := TWriter.Create(AStream, 1024);
  CollectionList := TObjectList.Create(True);
  try
    Writer.WriteListBegin;
    {init the flag array and the position property of the TCollectionItem objects.}
    SetLength(ObjectWritten, Count);
    for i := 0 to Count - 1 do
    begin
      ObjectWritten[i] := False;
      Items[i].Position := i;
    end;
    {write the TCollectionItem objects. we write first the name of the objects class,
    then write all the object of the same class.}
    for i := 0 to Count - 1 do
    begin
      if ObjectWritten[i] then
        Continue;
      ItemClass := TUmbCollectionItemClass(Items[i].ClassType);
      Collection := TCollection.Create(ItemClass);
      CollectionList.Add(Collection);
      {write the items class name}
      Writer.WriteString(Items[i].ClassName);
      {insert the items to the collection}
      for j := i to Count - 1 do
        if ItemClass = Items[j].ClassType then
        begin
          ObjectWritten[j] := True;
          (Collection.Add as ItemClass).Assign(Items[j]);
        end;
      {write the collection}
      Writer.WriteCollection(Collection);
    end;
  finally
    CollectionList.Free;
    Writer.WriteListEnd;
    Writer.Free;
  end;
end;

{ TUmbCollectionItem }

procedure TUmbCollectionItem.Assign(Source: TPersistent);
begin
  if Source is TUmbCollectionItem then
    Position := (Source as TUmbCollectionItem).Position
  else
    inherited;
end;

end.

Tip by Yoav (Yoav@tsoft-tele.com)

Взято из

Как сообщить что-нибудь всем формам моего приложения?

Как сообщить всем формам моего приложения (в том числе и не видимым в данный момент) об изминении каких-то глобальных значений?

Один из способов - создать пользовательское сообщение и использовать метод preform чтобы разослать его всем формам из массива Screen.Forms.

{Code for Unit1}

const
  UM_MyGlobalMessage = WM_USER + 1;

type
  TForm1 = class(TForm)
    Label1: TLabel;
    Button1: TButton;
    procedure FormShow(Sender: TObject);
    procedure Button1Click(Sender: TObject);
  private
  {Private declarations}
    procedure UMMyGlobalMessage(var AMessage: TMessage); message
      UM_MyGlobalMessage;
  public
  {Public declarations}
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

uses Unit2;

procedure TForm1.FormShow(Sender: TObject);
begin
  Form2.Show;
end;

procedure TForm1.UMMyGlobalMessage(var AMessage: TMessage);
begin
  Label1.Left := AMessage.WParam;
  Label1.Top := AMessage.LParam;
  Form1.Caption := 'Got It!';
end;

procedure TForm1.Button1Click(Sender: TObject);
var
  f: integer;
begin
  for f := 0 to Screen.FormCount - 1 do
    Screen.Forms[f].Perform(UM_MyGlobalMessage, 42, 42);
end;

{Code for Unit2}

const
  UM_MyGlobalMessage = WM_USER + 1;
type
  TForm2 = class(TForm)
    Label1: TLabel;
  private
  {Private declarations}
    procedure UMMyGlobalMessage(var AMessage: TMessage);
      message UM_MyGlobalMessage;
  public
  {Public declarations}
  end;

var
  Form2: TForm2;

implementation

{$R *.DFM}

procedure TForm2.UMMyGlobalMessage(var AMessage: TMessage);
begin
  Label1.Left := AMessage.WParam;
  Label1.Top := AMessage.LParam;
  Form2.Caption := 'Got It!';
end;

Как создать БД в кодировке CP1251

CREATEDATABASE Efes2
USING CODESET 1251 TERRITORY RU
COLLATE USING IDENTITY;

Взято из

Как создать Bitmap из массива пикселей

Один из способов создания битмапа из массива пикселей заключается в использовании Windows API функции CreateDiBitmap(). Это позволит использовать один из многих форматов битмапа, которые Windows использует для хранения пикселей. Следующий пример создаёт 256-цветный битмап из массива пикселей. Битмап состит из 256 оттенков серого цвета плавно переходящих от белого к чёрному. Обратите внимание, что Windows резервирует первые и последние 10 цветов для системных нужд, поэтому Вы можете получить максимум 236 оттенков серого.

{$IFNDEF WIN32}
type
{Used for pointer math under Win16}
  PPtrRec = ^TPtrRec;
  TPtrRec = record
    Lo : Word;
    Hi : Word;
  end;
{$ENDIF}

{Used for huge pointer math}
function GetBigPointer(lp : pointer;
                       Offset : Longint) : Pointer;
begin
{$IFDEF WIN32}
  GetBigPointer := @PByteArray(lp)^[Offset];
{$ELSE}
  Offset := Offset + TPtrRec(lp).Lo;
  GetBigPointer := Ptr(TPtrRec(lp).Hi + TPtrRec(Offset).Hi *
                       SelectorInc,
                       TPtrRec(Offset).Lo);
{$ENDIF}
end;

procedure TForm1.Button1Click(Sender: TObject);
var
  hPixelBuffer : THandle; {Handle to the pixel buffer}
  lpPixelBuffer : pointer; {pointer to the pixel buffer}
  lpPalBuffer : PLogPalette; {The palette buffer}
  lpBitmapInfo : PBitmapInfo; {The bitmap info header}
  BitmapInfoSize : longint; {Size of the bitmap info header}
  BitmapSize : longint; {Size of the pixel array}
  PaletteSize : integer; {Size of the palette buffer}
  i : longint; {loop variable}
  j : longint; {loop variable}
  OldPal : hPalette; {temp palette}
  hPal : hPalette; {handle to our palette}
  hBm : hBitmap; {handle to our bitmap}
  Bm : TBitmap; {temporary TBitmap}
  Dc : hdc; {used to convert the DOB to a DDB}
  IsPaletteDevice : bool;
begin
Application.ProcessMessages;
{If range checking is on - turn it off for now}
{we will remember if range checking was on by defining}
{a define called CKRANGE if range checking is on.}
{We do this to access array members past the arrays}
{defined index range without causing a range check}
{error at runtime. To satisfy the compiler, we must}
{also access the indexes with a variable. ie: if we}
{have an array defined as a: array[0..0] of byte,}
{and an integer i, we can now access a[3] by setting}
{i := 3; and then accessing a[i] without error}
{$IFOPT R+}
  {$DEFINE CKRANGE}
  {$R-}
{$ENDIF}

{Lets check to see if this is a palette device - if so, then}
{we must do palette handling for a successful operation.}
{Get the screen's dc to use since memory dc's are not reliable}
  dc := GetDc(0);
  IsPaletteDevice :=
    GetDeviceCaps(dc, RASTERCAPS) and RC_PALETTE = RC_PALETTE;
{Give back the screen dc}
  dc := ReleaseDc(0, dc);

{Размер информации о рисунке должен равняться размеру BitmapInfo}
{плюс размер таблицы цветов, минус одна таблица}
{так как она уже объявлена в TBitmapInfo}
  BitmapInfoSize := sizeof(TBitmapInfo) + (sizeof(TRGBQUAD) * 255);

{The bitmap size must be the width of the bitmap rounded}
{up to the nearest 32 bit boundary}
  BitmapSize := (sizeof(byte) * 256) * 256;

{Размер палитры должен равняться размеру TLogPalette}
{плюс количество ячеек цветовой палитры - 1, так как}
{одна палитра уже объявлена в TLogPalette}
  if IsPaletteDevice then
   PaletteSize := sizeof(TLogPalette) + (sizeof(TPaletteEntry) * 255);

{Выделяем память под BitmapInfo, PixelBuffer, и Palette}
  GetMem(lpBitmapInfo, BitmapInfoSize);
  hPixelBuffer := GlobalAlloc(GHND, BitmapSize);
  lpPixelBuffer := GlobalLock(hPixelBuffer);

  if IsPaletteDevice then
    GetMem(lpPalBuffer, PaletteSize);

{Заполняем нулями BitmapInfo, PixelBuffer, и Palette}
  FillChar(lpBitmapInfo^, BitmapInfoSize, #0);
  FillChar(lpPixelBuffer^, BitmapSize, #0);
  if IsPaletteDevice then
    FillChar(lpPalBuffer^,PaletteSize, #0);

{Заполняем структуру BitmapInfo}
  lpBitmapInfo^.bmiHeader.biSize := sizeof(TBitmapInfoHeader);
  lpBitmapInfo^.bmiHeader.biWidth := 256;
  lpBitmapInfo^.bmiHeader.biHeight := 256;
  lpBitmapInfo^.bmiHeader.biPlanes := 1;
  lpBitmapInfo^.bmiHeader.biBitCount := 8;
  lpBitmapInfo^.bmiHeader.biCompression := BI_RGB;
  lpBitmapInfo^.bmiHeader.biSizeImage := BitmapSize;
  lpBitmapInfo^.bmiHeader.biXPelsPerMeter := 0;
  lpBitmapInfo^.bmiHeader.biYPelsPerMeter := 0;
  lpBitmapInfo^.bmiHeader.biClrUsed := 256;
  lpBitmapInfo^.bmiHeader.biClrImportant := 256;

{Заполняем таблицу цветов BitmapInfo оттенками серого: от чёрного до белого}
  for i := 0 to 255 do begin
    lpBitmapInfo^.bmiColors[i].rgbRed := i;
    lpBitmapInfo^.bmiColors[i].rgbGreen := i;
    lpBitmapInfo^.bmiColors[i].rgbBlue := i;
  end;

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

Как создать цветовую паллитру

Below are functions that help to create a palette (an identity palette, BTW) from an array of RGBQuads (such as you would find in the palette section of a .BMP file). I stole this from the WinG documentation, and converted it to Delphi. First call ClearSystemPalette, then you can get an identity palette by calling CreateIdentityPalette. If you plan to try palette animation, work in a 256-color mode, and change all the PC_NOCOLLAPSE entries below to PC_RESERVED. Besides creating the palette, the other pieces to the puzzle are:

1. Override the form's GetPalette method, so that it returns the new palette.

2. Select and realize the new palette just before you paint.

OldPal:= SelectPalette(Canvas.Handle, NewPalette, False);
RealizePalette(Canvas.Handle);
{ Do your painting here }
SelectPalette(Canvas.Handle, OldPal, False);

3. Remember to release the palette when you are done using DeleteObject

4. If you are used using the RGB function to get color values, use the PaletteRGB function in its place.

function CreateIdentityPalette(const aRGB; nColors: Integer): HPALETTE;
type
  QA = array[0..255] of TRGBQUAD;
var
  Palette: PLOGPALETTE;
  PalSize: Word;
  ScreenDC: HDC;
  I: Integer;
  nStaticColors: Integer;
  nUsableColors: Integer;
begin
  PalSize := SizeOf(TLOGPALETTE) + SizeOf(TPALETTEENTRY) * 256;
  GetMem(Palette, PalSize);
  try
    with Palette^ do
    begin
      palVersion := $0300;
      palNumEntries := 256;
      ScreenDC := GetDC(0);
      try
        { For SYSPAL_NOSTATIC, just copy the color table into a PALETTEENTRY
          array and replace the first and last entries with black and white }
        if (GetSystemPaletteUse(ScreenDC) = SYSPAL_NOSTATIC) then
        begin
          { Fill in the palette with the given values, marking each with PalFlag }

{$R-}
          for i := 0 to (nColors - 1) do
            with palPalEntry[i], QA(aRGB)[I] do
            begin
              peRed := rgbRed;
              peGreen := rgbGreen;
              peBlue := rgbBlue;
              peFlags := PC_NOCOLLAPSE;
            end;
          { Mark any unused entries with PalFlag }
          for i := nColors to 255 do
            palPalEntry[i].peFlags := PC_NOCOLLAPSE;
          { Make sure the last entry is white -- This may replace an entry in the array!}
          I := 255;
          with palPalEntry[i] do
          begin
            peRed := 255;
            peGreen := 255;
            peBlue := 255;
            peFlags := 0;
          end;
          { And the first is black -- This may replace an entry in the array!}
          with palPalEntry[0] do
          begin
            peRed := 0;
            peGreen := 0;
            peBlue := 0;
            peFlags := 0;
          end;
{$R+}
        end
        else
        begin
          { For SYSPAL_STATIC, get the twenty static colors into the
            array, then fill in the empty spaces with the given color table }

          { Get the static colors from the system palette }
          nStaticColors := GetDeviceCaps(ScreenDC, NUMRESERVED);
          GetSystemPaletteEntries(ScreenDC, 0, 256, palPalEntry);
{$R-}
          { Set the peFlags of the lower static colors to zero }
          nStaticColors := nStaticColors shr 1;
          for i := 0 to (nStaticColors - 1) do
            palPalEntry[i].peFlags := 0;
          { Fill in the entries from the given color table}
          nUsableColors := nColors - nStaticColors;
          for I := nStaticColors to (nUsableColors - 1) do
            with palPalEntry[i], QA(aRGB)[i] do
            begin
              peRed := rgbRed;
              peGreen := rgbGreen;
              peBlue := rgbBlue;
              peFlags := PC_NOCOLLAPSE;
            end;
          { Mark any empty entries as PC_NOCOLLAPSE }
          for i := nUsableColors to (255 - nStaticColors) do
            palPalEntry[i].peFlags := PC_NOCOLLAPSE;
          { Set the peFlags of the upper static colors to zero }
          for i := (256 - nStaticColors) to 255 do
            palPalEntry[i].peFlags := 0;
        end;
      finally
        ReleaseDC(0, ScreenDC);
      end;
    end;
    { Return the palette }
    Result := CreatePalette(Palette^);
  finally
    FreeMem(Palette, PalSize);
  end;
end;

procedure ClearSystemPalette;
var
  Palette: PLOGPALETTE;
  PalSize: Word;
  ScreenDC: HDC;
  I: Word;
const
  ScreenPal: HPALETTE = 0;
begin
  PalSize := SizeOf(TLOGPALETTE) + SizeOf(TPALETTEENTRY) * 255; {256th = [0] }
  GetMem(Palette, PalSize);
  try
    FillChar(Palette^, PalSize, 0);
    Palette^.palVersion := $0300;
    Palette^.palNumEntries := 256;
{$R-}
    for I := 0 to 255 do
      with Palette^.palPalEntry[I] do
        peFlags := PC_NOCOLLAPSE;
{$R+}
    { Create, select, realize, deselect, and delete the palette }
    ScreenDC := GetDC(0);
    try
      ScreenPal := CreatePalette(Palette^);
      if ScreenPal <> 0 then
      begin
        ScreenPal := SelectPalette(ScreenDC, ScreenPal, FALSE);
        RealizePalette(ScreenDC);
        ScreenPal := SelectPalette(ScreenDC, ScreenPal, FALSE);
        DeleteObject(ScreenPal);
      end;
    finally
      ReleaseDC(0, ScreenDC);
    end;
  finally
    FreeMem(Palette, PalSize);
  end;
end;

unit VideoFcns;

interface
uses Windows;

procedure GrayColorTable(const clrtable: PRGBQUAD; const threshold: integer = -1);
procedure BinaryColorTable(const clrtable: PRGBQUAD; const threshold: integer);

implementation

procedure GrayColorTable(const clrtable: PRGBQUAD; const threshold: integer);
var
  j: integer;
  cp: PRGBQUAD;
begin
  if threshold <> -1 then
  begin
    BinaryColorTable(clrtable, threshold);
    exit;
  end;
  cp := clrtable;
  for j := 0 to 255 do
  begin
    {here you can set rgb components the way you like}
    cp^.rgbBlue := j;
    cp^.rgbGreen := j;
    cp^.rgbRed := j;
    cp^.rgbReserved := 0;
    inc(cp);
  end;
end;

procedure BinaryColorTable(const clrtable: PRGBQUAD; const threshold: integer);
var
  j: integer;
  g: integer;
  cp: PRGBQUAD;
begin
  cp := clrtable;
  for j := 0 to 255 do
  begin
    if j < threshold then
      g := 0
    else
      g := 255;
    cp^.rgbBlue := g;
    cp^.rgbGreen := g;
    cp^.rgbRed := g;
    cp^.rgbReserved := 0;
    inc(cp);
  end;
end;

Here is an example how palette is used:

procedure TBmpByteImage.FillBMPInfo(BMPInfo: pointer; const Wi, He: integer);
var
  p: ^TBitmapInfo;
begin
  p := BMPInfo;
  p^.bmiHeader.biSize := sizeof(p.bmiHeader);
  if Wi <> 0 then
    p^.bmiHeader.biWidth := Wi
  else
    p^.bmiHeader.biWidth := w;
  if He <> 0 then
    p^.bmiHeader.biHeight := He
  else
    p^.bmiHeader.biHeight := h;
  p^.bmiHeader.biPlanes := 1;
  p^.bmiHeader.biBitCount := 8;
  p^.bmiHeader.biCompression := BI_RGB;
  p^.bmiHeader.biClrUsed := 0;
  p^.bmiHeader.biClrImportant := 0;
end;

function TBmpByteImage.CreateDIB(const threshold: integer): HBITMAP;
var
  dc: HDC;
  bmpInfo: ^TBitmapInfo;
  BMPData: pointer;
  hBmp: HBITMAP;
  x, y: integer;
  cp1, cp2: pbyte;
begin
  GetMem(bmpInfo, sizeof(bmpInfo.bmiHeader) + sizeof(RGBQUAD) * 256);
  FillBMPInfo(BMPInfo);
  {I am using a grey palette}
  GrayColorTable(@bmpInfo^.bmiColors[0], threshold);
  dc := CreateDC('DISPLAY', nil, nil, nil);
  hBmp := CreateDIBSection(dc, bmpInfo^, DIB_RGB_COLORS, BMPData, 0, 0);
  DeleteDC(dc);
  FreeMem(bmpInfo, sizeof(bmpInfo.bmiHeader) + sizeof(RGBQUAD) * 256);
  cp2 := BMPData;
  for y := h - 1 downto 0 do
  begin
    cp1 := @g^[y]^[0];
    for x := 0 to w - 1 do
    begin
      cp2^ := cp1^;
      inc(cp1);
      inc(cp2);
    end;
  end;
  CreateDIB := hBmp;
end;

{and  finally draw bitmap }

procedure TBmpByteImage.Draw(const where: TImage; const threshold: integer);
var
  hBmp: HBITMAP;
  Bitmap1: TBitmap;
begin
  hBmp := CreateDIB(threshold);
  if hBmp = 0 then
    exit;
  Bitmap1 := TBitmap.Create;
  with Bitmap1 do
  begin
    Handle := hBmp;
    Width := w;
    Height := h;
  end;
  where.picture.Bitmap := Bitmap1;
  Bitmap1.Free;
  GlobalFree(hBmp);
end;

Взято с

Delphi Knowledge Base

var
  Form1: TForm1;
  blueVal: Byte;
  BluePalette: HPalette;
implementation

{$R *.DFM}

procedure TForm1.FormCreate(Sender: TObject);
var

  LogicalPalette: PLogPalette;
  ColorIndex: LongInt;
begin
  GetMem(LogicalPalette, (SizeOf(TLogPalette) + SizeOf(TPaletteEntry) * 256));
  GetSystemPaletteEntries(Canvas.Handle, 0, 256,
    LogicalPalette^.palPalEntry[0]);
  with LogicalPalette^ do

  begin
    palVersion := $300;
    palNumEntries := 256;
{$R-}
    for ColorIndex := 10 to 245 do
      with palPalEntry[ColorIndex] do
      begin
        peRed := 0;
        peGreen := 0;
        peBlue := 255 - (ColorIndex - 10);
        peFlags := PC_NOCOLLAPSE;
      end;
  end;
{$R+}
  BluePalette := CreatePalette(LogicalPalette^);
  FreeMem(LogicalPalette, (SizeOf(TLogPalette) + SizeOf(TPaletteEntry) * 256));
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin

  DeleteObject(BluePalette);
end;

procedure TForm1.FormMouseDown(Sender: TObject; Button: TMouseButton;

  Shift: TShiftState; X, Y: Integer);
var

  OldPal: HPALETTE;
begin

  OldPal := SelectPalette(Canvas.Handle, BluePalette, False);
  RealizePalette(Canvas.Handle);
  canvas.pen.color := $02000000 or (BlueVal * $00010000);
  canvas.pen.width := 10;
  canvas.moveto(0, 0);
  canvas.lineto(X, Y);
  SelectPalette(Canvas.Handle, OldPal, False);
  Inc(BlueVal);

  if BlueVal > 255 then
    BlueVal := 0;
end;

Взято из

Как создать DBase базу данных?

procedureMakeDataBase;
begin
  with TTable.Create(nil) do
  begin
    DatabaseName := 'c:\temp'; (* alias *)
    TableName := 'test.dbf';
    TableType := ttDBase;
    with FieldDefs do
    begin
      Add('F_NAME', ftString, 20, false);
      Add('L_NAME', ftString, 30, false);
    end;
    CreateTable;
    { create a calculated index }
    with IndexDefs do
    begin
      Clear;
      { don't forget ixExpression in calculated indexes! }
      AddIndex('name', 'Upper(L_NAME)+Upper(F_NAME)', [ixExpression]);
    end;
  end;
end;

Взято с

Delphi Knowledge Base

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

Данная процедура полезна для создания временных таблиц :

procedure MakeDataBase;
begin
   with TTable.Create(nil) do
   begin
     DatabaseName  := 'c:\temp';  (* alias *)
     TableName     := 'test.dbf';
     TableType     := ttDBase;
     with FieldDefs do
     begin
       Add('F_NAME', ftString,20,false);
       Add('L_NAME', ftString,30,false);
     end;
     CreateTable;
     { create a calculated index }
     with IndexDefs do
     begin
       Clear;
       { don't forget ixExpression in calculated indexes! }
       AddIndex('name','Upper(L_NAME)+Upper(F_NAME)',[ixExpression]);
     end;
   end;
end;

Взято из

Как создать disable битмап из обычного (emboss etc)?

CreateMappedBitmap() :-)

Один из паpаметpов yказатель на COLORMAP, в нем для 16 основных цветов делаешь
пеpекодиpовкy, цвета подбеpешь сам из пpинципа:
все самые яpкие -> в GetSysColor( COLOR_3DLIGHT );
самые темные -> GetSysColor( COLOR_3DSHADOW );
нейтpальные, котpые бyдyт пpозpачные -> GetSysColor( COLOR_3DFACE );

Serge Zakharchuk
(2:5060/32)

procedure Tform1.aaa(bmpFrom,bmpTo:Tbitmap);
var
  TmpImage,Monobmp:TBitmap;
  IRect:TRect;
begin
  MonoBmp := TBitmap.Create;
  TmpImage:=Tbitmap.Create;
  TmpImage.Width := bmpFrom.Width;
  TmpImage.Height := bmpFrom.Height;
  IRect := Rect(0, 0, bmpFrom.Width, bmpFrom.Height);
  TmpImage.Canvas.Brush.Color := clBtnFace;
  try
    with MonoBmp do
    begin
      Assign(bmpFrom);
      Canvas.Brush.Color := clBlack;
      if Monochrome then

      begin
        Canvas.Font.Color := clWhite;
        Monochrome := False;
        Canvas.Brush.Color := clWhite;
      end;
      Monochrome := True;
    end;
    with TmpImage.Canvas do
    begin
      Brush.Color := clBtnFace;
      FillRect(IRect);
      Brush.Color := clBlack;
      Font.Color := clWhite;
      CopyMode := MergePaint;
      Draw(IRect.Left + 1, IRect.Top + 1, MonoBmp);
      CopyMode := SrcAnd;
      Draw(IRect.Left, IRect.Top, MonoBmp);

      Brush.Color := clBtnShadow;
      Font.Color := clBlack;
      CopyMode := SrcPaint;
      Draw(IRect.Left, IRect.Top, MonoBmp);
      CopyMode := SrcCopy;
      bmpTo.assign(TmpImage);
      TmpImage.free;
    end;
  finally
    MonoBmp.Free;
  end;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  aaa(image1.picture.bitmap,image2.picture.bitmap);
  Image2.invalidate;
end;

Писал это не я. Это написал сам Борланд (некузявно было бы взглянуть на класс TButtonGlyph. Как раз из него я это и выдернул).

Hу а если уже совсем хорошо разобраться, то можно заметить функцию
ImageList_DrawEx, в которой можно на 25 и 50 процентов уменьшить яркость
(но визуально это очень плохо воспринимается). Соответственно
параметры ILD_BLEND25, ILD_BLEND50, ILD_BLEND-A-MED. Естественно, что
последний абзац работает только с тройкой.

Denis Tanayeff
denis@demo.ru

Это кусочек из рабочей проги на Си, Вроде все лишнее я убрал.

#define CO_GRAY         0x00C0C0C0L

hMemDC      =       CreateCompatibleDC(hDC);
hOldBitmap  =   SelectObject(hMemDC, hBits);

   //  hBits это собственно картинка, которую надо "засерить"

GetObject(hBits, sizeof(Bitmap), (LPSTR) &Bitmap);

if ( GetState(BS_DISABLED) ) // Blt disabled
{
    hOldBrush = SelectObject(hDC, CreateSolidBrush(CO_GRAY));//CO_GRAY

    PatBlt(hDC, BD_BORDERWIDTH, BD_BORDERWIDTH, Bitmap.bmWidth,
            Bitmap.bmHeight, PATCOPY);

    DeleteObject(SelectObject(hDC, hOldBrush));

    lbLogBrush.lbStyle = BS_PATTERN;
    lbLogBrush.lbHatch =(int)LoadBitmap(hInsts,
MAKEINTRESOURCE(BT_DISABLEBITS));
    hOldBrush = SelectObject(hDC, CreateBrushIndirect(&lbLogBrush));

    BitBlt(hDC, BD_BORDERWIDTH, BD_BORDERWIDTH, Bitmap.bmWidth,
                Bitmap.bmHeight, hMemDC, 0, 0, 0x00A803A9UL); // DPSoa

    DeleteObject(SelectObject(hDC, hOldBrush));
    DeleteObject((HGDIOBJ)lbLogBrush.lbHatch);

}

Andy Nikishin
http://www.gs.ru/~links/andy.shtml
(2:5031/16.2)

Как создать DLL для MS Excel?

Problem/Question/Abstract:

How do I make delphi functions available to Excel users?

I have seen many articles telling how to control Excel from within Delphi. However, it is also appealing to give Excel users (which tend to be far less programming oriented guys) the power of tools built with Dephi, its flexibility and velocity.

Answer:

The idea is very simple and is based upon the variable types that are common to Excel's VBA and to Delphi. Those include 32 bit integer, double precision floating point and, mainly, Excel ranges.

I found that Excel sometimes interprets incorrectly simple types when passed by reference and thus I limmited their usage to value parameters.
On the other hand, ranges can only be passed by reference and can be read from but not written to. This means that, within Delphi, you must use the reserved word CONST instead of VAR.

First, I defined within a simple unit a set of functions that convert simple Variant types to simple types and viceversa. Those are IntToVar,Double and VarTodouble (the real unit also includes a StrToVar function but not a VarToStr since this one is already included in the System unit), and are used within the procedures that do the real work (RangeToMatrix, RangeToVector,VectorToMatrix and VectortoRange).
All these functions (along with some others that you might find useful) are put together in a unit called "_Variants" whose source code is copied here (with some slight modifications).

In the real unit you will find that there fucntions that provide conversion between Excel ranges and SDL delphi component suite which I have found to be quite useful (refer to www.lohninger.com).

I shall restrict the examples, however to standard types.

Lets take first a simple function:
This function, called gamma_alfa, takes as input the mean and the variance of a population and returns the alfa parameter of a gamma distribution.

In Excel's VBA it is declared as
Declare Function gamma_alfa Lib "c:\archivos\del_files\f_auxiliares_delphi" Alias "gamma_alfa_XL" (ByVal media As Double, ByVal varianza As Double) As Double

note the lib statement that refers to name that the DLL actually has.
note also the ByVal modifiers used for declaring the variables as well as the "as double" statements.
These mean that both the input and the output will be simple types of type double.

In Delphi, the function is declared as
function gamma_alfa(media, varianza : double) : Double;stdcall;

Note the stdcall at the end of the declaration. This is to ensure that Delphi will use the Microsoft calling convention

Also note the inconsistency between the delphi function's name and the "alias" statement in VBA.
This is set in the export clause of the DLL:

exports...,
        gamma_alfa     name 'gamma_alfa_XL',
...;

Although irrelevant, the implementation of the function follows:

implementation

function gamma_alfa(media, varianza: double): Double; stdcall;
begin
  gamma_alfa := media * media / varianza;
end;

Now, let's go to the tough stuff: sending Excel ranges as parameters.
Now, I will make use of a function that gets and returns excel ranges as parameters:
This function is called gamma_parametros and takes as input an histogram (with frequencies and class markers) and returns the alfa and beta parameters for a gamma. Here is its VBA declaration:

Declare Function gamma_parametros Lib "c:\archivos\del_files\f_auxiliares_delphi" Alias "gamma_parametros_XL" (ByRef marcas_de_clase As Variant, ByRef frecuencias As Variant) As Variant

Now note hte "Byref" and the as "Variant" types.

In Delphi, the function is declared as follows:

function gamma_parametros_XL(const _marcas_de_clase, _frecuencias: Variant): Variant;
  stdcall;

and is implemented as:

function gamma_parametros_XL(const _marcas_de_clase, _frecuencias: Variant): Variant;
  stdcall;
var
  marcas_de_clase, frecuencias, pars: TVector_;
  pars_: Variant;
begin
  RangeToVector(_marcas_de_clase, marcas_de_clase);
  RangeToVector(_frecuencias, frecuencias);
  pars := gamma_parametros(marcas_de_clase, frecuencias);
  VectorToRange(pars, pars_);
  gamma_parametros_XL := pars_;
end;

Note that the functions that does the real work is not gamma_parametros_XL but gamma_parametros. The former only does the job of converting Excel ranges to TVector_ and viceversa.

the exports clause exports gamma_parametros_XL, since it's the one that is replicated in the VBA definition, and thus it does not need a 'name' clause.

Here is the implementation of the gamma_parametros function:

function gamma_parametros(const marcas_de_clase, frecuencias: TVector_): TVector_;
var
  pars: TVector_;
  mu, sigmac: double;
begin
  SetLength(pars, 2);
  mu := media_ponderada(marcas_de_clase, frecuencias);
  sigmac := varianza_ponderada(marcas_de_clase, frecuencias);
  pars[0] := gamma_alfa(mu, sigmac);
  pars[1] := gamma_beta(mu, sigmac);
  gamma_parametros := pars;
end;

Here is the listing of the _Variants unit:

interface
uses SysUtils,
  excel97,
  vector,
  matrix,
  Classes,
  Dialogs,
  registry,
  windows;

type

  tmatriz = array of array of double;
  tvector_ = array of double;

function IntToVar(dato: longint): variant;
function DoubleToVar(dato: double): variant;

function VarToDouble(const dato: variant): double;

procedure RangeToMatrix(const rango: variant; var matriz: tmatriz);
procedure RangeToVector(const rango: variant; var matriz: tvector_);
procedure MatrixToRange(const matriz: tmatriz; var rango: variant);
procedure VectorToRange(const matriz: tvector_; var rango: variant);

procedure transpose(var matriz: tmatriz);

implementation

function IntToVar(dato: longint): variant;
var
  temp: variant;
begin
  tvardata(temp).vtype := VarInteger;
  tvardata(temp).Vinteger := dato;
  IntToVar := temp;
end;

function DoubleToVar(dato: double): variant;
var
  temp: variant;
begin
  tvardata(temp).vtype := VarDouble;
  tvardata(temp).VDouble := dato;
  DoubleToVar := temp;
end;

function VarToDouble(const dato: variant): double;
var
  temp: variant;
begin
  try
    temp := varastype(dato, vardouble);
  except
    on EVariantError do
    begin
      tvardata(temp).vtype := vardouble;
      tvardata(temp).vdouble := 0.0;
    end;
  end;
  VarToDouble := tvardata(temp).vdouble;
end;

procedure RangeToMatrix(const rango: variant; var matriz: tmatriz);
var
  Rows, Columns: longint;
  i, j: longint;
begin
  if ((tvardata(rango).vtype and vararray) = 0) and
    ((tvardata(rango).vtype and vartypemask) = vardispatch) then
  begin
    Rows := Rango.rows.count;
    Columns := Rango.columns.count;
    SetLength(matriz, Rows);
    for i := 0 to Rows - 1 do
      SetLength(matriz[i], Columns);
    for i := 0 to Rows - 1 do
      for J := 0 to Columns - 1 do
        matriz[i, j] := VarToDouble(Rango.cells[i + 1, j + 1]);
  end
  else if ((tvardata(rango).vtype and vararray) <> 0) then
  begin
    rows := vararrayhighbound(rango, 1) - vararraylowbound(rango, 1) + 1;
    if VarArrayDimCount(rango) = 2 then
    begin
      columns := vararrayhighbound(rango, 2) - vararraylowbound(rango, 2) + 1;
      setLength(matriz, rows);
      for i := 0 to Rows - 1 do
        SetLength(matriz[i], Columns);
      for i := 0 to Rows - 1 do
        for J := 0 to Columns - 1 do
          matriz[i, j] := vartodouble(rango[i + 1, j + 1]);
    end
    else
    begin
      setlength(matriz, 1);
      setlength(matriz[0], rows);
      for i := 0 to rows - 1 do
        matriz[0, i] := vartodouble(rango[i + 1]);
    end;
  end
  else
  begin
    rows := 1;
    columns := 1;
    setLength(matriz, rows);
    setLength(matriz[0], columns);
    matriz[0, 0] := vartodouble(rango);
  end
end;

procedure RangeToVector(const rango: variant; var matriz: tvector_);
var
  Rows, columns: longint;
  i, j: longint;
begin
  if ((tvardata(rango).vtype and vararray) = 0) and
    ((tvardata(rango).vtype and vartypemask) = vardispatch) then
  begin
    Rows := Rango.count;
    SetLength(matriz, Rows);
    for i := 0 to Rows - 1 do
      matriz[i] := VarToDouble(Rango.cells[i + 1]);
  end
  else if ((tvardata(rango).vtype and vararray) <> 0) then
  begin
    rows := vararrayhighbound(rango, 1) - vararraylowbound(rango, 1) + 1;
    if VarArrayDimCount(rango) = 1 then
    begin
      setLength(matriz, rows);
      for i := 0 to rows - 1 do
        matriz[i] := vartodouble(rango[i + 1]);
    end
    else
    begin
      columns := vararrayhighbound(rango, 2) - vararraylowbound(rango, 2) + 1;
      setlength(Matriz, Columns * Rows);
      for i := 1 to rows do
        for j := 1 to columns do
        try
          matriz[(i - 1) * columns + j] := VarToDouble(rango[i, j]);
        except
          on EVariantError do
            matriz[(i - 1) * columns + j] := 0;
        end;
    end
  end
  else
  begin
    rows := 1;
    setLength(matriz, rows);
    matriz[0] := vartodouble(rango);
  end;
end;

procedure MatrixToRange(const matriz: tmatriz; var rango: variant);
var
  Rows, Columns: longint;
  i, j: longint;
begin
  Rows := high(matriz) - low(matriz) + 1;
  Columns := high(matriz[0]) - low(matriz[0]) + 1;
  rango := VarArrayCreate([1, Rows, 1, Columns], varDouble);
  for i := 1 to Rows do
    for j := 1 to Columns do
      rango[i, j] := matriz[i - 1, j - 1];
end;

procedure VectorToRange(const matriz: tvector_; var rango: variant);
var
  Rows: longint;
  i: longint;
begin
  Rows := high(matriz) - low(matriz) + 1;
  rango := VarArrayCreate([1, Rows], varDouble);
  for i := 1 to Rows do
    rango[i] := matriz[i - 1];
end;

procedure transpose(var matriz: tmatriz);
var
  Rows, Columns,
    i, j: longint;
  temp: double;
begin
  Rows := high(matriz) - low(matriz) + 1;
  Columns := high(matriz[0]) - low(matriz[0]) + 1;
  for i := 0 to rows - 1 do
    for j := i to columns - 1 do
    begin
      temp := matriz[i, j];
      matriz[i, j] := matriz[j, i];
      matriz[j, i] := temp;
    end;
end;

end.

One final warning note:

Notice that the types' names in VBA are NOT the same as in Delphi.
The two must obvious are BOOLEAN (which in VBA is a 2 byte type whereas in Delphi is a one byte type). Thus you MUST use WORDBOOL in Delphi.
The other obvious type is INTEGER (in DElphi is a 4-byte type and in VBA a 2-byte type). To avoid confussion use LONGINT in Delphi and LONG in VBA

I will be more than glad to send you the full source code of the _Variant unit

Взято с

Delphi Knowledge Base

Как создать DLL только с ресурсами?

Создайте и откомпилируйте пустой проект DLL, который содержит ссылку на файл ресурсов .res, который содержит Ваши ресурсы.

library ResTest;
uses
  SysUtils;

{$R MYRES.RES}

begin
end.

Для использования такой DLL, просто загрузите dll и ресурсы, которые Вы будете использовать:

Пример:

{$IFDEF WIN32}
const BadDllLoad = 0;
{$ELSE}
const BadDllLoad = 32;
{$ENDIF}

procedure TForm1.Button1Click(Sender: TObject);
var
  h : THandle;
  Icon : THandle;

begin
  h := LoadLibrary('RESTEST.DLL');

  if h <= BadDllLoad then
    ShowMessage('Bad Dll Load')
  else begin
    Icon := LoadIcon(h, 'ICON_1');
    DrawIcon(Form1.Canvas.Handle, 10, 10, Icon);
    FreeLibrary(h);
  end;
end;

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

Как создать форму в форме элипса?

procedureTForm1.FormCreate(Sender: TObject);
var
  Region: HRGN;
begin
  Region := CreateEllipticRgn(0, 0, 300, 300);
  SetWindowRgn(Handle, Region, True);
end;

Взято с

Delphi Knowledge Base

Как создать Help file?

Есть MS Help Compiler - он создаёт help файлы разных форматов. Сам он не удобный, есть множество оболочек и визуальных дизайнеров. Мне больше всего нравится "Help and Manual" - всё очень просто, визуально и интуитивно понятно.

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

Как создать и вызвать модальную форму?

ModalForm := TModalForm.Create(Self);
try
ModalForm.ShowModal;
finally
ModalForm.Free;
end;

Как создать каретку свой собственной формы?

{
  The example below demonstrates creating custom caret:
}

unit Unit1;

interface

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

type
  TForm1 = class(TForm)
    Memo1: TMemo;
    Image1: TImage;
    Edit1: TEdit;
    procedure Memo1MouseDown(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
    procedure Edit1MouseDown(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.Memo1MouseDown(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
  CreateCaret(Memo1.Handle, Image1.Picture.Bitmap.Handle, 0, 0);
  ShowCaret(Memo1.Handle);
end;

procedure TForm1.Edit1MouseDown(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
  CreateCaret(Edit1.Handle, 0, 10, 4);
  ShowCaret(Edit1.Handle);
end;

end.

{The form file source (*.dfm) }

object Form1: TForm1
  Left = 192
  Top = 107
  Width = 544
  Height = 375
  Caption = 'Form1'
  Color = clBtnFace
  Font.Charset = DEFAULT_CHARSET
  Font.Color = clWindowText
  Font.Height = -11
  Font.Name = 'MS Sans Serif'
  Font.Style = []
  OldCreateOrder = False
  PixelsPerInch = 96
  TextHeight = 13
  object Image1: TImage
    Left = 12
    Top = 4
    Width = 16
    Height = 16
    AutoSize = True
    Picture.Data = {
      07544269746D6170B6020000424DB602000000000000B6000000280000001000
      0000100000000100100000000000000200000000000000000000100000000000
      000000000000000080000080000000808000800000008000800080800000C0C0
      C000808080000000FF0000FF000000FFFF00FF000000FF00FF00FFFF0000FFFF
      FF00000000000000000000000000000000000000000000000000000000000000
      0000000000000000000000000000000000000000000000000000000000000000
      000000000000FF7FFF7FFF7FFF7F000000000000FF7FFF7FFF7FFF7FFF7FFF7F
      00000000FF7FFF7FFF7FFF7F000000000000FF7FFF7FFF7FFF7FFF7FFF7F0000
      0000FF7FFF7FFF7FFF7FFF7F00000000FF7FFF7FFF7FFF7FFF7FFF7FFF7F0000
      000000000000FF7FFF7FFF7F0000000000000000FF7FFF7FFF7FFF7F00000000
      0000000000000000FF7FFF7FFF7FFF7FFF7FFF7FFF7FFF7FFF7FFF7F00000000
      0000000000000000FF7FFF7FFF7FFF7FFF7FFF7FFF7FFF7FFF7F000000000000
      0000000000000000FF7FFF7FFF7F00000000FF7FFF7FFF7FFF7F000000000000
      00000000000000000000FF7FFF7FFF7FFF7FFF7FFF7FFF7F0000000000000000
      00000000000000000000FF7FFF7FFF7FFF7FFF7FFF7FFF7F0000000000000000
      000000000000000000000000FF7FFF7FFF7FFF7FFF7FFF7F0000000000000000
      000000000000000000000000FF7FFF7FFF7FFF7FFF7F00000000000000000000
      0000000000000000000000000000FF7FFF7FFF7FFF7F00000000000000000000
      0000000000000000000000000000FF7FFF7FFF7F000000000000000000000000
      00000000000000000000000000000000FF7F0000000000000000000000000000
      0000}
  end
  object Memo1: TMemo
    Left = 12
    Top = 36
    Width = 149
    Height = 149
    Lines.Strings = ('Memo1')
    TabOrder = 0
    OnMouseDown = Memo1MouseDown
  end
  object Edit1: TEdit
    Left = 220
    Top = 60
    Width = 121
    Height = 21
    TabOrder = 1
    Text = 'Edit1'
    OnMouseDown = Edit1MouseDown
  end
end

Взято с сайта

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

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

type
  TForm1 = class(TForm)
  protected
    MyLabel: TLabel;
    procedure LabelClick(Sender: TObject);
    procedure CreateControl;
  end;

procedure TForm1.LabelClick(Sender: TObject);
begin
  (Sender as Label).Caption := ...
end;

procedure TForm1.CreateControl;
var
  ALeft, ATop, AWidth, AHeight: Integer;
begin
  ALeft := 10;
  ATop := 10;
  AWidth := 50;
  AHeight := 13;
  MyLabel := TLabel.Create(Self);
  MyLabel.Parent := Self;
  MyLabel.Name:='LabelName';
  MyLabel.SetBounds(ALeft, ATop, AWidth, AHeight);

  MyLabel.OnClick := LabelClick;
end;

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

Как создать контрол в Run-Time?

var Butt:TButton;
begin
Butt:=TButton.Create(Self);
Butt.Parent:=self;
Butt.Visible:=true;
end;

Автор ответа: Fantasist (Немного дополнено: Vit )
Взято с Vingrad.ru

Как создать копию произвольного компонента?

{
Здесь пpоцедypа CreateClone, котоpая кpеатит компонентy ОЧЕHЬ ПОХОЖУЮ на
входнyю. С такими же значениями свойств. Пpисваивается все, кpоме методов.
}
function CreateClone(Src: TComponent): TComponent;
var
  F: TStream;
begin
  F := nil;
  try
    F := TMemoryStream.Create;
    F.WriteComponent(Src);
    RegisterClass(TComponentClass(Src.ClassType));
    F.Position := 0;
    Result := F.ReadComponent(nil);
  finally
    F.Free;
  end;
end;

Как создать круглую форму?

Здесь приведён полный пример того, как создать круглую форму.
Не забудьте создать TButton, чтобы окно можно было закрыть.

unit Unit1;

interface

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

type
  TForm1 = class(TForm)
    Button1: TButton;
    procedure FormCreate(Sender: TObject);
    procedure Button1Click(Sender: TObject);
  private
    { Private-Deklarationen}
    procedure CreateParams(var Params: TCreateParams); override;
  public
    { Public-Deklarationen}
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

{ TForm1 }

procedure TForm1.CreateParams(var Params: TCreateParams);
begin
  inherited CreateParams(Params);

  { удаляем заголовок и рамку }
  Params.Style := Params.Style or ws_popup xor ws_dlgframe;
end;

procedure TForm1.FormCreate(Sender: TObject);
var
  FormRgn: hRgn;
begin
  {clear form}
  Form1.Brush.Style := bsSolid; //bsclear;
  { делаем круг формы }
  GetWindowRgn(Form1.Handle, FormRgn);

  { удаляем старый объект }
  DeleteObject(FormRgn);
  { делаем прямоугольник формы }
  Form1.Height := 500;
  Form1.Width := Form1.Height;
  { создаём круглую форму }
  FormRgn := CreateRoundRectRgn(1, 1, Form1.Width - 1,
             Form1.height - 1, Form1.width, Form1.height);

  { устанавливаем новое круглое окно }
  SetWindowRgn(Form1.Handle, FormRgn, TRUE);
end;

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

end.

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

Как создать лупу для рабочего стола?

Автор: Zarko Gajic

// переменные
var Srect,Drect,PosForme:TRect;
    iWidth,iHeight,DmX,DmY:Integer;
    iTmpX,iTmpY:Real;
    C:TCanvas;
    Kursor:TPoint;
// Увеличиваем экран, если приложение не свёрнуто в иконку
If not IsIconic(Application.Handle) then begin
// Получаем координаты курсора
  GetCursorPos(Kursor);

// PosForm представляет прямоугольник с
// координатами Form (image control).
  PosForme:=Rect(Form1.Left,
                 Form1.Top,
                 Form1.Left+Form1.Width,
                 Form1.Top+Form1.Height);

//Показываем magnified screen
//если курсор за пределами формы.
  If not PtInRect(PosForme,Kursor) then begin

// Далее код можно использовать для увеличения выбранной
// части экрана. С небольшими модификациями его можно
// использовать для уменьшения
// экрана
  iWidth:=Image1.Width;
  iHeight:=Image1.Height;
  Drect:=Bounds(0,0,iWidth,iHeight);
  iTmpX:=iWidth / (Slider.Position * 4);
  iTmpY:=iHeight / (Slider.Position * 4);
  Srect:=

   Rect(Kursor.x,Kursor.y,Kursor.x,Kursor.y);
  InflateRect(Srect,Round(iTmpX),Round(iTmpY));

//Получаем обработчик(handle) окна рабочего стола.
  C:=TCanvas.Create;
  try
   C.Handle:=GetDC(GetDesktopWindow);
//Передаём часть изображения окна в TImage.
   Image1.Canvas.CopyRect(Drect,C,Srect);
  finally
   C.Free;
  end;

  end;

// Обязательно обрабатываем все сообщения Windows.
  Application.ProcessMessages;

end; // IsIconic

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

Как создать новый DSN из программы?

type
  TSQLConfigDataSource =
    function(hwndParent: Integer;
    fRequest: Integer;
    lpszDriverString: string;
    lpszAttributes: string): Smallint; stdcall;

function SQLConfigDataSource(hwndParent: Integer; fRequest: Integer;
  lpszDriverString: string; lpszAttributes: string): Integer; stdcall;
var
  func: TSQLConfigDataSource;
  OdbccpHMODULE: HMODULE;

begin
  OdbccpHMODULE := LoadLibrary('c:\WINDOWS\SYSTEM\odbccp32.dll');
  if OdbccpHMODULE = 0 then raise Exception.Create(SysErrorMessage(GetLastError));
  func := GetProcAddress(OdbccpHMODULE, PChar('SQLConfigDataSource'));
  if @func = nil then
    raise Exception.Create('Error Getting adress for SQLConfigDataSource' +
      SysErrorMessage(GetLastError));
  Result := func(hwndParent, fRequest, lpszDriverString, lpszAttributes);
  FreeLibrary(OdbccpHMODULE);
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  if SQLConfigDataSource(0, 1, 'Microsoft Excel Driver (*.xls)', Format('DSN=%s;DBQ=%s;DriverID=790', ['MyDSNName', 'c:\temp\temp.xls'])) <> 1 then
    ShowMessage('Cannot create ODBC alias');
end;

PS. Ecли вы собираетесь работать с этим DSN через BDE, то надо закрыть и открыть Session, иначе он не будет доступен.

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

Автор: Olivio Moura

Этот пример показывает один из способов создания ODBC драйвера для доступа к файлу Access MDB. Подобная операция применима к большинству файлов баз данных. Естевственно, Вам потребуется MDB файл, для того, чтобы связать его с DSN.

const
  ODBC_ADD_DSN        = 1;    // Добавляем источник данных
  ODBC_CONFIG_DSN     = 2;    // Конфигурируем (редактируем) источник данных
  ODBC_REMOVE_DSN     = 3;    // Удаляем источник данных
  ODBC_ADD_SYS_DSN    = 4;    // Добавляем системный DSN
  ODBC_CONFIG_SYS_DSN = 5;    // Конфигурируем системный DSN
  ODBC_REMOVE_SYS_DSN = 6;    // удаляем системный DSN

type
  TSQLConfigDataSource = function( hwndParent: HWND;
                                   fRequest: WORD;
                                   lpszDriver: LPCSTR;
                                   lpszAttributes: LPCSTR ) : BOOL; stdcall;

procedure Form1.FormCreate(Sender: TObject);
var
  pFn: TSQLConfigDataSource;
  hLib: LongWord;
  strDriver: string;
  strHome: string;
  strAttr: string;
  strFile: string;
  fResult: BOOL;
  ModName: array[0..MAX_PATH] of Char;
  srInfo : TSearchRec;
begin
  Windows.GetModuleFileName( HInstance, ModName, SizeOf(ModName) );
  strHome := ModName;
  while ( strHome[length(strHome)] <> '\' ) do
    Delete( strHome, length(strHome), 1 );
  strFile := strHome + 'TestData.MDB';   // Тестовая база данных (Axes = Access)
  hLib := LoadLibrary( 'ODBCCP32' );    // загружаем библиотеку (путь по умолчанию)
  if( hLib <> NULL ) then
  begin
    @pFn := GetProcAddress( hLib, 'SQLConfigDataSource' );
    if( @pFn <> nil ) then
    begin
      // начинаем создание DSN
      strDriver := 'Microsoft Access Driver (*.mdb)';
      strAttr := Format( 'DSN=TestDSN'+#0+
                         'DBQ=%s'+#0+
                         'Exclusive=1'+#0+
                         'Description=Test Data'+#0+#0,
                         [strFile] );
      fResult := pFn( 0, ODBC_ADD_SYS_DSN, @strDriver[1], @strAttr[1] );
      if( fResult = false ) then ShowMessage( 'Ошибка создания DSN (Datasource) !' );

      // test/create MDB file associated with DSN
      if( FindFirst( strFile, 0, srInfo ) <> 0 ) then
      begin
        strDriver := 'Microsoft Access Driver (*.mdb)';
        strAttr := Format( 'DSN=TestDSN'+#0+
                           'DBQ=%s'+#0+
                           'Exclusive=1'+#0+
                           'Description=Test Data'+#0+
                           'CREATE_DB="%s"'#0+#0,
                           [strFile,strFile] );
        fResult := pFn( 0, ODBC_ADD_SYS_DSN, @strDriver[1], @strAttr[1] );
        if( fResult = false ) then ShowMessage( 'Ошибка создания MDB (файла базы данных) !' );
      end;
      FindClose( srInfo );

      end;

    FreeLibrary( hLib );
  end
  else
  begin
    ShowMessage( 'Невозможно загрузить ODBCCP32.DLL' );
  end;
end;

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

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

uses
  Forms, Classes, Controls, StdCtrls, Db, DBTables, DBCtrls;

type
  TForm1 = class(TForm)
    Table1: TTable;   // DBDemos customer table
    Table2: TTable;   // DBDemos orders table
    Button1: TButton;
    DBLookupComboBox1: TDBLookupComboBox;
    DataSource1: TDataSource;
    Table2CustNo: TFloatField;  // CustNo key field object used for Lookup
    procedure Button1Click(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.Button1Click(Sender: TObject);
begin
  with TStringField.Create(Table2) do begin
    FieldName := 'MyLookup';
    FieldKind:= fkLookup;
    DataSet := Table2;
    Name := Dataset.Name + FieldName;
    KeyFields:= 'CustNo';
    LookUpDataset:= Table1;
    LookUpKeyFields:= 'CustNo';
    LookUpResultField:= 'Company';
    DbLookupCombobox1.DataField:= FieldName;
    DataSource1.DataSet:= Dataset;
    Table2.FieldDefs.Add(Name, ftString, 20, false);
  end;
  DbLookupCombobox1.DataSource:= Datasource1;
  Table1.Active:= True;
  Table2.Active:= True;
end;

end.

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

Как создать постоянный Alias?

There has been a number of occasions where I needed to create persistent BDE aliases. The point is that the DB API isn't very discussed and is unkown to most Delphi developers. Despite that fact, the Dbi calls are very powerful and useful functions.

The function below, CreateAlias, encapsulates the DbiAddAlias call, with some error checking and BDE initialization and finalization procedures.

usesWindows, SysUtils, DbiProcs, DbiErrs, DBTables;

const
  CRLF = #13 + #10;
  ERR_ALIASDRIVERNOTFOUND = 'Specified driver does not exist.';
  ERR_ALIASALREADYEXISTS = 'The Alias (%s) already exists.' + CRLF +
    'Would you like to reconfigure it?';
  ERR_ALIASINVALIDPARAM = 'Invalid Alias name.';
  ERR_ALIASCLOSEBDE = 'Error closing the BDE.' + CRLF +
    'Please close all applications and restart Windows';
  ERR_ALIASOPENBDE = 'Error initializing BDE. Cannot create Alias.';

procedure CreateAlias(sAlias, sPath, sDriver: string;
  PersistentAlias: Boolean);
var
  dbEnv: DbiEnv;
  dbRes: DbiResult;
  Resp: word;
begin
  { Sets the BDE environment }
  with dbEnv do
  begin
    StrPCopy(szWorkDir, sPath);
    StrPCopy(szIniFile, '');
    bForceLocalInit := True;
    StrPCopy(szLang, '');
    StrPCopy(szClientName, 'dbClientName');
  end;
  { Initalizes BDE with the environment dbEnv }
  if DbiInit(@dbEnv) <> DbiERR_NONE then
    raise Exception.Create(ERR_ALIASOPENBDE);
  { Adds the specified Alias }
  if sDriver = 'STANDARD' then
    dbRes := DbiAddAlias(nil, pchar(sAlias), nil,
      pchar('PATH:' + sPath), PersistentAlias)
  else
    dbRes := DbiAddAlias(nil, pchar(sAlias), pchar(sDriver),
      pchar('PATH:' + sPath), PersistentAlias);
  case dbRes of
    DbiERR_INVALIDPARAM:
      raise Exception.Create(ERR_ALIASINVALIDPARAM);
    DbiERR_NAMENOTUNIQUE:
      begin
        resp := MessageBox(0, pchar(Format(ERR_ALIASALREADYEXISTS, [sAlias])),
          'CreateAlias', MB_ICONSTOP + MB_YESNO);
        if Resp = ID_YES then
        begin
          Check(DbiDeleteAlias(nil, pchar(sAlias)));
          CreateAlias(sAlias, sPath, sDriver, PersistentAlias);
        end;
      end;
    DbiERR_UNKNOWNDRIVER:
      raise Exception.Create(ERR_ALIASDRIVERNOTFOUND);
  end;
  if DbiExit <> DbiERR_NONE then
    raise Exception.Create(ERR_ALIASCLOSEBDE);
end; {CreateAlias}

The parameters for this function are:

sAlias: Name of the new alias to be created

sPath: Full path of the directory to which the alias should point. With little adjustments, this function can be used to create any kind of aliases, and, instead of passing the path info in this argument, pass all the parameters needed by the driver to create the alias.

sDriver: Name of an existing BDE driver, such as PARADOX, DBASE, STANDARD

PersistentAlias: Determines whether the new alias will be for future use (persistent) or just for the actual session.

Example of usage:

CreateAlias('DBTEST', 'c:\progra~1\borland\delphi~1\projects\cd3\data', 'PARADOX',
  true);

Взято с

Delphi Knowledge Base

Как создать простейший эксперт?

{
This unit can be compiled into a package and will then appear in the Delphi
Help menu.
}
unit SDCSimpleExpert;

interface

uses ToolsApi;

type
  TSDCSimpleExpert = class(TNotifierObject, IOTAMenuWizard, IOTAWizard)
  public
    function GetIDString: string;
    function GetName: string;
    function GetState: TWizardState;
    procedure Execute;
    function GetMenuText: string;
  end;

procedure Register;

implementation

uses Dialogs;

procedure Register;
begin
  {register expert}
  RegisterPackageWizard(TSDCSimpleExpert.Create);
end;

{ TSDCSimpleExpert }

procedure TSDCSimpleExpert.Execute;
begin
  {code to execute when menu item is clicked}
  ShowMessage('Hello SwissDelphiCenter Simple Expert.');
end;

function TSDCSimpleExpert.GetIDString: string;
begin
  {unique expert identifier}
  Result := 'SwissDelphiCenter.SimpleExpert';
end;

function TSDCSimpleExpert.GetMenuText: string;
begin
  {caption of menu item in help menu}
  Result := 'SwissDelphiCenter Simple Expert';
end;

function TSDCSimpleExpert.GetName: string;
begin
  {name of the expert}
  Result := 'SwissDelphiCenter Simple Expert';
end;

function TSDCSimpleExpert.GetState: TWizardState;
begin
  Result := [wsEnabled];
end;

end.

Взято с сайта

Как создать регион(HRNG) по маске

Ниже приведена функция, которая создаёт HRGN из чёрно-белого битмапа. Все чёрные пиксели становятся регионом, а белые становятся прозрачными. Так же не составит труда сделать преобразования для поддержки всех цветов и чтобы один из них был прозрачным.

По окончании необходимо освободить регион при помощи функции DeleteObject.

function BitmapToRgn(Image: TBitmap): HRGN;
var
  TmpRgn: HRGN;
  x, y: integer;
  ConsecutivePixels: integer;
  CurrentPixel: TColor;
  CreatedRgns: integer;
  CurrentColor: TColor;
begin
  CreatedRgns := 0;
  Result := CreateRectRgn(0, 0, Image.Width, Image.Height);
  inc(CreatedRgns);

  if (Image.Width = 0) or (Image.Height = 0) then exit;

  for y := 0 to Image.Height - 1 do
    begin
    CurrentColor := Image.Canvas.Pixels[0,y];
    ConsecutivePixels := 1;
    for x := 0 to Image.Width - 1 do
      begin
      CurrentPixel := Image.Canvas.Pixels[x,y];

      if CurrentColor = CurrentPixel
        then inc(ConsecutivePixels)
        else begin
             // Входим в новую зону
             if CurrentColor = clWhite then
               begin
               TmpRgn := CreateRectRgn(x-ConsecutivePixels, y, x, y+1);
               CombineRgn(Result, Result, TmpRgn, RGN_DIFF);
               inc(CreatedRgns);
               DeleteObject(TmpRgn);
               end;
             CurrentColor := CurrentPixel;
             ConsecutivePixels := 1;
             end;
      end;

   if (CurrentColor = clWhite) and (ConsecutivePixels > 0) then
      begin
      TmpRgn := CreateRectRgn(x-ConsecutivePixels, y, x, y+1);
      CombineRgn(Result, Result, TmpRgn, RGN_DIFF);
      inc(CreatedRgns);
      DeleteObject(TmpRgn);
      end;
    end;
end;

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

Как создать ShortCut файл (.LNK)?

uses ShlObj, ActiveX, ComObj;
...

procedure CreateShortCut(ShortCutName, Parameters, FileName: string);
var ShellObject: IUnknown;
  ShellLink: IShellLink;
  PersistFile: IPersistFile;
  FName: WideString;
begin
  ShellObject := CreateComObject(CLSID_ShellLink);
  ShellLink := ShellObject as IShellLink;
  PersistFile := ShellObject as IPersistFile;
  with ShellLink do
    begin
      SetArguments(PChar(Parameters));
      SetPath(PChar(FileName));
      SetWorkingDirectory(PChar(extractfilepath(FileName)));
      FName := ShortCutName;
      PersistFile.Save(PWChar(FName), False);
    end;
end;

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

Как создать свой пункт меню в Дельфи IDE?

{....}

uses ToolsApi, Menus;

{....}

var
  item: TMenuItem;
begin
  {get reference to delphi's mainmenu. You can handle it like a common TMainMenu}
  with (BorlandIDEServices as INTAServices).GetMainMenu do
  begin
    item := TMenuItem.Create(nil);
    item.Caption := 'A Mewn caption';
    Items.Add(item);
  end;
end;

Взято с сайта

Как создать таблицу через SQL?

Следующая функция полностью совместима с Paradox:

procedure TForm1.Button1Click(Sender: TObject);
var
  Q: TQuery;
begin
  Q := TQuery.Create(Application)
    try
    Q.DatabaseName := 'SF';

    with Q.SQL do
      begin
        Add('Create Table Funcionarios');
        Add('( ID      AutoInc,       ');
        Add('  Name    Char(30),      ');
        Add('  Salary  Money,         ');
        Add('  Depno    SmallInt,     ');
        Add('  Primary Key ( ID ) )   ');
      end;

    Q.ExecSQL;
  finally
    Q.Free;
  end;
end;

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

Как создать таблицу в MS Access при помощи DAO?

1. Объявляем переменные:
var
  access, db, td, recordset: Variant;

2. объявляем массив констант соответствия типов данных
(между полями в Delphi и типами полей DAO)

  arrMDBTypes: array[TFieldType] of Integer =
    ({dbText} 10 {ftUnknown},
     {dbText} 10 {ftString},
     {dbInteger} 3 {ftSmallint},
     {dbLong} 4 {ftInteger},
     {dbInteger} 3 {ftWord},
     {dbBoolean} 1 {ftBoolean},
     {dbDouble} 7 {ftFloat},
     {dbCurrency} 5 {ftCurrency},
     {dbDouble} 7 {ftBCD},
     {dbDate} 8 {ftDate},
     {dbTime} 22 {ftTime},
     {dbDate} 8 {ftDateTime},
     {dbLongBinary} 11 {ftBytes},
     {dbLongBinary} 11 {ftVarBytes},
     {dbInteger} 3 {ftAutoInc},
     {dbLongBinary} 11 {ftBlob},
     {dbMemo} 12 {ftMemo},
     {dbLongBinary} 11 {ftGraphic},
     {dbMemo} 12 {ftFmtMemo},
     {dbLongBinary} 11 {ftParadoxOle},
     {dbLongBinary} 11 {ftDBaseOle},
     {dbBinary} 9 {ftTypedBinary},
     {dbText} 10 {ftCursor}

    {$IFDEF VER120}
     ,
     {dbText} 10 {ftFixedChar},
     {dbText} 10 {ftWideString},
     {dbBigInt} 16 {ftLargeint},
     {dbText} 10 {ftADT},
     {dbText} 10 {ftArray},
     {dbText} 10 {ftReference},
     {dbText} 10 {ftDataSet}
    {$ELSE}

    {$IFDEF VER125}
     ,
     {dbText} 10 {ftFixedChar},
     {dbText} 10 {ftWideString},
     {dbBigInt} 16 {ftLargeint},
     {dbText} 10 {ftADT},
     {dbText} 10 {ftArray},
     {dbText} 10 {ftReference},
     {dbText} 10 {ftDataSet}

    {$ELSE}

    {$IFDEF VER130}
     ,
     {dbText} 10 {ftFixedChar},
     {dbText} 10 {ftWideString},
     {dbBigInt} 16 {ftLargeint},
     {dbText} 10 {ftADT},
     {dbText} 10 {ftArray},
     {dbText} 10 {ftReference},
     {dbText} 10 {ftDataSet},
     {dbLongBinary} 11 {ftOraBlob},
     {dbLongBinary} 11 {ftOraClob},
     {dbText} 10 {ftVariant},
     {dbText} 10 {ftInterface},
     {dbText} 10 {ftIDispatch},
     {dbGUID} 15 {ftGuid}
    {$ENDIF}
    {$ENDIF}
    {$ENDIF}

    );

3. загружаем DAO:
    try
      access := GetActiveOleObject('DAO.DBEngine.35');
    except
      access := CreateOleObject('DAO.DBEngine.35');
    end;

4. открываем базу данных
    try
      db := access.OpenDatabase(yourDatabaseName);
    except
      exit
    end;

5. создаём новую таблицу в открытой базе данных
    td := db.CreateTableDef(yourTableName, 0, '', '');

6. добавляем в таблицу поле с описаниями
    td.Fields.Append(td.CreateField(strFieldName, arrMDBTypes[intDataType], Size));

например,
    td.Fields.Append(td.CreateField('ID', arrMDBTypes[intDataType], Size));
    td.Fields.Append(td.CreateField('NAME', arrMDBTypes[intDataType], Size));

7. добавляем таблицу в список таблиц
    db.TableDefs.Append(td);

8. открываем созданную таблицу
   recordset := db.OpenTable(yourTableName, 0);

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

10. изменяем значения поля
    curField := recordset.Fields[0].Value := 1;
     curField := recordset.Fields[1].Value := 'First record';

11. помещаем новую запись в базу
    recordset.Update(dbUpdateRegular, False);
где
const
  dbUpdateRegular = 1;

12. закрываем recordset
     recordset.Close;

13. закрываем базу данных
     db.Close;

14. освобождаем экземпляр DAO
     access := UnAssigned;

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

Как создать таблицу в MS Word?

If Doc is a TWordDocument, for example:

{... }
var
  Tbl: Table;
  R: Range;
  Direction: OleVariant;
  { ... }
Direction := wdCollapseEnd;
R := Doc.Range;
R.Collapse(Direction);
Tbl := Doc.Tables.Add(R, 2, 4, EmptyParam, EmptyParam);
Tbl.Cell(1, 1).Range.Text := 'Row 1, Col 1';
Tbl.Cell(1, 2).Range.Text := 'Row 1, Col 2';

But doing things with individual table cells in Word is extremely slow. If you can, it's better to enter the data as (for example) comma-separated values and convert it into a table only as the last step. Here's an example:

{ ... }
const
  Line1 = 'January,February,March';
  Line2 = '31,28,31';
  Line3 = '31,59,90';
var
  R: Range;
  Direction, Separator, Format: OleVariant;
{ ... }
R := Word.Selection.Range;
Direction := wdCollapseEnd;
R.Collapse(Direction);
R.InsertAfter(Line1);
R.InsertParagraphAfter;
R.InsertAfter(Line2);
R.InsertParagraphAfter;
R.InsertAfter(Line3);
R.InsertParagraphAfter;
Separator := ',';
Format := wdTableFormatGrid1;
R.ConvertToTable(Separator, EmptyParam, EmptyParam, EmptyParam, Format, EmptyParam,
  EmptyParam, EmptyParam, EmptyParam, EmptyParam, EmptyParam, EmptyParam,
  EmptyParam, EmptyParam);
{ ... }

Взято с

Delphi Knowledge Base

Как создать таблицу в памяти?

{
  This is an InMemoryTable example. Free for anyone to use, modify and do
  whatever else you wish.

  Just like all things free it comes with no guarantees.
  I cannot be responsible for any damage this code may cause.
  Let me repeat this:

   WARNING! THIS CODE IS PROVIDED AS IS WITH NO GUARANTEES OF ANY KIND!
   USE THIS AT YOUR OWN RISK - YOU ARE THE ONLY PERSON RESPONSIBLE FOR
   ANY DAMAGE THIS CODE MAY CAUSE - YOU HAVE BEEN WARNED!

  THANKS to Steve Garland <72700.2407@compuserve.com> for his help.
  He created his own variation of an in-memory table component and
  I used it to get started.

  InMemory tables are a feature of the Borland Database Engine (BDE).
  InMemory tables are created in RAM and deleted when you close them.
  They are much faster and are very useful when you need fast operations on
  small tables. This example uses the DbiCreateInMemoryTable DBE function call.

  This object should work just like a regular table, except InMemory
  tables do not support certain features (like referntial integrity,
  secondary indexes and BLOBs) and currently this code doesn't do anything to
  prevent you from trying to use them. You will probably get some error if
  you try to create a memo field.
}

unit Inmem;

interface

uses DBTables, WinTypes, WinProcs, DBITypes, DBIProcs, DB, SysUtils;

type
  TInMemoryTable = class(TTable)
  private
    hCursor: hDBICur;
    procedure EncodeFieldDesc(var FieldDesc: FLDDesc;
      const Name: string; DataType: TFieldType; Size: Word);
    function CreateHandle: HDBICur; override;
  public
    procedure CreateTable;
  end;

implementation

{
  Luckely this function is virtual - so I could override it. In the
  original VCL code for TTable this function actually opens the table -
  but since we already have the handle to the table - we just return it
}

function TInMemoryTable.CreateHandle;
begin
  Result := hCursor;
end;

{
  This function is cut-and-pasted from the VCL source code. I had to do
  this because it is declared private in the TTable component so I had no
  access to it from here.
}

procedure TInMemoryTable.EncodeFieldDesc(var FieldDesc: FLDDesc;
  const Name: string; DataType: TFieldType; Size: Word);
const
  TypeMap: array[TFieldType] of Byte = (fldUNKNOWN, fldZSTRING, fldINT16,
    fldINT32, fldUINT16, fldBOOL,
    fldFLOAT, fldFLOAT, fldBCD, fldDATE, fldTIME, fldTIMESTAMP, fldBYTES,
    fldVARBYTES, fldBLOB, fldBLOB, fldBLOB);
begin
  with FieldDesc do
  begin
    AnsiToNative(Locale, Name, szName, SizeOf(szName) - 1);
    iFldType := TypeMap[DataType];
    case DataType of
      ftString, ftBytes, ftVarBytes, ftBlob, ftMemo, ftGraphic:
        iUnits1 := Size;
      ftBCD:
        begin
          iUnits1 := 32;
          iUnits2 := Size;
        end;
    end;
    case DataType of
      ftCurrency:
        iSubType := fldstMONEY;
      ftBlob:
        iSubType := fldstBINARY;
      ftMemo:
        iSubType := fldstMEMO;
      ftGraphic:
        iSubType := fldstGRAPHIC;
    end;
  end;
end;

{
  This is where all the fun happens. I copied this function from the VCL
  source and then changed it to use DbiCreateInMemoryTable instead of
  DbiCreateTable.

  Since InMemory tables do not support Indexes - I took all of the
  index-related things out
}

procedure TInMemoryTable.CreateTable;
var
  I: Integer;
  pFieldDesc: pFLDDesc;
  szTblName: DBITBLNAME;
  iFields: Word;
  Dogs: pfldDesc;
begin
  CheckInactive;
  if FieldDefs.Count = 0 then
    for I := 0 to FieldCount - 1 do
      with Fields[I] do
        if not Calculated then
          FieldDefs.Add(FieldName, DataType, Size, Required);
  pFieldDesc := nil;
  SetDBFlag(dbfTable, True);
  try
    AnsiToNative(Locale, TableName, szTblName, SizeOf(szTblName) - 1);
    iFields := FieldDefs.Count;
    pFieldDesc := AllocMem(iFields * SizeOf(FLDDesc));
    for I := 0 to FieldDefs.Count - 1 do
      with FieldDefs[I] do
      begin
        EncodeFieldDesc(PFieldDescList(pFieldDesc)^[I], Name,
          DataType, Size);
      end;
    { the driver type is nil = logical fields }
    Check(DbiTranslateRecordStructure(nil, iFields, pFieldDesc,
      nil, nil, pFieldDesc));
    { here we go - this is where hCursor gets its value }
    Check(DbiCreateInMemTable(DBHandle, szTblName, iFields, pFieldDesc, hCursor));
  finally
    if pFieldDesc <> nil then FreeMem(pFieldDesc, iFields * SizeOf(FLDDesc));
    SetDBFlag(dbfTable, False);
  end;
end;

end.

Взято с сайта

Как создать временный canvas

Создайте Bitmap, и воспользуйтесь свойством холста TBitmap-а, чтобы рисовать на нём. Следующий пример создаёт Bitmap, рисует на его canvas-е, рисует canvas на форме, а затем освобождает bitmap.

procedure TForm1.Button1Click(Sender: TObject);
var
  bm : TBitmap;
begin
  bm := TBitmap.Create;
  bm.Width := 100;
  bm.Height := 100;
  bm.Canvas.Brush.Color := clRed;
  bm.Canvas.FillRect(Rect(0, 0, 100, 100));
  bm.Canvas.MoveTo(0, 0);
  bm.Canvas.LineTo(100, 100);
  Form1.Canvas.StretchDraw(Form1.ClientRect, Bm);
  bm.Free;
end;

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

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

Всё, что нам нужно, это HRGN и дескриптор (handle) элемента управления. SetWindowRgn имеет три параметра: дескриптор окна, которое будем менять, дескритор региона и булевый (boolean) параметр, который указывает - перерисовывать или нет после изменения. Как только у нас есть дескриптор и регион, то можно вызвать SetWindowRgn(Handle, Region, True) и вуаля!

Здесь приведён пример использования функции BitmapToRgn (описанной в примере Как создать регион(HRNG) по маске).

Заметьте, что Вы не должны освобождать регион при помощи DeleteObject, так как после вызова SetWindowRgn владельцем региона становится операционная система.

var
  MaskBmp: TBitmap;
begin
  MaskBmp := TBitmap.Create;
  try
    MaskBmp.LoadFromFile('FormShape.bmp');
    Height := MaskBmp.Height;
    Width := MaskBmp.Width;
    // ОС владеет регионом, после вызова SetWindowRgn
    SetWindowRgn(Self.Handle, BitmapToRgn(MaskBmp), True);
  finally
    MaskBmp.Free;
  end;
end;

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

Как создавать потоки без класса TThread?

unitUnit1;

interface

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

procedure incedit1; stdcall;
procedure incedit2; stdcall;

type
  TForm1 = class(TForm)
    Button1: TButton;
    Edit1: TEdit;
    Edit2: TEdit;
    Button6: TButton;
    Button7: TButton;
    Button2: TButton;
    Button3: TButton;
    Button5: TButton;
    Button4: TButton;
    procedure Button1Click(Sender: TObject);
    procedure Button6Click(Sender: TObject);
    procedure Button7Click(Sender: TObject);
    procedure Button4Click(Sender: TObject);
    procedure Button5Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);
    procedure Button3Click(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

var
  th1, th2: cardinal;
  h1, h2: integer;

procedure incedit1;
var
  i: integer;
begin
  i := 0;
  while true do
  begin
    form1.edit1.text := inttostr(i);
    i := i + 1;
  end;
end;

procedure incedit2;
var
  i: integer;
begin
  i := 0;
  while true do
  begin
    form1.edit2.text := inttostr(i);
    i := i + 1;
  end;
end;
{$R *.DFM}

procedure TForm1.Button1Click(Sender: TObject);
begin
  h1 := beginthread(nil, 1024, @incedit1, nil, 0, th1);
  h2 := beginthread(nil, 1024, @incedit2, nil, 0, th2);
end;

procedure TForm1.Button6Click(Sender: TObject);
begin
  terminatethread(h1, 0);
end;

procedure TForm1.Button7Click(Sender: TObject);
begin
  terminatethread(h2, 0);
end;

procedure TForm1.Button4Click(Sender: TObject);
begin
  resumethread(h1);
end;

procedure TForm1.Button5Click(Sender: TObject);
begin
  resumethread(h2);
end;

procedure TForm1.Button2Click(Sender: TObject);
begin
  suspendthread(h1);
end;

procedure TForm1.Button3Click(Sender: TObject);
begin
  suspendthread(h2);
end;

end.

unit Unit1;

interface

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

procedure printh(p: pointer); stdcall;
type
  TForm1 = class(TForm)
    Button1: TButton;
    procedure Button1Click(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

procedure printh(p: pointer);
begin
  TForm1(p).caption := 'Hello from thread';
  ExitThread(0);
end;

procedure TForm1.Button1Click(Sender: TObject);
var
  h1: cardinal;
begin
  createthread(nil, 128, @printh, self, 0, h1);
end;

end.

Взято с

Примечание от Jin X
Программа не работает. Запускаю, жму Button1, счётчик покрутится полсекунды и всё. Кстати, у procedure incedit1; stdcall; не должно быть параметра типа pointer? Но даже и с ним не пашет. А вот если после i := i + 1; поставить Sleep(10), то будет работать. Вот только не понятно почему. Может, из-за того, что нет синхронизации?

Как спрятать форму?

showwindow(Application.handle, SW_HIDE);
showwindow(Frorm1.handle, SW_HIDE);

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

Как спрятать окно при запуске приложения?

oncreate формы ставишь Application.Showmainform:=false; собственно и все , этим решается и вопрос с закладкой в таскбаре и с видимостью формы

Автор ответа: Diamond Cat

Взято с Vingrad.ru

Как сравнить 2 файла?

{1.}

function Are2FilesEqual(const File1, File2: TFileName): Boolean;
var
  ms1, ms2: TMemoryStream;
begin
  Result := False;
  ms1 := TMemoryStream.Create;
  try
    ms1.LoadFromFile(File1);
    ms2 := TMemoryStream.Create;
    try
      ms2.LoadFromFile(File2);
      if ms1.Size = ms2.Size then
        Result := CompareMem(ms1.Memory, ms2.memory, ms1.Size);
    finally
      ms2.Free;
    end;
  finally
    ms1.Free;
  end
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  if Opendialog1.Execute then
    if Opendialog2.Execute then
      if Are2FilesEqual(Opendialog1.FileName, Opendialog2.FileName) then
        ShowMessage('Files are equal.');
end;

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

{2.}

function FilesAreEqual(const File1, File2: TFileName): Boolean;
const
  BlockSize = 65536;
var
  fs1, fs2: TFileStream;
  L1, L2: Integer;
  B1, B2: array[1..BlockSize] of Byte;
begin
  Result := False;
  fs1 := TFileStream.Create(File1, fmOpenRead or fmShareDenyWrite);
  try
    fs2 := TFileStream.Create(File2, fmOpenRead or fmShareDenyWrite);
    try
      if fs1.Size = fs2.Size then
      begin
        while fs1.Position < fs1.Size do
        begin
          L1 := fs1.Read(B1[1], BlockSize);
          L2 := fs2.Read(B2[1], BlockSize);
          if L1 <> L2 then
          begin
            Exit;
          end;
          if not CompareMem(@B1[1], @B2[1], L1) then Exit;
        end;
        Result := True;
      end;
    finally
      fs2.Free;
    end;
  finally
    fs1.Free;
  end;
end;

Взято с сайта

function CompareFiles(Filename1,FileName2:string):longint;
{
  Сравнение файлов

  возвращает номер несовпадающего байта,
  (байты отсчитываются с 1)или:
  0 - не найдено отличий,
  -1 - ошибка файла 1
  -2 - ошибка файла 2
  -3 - другие ошибки
}
const
  Buf_Size=16384;
var
  F1,F2:TFileStream;
  i:longint;
  Buff1,Buff2:PByteArray;
  BytesRead1,BytesRead2:integer;
begin
  Result:=0;
  try
    F1:=TFileStream.Create(FileName1,fmShareDenyNone);
  except
    Result:=-1;
    exit;
  end;
  try
    F2:=TFileStream.Create(FileName2,fmShareDenyNone);
  except
    Result:=-2;
    F1.Free;
    exit;
  end;
  GetMem(Buff1,Buf_Size);
  GetMem(Buff2,Buf_Size);
  try
    if F1.Size> F2.Size then Result:=F2.Size+1
    else if F1.SizeF1.Position) and (Result=0) do begin
      BytesRead1 :=F1.Read(Buff1^,Buf_Size);
      BytesRead2 :=F2.Read(Buff2^,Buf_Size);
      if (BytesRead1=BytesRead2) then begin
        for i:= 0 to BytesRead1-1 do begin
          if Buff1^[i]< > Buff2^[i]
          then begin
            result:=F1.Position-BytesRead1+i+1;
            break;
          end;
        end;
      end else begin
        Result:=-3;
        break;
      end;
    end;
  end;
  except
    Result:=-3;
  end;
  F1.Free;
  F2.Free;
  FreeMem(Buff1,Buf_Size);
  FreeMem(Buff2,Buf_Size);
end;

Взято с

unit findin;

interface

uses
  Windows, SysUtils, findstr;

type
  TFindInFile = class;

  TFindIn = class
  protected
    FFindInFile: TFindInFile;
    FHandle: THandle;
    function GetPartNum: Integer; virtual; abstract;
    function GetPartLen(Index: Integer): Cardinal; virtual; abstract;
  public
    constructor Create(FindInFile: TFindInFile; FileName: string); virtual;
    destructor Destroy; override;
    function CanUseMem: Boolean; virtual; abstract;
    function UseMemSize: Cardinal; virtual; abstract;
    function GetPart(Index: Integer; Len: Cardinal): Pointer; virtual; abstract;
    property PartNum: Integer read GetPartNum;
    property PartLen[Index: Integer]: Cardinal read GetPartLen;
  end;

  TFindInClass = class of TFindIn;

  TBMSearchFunc = function(var Buffer; BufLength: Cardinal; var BT: TBMTbl;
    MatchString: PAnsiChar; var Pos: Cardinal): Boolean;

  TFindInFile = class
  protected
    FFindIn: TFindIn;
    FFindInClass: TFindInClass;
    FFindStrParams: PFindStrParams;
    FMemHandle: THandle;
    FMem: Pointer;
    FStrLen: Cardinal;
    FDriveTp: UINT;
    FBMSearchFunc: TBMSearchFunc;
    function GetDriveTp(Root: string): UINT;
  public
    constructor Create(FindStrParams: PFindStrParams);
    destructor Destroy; override;
    function Find(FileName: string): Cardinal;
    function SwitchToRoot(Root: string): Boolean; virtual;
  end;

  TFindInHDD = class(TFindIn)
  private
    FSize: Cardinal;
  protected
    FMapPtr: Pointer;
    function GetPartNum: Integer; override;
    function GetPartLen(Index: Integer): Cardinal; override;
  public
    constructor Create(FindInFile: TFindInFile; FileName: string); override;
    destructor Destroy; override;
    function CanUseMem: Boolean; override;
    function UseMemSize: Cardinal; override;
    function GetPart(Index: Integer; Len: Cardinal): Pointer; override;
  end;

  PIntArr = ^TIntArr;
  TIntArr = array[0..1] of Cardinal;

  TFindInRemovable = class(TFindIn)
  private
    FSize: Cardinal;
  protected
    FPartNum: Integer;
    function GetPartNum: Integer; override;
    function GetPartLen(Index: Integer): Cardinal; override;
  public
    constructor Create(FindInFile: TFindInFile; FileName: string); override;
    function CanUseMem: Boolean; override;
    function UseMemSize: Cardinal; override;
    function GetPart(Index: Integer; Len: Cardinal): Pointer; override;
  end;

implementation

resourcestring
  SInvalidDrive = 'Invalid drive - "%s".';

  { TFindIn }

constructor TFindIn.Create(FindInFile: TFindInFile; FileName: string);
begin
  inherited Create;
  FFindInFile := FindInFile;
  FHandle := CreateFile(PChar(FileName), GENERIC_READ, FILE_SHARE_READ,
    nil, OPEN_EXISTING, FILE_FLAG_SEQUENTIAL_SCAN, 0);
  if FHandle = INVALID_HANDLE_VALUE then
    RaiseLastWin32Error;
end;

destructor TFindIn.Destroy;
begin
  if FHandle <> 0 then
    CloseHandle(FHandle);
  inherited Destroy;
end;

{ TFindInHDD }

constructor TFindInHDD.Create(FindInFile: TFindInFile; FileName: string);
var
  hFile: THandle;
begin
  inherited Create(FindInFile, FileName);
  FSize := GetFileSize(FHandle, nil);
  hFile := CreateFileMapping(FHandle, nil, PAGE_READONLY, 0, 0, nil);
  CloseHandle(FHandle);
  FHandle := hFile;
  if FHandle <> 0 then
  begin
    FMapPtr := MapViewOfFile(FHandle, FILE_MAP_READ, 0, 0, 0);
    if FMapPtr = nil then
      RaiseLastWin32Error;
  end
  else
    RaiseLastWin32Error;
end;

destructor TFindInHDD.Destroy;
begin
  if FMapPtr <> nil then
    UnmapViewOfFile(FMapPtr);
  inherited Destroy;
end;

function TFindInHDD.GetPartNum: Integer;
begin
  Result := 1;
end;

function TFindInHDD.GetPartLen(Index: Integer): Cardinal;
begin
  Result := FSize;
end;

function TFindInHDD.GetPart(Index: Integer; Len: Cardinal): Pointer;
begin
  Result := FMapPtr;
end;

function TFindInHDD.CanUseMem: Boolean;
begin
  Result := False;
end;

function TFindInHDD.UseMemSize: Cardinal;
begin
  Result := 0;
end;

{ TFindInRemovable }

constructor TFindInRemovable.Create(FindInFile: TFindInFile; FileName: string);
var
  S: Cardinal;
begin
  inherited Create(FindInFile, FileName);
  FSize := GetFileSize(FHandle, nil);
  if FSize = $FFFFFFFF then
    RaiseLastWin32Error;
  S := UseMemSize - Pred(FFindInFile.FStrLen);
  FPartNum := FSize div S;
  if FSize mod S <> 0 then
    Inc(FPartNum);
end;

function TFindInRemovable.GetPartNum: Integer;
begin
  Result := FPartNum;
end;

function TFindInRemovable.GetPartLen(Index: Integer): Cardinal;
begin
  Result := UseMemSize;
  if (Index = Pred(FPartNum)) and (FSize mod (Result - FFindInFile.FStrLen) <> 0) then
    Result := FSize - (Result - Pred(FFindInFile.FStrLen)) * Pred(FPartNum);
end;

function TFindInRemovable.GetPart(Index: Integer; Len: Cardinal): Pointer;
var
  Dist: ULONG;
  Reading: DWORD;
begin
  Result := FFindInFile.FMem;
  Dist := Index * (UseMemSize - Pred(FFindInFile.FStrLen));
  SetFilePointer(FHandle, Dist, nil, FILE_BEGIN);
  if not ReadFile(FHandle, Result^, Len, Reading, nil) then
    RaiseLastWin32Error;
end;

function TFindInRemovable.CanUseMem: Boolean;
begin
  Result := True;
end;

function TFindInRemovable.UseMemSize: Cardinal;
begin
  Result := 8; {512 * 1024;}
end;

{ TFindInFile }

function Max(V1, V2: Integer): Integer; assembler; register;
asm
  CMP  EAX,EDX
  JG   @@1
  MOV  EAX,EDX
@@1:
end;

constructor TFindInFile.Create(FindStrParams: PFindStrParams);
var
  I: Integer;
begin
  inherited Create;
  FDriveTp := $FFFFFFFF;
  FFindStrParams := FindStrParams;
  if FFindStrParams^.CaseSensitive then
    FBMSearchFunc := BMSearch
  else
    FBMSearchFunc := BMSearchUC;
  FStrLen := 0;
  for I := 0 to Pred(FFindStrParams^.Substr.Count) do
    FStrLen := Max(FStrLen, length(FFindStrParams^.Substr[I]));
end;

destructor TFindInFile.Destroy;
begin
  if FMemHandle <> 0 then
  begin
    GlobalUnlock(FMemHandle);
    GlobalFree(FMemHandle);
  end;
  inherited Destroy;
end;

function TFindInFile.GetDriveTp(Root: string): UINT;
begin
  Result := GetDriveType(PChar(ExtractFileDrive(Root) + '\'));
end;

function TFindInFile.Find(FileName: string): Cardinal;
var
  I, J, K: Integer;
  L: Cardinal;
  P: Pointer;
  PI: PFindStrInfo;
  BMSFunc: TBMSFunc;
begin
  Result := NotFound;
  FFindIn := FFindInClass.Create(Self, FileName);
  try
    if FFindIn.CanUseMem and (FMem = nil) then
    begin
      FMemHandle := GlobalAlloc(GMEM_MOVEABLE, FFindIn.UseMemSize);
      if FMemHandle = 0 then
        RaiseLastWin32Error;
      FMem := GlobalLock(FMemHandle);
    end;
    for I := 0 to Pred(FFindIn.PartNum) do
      for J := 0 to Pred(FFindStrParams^.Substr.Count) do
      begin
        L := FFindIn.PartLen[I];
        P := FFindIn.GetPart(I, L);
        Result := FindString(P^, L, J, FFindStrParams);
        PI := PFindStrInfo(FFindStrParams.Substr.Objects[J]);
        if FBMSearchFunc(P^, L, PI^.BMTbl, PI^.FindS, Result) then
        begin
          if I > 0 then
            for K := 1 to I - 1 do
              Inc(Result, FFindIn.PartLen[K]);
          Exit;
        end;
      end;
  finally
    FFindIn.Free;
  end;
end;

function TFindInFile.SwitchToRoot(Root: string): Boolean;
var
  Tp: UINT;
begin
  Tp := GetDriveTp(Root);
  if Tp <> FDriveTp then
    case Tp of
      0, 1: Exception.CreateFmt(SInvalidDrive, [Root]);
      DRIVE_FIXED: FFindInClass := TFindInHDD;
    else
      {DRIVE_REMOVABLE:
       DRIVE_REMOTE:
       DRIVE_CDROM:
       DRIVE_RAMDISK:}
      FFindInClass := TFindInRemovable;
    end;
end;

end.

Взято с

Delphi Knowledge Base

Как сравнить Bookmarks в таблице

functionTBDEDirect.CompareBookmarks(Bookmark1, Bookmark2: TBookmark): Boolean;
var
  Res: DBIResult;
  CompareRes: Word;
begin
  Result := False;
  if CheckDatabase then
  begin
    Res := DbiCompareBookmarks(FDataLink.DataSource.DataSet.Handle,
    Bookmark1, Bookmark2, CompareRes);
    if Res = 0 then
      if CompareRes = 0 then
        Result := True
      else
    else
      Check(Res);
  end;
end;

Взято из

Как среагировать на минимизацию-максимизацию формы перед тем как произойдет изменение?

Перехватывать сообщение WM_SYSCOMMAND. Если это сообщение говорит о
минимизации или максимизации формы - пищит динамик.

type
  TForm1 = class(TForm)
  private
  {Private declarations}
    procedure WMSysCommand(var Msg: TWMSysCommand);
      message WM_SYSCOMMAND;
  public
  {Public declarations}
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.WMSysCommand;
begin
  if (Msg.CmdType = SC_MINIMIZE) or (Msg.CmdType = SC_MAXIMIZE) then
    MessageBeep(0)
  else
    inherited;
end;

Как стать невидимым в Windows NT (статья)?

Как стать невидимым в Windows NT

Author: Holy_Father <holy_father@phreaker.net>
Version: 1.2 russian
Date: 05.08.2003
Translation: Kerk <kerk_p@yahoo.com>

Вступление

Эта статья описывает техники скрытия объектов, файлов, сервисов,
процессов и т.д. в ОС Windows NT. Эти методы основаны на перехвате функций
Windows API, что описано в моей статье "Hooking Windows API".
Данная информация была получена мною в процессе написания rootkit'а,
поэтому есть вероятность, что это может быть реализовано более эффективно или
намного более просто.
Под скрытием объектов в этой статье подразумевается замена некоторых
системных функций, которые работают с этим объектом таким образом, чтобы они
его пропускали. В случае, если объект - всего лишь возвращаемое значение
функции, мы просто возвратим значение, как будто бы объекта не существует.
Простейший метод (исключая случаи, когда сказано обратное) - это
вызов оригинальной функции с оригинальными аргументами и замена ее выходных
данных.
В этой версии статьи описаны методы скрытия файлов, процессов,
ключей и значений реестра, системных сервисов и драйверов, выделенной памяти и
хэндлов.

Файлы

Существует несколько способов скрытия файлов, чтобы ОС не могла их
видеть. Мы сконцентрируемся на изменении API и отбросим такие техники, как
использование возможностей файловой системы. К тому же это намного проще, т.к.
в этом случае нам не нужно знать как работает конкретная файловая система.

NtQueryDirectoryFile

Поиск файла в wNT в какой-либо директории заключается в просмотре всех
файлов этой директории и файлов всех ее поддиректорий. Для перечисления файлов
используется функция NtQueryDirectoryFile.

NTSTATUSNtQueryDirectoryFile(
IN HANDLE FileHandle,
IN HANDLE Event OPTIONAL,
IN PIO_APC_ROUTINE ApcRoutine OPTIONAL,
IN PVOID ApcContext OPTIONAL,
OUT PIO_STATUS_BLOCK IoStatusBlock,
OUT PVOID FileInformation,
IN ULONG FileInformationLength,
IN FILE_INFORMATION_CLASS FileInformationClass,
IN BOOLEAN ReturnSingleEntry,
IN PUNICODE_STRING FileName OPTIONAL,
IN BOOLEAN RestartScan
);

Для нас важны параметры FileHandle, FileInformation
и FileInformationClass. FileHandle - хэндл объекта директории, который может
быть получен с использованием функции NtOpenFile. FileInformation - указатель
на выделенную память, куда функция запишет необходимые данные.
FileInformationClass определяет тип записей в FileInformation.
FileInformationClass перечислимого типа, но нам необходимы только
четыре его значения, используемые для просмотра содержимого директории.

#define FileDirectoryInformation 1
#define FileFullDirectoryInformation 2
#define FileBothDirectoryInformation 3
#define FileNamesInformation 12

структура записи в FileInformation для FileDirectoryInformation:

typedef struct _FILE_DIRECTORY_INFORMATION {
ULONG NextEntryOffset;
ULONG Unknown;
LARGE_INTEGER CreationTime;
LARGE_INTEGER LastAccessTime;
LARGE_INTEGER LastWriteTime;
LARGE_INTEGER ChangeTime;
LARGE_INTEGER EndOfFile;
LARGE_INTEGER AllocationSize;
ULONG FileAttributes;
ULONG FileNameLength;
WCHAR FileName[1];
} FILE_DIRECTORY_INFORMATION, *PFILE_DIRECTORY_INFORMATION;

для FileFullDirectoryInformation:

typedef struct _FILE_FULL_DIRECTORY_INFORMATION {
ULONG NextEntryOffset;
ULONG Unknown;
LARGE_INTEGER CreationTime;
LARGE_INTEGER LastAccessTime;
LARGE_INTEGER LastWriteTime;
LARGE_INTEGER ChangeTime;
LARGE_INTEGER EndOfFile;
LARGE_INTEGER AllocationSize;
ULONG FileAttributes;
ULONG FileNameLength;
ULONG EaInformationLength;
WCHAR FileName[1];
} FILE_FULL_DIRECTORY_INFORMATION, *PFILE_FULL_DIRECTORY_INFORMATION;

для FileBothDirectoryInformation:

typedef struct _FILE_BOTH_DIRECTORY_INFORMATION {
ULONG NextEntryOffset;
ULONG Unknown;
LARGE_INTEGER CreationTime;
LARGE_INTEGER LastAccessTime;
LARGE_INTEGER LastWriteTime;
LARGE_INTEGER ChangeTime;
LARGE_INTEGER EndOfFile;
LARGE_INTEGER AllocationSize;
ULONG FileAttributes;
ULONG FileNameLength;
ULONG EaInformationLength;
UCHAR AlternateNameLength;
WCHAR AlternateName[12];
WCHAR FileName[1];
} FILE_BOTH_DIRECTORY_INFORMATION, *PFILE_BOTH_DIRECTORY_INFORMATION;

и для FileNamesInformation:

typedef struct _FILE_NAMES_INFORMATION {
ULONG NextEntryOffset;
ULONG Unknown;
ULONG FileNameLength;
WCHAR FileName[1];
} FILE_NAMES_INFORMATION, *PFILE_NAMES_INFORMATION;

Функция записывает набор этих структур в буфер FileInformation.
Во всех этих типах структур для нас важны только три переменных.
NextEntryOffset - размер данного элемента списка. Первый элемент
расположен по адресу FileInformation + 0, а второй элемент по адресу
FileInformation + NextEntryOffset первого элемента. У последнего элемента
поле NextEntryOffset содержит нуль.
FileName - это полное имя файла.
FileNameLength - это длина имени файла.

Для скрытия файла, необходимо сравнить имя каждой возвращаемой записи
и имя файла, который мы хотим скрыть. Если мы хотим скрыть первую запись,
нужно сдвинуть следующие за ней структуры на размер первой записи. Это приведет
к тому, что первая запись будет затерта. Если мы хотим скрыть другую запись,
мы можем просто изменить значение NextEntryOffset предыдущей записи. Новое
значение NextEntryOffset будет нуль, если мы хотим скрыть последнюю запись,
иначе значение будет суммой полей NextEntryOffset записи, которую мы хотим
скрыть и предыдущей записи. Затем необходимо изменить значение поля Unknown
предыдущей записи, которое предоставляет индекс для последующего поиска.
Значение поля Unknown предыдущей записи должно равняться значению поля Unknown
записи, которую мы хотим скрыть.
Если нет ниодной записи, которую можно видеть, мы должны вернуть ошибку
STATUS_NO_SUCH_FILE.

#define STATUS_NO_SUCH_FILE 0xC000000F

NtVdmControl

По неизвестной причине эмуляция DOS - NTVDM может получить список
файлов еще и с помощью функции NtVdmControl.

NTSTATUS NtVdmControl(
IN ULONG ControlCode,
IN PVOID ControlData
);

ControlCode указывает подфункцию, которая будет применена к данным
в буфере ControlData. Если ControlCode равняется VdmDirectoryFile, эта
функция делает то же, что и NtQueryDirectoryFile с FileInformationClass
равным FileBothDirectoryInformation.

#define VdmDirectoryFile 6

Тогда буфер ControlData используется как FileInformation. Единственная
разница в том, что мы не знаем длину этого буфера. Поэтому мы должны вычислить
ее вручную. Мы можем сложить NextEntryOffset всех записей, FileNameLength
последней записи и 0x5E (длина последней записи исключая длину имени файла).
Методы скрытия такие же как и в случае с NtQueryDirectoryFile.

Процессы

Различная системная информация доступна через NtQuerySystemInformation.

NTSTATUS NtQuerySystemInformation(
IN SYSTEM_INFORMATION_CLASS SystemInformationClass,
IN OUT PVOID SystemInformation,
IN ULONG SystemInformationLength,
OUT PULONG ReturnLength OPTIONAL
);

SystemInformationClass указывает тип информации, которую мы хотим
получить, SystemInformation - это указатель на результирующий буфер,
SystemInformationLength - размер этого буфера и ReturnLength - количество
записанных байт.
Для перечисления запущенных процессов мы устанавливаем в параметр
SystemInformationClass значение SystemProcessesAndThreadsInformation.

#define SystemInformationClass 5

Возвращаемая структура в буфере SystemInformation:

typedef struct _SYSTEM_PROCESSES {
ULONG NextEntryDelta;
ULONG ThreadCount;
ULONG Reserved1[6];
LARGE_INTEGER CreateTime;
LARGE_INTEGER UserTime;
LARGE_INTEGER KernelTime;
UNICODE_STRING ProcessName;
KPRIORITY BasePriority;
ULONG ProcessId;
ULONG InheritedFromProcessId;
ULONG HandleCount;
ULONG Reserved2[2];
VM_COUNTERS VmCounters;
IO_COUNTERS IoCounters; // только Windows 2000
SYSTEM_THREADS Threads[1];
} SYSTEM_PROCESSES, *PSYSTEM_PROCESSES;

Скрытие процессов похоже на скрытие файлов. Мы должны изменить
NextEntryDelta записи предшествующей записи скрываемого процесса. Обычно
не требуется скрывать первую запись, т.к. это процесс Idle.

Реестр

Реестр Windows - это достаточно большая древовидная структура,
содержащая два важных типа записей, которые мы можем захотеть скрыть. Первый
тип - ключи реестра, второй - значения реестра. Благодаря структуре реестра
скрытие его ключей не так тривиально, как скрытие файлов или процессов.

NtEnumerateKey

Благодаря структуре реестра, мы не можем запросить список всех ключей
в какой-либо его части. Мы можем получить информацию только об одном ключе,
указанном его индексом. Используется функция NtEnumerateKey.

NTSTATUS NtEnumerateKey(
IN HANDLE KeyHandle,
IN ULONG Index,
IN KEY_INFORMATION_CLASS KeyInformationClass,
OUT PVOID KeyInformation,
IN ULONG KeyInformationLength,
OUT PULONG ResultLength
);

KeyHandle - это дескриптор ключа, в котором мы хотим получить
информацию о подключе, указанном параметром Index. Тип полученной информации
определяется полем KeyInformationClass. Данные записываются в буффер
KeyInformation, длина которого указана в параметре KeyInformationLength.
Количество записанных байт возвращается в ResultLength.
Наиболее важным является понимание того, что если мы скроем ключ, то
индексы всех последующих ключей будут сдвинуты. И так как нам придется получать
информацию о ключе с большим индексом запрашивая ключ с меньшим индексом, мы
должны подсчитать количество записей до скрытой и вернуть правильное значение.
Давайте разберем пример. Допустим в какой-то части реестра есть ключи с
именами A, B, C, D, E и F. Индекс начинается с нуля, это означает, что ключ E
имеет индекс 4. Теперь, если мы хотим скрыть ключ B и приложение вызвало
NtEnumerateKey с Index равным 4, мы должны вернуть информацию о ключе F, так
как индекс сдвинут. Проблема в том, что нам неизвестно, что нужно произвести
сдвиг. А если мы не позаботимся о сдвиге, то вернем E вместо F, когда будет
запрашиваться ключ с индексом 4, или ничего не вернем для ключа с индексом 1,
хотя должны вернуть C. В обоих случаях ошибка. Вот почему мы должны подумать
о сдвиге.
Если мы будем вычислять сдвиг вызовом функции для каждого индекса
от 0 до Index, иногда нам придется ждать годами (на 1ГГц процессоре это может
занять до 10 секунд со стандартным реестром, который очень большой). Поэтому
мы должны придумать более совершенный метод.
Мы знаем, что ключи (исключая ссылки) отсортированы по алфавиту. Если
мы пренебрежем ссылками (которые мы не хотим скрывать), мы сможем вычислить
сдвиг следующим методом. Мы отсортируем по алфавиту список имен ключей, которые
необходимо скрыть (используя RtlCompareUnicodeString), затем, когда приложение
вызывает NtEnumerateKey, мы не будем перевызывать ее с неизмененными
аргументами, а определим имя записи указанной параметром Index.

NTSTATUS RtlCompareUnicodeString(
IN PUNICODE_STRING String1,
IN PUNICODE_STRING String2,
IN BOOLEAN CaseInSensitive
);

String1 и String2 - строки, которые необходимо сравнить,
CaseInSensitive - True, если мы хотим провести сравнение, игнорируя регистр.
Результат функции описывает отношение между String1 и String2:

result > 0: String1 > String2
result = 0: String1 = String2
result < 0: String1 < String2

Теперь мы должны найти границу. Мы сравним имя, указанное параметром Index с
именами в нашем списке. Границей будет последнее меньшее имя из нашего списка.
Мы знаем, что сдвиг не превышает номер граничного элемента в нашем списке.
Но не все элементы списка являются действительными ключами в той части реестра,
где мы находимся. Поэтому мы должны определить элементы списка до границы,
которые являются частью реестра. Мы можем сделать это используя NtOpenKey.

NTSTATUS NtOpenKey(
OUT PHANDLE KeyHandle,
IN ACCESS_MASK DesiredAccess,
IN POBJECT_ATTRIBUTES ObjectAttributes
);

KeyHandle - это хэндл родительского ключа. Мы будем использовать
значение, переданное в NtEnumerateKey. DesiredAccess - права доступа,
используем значение KEY_ENUMERATE_SUB_KEYS. ObjectAttributes описывают
подключ, которых мы хотим открыть (включая его имя).

#define KEY_ENUMERATE_SUB_KEYS 8

Если NtOpenKey вернет 0 - ключ был открыт успешно - это значит, что
этот элемент списка существует. Открытый ключ следует закрыть, используя
NtClose.

NTSTATUS NtClose(
IN HANDLE Handle
);

При каждом вызове функции NtEnumerateKey мы должны вычислять сдвиг,
как количество ключей из нашего списка, которые существуют в данной части
реестра. Затем мы должны прибавить этот сдвиг к аргументу Index и, наконец,
вызвать оригинальную NtEnumerateKey.
Для получения имени ключа, указанного параметром Index, мы используем
KeyBasicInformation в качестве значения для KeyInformationClass.

#define KeyBasicInformation 0

NtEnumerateKey вернет в буфере KeyInformation структуру:

typedef struct _KEY_BASIC_INFORMATION {
LARGE_INTEGER LastWriteTime;
ULONG TitleIndex;
ULONG NameLength;
WCHAR Name[1];
} KEY_BASIC_INFORMATION, *PKEY_BASIC_INFORMATION;

Единственное что нам нужно - это Name, и его длина - NameLength.
Если ключа для сдвинутого параметра Index не существует, мы
должны вернуть ошибку STATUS_EA_LIST_INCONSISTENT.

#define STATUS_EA_LIST_INCONSISTENT 0x80000014

NtEnumerateValueKey

Значения реестра не отсортированы. К счастью, их количество в одном
ключе достаточно мало, поэтому мы можем перевызывать функцию, чтобы получить
сдвиг. API для получения информации об одном значении реестра
назывется NtEnumarateValueKey.

NTSTATUS NtEnumerateValueKey(
IN HANDLE KeyHandle,
IN ULONG Index,
IN KEY_VALUE_INFORMATION_CLASS KeyValueInformationClass,
OUT PVOID KeyValueInformation,
IN ULONG KeyValueInformationLength,
OUT PULONG ResultLength
);

KeyHandle - это снова хэндл родительского ключа. Index - это индекс
в списке значений данного ключа. KeyValueInformationClass описывает тип
информации, которая будет помещена в буфер KeyValueInformation размером
KeyValueInformationLength байт. Количество записанных в буфер байт возвращается
в ResultLength.
И снова мы должны вычислить сдвиг, перевызывая функцию для всех
индексов от 0 до Index. Имя значения может быть получено при использовании
KeyValueBasicInformation в качестве значения для KeyValueInformationClass.

#define KeyValueBasicInformation 0

Тогда в буфере KeyValueInformation мы получим следующую структуру:

typedef struct _KEY_VALUE_BASIC_INFORMATION {
ULONG TitleIndex;
ULONG Type;
ULONG NameLength;
WCHAR Name[1];
} KEY_VALUE_BASIC_INFORMATION, *PKEY_VALUE_BASIC_INFORMATION;

Нас снова интересуют только Name и NameLength.

Если для сдвинутого параметра Index не существует соответствующего
значения реестра, то мы должны вернуть STATUS_NO_MORE_ENTRIES.

#define STATUS_NO_MORE_ENTRIES 0x8000001A

Сервисы и драйверы

Системные сервисы и драйверы обрабатываются четырьмя независимыми
API-функциями. Их связи различны в каждой версии Windows. Поэтому мы вынуждены
перехватывать все четыре функции.

BOOL EnumServicesStatusA(
SC_HANDLE hSCManager,
DWORD dwServiceType,
DWORD dwServiceState,
LPENUM_SERVICE_STATUS lpServices,
DWORD cbBufSize,
LPDWORD pcbBytesNeeded,
LPDWORD lpServicesReturned,
LPDWORD lpResumeHandle
);

BOOL EnumServiceGroupW(
SC_HANDLE hSCManager,
DWORD dwServiceType,
DWORD dwServiceState,
LPBYTE lpServices,
DWORD cbBufSize,
LPDWORD pcbBytesNeeded,
LPDWORD lpServicesReturned,
LPDWORD lpResumeHandle,
DWORD dwUnknown
);

BOOL EnumServicesStatusExA(
SC_HANDLE hSCManager,
SC_ENUM_TYPE InfoLevel,
DWORD dwServiceType,
DWORD dwServiceState,
LPBYTE lpServices,
DWORD cbBufSize,
LPDWORD pcbBytesNeeded,
LPDWORD lpServicesReturned,
LPDWORD lpResumeHandle,
LPCTSTR pszGroupName
);

BOOL EnumServicesStatusExW(
SC_HANDLE hSCManager,
SC_ENUM_TYPE InfoLevel,
DWORD dwServiceType,
DWORD dwServiceState,
LPBYTE lpServices,
DWORD cbBufSize,
LPDWORD pcbBytesNeeded,
LPDWORD lpServicesReturned,
LPDWORD lpResumeHandle,
LPCTSTR pszGroupName
);

Наиболее важен здесь параметр lpServices, которое указывает на буфер,
где должен быть размещен список сервисов. lpServicesReturned, которое указывает
на количество записей в буфере, также важно. Структура данных в выходном буфере
зависит от типа функции. Для функций EnumServicesStatusA и EnumServicesGroupW
возвращается структура:

typedef struct _ENUM_SERVICE_STATUS {
LPTSTR lpServiceName;
LPTSTR lpDisplayName;
SERVICE_STATUS ServiceStatus;
} ENUM_SERVICE_STATUS, *LPENUM_SERVICE_STATUS;

typedef struct _SERVICE_STATUS {
DWORD dwServiceType;
DWORD dwCurrentState;
DWORD dwControlsAccepted;
DWORD dwWin32ExitCode;
DWORD dwServiceSpecificExitCode;
DWORD dwCheckPoint;
DWORD dwWaitHint;
} SERVICE_STATUS, *LPSERVICE_STATUS;

а для EnumServicesStatusExA и EnumServicesStatusExW:

typedef struct _ENUM_SERVICE_STATUS_PROCESS {
LPTSTR lpServiceName;
LPTSTR lpDisplayName;
SERVICE_STATUS_PROCESS ServiceStatusProcess;
} ENUM_SERVICE_STATUS_PROCESS, *LPENUM_SERVICE_STATUS_PROCESS;

typedef struct _SERVICE_STATUS_PROCESS {
DWORD dwServiceType;
DWORD dwCurrentState;
DWORD dwControlsAccepted;
DWORD dwWin32ExitCode;
DWORD dwServiceSpecificExitCode;
DWORD dwCheckPoint;
DWORD dwWaitHint;
DWORD dwProcessId;
DWORD dwServiceFlags;
} SERVICE_STATUS_PROCESS, *LPSERVICE_STATUS_PROCESS;

Нас интересует только поле lpServiceName, которое содержит имя
сервиса. Записи имеют фиксированный размер, поэтому, если мы хотим скрыть
одну, мы передвинем все последующие записи на ее размер. Здесь мы должны
помнить о различии размеров SERVICE_STATUS и SERVICE_STATUS_PROCESS.

Перехват и распространение

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

Привелегии

Нам нужны как минимум администраторские права, чтобы получить доступ ко
всем запущенным процессам. Лучшая возможность - это запуск нашего процесса как
системного сервиса, который работает с правами пользователя SYSTEM. Чтобы
установить сервис нам тоже нужны специальные привелегии.
Также очень полезно получение привелегии SeDebugPrivilege. Это может
быть сделано с помощью функций OpenProcessToken, LookupPrivilegeValue и
AdjustTokenPrivileges.

BOOL OpenProcessToken(
HANDLE ProcessHandle,
DWORD DesiredAccess,
PHANDLE TokenHandle
);

BOOL LookupPrivilegeValue(
LPCTSTR lpSystemName,
LPCTSTR lpName,
PLUID lpLuid
);

BOOL AdjustTokenPrivileges(
HANDLE TokenHandle,
BOOL DisableAllPrivileges,
PTOKEN_PRIVILEGES NewState,
DWORD BufferLength,
PTOKEN_PRIVILEGES PreviousState,
PDWORD ReturnLength
);

Игнорируя возможные ошибки, это может быть сделано так:

#define SE_PRIVILEGE_ENABLED 0x0002
#define TOKEN_QUERY 0x0008
#define TOKEN_ADJUST_PRIVILEGES 0x0020

HANDLE hToken;
LUID DebugNameValue;
TOKEN_PRIVILEGES Privileges;
DWORD dwRet;

OpenProcessToken(GetCurrentProcess(),
TOKEN_ADJUST_PRIVILEGES | TOKEN_QUERY,hToken);
LookupPrivilegeValue(NULL,"SeDebugPrivilege",&DebugNameValue);
Privileges.PrivilegeCount=1;
Privileges.Privileges[0].Luid=DebugNameValue;
Privileges.Privileges[0].Attributes=SE_PRIVILEGE_ENABLED;
AdjustTokenPrivileges(hToken,FALSE,&Privileges,sizeof(Privileges),
NULL,&dwRet);
CloseHandle(hToken);

Перехват

Перечисление процессов производится уже упомянутой API-функцией
NtQuerySystemInformation. Для перехвата функций используется метод перезаписи
ее первых инструкций. Это делается для каждого запущеного процесса. Мы выделим
память в нужном процессе, где запишем новый код для функций, которые хотим
перехватить. Затем заменим первые пять байт этих функций на инструкцию jmp.
Эта инструкция будет перенаправлять выполнение на наш код. Так, инструкция jmp
будет выполнена сразу, как только функция будет вызвана. Мы должны сохранить
первые инструкции каждой перезаписанной функции - они необходимы для вызова
оригинального кода перехваченной функции. Сохранение инструкций описывается в
разделе 3.2.3 статьи "Hooking Windows API".
Сначала мы должны открыть нужный процесс с помощью NtOpenProcess и
получить его хэндл. Произойдет ошибка, если у нас недостаточно привелегий.

NTSTATUS NtOpenProcess(
OUT PHANDLE ProcessHandle,
IN ACCESS_MASK DesiredAccess,
IN POBJECT_ATTRIBUTES ObjectAttributes,
IN PCLIENT_ID ClientId OPTIONAL
);

ProcessHandle - указатель на хэндл, где будет сохранен результат.
DesiredAccess следует установить равным PROCESS_ALL_ACCESS. Мы установим
поле UniqueProcess структуры ClientId равным PID нужного процесса, UniqueThread
должно быть равно нулю. Открытый хэндл должен быть закрыт с помощью NtClose.

#define PROCESS_ALL_ACCESS 0x001F0FFF

Теперь мы выделим память для нашего кода. Это может быть сделано
с помощью функции NtAllocateVirtualMemory.

NTSTATUS NtAllocateVirtualMemory(
IN HANDLE ProcessHandle,
IN OUT PVOID BaseAddress,
IN ULONG ZeroBits,
IN OUT PULONG AllocationSize,
IN ULONG AllocationType,
IN ULONG Protect
);

Используется значение ProcessHandle возвращенное функцией
NtOpenProcess. BaseAddress - указатель на указатель на желаемое начало блока
выделенной памяти. Здесь будет сохранен указатель на выделенную память.
Входное значение может быть равно NULL. AllocationSize - указатель на
переменную, содержащую размер буфера, который мы хотим выделить. И также
здесь будет сохранено количество реально выделенных байт. Рекомендую включить
значение MEM_TOP_DOWN в параметр AllocationType в дополнение к MEM_COMMIT, т.к.
в этом случае память будет выделена как можно выше рядом с DLL.

#define MEM_COMMIT 0x00001000
#define MEM_TOP_DOWN 0x00100000

Теперь мы можем записать наш код, используя NtWriteVirtualMemory.

NTSTATUS NtWriteVirtualMemory(
IN HANDLE ProcessHandle,
IN PVOID BaseAddress,
IN PVOID Buffer,
IN ULONG BufferLength,
OUT PULONG ReturnLength OPTIONAL
);

В параметре BaseAddress используем значение возвращенное
NtAllocateVirtual. Buffer указывает на байты, которые мы хотим записать,
BufferLength - количество этих байтов.

Теперь мы перехватим функции. Единственная DLL, которая загружается в
каждый процесс - ntdll.dll. Так, мы должны проверить импортирована ли функция,
которую мы хотим перехватить, в процесс, если эта функция не из ntdll.dll.
Но память, которую эта функция (из другой DLL) могла бы занимать может быть
выделена, и перезапись этих байт повлечет за собой сбой в процессе. Поэтому
мы должны проверить загружена ли эта библиотека (в которой нужная нам функция)
в процесс.
Мы должны получить PEB (Process Environment Block) нужного процесса,
используя NtQueryInformationProcess.

NTSTATUS NtQueryInformationProcess(
IN HANDLE ProcessHandle,
IN PROCESSINFOCLASS ProcessInformationClass,
OUT PVOID ProcessInformation,
IN ULONG ProcessInformationLength,
OUT PULONG ReturnLength OPTIONAL
);

Присвоим значение ProcessBasicInformation параметру
ProcessInformationClass. Тогда в буфер ProcessInformation, размер которого
указан в параметре ProcessInformationLength, будет возвращена структура
PROCESS_BASIC_INFORMATION.

#define ProcessBasicInformation 0

typedef struct _PROCESS_BASIC_INFORMATION {
NTSTATUS ExitStatus;
PPEB PebBaseAddress;
KAFFINITY AffinityMask;
KPRIORITY BasePriority;
ULONG UniqueProcessId;
ULONG InheritedFromUniqueProcessId;
} PROCESS_BASIC_INFORMATION, *PPROCESS_BASIC_INFORMATION;

PebBaseAddress - то, что мы ищем. PebBaseAddress+0x0C - это адрес
PPEB_LDR_DATA. Он может быть получен вызовом NtReadVirtualMemory.

NTSTATUS NtReadVirtualMemory(
IN HANDLE ProcessHandle,
IN PVOID BaseAddress,
OUT PVOID Buffer,
IN ULONG BufferLength,
OUT PULONG ReturnLength OPTIONAL
);

Параметры такие же как и у NtWriteVirtualMemory.
PPEB_LDR_DATA+0x1C - адрес InInitializationOrderModuleList. Это список
библиотек, загруженных в процесс. Нас интересует только часть этой структуры.

typedef struct _IN_INITIALIZATION_ORDER_MODULE_LIST {
PVOID Next,
PVOID Prev,
DWORD ImageBase,
DWORD ImageEntry,
DWORD ImageSize,
...
);

Next - указатель на следующую запись, Prev - на предыдущую. Последняя
запись указывает на первую. ImageBase - адрес модуля в памяти. ImageEntry - это
точка входа модуля, ImageSize - его размер.

Для каждой библиотеки, функции которой мы хотим перехватить, мы получим
ImageBase (например, используя GetModuleHandle или LoadLibrary). Эту ImageBase
мы сравним с ImageBase каждого элемента в InInitializationOrderModuleList.
Теперь мы готовы к перехвату. Из-за того, что мы перехватываем функции
в работающих процессах, существует вероятность, что код, который мы будем
перезаписывать в тот момент будет выполняться. Это может вызвать ошибку,
поэтому сначала мы остановим все потоки этого процесса. Список потоков можно
получить, используя функцию NtQuerySystemInformation с классом
SystemProcessesAndThreadsInformation. Результат работы этой функции описан в
разделе 4, необходимо лишь добавить описание структуры SYSTEM_THREADS, которая
содержит информацию о потоке.

typedef struct _SYSTEM_THREADS {
LARGE_INTEGER KernelTime;
LARGE_INTEGER UserTime;
LARGE_INTEGER CreateTime;
ULONG WaitTime;
PVOID StartAddress;
CLIENT_ID ClientId;
KPRIORITY Priority;
KPRIORITY BasePriority;
ULONG ContextSwitchCount;
THREAD_STATE State;
KWAIT_REASON WaitReason;
} SYSTEM_THREADS, *PSYSTEM_THREADS;

Для каждого потока мы должны получить его хэндл, используя
NtOpenThread. Мы используем для этого ClientId.

NTSTATUS NtOpenThread(
OUT PHANDLE ThreadHandle,
IN ACCESS_MASK DesiredAccess,
IN POBJECT_ATTRIBUTES ObjectAttributes,
IN PCLIENT_ID ClientId
);

Хэндл, который нам нужен, будет сохранен в ThreadHandle. Параметр
DesiredAccess должен быть равен THREAD_SUSPEND_RESUME.

#define THREAD_SUSPEND_RESUME 2

ThreadHandle будет использован при вызове NtSuspendThread.

NTSTATUS NtSuspendThread(
IN HANDLE ThreadHandle,
OUT PULONG PreviousSuspendCount OPTIONAL
);

Приостановленный процесс готов к перезаписи. Мы поступим, как описано
в разделе 3.2.2 статьи "Hooking Windows API". Единственная разница в том, что
функции будут использоваться для других процессов.

После перехвата мы возобновим работу всех потоков процесса, используя
NtResumeThread.

NTSTATUS NtResumeThread(
IN HANDLE ThreadHandle,
OUT PULONG PreviousSuspendCount OPTIONAL
);

Новые процессы

Заражение всех запущенных процессов не затронет процессы, которые будут
запущены позже. Мы должны получить список процессов, через некоторое время
получить новый, сравнить их, а затем заразить те процессы, которые есть во
втором списке и отсутствуют в первом. Но этот метод очень ненадежен.
Намного лучше перехватить функцию, которая вызывается, когда стартует
новый процесс. Так как все запущенные в системе процессы заражены, мы не сможем
пропустить ни один новый процесс, используя данный метод. Мы можем перехватить
NtCreateThread, но это не самый простой путь. Мы будем перехватывать функцию
NtResumeThread, которая также всегда вызывается при старте нового процесса.
Она вызвается после NtCreateThread.
Единственная проблема с NtResumeThread состоит в том, что она
вызывается не только при запуске нового процесса. Но мы легко решим эту
проблему. NtQueryInformationThread предоставит нам информацию о том, какой
процесс владеет данным потоком. Мы должны просто проверить, заражен ли этот
процесс. Это можно определить прочитав первые байты любой из функций, которые
мы перехватываем.

NTSTATUS NtQueryInformationThread(
IN HANDLE ThreadHandle,
IN THREADINFOCLASS ThreadInformationClass,
OUT PVOID ThreadInformation,
IN ULONG ThreadInformationLength,
OUT PULONG ReturnLength OPTIONAL
);

В нашем случае параметр ThreadInformationClass должен быть равен
ThreadBasicInformation. ThreadInformation - это буфер для результата, размер
этого буфера указан в параметре ThreadInformationLength.

#define ThreadBasicInformation 0

Для класса ThreadBasicInformation возвращается такая структура:

typedef struct _THREAD_BASIC_INFORMATION {
NTSTATUS ExitStatus;
PNT_TIB TebBaseAddress;
CLIENT_ID ClientId;
KAFFINITY AffinityMask;
KPRIORITY Priority;
KPRIORITY BasePriority;
} THREAD_BASIC_INFORMATION, *PTHREAD_BASIC_INFORMATION;

В параметре ClientId находится PID процесса, владеющего этим потоком.

Теперь мы должны заразить новый процесс. Проблема в том, что процесс
имеет в своей памяти только ntdll.dll. Все остальные модули загружаются сразу
после вызова NtResumeThread. Существует несколько путей решения этой проблемы.
Например, можно перехватить функцию LdrInitializeThunk, которая вызывается при
инициализации процесса.

NTSTATUS LdrInitializeThunk(
DWORD Unknown1,
DWORD Unknown2,
DWORD Unknown3
);

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

DLL

В каждом процессе в системе есть копия ntdll.dll. Это значит, что мы
можем перехватить любую функцию этого модуля при инициализации процесса.
Но как быть с функциями из других модулей, например, kernel32.dll или
advapi32.dll? Есть несколько процессов, у которых есть только ntdll.dll.
Все остальные модули могут быть загружены динамически в середине кода после
перехвата процесса. Вот почему мы должны перехватить LdrLoadDll, которая
загружает новые модули.

NTSTATUS LdrLoadDll(
PWSTR szcwPath,
PDWORD pdwLdrErr,
PUNICODE_STRING pUniModuleName,
PHINSTANCE pResultInstance
);

Наиболее важно для нас pUniModuleName - имя модуля. pResultInstance
будет адресом модуля, если вызов был успешен.
Мы вызовем оригинальную LdrLoadDll и затем перехватим все функции в
загруженном модуле.

Память

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

NTSTATUS NtReadVirtualMemory(
IN HANDLE ProcessHandle,
IN PVOID BaseAddress,
OUT PVOID Buffer,
IN ULONG BufferLength,
OUT PULONG ReturnLength OPTIONAL
);

Мы заменили байты в начале тех функций, которые перехватили, и еще
выделили память для нового кода. Необходимо проверить читает ли функция
какие-либо из этих байт. Если наши байты находятся в диапазоне от BaseAddress
до (BaseAddress + BufferLength), мы должны заменить некоторые байты в Buffer.
Если кто-либо пытается прочитать байты из нашей выделенной памяти,
следует вернуть пустой Buffer и ошибку STATUS_PARTIAL_COPY. Это значение
говорит о том, что не все запрошенные байты были скопированы в буфер Buffer.
Это также происходит при попытке доступа к невыделенной памяти. ReturnLength
должно быть установлено в нуль в данном случае.

#define STATUS_PARTIAL_COPY 0x8000000D

Если кто-нибудь запрашивает первые байты перехваченной нами функции,
мы должны вызвать оригинальный код, а затем скопировать оригинальные байты
(мы их сохранили) в буфер Buffer.
Теперь процесс не сможет определить, что функции перехвачены, чтением
памяти. Также, если вы отлаживаете перехватываченные функции, у отладчика будут
проблемы. Он будет показывать оригинальные байты, но выполнять наш код.

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

NTSTATUS NtQueryVirtualMemory(
IN HANDLE ProcessHandle,
IN PVOID BaseAddress,
IN MEMORY_INFORMATION_CLASS MemoryInformationClass,
OUT PVOID MemoryInformation,
IN ULONG MemoryInformationLength,
OUT PULONG ReturnLength OPTIONAL
);

MemoryInformationClass определяет тип возвращаемых данных. Нас
интересуют первые два типа.

#define MemoryBasicInformation 0
#define MemoryWorkingSetList 1

Для MemoryBasicInformation возвращается структура:

typedef struct _MEMORY_BASIC_INFORMATION {
PVOID BaseAddress;
PVOID AllocationBase;
ULONG AllocationProtect;
ULONG RegionSize;
ULONG State;
ULONG Protect;
ULONG Type;
} MEMORY_BASIC_INFORMATION, *PMEMORY_BASIC_INFORMATION;

Каждая секция памяти имеет размер - RegionSize и тип - Type. Свободная
память имеет тип MEM_FREE.

#define MEM_FREE 0x10000

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

Для MemoryWorkingSetList возвращается структура:

typedef struct _MEMORY_WORKING_SET_LIST {
ULONG NumberOfPages;
ULONG WorkingSetList[1];
} MEMORY_WORKING_SET_LIST, *PMEMORY_WORKING_SET_LIST;

NumberOfPages - количество элементов в WorkingSetList. Это число должно
быть уменьшено. Мы должны найти нашу секцию в WorkingSetList и передвинуть
следующие записи на нее. WorkingSetList - массив DWORD'ов, где старшие 20 бит -
это старшие 20 бит адреса секции, а младшие 12 бит содержат флаги.

Хэндлы

Вызов NtQuerySystemInformation с классом SystemHandleInformation дает
нам массив всех открытых хэндлов в структуре _SYSTEM_HANDLE_INFORMATION_EX.

#define SystemHandleInformation 0x10

typedef struct _SYSTEM_HANDLE_INFORMATION {
ULONG ProcessId;
UCHAR ObjectTypeNumber;
UCHAR Flags;
USHORT Handle;
PVOID Object;
ACCESS_MASK GrantedAccess;
} SYSTEM_HANDLE_INFORMATION, *PSYSTEM_HANDLE_INFORMATION;

typedef struct _SYSTEM_HANDLE_INFORMATION_EX {
ULONG NumberOfHandles;
SYSTEM_HANDLE_INFORMATION Information[1];
} SYSTEM_HANDLE_INFORMATION_EX, *PSYSTEM_HANDLE_INFORMATION_EX;

ProcessId указывает процесс, владеющий этим хэндлом. ObjectTypeNumber -
это тип хэндла. NumberOfHandles - количество записей в массиве Information.
Скрытие одного элемента тривиально. Нужно сдвинуть последующие записи на одну
и уменьшить значение NumberOfHandles. Сдвиг последующих записей требуется,
потому что хэндлы в массиве сгруппированы по ProcessId. Это значит, что все
хэндлы одного процесса расположены последовательно. И для каждого процесса
значение поля Handle растет.
Вспомните структуру _SYSTEM_PROCESSES, которая возвращается этой
функцией с классом SystemProcessesAndThreadsInformation. Здесь мы можем
увидеть, что каждый процесс имеет информацию о количестве хэндлов в
HandleCount. Если мы хотим сделать все идеально, нам следует изменить поле
HandleCount (в соответствии с тем, сколько хэндлов мы скрыли), когда функция
будет вызвана с классом SystemProcessesAndThreadsInformation. Но эта поправка
может требовать слишком много времени. Множество хэндлов открываются и
закрываются в течении очень короткого времени при нормальной работе системы.
Легко может случиться, что количество хэндлов изменилось между двумя вызовами
функции, поэтому нам не нужно изменять здесь поле HandleCount.

Именование хэндлов и получение типа

Скрытие хэндлов тривиально, но немного сложнее определить какие хэндлы
мы должны скрыть. Если у нас есть, например, скрытый процесс, нас следует
скрыть все его хэндлы и все хэндлы связанные с ним. Скрытие хэндлов этого
процесса также тривиально. Мы просто сравниваем ProcessId хэндла и PID нашего
процесса, если они равны мы прячем хэндл. Но хэндлы других процессов должны
быть проименованы прежде, чем мы сможем сравнивать их с чем-либо. Количество
хэндлов в системе обычно очень велико, поэтому лучшее, что мы можем сделать -
это сравнить тип хэндла прежде, чем попытаться проименовать его. Именование
типов сохранит много времени для хэндлов, которые нас не интересуют.
Именование хэндла и типа хэндла может быть выполнено с помощью функции
NtQueryObject.

NTSTATUS ZwQueryObject(
IN HANDLE ObjectHandle,
IN OBJECT_INFORMATION_CLASS ObjectInformationClass,
OUT PVOID ObjectInformation,
IN ULONG ObjectInformationLength,
OUT PULONG ReturnLength OPTIONAL
);

ObjectHandle - хэндл, информацию о котором мы хотим получить,
ObjectInformationClass - тип информации, которая будет сохранена в буфер
ObjectInformation размером ObjectInformationLength байт.
Мы будем использовать классы ObjectNameInformation и
ObjectAllTypesInformation. Класс ObjectNameInfromation заполнит буфер
структурой OBJECT_NAME_INFORMATION, а класс ObjectAllTypesInformation
структурой OBJECT_ALL_TYPES_INFORMATION.

#define ObjectNameInformation 1
#define ObjectAllTypesInformation 3

typedef struct _OBJECT_NAME_INFORMATION {
UNICODE_STRING Name;
} OBJECT_NAME_INFORMATION, *POBJECT_NAME_INFORMATION;

Поле Name определяет имя хэндла.

typedef struct _OBJECT_TYPE_INFORMATION {
UNICODE_STRING Name;
ULONG ObjectCount;
ULONG HandleCount;
ULONG Reserved1[4];
ULONG PeakObjectCount;
ULONG PeakHandleCount;
ULONG Reserved2[4];
ULONG InvalidAttributes;
GENERIC_MAPPING GenericMapping;
ULONG ValidAccess;
UCHAR Unknown;
BOOLEAN MaintainHandleDatabase;
POOL_TYPE PoolType;
ULONG PagedPoolUsage;
ULONG NonPagedPoolUsage;
} OBJECT_TYPE_INFORMATION, *POBJECT_TYPE_INFORMATION;

typedef struct _OBJECT_ALL_TYPES_INFORMATION {
ULONG NumberOfTypes;
OBJECT_TYPE_INFORMATION TypeInformation;
} OBJECT_ALL_TYPES_INFORMATION, *POBJECT_ALL_TYPES_INFORMATION;

Поле Name определяет имя типа объекта, которое следует сразу после
каждой структуры OBJECT_TYPE_INFORMATION. Следующая структура
OBJECT_TYPE_INFORMATION расположена после этого имени и выровнена на границу
четырех байт.

ObjectTypeNumber из структуры SYSTEM_HANDLE_INFORMATION - это индекс
в массиве TypeInformation.

Сложнее получить имя хэндла из другого процесса. Существуют два способа
сделать это. Первый состоит в том, чтобы скопировать хэндл функцией
NtDuplicateObject в наш процесс и затем проименовать его. Этот метод не
сработает для некоторых специфических типов хэндлов. Но он не срабатывает
довольно редко, поэтому мы можем оставаться спокойными и использовать его.

NtDuplicateObject(
IN HANDLE SourceProcessHandle,
IN HANDLE SourceHandle,
IN HANDLE TargetProcessHandle,
OUT PHANDLE TargetHandle OPTIONAL,
IN ACCESS_MASK DesiredAccess,
IN ULONG Attributes,
IN ULONG Options
);

SourceProcessHandle - хэндл процесса, который владеет SourceHandle,
то есть хэндлом, который мы хотим скопировать. TargetProcessHandle - это хэндл
процесса, в который мы хотим копировать. Это хэндл нашего процесса в нашем
случае. TargetHandle - указатель, куда будет сохранена копия хэндла. Параметр
DesiredAccess должен быть равен PROCESS_QUERY_INFORMATION, а Attribures
и Options - нулю.

Второй способ именования, работающий со всеми хэндлами, состоит в
использовании системного драйвера. Исходный код этого метода доступен в
проекте OpHandle на моем сайте http://rootkit.host.sk.

Порты

Самый простой путь для перечисления открытых портов - это использование
функций AllocateAndGetTcpTableFromStack и AllocateAndGetUdpTableFromStack,
и/или AllocateAndGetTcpExTableFromStack и AllocateAndGetUdpExTableFromStack из
iphlpapi.dll. Ex-функции доступны начиная с Windows XP.

typedef struct _MIB_TCPROW {
DWORD dwState;
DWORD dwLocalAddr;
DWORD dwLocalPort;
DWORD dwRemoteAddr;
DWORD dwRemotePort;
} MIB_TCPROW, *PMIB_TCPROW;

typedef struct _MIB_TCPTABLE {
DWORD dwNumEntries;
MIB_TCPROW table[ANY_SIZE];
} MIB_TCPTABLE, *PMIB_TCPTABLE;

typedef struct _MIB_UDPROW {
DWORD dwLocalAddr;
DWORD dwLocalPort;
} MIB_UDPROW, *PMIB_UDPROW;

typedef struct _MIB_UDPTABLE {
DWORD dwNumEntries;
MIB_UDPROW table[ANY_SIZE];
} MIB_UDPTABLE, *PMIB_UDPTABLE;

typedef struct _MIB_TCPROW_EX
{
DWORD dwState;
DWORD dwLocalAddr;
DWORD dwLocalPort;
DWORD dwRemoteAddr;
DWORD dwRemotePort;
DWORD dwProcessId;
} MIB_TCPROW_EX, *PMIB_TCPROW_EX;

typedef struct _MIB_TCPTABLE_EX
{
DWORD dwNumEntries;
MIB_TCPROW_EX table[ANY_SIZE];
} MIB_TCPTABLE_EX, *PMIB_TCPTABLE_EX;

typedef struct _MIB_UDPROW_EX
{
DWORD dwLocalAddr;
DWORD dwLocalPort;
DWORD dwProcessId;
} MIB_UDPROW_EX, *PMIB_UDPROW_EX;

typedef struct _MIB_UDPTABLE_EX
{
DWORD dwNumEntries;
MIB_UDPROW_EX table[ANY_SIZE];
} MIB_UDPTABLE_EX, *PMIB_UDPTABLE_EX;

DWORD WINAPI AllocateAndGetTcpTableFromStack(
OUT PMIB_TCPTABLE *pTcpTable,
IN BOOL bOrder,
IN HANDLE hAllocHeap,
IN DWORD dwAllocFlags,
IN DWORD dwProtocolVersion;
);

DWORD WINAPI AllocateAndGetUdpTableFromStack(
OUT PMIB_UDPTABLE *pUdpTable,
IN BOOL bOrder,
IN HANDLE hAllocHeap,
IN DWORD dwAllocFlags,
IN DWORD dwProtocolVersion;
);

DWORD WINAPI AllocateAndGetTcpExTableFromStack(
OUT PMIB_TCPTABLE_EX *pTcpTableEx,
IN BOOL bOrder,
IN HANDLE hAllocHeap,
IN DWORD dwAllocFlags,
IN DWORD dwProtocolVersion;
);

DWORD WINAPI AllocateAndGetUdpExTableFromStack(
OUT PMIB_UDPTABLE_EX *pUdpTableEx,
IN BOOL bOrder,
IN HANDLE hAllocHeap,
IN DWORD dwAllocFlags,
IN DWORD dwProtocolVersion;
);

Есть и другой способ. Когда программа создает сокет и начинает его
слушать, она, конечно, имеет открытый хэндл для него и для открытого порта.
Мы можем перечислить все открытые хэндлы в системе и послать им специальный
буфер, используя функцию NtDeviceIoControlFile, чтобы определить хэндлы
для открытых портов. Это также даст нам информацию о портах. Так как открытых
хэндлов очень много, мы будем тестировать только хэндлы с типом File и именем
\Device\Tcp или \Device\Udp. Открытые порты имеют только этот тип и имя.

Когда мы смотрели код перечисленных функций в iphlpapi.dll, мы
обнаружили, что эти функции вызывают NtDeviceIoControlFile и посылают
специальный буфер для того, чтобы получить список всех открытых портов в
системе. Это значит, что единственная функция, которую нужно перехватить для
скрытия портов - это NtDeviceIoControlFile.

NTSTATUS NtDeviceIoControlFile(
IN HANDLE FileHandle
IN HANDLE Event OPTIONAL,
IN PIO_APC_ROUTINE ApcRoutine OPTIONAL,
IN PVOID ApcContext OPTIONAL,
OUT PIO_STATUS_BLOCK IoStatusBlock,
IN ULONG IoControlCode,
IN PVOID InputBuffer OPTIONAL,
IN ULONG InputBufferLength,
OUT PVOID OutputBuffer OPTIONAL,
IN ULONG OutputBufferLength
);

Интересующие нас параметры - это FileHandle (определяет хэндл
устройства), IoStatusBlock (указывает на переменную, которая получает
информацию о статусе выполнения и информацию об операции), IoControlCode
(число, определяющее тип устройства, метод, права доступа и функцию).
InputBiffer содержит данные размером InputBufferLength байт. И тоже самое в
OutputBuffer и OutputbufferLength.

Netstat, OpPorts в WinXP, FPort в WinXP

Получение списка открытых портов в первую очередь использутеся,
например, в OpPorts и FPort в Windows XP, а также Netstat.
Программы вызывают NtDeviceIoControlFile дважды с IoControlCode равным
0x000120003. OutputBuffer заполняется после второго вызова. Имя FileHandle
здесь всегда \Device\Tcp. InputBuffer различается для разных типов вызова:

1) Для получения массива из MIB_TCPROW InputBuffer должен быть таким:

первый вызов:
0x00 0x04 0x00 0x00 0x00 0x00 0x00 0x00 0x00 0x02 0x00 0x00 0x00 0x01 0x00 0x00
0x01 0x00 0x00 0x00 0x00 0x00 0x00 0x00 0x00 0x00 0x00 0x00 0x00 0x00 0x00 0x00
0x00 0x00 0x00 0x00

второй вызов:
0x00 0x04 0x00 0x00 0x00 0x00 0x00 0x00 0x00 0x02 0x00 0x00 0x00 0x01 0x00 0x00
0x01 0x01 0x00 0x00 0x00 0x00 0x00 0x00 0x00 0x00 0x00 0x00 0x00 0x00 0x00 0x00
0x00 0x00 0x00 0x00

2) Чтобы получить массив из MIB_UDPROW:

первый вызов:
0x01 0x04 0x00 0x00 0x00 0x00 0x00 0x00 0x00 0x02 0x00 0x00 0x00 0x01 0x00 0x00
0x01 0x00 0x00 0x00 0x00 0x00 0x00 0x00 0x00 0x00 0x00 0x00 0x00 0x00 0x00 0x00
0x00 0x00 0x00 0x00

второй вызов:
0x01 0x04 0x00 0x00 0x00 0x00 0x00 0x00 0x00 0x02 0x00 0x00 0x00 0x01 0x00 0x00
0x01 0x01 0x00 0x00 0x00 0x00 0x00 0x00 0x00 0x00 0x00 0x00 0x00 0x00 0x00 0x00
0x00 0x00 0x00 0x00

3) Чтобы получить массив из MIB_TCPROW_EX:

первый вызов:
0x00 0x04 0x00 0x00 0x00 0x00 0x00 0x00 0x00 0x02 0x00 0x00 0x00 0x01 0x00 0x00
0x01 0x00 0x00 0x00 0x00 0x00 0x00 0x00 0x00 0x00 0x00 0x00 0x00 0x00 0x00 0x00
0x00 0x00 0x00 0x00

второй вызов:
0x00 0x04 0x00 0x00 0x00 0x00 0x00 0x00 0x00 0x02 0x00 0x00 0x00 0x01 0x00 0x00
0x02 0x01 0x00 0x00 0x00 0x00 0x00 0x00 0x00 0x00 0x00 0x00 0x00 0x00 0x00 0x00
0x00 0x00 0x00 0x00

4) Чтобы получить массив из MIB_UDPROW_EX:

Первый вызов:
0x01 0x04 0x00 0x00 0x00 0x00 0x00 0x00 0x00 0x02 0x00 0x00 0x00 0x01 0x00 0x00
0x01 0x00 0x00 0x00 0x00 0x00 0x00 0x00 0x00 0x00 0x00 0x00 0x00 0x00 0x00 0x00
0x00 0x00 0x00 0x00

Второй вызов:
0x01 0x04 0x00 0x00 0x00 0x00 0x00 0x00 0x00 0x02 0x00 0x00 0x00 0x01 0x00 0x00
0x02 0x01 0x00 0x00 0x00 0x00 0x00 0x00 0x00 0x00 0x00 0x00 0x00 0x00 0x00 0x00
0x00 0x00 0x00 0x00

Вы можете заметить, что буферы различаются только в нескольких байтах.
Мы можем объяснить это.

Интересующие нас вызовы имеют в InputBuffer[1] 0x04 и, в основном,
InputBuffer[17] содержит 0x01. Только при таких входных данных мы получим
в OutputBuffer нужные таблицы. Если мы хотим получить информацию о TCP-портах,
нужно установить в InputBuffer[0] значение 0x00, или 0x01 для получения
информации о UDP-портах. Если нам нужны Ex-таблицы (MIB_TCPROW_EX или
MIB_UDPROW_EX), нужно во втором вызове установить в Inputbuffer[16] 0x02.

Если мы перехватили вызов с этими параметрами, нужно просто изменить
выходной буфер. Чтобы получить количество строк в выходном буфере, просто
разделите Information из IoStatusBlock на размер строки. Скрыть одну строку
очень просто. Просто перезапишите ее последующими строками и удалить последнюю
строку. Не забудьте изменить OutputBufferLength и IoStatusBlock.

OpPorts в Win2k и NT4, FPort в Win2k

Мы используем NtDeviceIoControlFile с IoControlCode равным 0x00210012,
чтобы определить, что хэндл с типом File и именем \Device\Tcp или \Device\Udp -
это хэндл открытого порта.

Во-первых, мы сравним IoControlCode, а затем тип и имя хэндла. Если
он нас все еще интересует, мы проверим длину входного буфера, который должен
быть равным длине структуры TDI_CONNECTION_IN. Ее длина 0x18. Выходной буфер -
TDI_CONNETION_OUT.

typedef struct _TDI_CONNETION_IN
{
ULONG UserDataLength,
PVOID UserData,
ULONG OptionsLength,
PVOID Options,
ULONG RemoteAddressLength,
PVOID RemoteAddress
} TDI_CONNETION_IN, *PTDI_CONNETION_IN;

typedef struct _TDI_CONNETION_OUT
{
ULONG State,
ULONG Event,
ULONG TransmittedTsdus,
ULONG ReceivedTsdus,
ULONG TransmissionErrors,
ULONG ReceiveErrors,
LARGE_INTEGER Throughput
LARGE_INTEGER Delay,
ULONG SendBufferSize,
ULONG ReceiveBufferSize,
ULONG Unreliable,
ULONG Unknown1[5],
USHORT Unknown2
} TDI_CONNETION_OUT, *PTDI_CONNETION_OUT;

Конкретная реализация, того как определить то, что хэндл - это хэндл
открытого порта, доступна в исходном коде OpPorts на моем сайте
http://rootkit.host.sk. Сейчас нам необходимо скрыть определенные порты. Мы
уже проверили InputBufferLength и IoControlCode. Теперь мы должны проверить
RemoteAddressLength - для открытого порта всегда 3 или 4. Наконец, мы должны
сравнить поле ReceivedTsdus из OutputBuffer, которое содержит порт в
сетевой форме, со списком портов, которые мы хотим скрыть. Мы можем различать
TCP и UDP в соответствии с именем хэндла. Удалив OutputBuffer, изменив
IoStatusBlock и вернув значение STATUS_INVALID_ADDRESS, мы скроем порт.

Окончание

Конкретная реализация описанных техник доступна в исходном коде
Hacker Defender Rootkit версии 1.0.0 на сайте http://rootkit.host.sk и на
http://www.rootkit.com.
Возможно, я добавлю информацию о невидимости в Windows NT в будущем.
Новые версии документа также будут содержать улучшения описаных методов и новые
комментарии.
Отдельное спасибо Ratter'у, который дал мне много ноу-хау, которые были
необходимы для написания этой статьи и кода проекта Hacker Defender.
Все комментарии присылаете на holy_father@phreaker.net или на доску на
сайте http://rootkit.host.sk.

Взято из

Как свернуть прогу в tray?

Проще всего использовать RxTrayIcon компонент из библиотеки RxLib

procedure TForm1.ApplicationMinimize(Sender : TObject);
begin
RxTrayIcon1.Show;
ShowWindow(Application.Handle,SW_HIDE);
end;

procedure TForm1.RxTrayIcon1Click(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
Application.Restore;
SetForeGroundWindow(Application.MainForm.Handle);
RxTrayIcon1.Hide;
end;

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

Нет такого понятия "свернуть в трей". Есть возможность только добавлять, удалять и менять значок в области трея. Сама же программа просто прячется.
Для изменения значка в трее используется класс TShellNotifyIcon модуля ShellApi
Объявим следующую процедруру:
Параметры к ней такие: n - номер операции ( 1 - добавить, 2 - удалить, 3 - заменить) и Icon - сама иконка с которой будет делаться эта операция

Procedure TForm1.Ic(n:Integer;Icon:TIcon);
  Var Nim:TNotifyIconData;
begin
With Nim do
Begin
cbSize:=SizeOf(Nim);
Wnd:=Form1.Handle;
uID:=1;
uFlags:=NIF_ICON or NIF_MESSAGE or NIF_TIP;
hicon:=Icon.Handle;
uCallbackMessage:=wm_user+1;
szTip:='Хинт, который будет появляться у значка';
End;
Case n OF
1: Shell_NotifyIcon(Nim_Add,@Nim);
2: Shell_NotifyIcon(Nim_Delete,@Nim);
3: Shell_NotifyIcon(Nim_Modify,@Nim);
End;
end;

Теперь, нам нужно отловить минимизацию приложения, для того, чтобы заменить стандартное действие Windows на "свёртывание в трей". Объявляем в секции protected процедуру

protected

procedure ControlWindow(var Msg: TMessage); message WM_SYSCOMMAND;
...
    procedure TForm1.ControlWindow(var Msg: TMessage);
  begin
    if Msg.WParam = SC_MINIMIZE then
      begin
        Ic(1, Application.Icon); // Добавляем значок в трей
        ShowWindow(Handle, SW_HIDE); // Скрываем программу
      end
    else
      inherited;
  end;

Теперь нам нужно, чтобы значок в трее мог реагировать на манипуляции с ним. Если Вы внимательно посмотрите процедру Ic(), то Вы увидите там ссылку на сообщение WM_USER+1. Это не что иное, как сообщение, которое приходит нам от этого значка. Обычно для значка в трее делают всплывающее меню и выводят там те или иные действия. Но TPopUpMenu делается обычно для правой кнопки, по левой же просто активируют приложение. На форму кидаем комопонент TPopUpMenu (пусть это будет PopUpMenu1) и заносим в него все пункты меню, которые мы хотим, чтобы онм появилис в меню, которое будет всплывать по нажатию правой кнопки на значке.
После этого описываем обработчик: В вышеназванную секцию protected добавляем ещё одну процедуру IconMouse, которая будет реагировать на сообщение WM_USER+1

protected

procedure ControlWindow(var Msg: TMessage); message WM_SYSCOMMAND;
  procedure IconMouse(var Msg: TMessage); message WM_USER + 1;

    Теперь описываем собственно процедуру.

    procedure TForm1.IconMouse(var Msg: TMessage);
    var p: tpoint;
    begin
      GetCursorPos(p); // Запоминаем координаты курсора мыши
      case Msg.LParam of // Проверяем какая кнопка была нажата
        WM_LBUTTONUP, WM_LBUTTONDBLCLK: {Действия, выполняемый по одинарному или двойному щел?ку левой кнопки мыши на зна?ке. В нашем слу?ае это просто активация приложения}
          begin
            Ic(3, Applicattion.Icon); // Удаляем зна?ок из трея
            ShowWindow(Application.Handle, SW_SHOWNORMAL); // Восстанавливаем окно программы
          end;
        WM_RBUTTONUP: {Действия, выполняемый по одинарному щел?ку правой кнопки мыши}
          begin
            SetForegroundWindow(Handle); // Восстанавливаем программу в ка?естве переднего окна
            PopupMenu1.Popup(p.X, p.Y); // Заставляем всплыть тот самый TPopUp о котором я говорил ?уть раньше
            PostMessage(Handle, WM_NULL, 0, 0) // Обнуляем сообщение
          end;
      end;
    end;

Для выполнения пунктов всплывающего меню, пишите стандартные обработчики onClick() для его пунктов.

Данный опус писался только в форме, в IDE не тестировался . Всё работает конечно, но не обессудьте, если будут ошибочки мелкие.

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

Для работы с SystemTray существует всего одна функция. Вот ее
Си-прототип:
WINSHELLAPI BOOL WINAPI Shell_NotifyIcon(
DWORD dwMessage, // message identifier
PNOTIFYICONDATA pnid // pointer to structure);

Эта функция описана в заголовочном файле Win32-SDK " shellapi.h" ,
включаемом в программу при включении " windows.h" . Параметр
dwMessage может принимать одно из трех значений: NIM_ADD,
NIM_DELETE, NIM_MODIFY. Для добавления иконки он должен быть
установлен в NIM_ADD.
Параметр pnid имеет тип PNOTIFYDATA, который описан как:
typedef struct _NOTIFYICONDATA { // nid
DWORD cbSize;
HWND hWnd;
UINT uID;
UINT uFlags;
UINT uCallbackMessage;
HICON hIcon;
char szTip[64];
} NOTIFYICONDATA, *PNOTIFYICONDATA;
Поля структуры NOTIFYICONDATA имеют следующий смысл:
cbSize - размер структуры, должен быть
sizeof(NOTIFYICONDATA).
hWnd - дескриптор окна, которое будет получать события
мыши над иконкой.
uID - уникальный идентификатор иконки. Идентификатор
должен быть уникален в пределах окна - обрабо-
тчика, передаваемого в hWnd.
uFlags - битовое поле, определяющее какое из следующих
полей несет действительную информацию.
Может быть одним из следующих значений: NIF_ICON,
NIF_MESSAGE, NIF_TIP или их OR-комбинацией.
uCallbackMessage - сообщение, передаваемое окну - обработчику при
событиях мыши. Желательно получать номер
сообщения вызовом RegisterWindowMessage(),
но допускаются и значения WM_USER+N, где N > 0.
hIcon - дескриптор иконки, помещаемой на Tray.
szTip - текст для ToolTip'а, если szTip[0] = 0x00, то
ToolTip'а не будет.
Таким образом, для добавления иконки на Tray необходимо
заполнить экземпляр структуры NOTIFYICONDATA и вызвать функцию
Shell_NotifyIcon() с параметром NIM_ADD и указателем на
заполненный экземпляр структуры.
При добавлении иконки необходимо заполнить поля cbSize, hWnd,
uID, uFlags, uCallbackMessage, hIcon. Поле szTip можно оставить
пустым, если вам не нужен ToolTip. Поле uFlags должно содержать
как минимум NIF_MESSAGE | NIF_ICON.

Взято из FAQ:

Как связать определённое расширение файлов с моим приложением?

В Win32 необходимо создать новую запись в реестре в корневом ключе HKEY_CLASSES_ROOT, которая будет указывать на расширение файла, командную строку и иконку, которая будет отображаться для этого расширения. В Win16, просто включить расширение файла и командную строку в секцию [Extensions] в Win.ini.

Пример:

uses
  Registry, {For Win32}
  IniFiles; {For Win16}

{Для Win32}
procedure TForm1.Button1Click(Sender: TObject);
var
  reg: TRegistry;
begin
  reg := TRegistry.Create;
  reg.RootKey := HKEY_CLASSES_ROOT;
  reg.LazyWrite := false;
  {Add Program Support}
  reg.OpenKey('.bor\shell\open\command', true);
  {Имя файла будет передавать в приложение как первый параметр}
  reg.WriteString('', 'C:\Program Files\Borland\Delphi 3\Project1.exe %1');
  {Добавляем отображаемую иконку}
  reg.CloseKey;
  reg.OpenKey('.bor\DefaultIcon',true);
  {Для отображения используем первую иконку в нашем приложении}
  reg.WriteString('', 'C:\Program Files\Borland\Delphi 3\Project1.exe,0');
  reg.CloseKey;
  reg.free;
end;

{Для Win16}
procedure TForm1.Button2Click(Sender: TObject);
var
  WinIni : TIniFile;
  WinIniFileName : array[0..MAX_PATH] of char;
  s : array[0..64] of char;
begin
  GetWindowsDirectory(WinIniFileName, sizeof(WinIniFileName));
  StrCat(WinIniFileName, '\win.ini');
  WinIni := TIniFile.Create(WinIniFileName);
  WinIni.WriteString('Extensions',
                     'bor',
                     'C:\PROGRA~1\BORLAND\DELPHI~1\PROJECT1.EXE ^.bor');
  WinIni.Free;
  StrCopy(S, 'Extensions');
  SendMessage(HWND_BROADCAST, WM_WININICHANGE, 0, LongInt(@S));
end;

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

Как связать TreeView и PageControl?

На форме стоит TreeView, PageControl и кнопка.
При смене страницы - меняется текущий узел, а при смене узла меняется страница.

unit Unit1;

interface

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

type
  TForm1 = class(TForm)
    TreeView1: TTreeView;
    Button1: TButton;
    PageControl1: TPageControl;
    procedure Button1Click(Sender: TObject);
    procedure TreeView1Change(Sender: TObject; Node: TTreeNode);
    procedure PageControl1Change(Sender: TObject);
  private
    procedure addItem(t: String);
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

Procedure TForm1.addItem(t:String);
  var TabSheet:TTabSheet;
      Node:TTreenode;
begin
  TabSheet:=TTabSheet.Create(Self);
  TabSheet.PageControl:=PageControl1;
  TabSheet.caption:=t;
  Node:=TreeView1.Items.Add(nil, t);
  Node.data:=TabSheet; //ассоциируем узел с страницей
  TabSheet.tag:=Integer(Node); // ассоциируем страницу с узлом

end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  TreeView1.HideSelection:=false;
  addItem('Item1');
  addItem('Item2');
  addItem('Item3');
  addItem('Item4');
end;

procedure TForm1.TreeView1Change(Sender: TObject; Node: TTreeNode);
begin
  PageControl1.ActivePage:=TTabSheet(Node.data);// Доступ к ассоциированной странице через узел
end;

procedure TForm1.PageControl1Change(Sender: TObject);
begin
  TreeView1.Selected:=TTreeNode(Pointer(PageControl1.ActivePage.tag));// Доступ к ассоциированному узлу через страницу
end;

end.

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

Как таскать форму за метку?

procedure TForm1.Label1MouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
const SC_DragMove = $F012; { a magic number }
begin
ReleaseCapture;
Form1.perform(WM_SysCommand, SC_DragMove, 0);
end;

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

Как убить задачу, зная только имя .exe?

{ Эта небольшая функция закрывает приложения, соответствующие заданному имени .exe.
  Пример: KillTask('notepad.exe');
                  KillTask('iexplore.exe'); }

uses
  Tlhelp32, Windows, SysUtils;

function KillTask(ExeFileName: string): integer;
const
  PROCESS_TERMINATE=$0001;
var
  ContinueLoop: BOOL;
  FSnapshotHandle: THandle;
  FProcessEntry32: TProcessEntry32;
begin
  result := 0;

  FSnapshotHandle := CreateToolhelp32Snapshot
                     (TH32CS_SNAPPROCESS, 0);
  FProcessEntry32.dwSize := Sizeof(FProcessEntry32);
  ContinueLoop := Process32First(FSnapshotHandle,
                                 FProcessEntry32);

  while integer(ContinueLoop) <> 0 do
  begin
    if ((UpperCase(ExtractFileName(FProcessEntry32.szExeFile)) =
         UpperCase(ExeFileName))
     or (UpperCase(FProcessEntry32.szExeFile) =
         UpperCase(ExeFileName))) then
      Result := Integer(TerminateProcess(OpenProcess(
                        PROCESS_TERMINATE, BOOL(0),
                        FProcessEntry32.th32ProcessID), 0));
    ContinueLoop := Process32Next(FSnapshotHandle,
                                  FProcessEntry32);
  end;

  CloseHandle(FSnapshotHandle);
end;

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

Как убрать HSCROLL у DBGRID?

Нужные нам свойства существуют, но вынесены в секцию Protected предка DBGrid: TCustomGrid. Наиболее правильным способом было бы создание класса наследника от TDBGrid с выводом ScrollBars в секцию Public, но можно обойтись и без этого следующим способом:

Type TFake=class(TCustomGrid);

implementation

{$R *.dfm}

procedure TForm1.Button1Click(Sender: TObject);
begin
TFake(DBGrid1).ScrollBars:=ssVertical;
end;

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

Как убрать мою программу из списка Alt+Ctrl+Del?

function RegisterServiceProcess(dwProcessID, dwType: Integer): Integer; stdcall; external 'KERNEL32.DLL';

implementation

procedure TForm1.Button1Click(Sender: TObject);
begin //Скрываем
if not (csDesigning in ComponentState) then
RegisterServiceProcess(GetCurrentProcessID, 1);
end;

procedure TForm1.Button2Click(Sender: TObject);
begin //Опять показываем
if not (csDesigning in ComponentState) then
RegisterServiceProcess(GetCurrentProcessID, 0);
end;

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