IDE highlighting the incorrect line

On one project, the IDE insists on highlighting the incorrect line
for different conditions. For example, when a syntax error is
highlighted, the line above the error is highlighted or when I set
breakpoints by choosing a blue dot in the gutter, it does not
"line up" with the text line. How can I fix this?

This condition is usually caused by opening the file in a different
editor than the editor provided by the IDE. If a line of code is
somehow modified and then saved back to the disk using only a carriage
return for a line terminating character (instead of a carriage return
+ line feed sequence), the IDE may get confused. To fix the problem,
load the file into an editor that will save each line with a carriage
return + line feed sequence.

Примечание от Vit: ошибка исправлена в Дельфи 7.

Иерархия классов

Следующий модуль строит дерево классов

unitInfoForm;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,
  StdCtrls, ExtCtrls, Buttons, Clipbrd, Comctrls, Db, Dbcgrids,
  Dbctrls, Dbgrids, Dblookup, Dbtables, Dialogs,
  Filectrl, Grids, Mask, Menus, Mplayer, Oleconst, Olectnrs,
  Olectrls, Outline, Tabnotbk, Tabs, IniFiles, Printers,
  Registry, DsgnIntf, Provider, BdeProv, DBClient,
  ComObj, ActiveX, DDEMan, IBCtrls, Math, Nsapi, Isapi,
  ScktComp, Axctrls, Calendar, CgiApp, checklst,
  ColorGrd, ComServ, syncobjs, httpapp, dbweb, DirOutln,
  Gauges, DsIntf, ToolIntf, EditINtf, ExptIntf, VirtIntf,
  istreams, isapiapp, dblogdlg, masks, ExtDlgs, Spin;

type
  TForm1 = class(TForm)
    ListBox1: TListBox;
    Label1: TLabel;
    Edit1: TEdit;
    Label2: TLabel;
    Panel1: TPanel;
    TreeView1: TTreeView;
    ProgressBar1: TProgressBar;
    Button1: TButton;
    Button2: TButton;
    procedure Button1Click(Sender: TObject);
    procedure TreeView1Change(Sender: TObject; Node: TTreeNode);
    procedure Button2Click(Sender: TObject);
  private
    function AddClass (NewClass: TClass): TTreeNode;
    function GetNode (BaseClass: TClass): TTreeNode;
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

type
  TClassArray = array [1..498] of TClass;

const
  ClassArray: TClassArray = (
EAbort,
EAccessViolation,
EAssertionFailed,
EBitsError,
EClassNotFound,
EComponentError,
EControlC,
EConvertError,
EDatabaseError,
EDateTimeError,
EDBClient,
EDBEditError,
EDBEngineError,
EDivByZero,
EExternalException,
EFCreateError,
EFilerError,
EFOpenError,
EIBError,
EInOutError,
EIntError,
EIntfCastError,
EIntOverflow,
EInvalidArgument,
EInvalidCast,
EInvalidContainer,
EInvalidGraphic,
EInvalidGraphicOperation,
EInvalidGridOperation,
EInvalidImage,
EInvalidInsert,
EInvalidOp,
EInvalidOperation,
EInvalidPointer,
EListError,
EMathError,
EMCIDeviceError,
EMenuError,
EMethodNotFound,
ENoResultSet,
EOleCtrlError,
EOleError,
EOleException,
EOleException,
EOleSysError,
EOutlineError,
EOutOfMemory,
EOutOfResources,
EOverflow,
EPackageError,
EParserError,
EPrinter,
EPrivilege,
EPropertyError,
EPropReadOnly,
EPropWriteOnly,
ERangeError,
EReadError,
EReconcileError,
ERegistryException,
EResNotFound,
ESocketError,
EStackOverflow,
EStreamError,
EStringListError,
EThread,
ETreeViewError,
EUnderflow,
EUpdateError,
EVariantError,
EWin32Error,
EWriteError,
Exception,
EZeroDivide,
OutlineError,
TActiveForm,
TActiveFormControl,
TActiveFormFactory,
TActiveXControl,
TActiveXControlFactory,
TActiveXPropertyPage,
TActiveXPropertyPageFactory,
TAdapterNotifier,
TAggregatedObject,
TAnimate,
TApplication,
TAutoIncField,
TAutoIntfObject,
TAutoObject,
TAutoObjectFactory,
TBatchMove,
TBCDField,
TBDECallback,
TBDEDataSet,
TBevel,
TBinaryField,
TBitBtn,
TBitmap,
TBitmapImage,
TBits,
TBlobField,
TBlobStream,
TBookmarkList,
TBooleanField,
TBoolProperty,
TBrush,
TButton,
TButtonControl,
TBytesField,
TCalendar,
TCanvas,
TCaptionProperty,
TCGIApplication,
TCGIRequest,
TCGIResponse,
TChangeLink,
TCharProperty,
TCheckBox,
TCheckConstraint,
TCheckConstraints,
TCheckListBox,
TClassProperty,
TClientDataSet,
TClientSocket,
TClientWinSocket,
TClipboard,
TCollection,
TCollectionItem,
TColorDialog,
TColorGrid,
TColorProperty,
TColumn,
TColumnTitle,
TComboBox,
TComboButton,
TComClassManager,
TCommonDialog,
TCommonDialog,
TComObject,
TComObjectFactory,
TComponent,
TComponentEditor,
TComponentList,
TComponentNameProperty,
TComponentProperty,
TComServer,
TComServerObject,
TComServerObject,
TConnectionPoint,
TConnectionPoints,
TContainedObject,
TControl,
TControlCanvas,
TControlScrollBar,
TConversion,
TCoolBand,
TCoolBands,
TCoolBar,
TCriticalSection,
TCurrencyField,
TCursorProperty,
TCustomAdapter,
TCustomAdapter,
TCustomCheckBox,
TCustomComboBox,
TCustomControl,
TCustomDBGrid,
TCustomEdit,
TCustomForm,
TCustomGrid,
TCustomGroupBox,
TCustomHotKey,
TCustomImageList,
TCustomLabel,
TCustomListBox,
TCustomListView,
TCustomMaskEdit,
TCustomMemo,
TCustomMemoryStream,
TCustomModule,
TCustomOutline,
TCustomPageProducer,
TCustomPanel,
TCustomProvider,
TCustomRadioGroup,
TCustomRemoteServer,
TCustomRemoteServer,
TCustomRichEdit,
TCustomServerSocket,
TCustomSocket,
TCustomStaticText,
TCustomTabControl,
TCustomTreeView,
TCustomUpDown,
TCustomWebDispatcher,
TCustomWinSocket,
TDatabase,
TDataLink,
TDataModule,
TDataSet,
TDataSetDesigner,
TDataSetTableProducer,
TDataSetUpdateObject,
TDataSetUpdateObject,
TDataSource,
TDataSourceLink,
TDateField,
TDateProperty,
TDateTimeColors,
TDateTimeField,
TDateTimePicker,
TDBCheckBox,
TDBComboBox,
TDBCtrlGrid,
TDBCtrlGridLink,
TDBCtrlPanel,
TDBDataSet,
TDBEdit,
TDBError,
TDBGrid,
TDBGridColumns,
TDBImage,
TDBListBox,
TDBLookupCombo,
TDBLookupComboBox,
TDBLookupControl,
TDBLookupList,
TDBLookupListBox,
TDBMemo,
TDBNavigator,
TDBRadioGroup,
TDBRichEdit,
TDBText,
TDdeClientConv,
TDdeClientItem,
TDdeMgr,
TDdeServerConv,
TDdeServerItem,
TDefaultEditor,
TDesigner,
TDirectoryListBox,
TDirectoryOutline,
TDragControlObject,
TDragObject,
TDrawGrid,
TDriveComboBox,
TDSTableProducer,
TDSTableProducerEditor,
TEdit,
TEnumPropDesc,
TEnumProperty,
TEvent,
TEventDispatch,
TField,
TFieldDataLink,
TFieldDef,
TFieldDefs,
TFileListBox,
TFiler,
TFileStream,
TFilterComboBox,
TFindDialog,
TFloatField,
TFloatProperty,
TFont,
TFontAdapter,
TFontCharsetProperty,
TFontDialog,
TFontNameProperty,
TFontProperty,
TForm,
TFormDesigner,
TGauge,
TGraphic,
TGraphicControl,
TGraphicField,
TGraphicsObject,
TGridDataLink,
TGroupBox,
THandleObject,
THandleStream,
THeader,
THeaderControl,
THeaderSection,
THeaderSections,
THintWindow,
THotKey,
THTMLTableAttributes,
THTMLTableCellAttributes,
THTMLTableColumn,
THTMLTableColumns,
THTMLTableElementAttributes,
THTMLTableHeaderAttributes,
THTMLTableRowAttributes,
THTMLTagAttributes,
THTTPDataLink,
TIBComponent,
TIBEventAlerter,
TIComponentInterface,
TIcon,
TIconImage,
TIconOptions,
TIEditorInterface,
TIEditReader,
TIEditView,
TIEditWriter,
TIExpert,
TIFileStream,
TIFormInterface,
TImage,
TImageList,
TIMainMenuIntf,
TIMemoryStream,
TImeNameProperty,
TIMenuItemIntf,
TIModuleCreator,
TIModuleInterface,
TIModuleNotifier,
TIndexDef,
TIndexDefs,
TIndexFiles,
TIniFile,
TInplaceEdit,
TIntegerField,
TIntegerProperty,
TInterface,
TInterfacedObject,
TIProjectCreator,
TIResourceEntry,
TIResourceFile,
TISAPIApplication,
TISAPIRequest,
TISAPIResponse,
TIStream,
TIStreamAdapter,
TIToolServices,
TIVCLStreamAdapter,
TLabel,
TList,
TListBox,
TListColumn,
TListColumns,
TListColumns,
TListItem,
TListItems,
TListSourceLink,
TListView,
TLoginDialog,
TLookupList,
TMainMenu,
TMask,
TMaskEdit,
TMediaPlayer,
TMemo,
TMemoField,
TMemoryStream,
TMenu,
TMenuItem,
TMetafile,
TMetafileCanvas,
TMetafileImage,
TMethodProperty,
TModalResultProperty,
TMPFilenameProperty,
TNavButton,
TNavButton,
TNavDataLink,
TNotebook,
TNumericField,
TObject,
TOleContainer,
TOleControl,
TOleForm,
TOleGraphic,
TOleStream,
TOpenDialog,
TOpenPictureDialog,
TOrdinalProperty,
TOutline,
TOutlineNode,
TPage,
TPageControl,
TPageProducer,
TPaintBox,
TPaintControl,
TPanel,
TParaAttributes,
TParam,
TParamList,
TParams,
TParser,
TPen,
TPersistent,
TPicture,
TPictureAdapter,
TPopupDataList,
TPopupGrid,
TPopupMenu,
TPrintDialog,
TPrinter,
TPrinterSetupDialog,
TProgressBar,
TPropertyEditor,
TPropertyPage,
TProvider,
TProviderObject,
TQuery,
TQueryTableProducer,
TRadioButton,
TRadioGroup,
TReader,
TRegIniFile,
TRegistry,
TRemoteServer,
TReplaceDialog,
TResourceStream,
TRichEdit,
TSaveDialog,
TSavePictureDialog,
TScreen,
TScrollBox,
TScroller,
TScrollingWinControl,
TServerAcceptThread,
TServerClientThread,
TServerClientWinSocket,
TServerSocket,
TServerWinSocket,
dbtables.TSession,
TSessionList,
TSetElementProperty,
TSetProperty,
TShape,
TSharedImage,
TShortCutProperty,
TSimpleEvent,
TSmallintField,
TSpeedButton,
TSpinButton,
TSpinEdit,
TSplitter,
TStaticText,
TStatusBar,
TStatusBar,
TStatusPanel,
TStatusPanels,
TStoredProc,
TStream,
TStringField,
TStringGrid,
TStringGrid,
TStringGridStrings,
TStringList,
TStringProperty,
TStrings,
TStringsAdapter,
TStringStream,
TSynchroObject,
TTabbedNotebook,
TTabControl,
TTable,
TTabList,
TTabOrderProperty,
TTabPage,
TTabSet,
TTabSheet,
TTextAttributes,
TThread,
TThreadList,
TTimeField,
TTimeProperty,
TTimer,
TTimerSpeedButton,
TToolBar,
TToolButton,
TTrackBar,
TTreeNode,
TTreeNodes,
TTreeView,
TTypedComObject,
TTypedComObjectFactory,
TUpdateSQL,
TUpDown,
TVarBytesField,
TVirtualStream,
TWebActionItem,
TWebActionItems,
TWebApplication,
TWebDispatcher,
TWebModule,
TWebRequest,
TWebResponse,
TWinCGIRequest,
TWinCGIResponse,
TWinControl,
TWinSocketStream,
TWordField,
TWriter
);

function TForm1.AddClass (NewClass: TClass): TTreeNode;
var
  ParentNode: TTreeNode;
begin
  // if the class is not there...
  Result := GetNode (NewClass);
  if Result = nil then
  begin
    // look for the parent (eventually adding it)
    ParentNode := AddClass (NewClass.ClassParent);
    // add the new class
    Result := TreeView1.Items.AddChildObject (
      ParentNode,
      NewClass.ClassName,
      Pointer (NewClass));
  end;
end;

function TForm1.GetNode (BaseClass: TClass): TTreeNode;
var
  Node1: TTreeNode;
begin
  Result := nil; // not found
  // find the node in the tree
  Node1 := TreeView1.Items.GetFirstNode;
  while Node1 <> nil do
  begin
    if Node1.Text = BaseClass.ClassName then
    begin
      Result := Node1;
      Exit;
    end;
    Node1 := Node1.GetNext;
    Forms.Application.ProcessMessages;
  end;
(* slower loop...
  for I := 0 to TreeView1.Items.Count - 1 do
  begin
    if TreeView1.Items [I].Text = BaseClass.ClassName then
    begin
      Result := TreeView1.Items [I];
      Exit;
    end;
    Application.ProcessMessages;
  end;*)
end;

procedure TForm1.Button1Click(Sender: TObject);
var
  I: Integer;
begin
  // don't restart this loop
  Button1.Enabled := False;
  // add the root class
  TreeView1.Items.AddObject (nil, 'TObject',
    Pointer (TObject));
  // add each class to the tree
  ProgressBar1.Min := Low (ClassArray);
  ProgressBar1.Max := High (ClassArray);
  for I := Low (ClassArray) to High (ClassArray) do
  begin
    AddClass (ClassArray [I]);
    ProgressBar1.Position := I;
  end;
  Beep;
  ShowMessage ('Tree Completed');
  Button2.Enabled := True;
  Button1.Enabled := False;
end;

procedure TForm1.TreeView1Change (
  Sender: TObject; Node: TTreeNode);
var
  MyClass: TClass;
begin
  MyClass := TClass (Node.Data);
  Edit1.Text := Format ('Name: %s - Size: %d bytes',
    [MyClass.ClassName, MyClass.InstanceSize]);
  with Listbox1.Items do
  begin
    Clear;
    while MyClass.ClassParent <> nil do
    begin
      MyClass := MyClass.ClassParent;
      Add (MyClass.ClassName);
    end; // while
  end; // with
end;

procedure TForm1.Button2Click(Sender: TObject);
begin
  Screen.Cursor := crHourglass;
  TreeView1.SortType := stText;
  Screen.Cursor := crDefault;
  Button2.Enabled := False;
end;

end.

Взято с

Имитация Tab

SelectNext(screen.ActiveControl,True, True);

Разместите приведенный код в обработчике одного из собитий. SelectNext - защищенный метод TWinControl со следующим прототипом:

procedure SelectNext(CurControl: TWinControl;
GoForward, CheckTabStop: Boolean);

Так как форма также является потомком TWinControl, то она имеет доступ к защищенным методам.

Взято с

Имя класса компонента и модуля

Мне необходима функция, которая возвращала бы имя класса компонента и имя модуля, где определен данный класс.

Например: xxx('TPanel') возвращала бы 'ExtCtrls'

Также мне необходима функция, возвращающая список имен страниц палитры компонентов.

UsesTypInfo;

Function ObjectsUnit (Obj: TClass): String;
Begin
Result := GetTypeData (PTypeInfo(Obj.ClassInfo))^.UnitName
end;

Для создания описанной вами функции "Какой модуль" могут использоваться описанные в TOOLINTF.INT методы GetModuleCount, GetModuleName, GetComponentCount и GetComponentName.

Для получения представления о формате палитры компонентов обратитесь к файлу DELPHI.INI.

Взято с

Имя компьютера

Cодержание раздела:

См. также статьи в других разделах:

Имя пользователя Paradox

Вы можете выполнить эту задачу, непосредственно обращаясь к BDE. Включите следующие модули в сецию Uses вашего модуля: DBIPROCS, DBIERRS, DBITYPES

Ниже приведена функция с именем ID, возвращающая сетевое имя входа:

functionID: string;
var

  rslt: DBIResult;
  szErrMsg: DBIMSG;
  pszUserName: PChar;
begin

  try
    Result := '';
    pszUserName := nil;
    GetMem(pszUserName, SizeOf(Char) * DBIMAXXBUSERNAMELEN);
    rslt := DbiGetNetUserName(pszUserName);
    if rslt = DBIERR_NONE then
      Result := StrPas(pszUserName)
    else
      begin
        DbiGetErrorString(rslt, szErrMsg);
        raise Exception.Create(StrPas(szErrMsg));
      end;
    FreeMem(pszUserName, SizeOf(Char) * DBIMAXXBUSERNAMELEN);
    pszUserName := nil;
  except
    on E: EOutOfMemory do ShowMessage('Ошибка. ' + E.Message);
    on E: Exception do ShowMessage(E.Message);
  end;
  if pszUserName <> nil then FreeMem(pszUserName, SizeOf(Char) * DBIMAXXBUSERNAMELEN);
end;

Взято из

Советов по Delphi от

Сборник Kuliba

Импорт большого CSV файла

vars: string; f: TextFile;
  AssignFile(f, 'D:\\INPUT.TXT');
    Reset(f);
    while not EOF(f) do
      begin
        ReadLn(s, f);
        ShowMessage(GetField(s, 1)); {The first field\}
        ShowMessage(GetField(s, 6)); {The sixth field\}
        ShowMessage(GetField(s, 25)); {will return '' if no 25 column...\}
      end;
    CloseFile(f);

{ ==== This function will return a field from a delimited string. ==== \}

function GetField(InpString: string; fieldpos: Integer): string;
var
  c: Char;
  curpos, i: Integer;
begin
  curpos := 1;
  for i := 1 to fieldpos do
    begin
      result := ''; if curpos > Length(InpString) then Break;
      repeat
        c := InpString[curpos]; Inc(curpos, 1);
        if (c = '"') or (c = #13) or (c = #10) then c := ' ';
        if c <> ',' then result := result + c;
      until (c = ',') or (curpos > Length(InpString))
    end;
  if (curpos > Length(InpString)) and (i < fieldpos) then result := '';
  result := Trim(result);
end;

{ ==== This function will trim a string removing spaces etc. ==== \}

function Trim(inp_str: string): string;
var
  i: Integer;
begin
  for i := 1 to Length(inp_str) do
    if inp_str[i] <> ' ' then Break;
  if i > 1 then Delete(inp_str, 1, i - 1);
  for i := Length(inp_str) downto 1 do
    if inp_str[i] <> ' ' then Break;
  if i < Length(inp_str) then Delete(inp_str, i + 1, Length(inp_str));
  result := inp_str;
  if result = ' ' then result := '';
end;

Взято из

Импорт CSV ASCII

unitCdbascii;

interface

uses

  SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
  Forms, Dialogs, DbiErrs, DbiTypes, DbiProcs, DB, DBTables;

type

  TAsciiDelimTable = class(TTable)
  private
{ Private declarations }
    fQuote: Char;
    fDelim: Char;
  protected
{ Protected declarations }
    function CreateHandle: HDBICur; override;
    procedure SetQuote(newValue: Char);
    procedure SetDelim(newValue: Char);
  public
{ Public declarations }
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
{ Эти свойства не должны больше публиковаться }
    property IndexFieldNames;
    property IndexName;
    property MasterFields;
    property MasterSource;
    property UpdateMode;
  published
{ Published declarations }
    property Quote: Char read fQuote write setQuote default '"';
    property Delim: Char read fDelim write setDelim default ',';
  end;

procedure Register;

implementation

uses DBConsts;

procedure Register;
begin

  RegisterComponents('Data Access', [TAsciiDelimTable]);
end;

constructor TAsciiDelimTable.Create(AOwner: TComponent);
begin

  inherited Create(AOwner);
  Exclusive := True;
  TableType := ttASCII;
  fQuote := '"';
  fDelim := ',';
end;

destructor TAsciiDelimTable.Destroy;
begin

  inherited Destroy;
end;

{ Рабочий код }

function CheckOpen(Status: DBIResult): Boolean;
begin

  case Status of
    DBIERR_NONE:
      Result := True;
    DBIERR_NOTSUFFTABLERIGHTS:
      begin
        if not Session.GetPassword then DbiError(Status);
        Result := False;
      end;
  else
    DbiError(Status);
  end;
end;

function TAsciiDelimTable.CreateHandle: HDBICur;
const

  OpenModes: array[Boolean] of DbiOpenMode = (dbiReadWrite, dbiReadOnly);
  ShareModes: array[Boolean] of DbiShareMode = (dbiOpenShared, dbiOpenExcl);
var

  STableName: array[0..SizeOf(TFileName) - 1] of Char;
  SDriverType: array[0..12] of Char;
begin

  if TableName = '' then DBError(SNoTableName);
  AnsiToNative(DBLocale, TableName, STableName, SizeOf(STableName) - 1);
  StrPCopy(SDriverType, 'ASCIIDRV-' + Quote + '-' + Delim);
  Result := nil;
  while not CheckOpen(DbiOpenTable(DBHandle, STableName, SDriverType,
    nil, nil, 0, OpenModes[ReadOnly], ShareModes[Exclusive],
    xltField, False, nil, Result)) do {Повтор}
    ;
end;

procedure TAsciiDelimTable.SetQuote(newValue: Char);
begin

  if Active then
{    DBError(SInvalidBatchMove); };
  fQuote := newValue;
end;

procedure TAsciiDelimTable.SetDelim(newValue: Char);
begin

  if Active then
{    DBError(SInvalidBatchMove); };
  fDelim := newValue;
end;

end.

Взято из

Советов по Delphi от

Сборник Kuliba

Индекс БД в другом каталоге

Подскажите как работать c dbf под Delphi 5 , когда индексы расположены в другом каталоге?

Serg
(10.01.01 19:54) можно сделать следующее:

Vnhead_Cdx := TStringList.Create;
Vnhead_Cdx.Add('c:\parus\bumi1\idx\vnhead.cdx');
Vnhead.IndexFiles := Vnhead_Cdx;

при это сам dbf находится в c:\parus\bumi1\dbf

Взято с сайта

Индексы выражений

dBASE - Индексы выражений (Expression Indexes): Введение

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

В конце данного совета включены два небольших раздела, описывающих механику создания индексов выражений dBASE, один относится к утилите Database Desktop, другой - к приложениям Delphi.

Индексные выражения на основе множества полей

Функции dBASE доступны для применения в Delphi или Database Desktop для ускоренного использования в выражениях индекса, и затем только в связи с индексами dBASE. То есть, вы не сможете использовать функции dBASE или синтаксис для создания выражения индекса для таблицы Paradox или Local InterBase Server (LIBS). Функции dBASE не могут использоваться при программировании в Delphi. Они доступны только для выражений индесов dBASE. Синтаксис и функции dBASE, которые могут быть использованы для выражений индексов, "расположены" в библиотечном файле Borland Database Engine (BDE) IDDBAS01.DLL.

При создании индекса dBASE, который должен базироваться на двух или более полях таблицы, для которой он создается, два или более поля конкатенируются (связываются вместе) в величине, которая в некоторой степени похожа на Delphi тип String, с использованием синтакса Delphi: оператор "+". Например, выражению необходимо создать индекс, который должен базироваться в первую очередь на основе поля LastName, а затем на основе поля FirstName:

LastName + FirstName
В отличие от самого dBASE, такие индексы, основанные на нескольких полях, ограничены использованием таких же полей в таблице. dBASE допускает создание индексов, основанных на нескольких полях, содержищихся в другой таблице. Это позволяет во время создания индекса иметь открытую только "другую" таблицу или использовать таблицу, содержащую индекс.
У индексов с несколькими полями для других типов таблиц (например, Paradox и InterBase), используемые поля должны быть разделены точкой с запятой (;), как показано ниже:

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

LastName + FirstName
При создании индексных выражений, которые конкатенируют два и более поля, все включенные поля должны иметь одинаковый тип. К тому же, если они должны конкатенироваться, вместо складывания, то все поля должны иметь тип String. Например, для двух целочисленных полей, Value1 и Value2, выражение индекса...

Value1 + Value2
...не вызовет ошибку. Но в этом случае произойдет конкатенация двух значений полей и они суммируются. Таким образом, если Value1 для данной записи содержало 4, а Value2 - 5, результирующий индексный узел будет целой величиной 9, а не строковой конкантенацией "45".
Если поля, включенные в выражение индекса, имеют не строковый тип, они должны быть преобразованы. Вот некоторые функции dBASE, преобразовывающие различные типы данных к строковому типу для использования в выражениях индекса:

STR( [, [, ]])
Преобразовывает dBASE-тип Float или Numeric в Character (String)

DTOS()
Преобразовывает значение Date к Character, формат YYYYMMDD

MLINE(, )
Извлекает отдельную строку из Memo-поля как значение Character
Другое ограничение при создании индексов путем конкантенации нескольких полей - максимально допустимая длина индексной величины. Величина, возвращаемая индексным значением, не может превышать 100 символов. Это предел длины значения, возвращаемого выражением, не длина самого выражения. Например, вы не можете создать индекс путем конкантенации двух полей, если они оба имееют длину 255 символов.

Индексные выражения на основе модификации значений полей

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

Создание индексов на основе модификации значений полей требует, по крайней мере, практическое знание функций dBASE и синтаксиса, поскольку данная технология использует dBASE, а не функции и синтаксис Delphi. Функция dBASE SUBSTR() извлекает подстроку из поля типа String. Delphi-эквивалент данной dBASE-функции - Copy. Но только dBASE функция SUBSTR() может применяться при создании индексного выражения dBASE.

Использование фунций dBASE в индексных выражениях dBASE заключается в простом включении в индексное выражение функции, использование в функциях dBASE-синтаксиса и имени (имен) поля (полей), использующихся в функциях. Например, индексное выражение на основе трех последних символов значения поля типа String с именем Code, имеющим длину 20 символов выглядит так:

RIGHT(Code, 3)
Важно соблюдение следующего правила: конструкции индексных выражений dBASE, модифицирующих значения полей, должны возвращать величину с "последовательной длиной" для каждой записи таблицы, т.е. результат не должен содержать граничных пробелов. Например, функция dBASE TRIM() удаляет граничные пробелы (ASCII код 32) из значения поля типа String. Если это было использовано вместе с конкантенацией двух полей, имеющих тип String, где поле не имеет постоянной длины для разных записей, длина результирующего значения будет различная для всех записей. В свете этого рассмотрим следующий пример: построим индексное выражение на основе конкантенации полей LastName и FirstName field, где функция TRIM() применена к полю LastName:

TRIM(LastName) + FirstName
Данное выражение не возратит значения "последовательной длины" для всех записей. Если поля LastName и FirstName содержали значения...

LastName  FirstName
  --------  ---------
  Smith     Jonas
  Wesson    Nancy

...то результат использования индексного выражения может быть таким:

SmithJonas
WessonNancy

Как вы можете наблюдать, длина значения первого поля равна 10 символов, тогда как второго - 11 символов. Узлы индекса для данного индексного выражения должны базироваться на значении поля первой ненумерованной записи. Следовательно, результат выражения индекса для каждого узла должен быть равен 10 символов. В нашем примере результат вычисления для второй записи округляется до "WessonNanc". Все это приводит к тому, что поиск, основанный на поиске полных значений в полях, окончится неудачей.
Решение это дилеммы кроется в не использовании функции TRIM(), а в использовании полной длины значений поля LastName, включая граничные пробелы. В индексах, которые используют функции IIF() для установления порядка одного поля или другого, основанных на сравнении логических выражений в IIF(), если два поля имеют различную длину, более короткое поле должно быть заполнено пробелами до длины большей области. Для примера, создавая индекс с использованием функции IIF(), и индексируя поля Company или Name, базирующийся на поле Category, и где поле Company длиной 40 символов, а поле Name длиной 25 симловов, поле Name необходимо дополнять 15-ю пробелами; например, с помощью dBASE-функции SPACE(). Выражение индекса в этом случае будет таким:

IIF(Category = "B", Company, Name + SPACE(15))
Поиск и выражения индексов dBASE
Выражения индексов dBASE являются исключениями из правил в том, как они обрабатываются Delphi и BDE, по сравнению с обработкой индексов таблиц другого типа, также основанных на множестве полей.

Это вынуждает вынести dBASE-индексы в отдельный класс. Обработка таких индексов в Delphi и BDE отличается от обработки индексов для других типов таблиц. Одно из самых существенных различий заключается в том, что не все поисковые инструменты, основанные на индексах и использующие синтаксис Delphi, могут использовать выражения индексов dBASE. FindKey, FindNearest и GotoKey методы компонента TTable не годятся для работы с выражениями индексов. При попытке использования FindKey вы получите сообщение об ошибке: "Field index out of range." (Индекс поля за границами диапазона). При попытке использования метода GotoKey может произойти та же ошибка, или табличный курсор может остаться на месте (визуально искомая величина не найдена). С выражениями индексов может использоваться только метод GotoNearest. Но даже GotoNearest может не работать с некоторыми индексными выражениями. Только с помощью эксперимента можно установить - работает ли метод GotoNearest с данным индексным выражением.

Фильтрация индексных выражений dBASE

Как и основанный на индексах поиск, индексные выражения dBASE при использовании фильтров Delphi также имеют некоторые исключения.

С активным индексным выражением метод SetRange компонента TTable приводит к следующей ошибке: "Field index out of range." (Индекс поля за границами диапазона). Тем не менее, с тем же активным индексным выражением методы SetRangeStart и SetRangeEnd успешно фильтруют набор данных.

Например, выражение индекса с конкантенацией поля LastName и активного FirstName, в приведенном ниже коде, использующем метод FindKey (предполагающий фильтрацию тех записей, где первый символ поля LastName содержит "S"), "вылетит" с ошибкой:

begin
  Table1.SetRange(['S'], ['Szzz'])
end;

Код, приведенный ниже, использует то же активное выражение индекса, но используемый фильтр поля LastName правильно отфильтрует данные, и не вызовет ошибки:

begin
  with Table1 do
    begin
      SetRangeStart;
      FieldByName('LastName').AsString := 'S';
      SetRangeEnd;
      FieldByName('LastName').AsString := 'Szzz';
      ApplyRange;
    end;
end;

И, так же, как и в случае основанного на индексах поиска, успех применения фильтра целиком и полностью зависит от самого индексного выражения. Использование методов SetRangeStart и SetRangeEnd в приведенном примере работало бы с индексом, построенным на основе простой конкантенации двух полей, имеющих тип String. Но если вместо этого выражение было основано на одном или нескольких полях с использованием функции IIF(), тот же самый процесс фильтрации потерпел бы неудачу (хотя и без ошибки).

Несколько полезных советов при создании индексных выражений dBASE

Вот некоторые "удобные" индексные выражения dBASE. Некоторые интуитивно-понятные в достижении своей цели, другие немного "заумные".

Сортировка поля типа Character символов по-возрастающей, поля Date - по-убывающей

С полем типа Character и именем Name, и полем типа Date и именем OrdDate:

Name + STR(OrdDate - {12/31/3099}, 10, 0)
Сортировка поля типа Character по-возрастающей и поля типа Numeric (или Float) по-убывающей
C полем типа Character и именем Company, и полем типа Numeric и именем Amount (поле Amount имеет длину 9 цифр с двумя цифрами после десятичной запятой):

Company + STR(Amount - 999999.99, 9, 2)
Сортировка логического поля
Для того, чтобы записи со значением True располагались впереди записей со значением False в логическом поле с именем Paid, выполните следующее:

IIF(Paid, "A", "Z")
Два поля с типом Numeric (или Float)
Предположим, у нас имеется два поля типа Numeric с пятью и двумя десятичными разрядами, первое поле с именем Price, второе - Quantity:

STR(Price, 5, 2) + STR(Quantity, 5, 2)
Сортировка одного из двух полей в зависимости от выполнения логического условия
Сортировка имен месяцев в поле, имеющим тип Character

Предположим, поле содержит имена месяцев на английском языке ("Jan," "Feb" и т.д.), и его необходимо расположить в соответствующем порядке (имя поля M):

IIF(M="Jan", 1, IIF(M="Feb", 2, IIF(M="Mar", 3, IIF(M="Apr", 4,
IIF(M="May", 5, IIF(M="Jun", 6, IIF(M="Jul", 7, IIF(M="Aug", 8,
IIF(M="Sep", 9, IIF(M="Oct", 10, IIF(M="Nov", 11, 12)))))))))))

(Вышеприведенный код - единственная строка кода, разбирая на несколько из-за ограничений ширины страницы.)
Сортировка по первой строке Memo-поля

Для Memo-поля с именем Notes:

MLINE(Notes, 1)
Сортировка по средним трем символам в девятисимвольном поле типа long
Для девятисимвольного поля типа long с именем StockNo:

SUBSTR(StockNo, 4, 3)
Создание индексных выражений dBASE в Database Desktop
В утилите Database Desktop, индексы могут создаваться как для новой таблицы (во время ее создания), так и для существующей, путем ее реструктуризации. В обоих случаях используется диалог "Define Index", использующийся для создания одного или более индексов таблицы.

Для вывода диалога создания индекса ("Create Index") во время создания новой таблицы, в диалоге создания dBASE таблицы ("Create dBASE Table") (показ структуры), выберите в списке "Table Properties" (свойства таблицы) пункт "Indexes" (индексы) и нажмите на кнопку "Define".

Чтобы вывести диалог создания индекса ("Create Index") при создании индекса для существующей таблицы, выберите Utilities|Restructure, выберите файл с таблицей в диалоге выбора файла ("Select File"), и в диалоге реструктуризации таблицы dBASE ("Restructure dBASE Table") (показ структуры таблицы) выберите в списке "Table Properties" (свойства таблицы) пункт "Indexes" (индексы) и нажмите на кнопку "Define".

Только в диалоге создания индекса ("Create Index"), выражения индекса могут создаваться щелчком на кнопке "Expression Index" (индеск выражения) и вводом выражения в поле редактирования "Expression Index". Для ассистирования данного процесса, вы можете дважды щелкнуть на имени поля с списке полей, после чего имя поля будет помещено в область редактирования "Index Expression" в текущей точке ввода (позиция курсора).

Как только нужное выражение составлено, нажмите кнопку OK. Введите имя нового индексного тэга в поле редактирования "Index Tag Name" (имя индексного тэга") в диалоге "Save Index As" (сохранить индекс как...) и нажмите "OK". (Помните, имена тэгов индексов dBASE не могут превышать десяти символов и должны соблюдать соглашения об именах dBASE.)

Создание индексных выражений dBASE в приложениях Delphi

dBASE-индексы могут создаваться программным путем в Delphi-приложениях как для новой таблицы (метод CreateTable компонента TTable), так и для существующей.

Для создания индекса как части новой таблицы, необходимо вызваться метод Add свойства IndexDefs компонента TTable. В нашем случае необходимо включить в набор флажков индекса флажок ixExpression. Данный флажок уникален для индексов таблиц dBASE, и может использоваться только с индексными выражениями dBASE. Для примера:

with Table1 do
  begin
    Active := False;
    DatabaseName := 'Delphi_Demos';
    TableName := 'CustInfo';
    TableType := ttdBASE;
    with FieldDefs do
      begin
        Clear;
        Add('LastName', ftString, 30, False);
        Add('FirstName', ftString, 20, False);
      end;
    with IndexDefs do
      begin
        Clear;
        Add('FullName', 'LastName + FirstName', [ixExpression]);
      end;
    CreateTable;
  end;

Добавление индекса к существующей таблицы осуществляется вызовом метода AddIndex компонента TTable. Кроме того, флажки индекса должны включать в себя значение TIndexOptions ixExpression.

    Table1.AddIndex('FullName', 'LastName + FirstName', [ixExpression]);

Изучение функций и синтаксиса dBASE

Для создания индексных выражений dBASE могут использоваться только функции и синтакс, относящиеся к обработке данных. Тем не менее, полный список и описание данных функций выходит за рамки данного совета. Для получения дополнительной информации о dBASE-функциях обработки данных, обратитесь к руководству "dBASE Language Reference" или книгам и справочникам по dBASE третьих фирм.

Взято из

Советов по Delphi от

Сборник Kuliba

Информация о файле

Привожу пример функции которая собирает довольно большое количество информации о выбранном файле:

Type TFileInfo=record
Exists:boolean;//true если файл найден
Name:String; //имя файла с расширением
ShortName:String;//DOS 8.3 имя файла
NameNoExt:String;//имя файла без расширения
Extension:string;//расширение файла
AssociatedFile:string;//программа с которой ассоциирован файл
Path:string;// путь к файлу
ShortPath:string;// DOS 8.3 путь файла
Drive:string;// дисковод на котором находится файл
CreateDate:TDateTime; //время когда файл создан
Size:Int64;// размер файла (работает для файлов и больше 2Gb)
Attributes:record //нали?ие/отсутствие системных атрибутов
ReadOnly:boolean;
Hidden:boolean;
System:boolean;
Archive:boolean;
end;
ModifyDate:TDateTime; // время последнего изменения файла
LastAccessDate:TDateTime; // дата последнего открытия файла
end;

Function ReadFileInfo(FileName:string):TFileInfo;
var ts:TSearchRec;

Function FileTime2DateTime(FT:_FileTime):TDateTime;
var FileTime:_SystemTime;
begin
FileTimeToLocalFileTime(FT, FT);
FileTimeToSystemTime(FT,FileTime);
Result:=EncodeDate(FileTime.wYear, FileTime.wMonth, FileTime.wDay)+
EncodeTime(FileTime.wHour, FileTime.wMinute, FileTime.wSecond, FileTime.wMilliseconds);
end;

Function AssociatedFile(FileExt:string):string;
var key:string;
begin
With TRegistry.create do
try
RootKey:=HKEY_CLASSES_ROOT;
OpenKey(FileExt, false);
Key:=ReadString('');
CloseKey;
OpenKey(key+'\Shell\open\command', false);
result:=ReadString('');
Closekey;
finally
free;
end
end;

begin
Result.Name:=ExtractFileName(FileName);
Result.Extension:=ExtractFileExt(FileName);
Result.NameNoExt:=Copy(Result.Name,1,length(Result.Name)-length(Result.Extension));
Result.Path:=ExtractFilePath(FileName);
Result.Drive:=ExtractFileDrive(FileName);
Result.ShortPath:=ExtractShortPathName(ExtractFilePath(FileName));
if lowercase(Result.Extension)<>'.exe' then Result.AssociatedFile:=AssociatedFile(Result.Extension);
if FindFirst(FileName, faAnyFile, ts)=0 then
begin
Result.Exists:=true;
Result.CreateDate:=FileDateToDateTime(ts.Time);
Result.Size:=ts.FindData.nFileSizeHigh*4294967296+ts.FindData.nFileSizeLow;
Result.Attributes.ReadOnly:=(faReadOnly and ts.Attr)>0;
Result.Attributes.Hidden:=(faHidden and ts.Attr)>0;
Result.Attributes.System:=(faSysFile and ts.Attr)>0;
Result.Attributes.Archive:=(faArchive and ts.Attr)>0;
Result.ModifyDate:=FileTime2DateTime(ts.FindData.ftLastWriteTime);
Result.LastAccessDate:=FileTime2DateTime(ts.FindData.ftLastAccessTime);
Result.ShortName:=ts.FindData.cAlternateFileName;
Findclose(ts);
end
else
Result.Exists:=false;
end;

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

Информация о физических дисках

Посмотри функцию DeviceIoControl - может там что получиться. Я ее мало использовал, но что-то там было.

Там есть ссылка на CreateFile - эта функция под NT может действительно вернуть хэндл на физический диск.

You can use the CreateFile function to open a disk drive or a partition on a disk drive. The function returns a handle to the disk device; that handle can be used with the DeviceIOControl function.

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

{ **** UBPFD *********** by delphibase.endimus.com ****
>> Поличение серийного номера IDE диска.

Функция получает серийный номер первого физического диска IDE (не серийный номер тома!).
Используется S.M.A.R.T. API, а под Windows NT/2K/XP запрос производится не напрямую к диску, а через miniport драйвер контроллера, что позволяет читать серийный номер не имея прав администратора.
Функция может не работать, если первый контролер в системе не ATA или если первое устройство не является винчестером, который поддерживает SMART (современные винчестеры поддерживают).
Если Вы хотите получить другие параметры диска/других дисков, то смотрите пример IdeInfo2 с моего сайта.
На Windows 9x требует наличия драйвера smartvsd.vxd (должен быть в стандартной поставке), просто скопируйте его в \windows\system\iosubsys и перезагрузите компьютер.

Зависимости: Windows, SysUtils
Автор: Alex Konshin, akonshin@earthlink.net, Boston, USA
Copyright: http://home.earthlink.net/~akonshin/index.htm
Дата: 30 декабря 2002 г.
*****************************************************}

function GetIdeDiskSerialNumber : String;
type
  TSrbIoControl = packed record
    HeaderLength : ULONG;
    Signature : Array[0..7] of Char;
    Timeout : ULONG;
    ControlCode : ULONG;
    ReturnCode : ULONG;
    Length : ULONG;
  end;
  SRB_IO_CONTROL = TSrbIoControl;
  PSrbIoControl = ^TSrbIoControl;

  TIDERegs = packed record
    bFeaturesReg : Byte; // Used for specifying SMART "commands".
    bSectorCountReg : Byte; // IDE sector count register
    bSectorNumberReg : Byte; // IDE sector number register
    bCylLowReg : Byte; // IDE low order cylinder value
    bCylHighReg : Byte; // IDE high order cylinder value
    bDriveHeadReg : Byte; // IDE drive/head register
    bCommandReg : Byte; // Actual IDE command.
    bReserved : Byte; // reserved for future use. Must be zero.
  end;
  IDEREGS = TIDERegs;
  PIDERegs = ^TIDERegs;

  TSendCmdInParams = packed record
    cBufferSize : DWORD; // Buffer size in bytes
    irDriveRegs : TIDERegs; // Structure with drive register values.
    bDriveNumber : Byte; // Physical drive number to send command to (0,1,2,3).
    bReserved : Array[0..2] of Byte; // Reserved for future expansion.
    dwReserved : Array[0..3] of DWORD; // For future use.
    bBuffer : Array[0..0] of Byte; // Input buffer.
  end;
  SENDCMDINPARAMS = TSendCmdInParams;
  PSendCmdInParams = ^TSendCmdInParams;

  TIdSector = packed record
    wGenConfig : Word;
    wNumCyls : Word;
    wReserved : Word;
    wNumHeads : Word;
    wBytesPerTrack : Word;
    wBytesPerSector : Word;
    wSectorsPerTrack : Word;
    wVendorUnique : Array[0..2] of Word;
    sSerialNumber : Array[0..19] of Char;
    wBufferType : Word;
    wBufferSize : Word;
    wECCSize : Word;
    sFirmwareRev : Array[0..7] of Char;
    sModelNumber : Array[0..39] of Char;
    wMoreVendorUnique : Word;
    wDoubleWordIO : Word;
    wCapabilities : Word;
    wReserved1 : Word;
    wPIOTiming : Word;
    wDMATiming : Word;
    wBS : Word;
    wNumCurrentCyls : Word;
    wNumCurrentHeads : Word;
    wNumCurrentSectorsPerTrack : Word;
    ulCurrentSectorCapacity : ULONG;
    wMultSectorStuff : Word;
    ulTotalAddressableSectors : ULONG;
    wSingleWordDMA : Word;
    wMultiWordDMA : Word;
    bReserved : Array[0..127] of Byte;
  end;
  PIdSector = ^TIdSector;

const
  IDE_ID_FUNCTION = $EC;
  IDENTIFY_BUFFER_SIZE = 512;
  DFP_RECEIVE_DRIVE_DATA = $0007c088;
  IOCTL_SCSI_MINIPORT = $0004d008;
  IOCTL_SCSI_MINIPORT_IDENTIFY = $001b0501;
  DataSize = sizeof(TSendCmdInParams)-1+IDENTIFY_BUFFER_SIZE;
  BufferSize = SizeOf(SRB_IO_CONTROL)+DataSize;
  W9xBufferSize = IDENTIFY_BUFFER_SIZE+16;
var
  hDevice : THandle;
  cbBytesReturned : DWORD;
  pInData : PSendCmdInParams;
  pOutData : Pointer; // PSendCmdInParams;
  Buffer : Array[0..BufferSize-1] of Byte;
  srbControl : TSrbIoControl absolute Buffer;

  procedure ChangeByteOrder( var Data; Size : Integer );
  var ptr : PChar;
      i : Integer;
      c : Char;
  begin
    ptr := @Data;
    for i := 0 to (Size shr 1)-1 do
    begin
      c := ptr^;
      ptr^ := (ptr+1)^;
      (ptr+1)^ := c;
      Inc(ptr,2);
    end;
  end;

begin
  Result := '';
  FillChar(Buffer,BufferSize,#0);
  if Win32Platform=VER_PLATFORM_WIN32_NT then
    begin // Windows NT, Windows 2000
      // Get SCSI port handle
      hDevice := CreateFile( '\\.\Scsi0:', GENERIC_READ or GENERIC_WRITE,
        FILE_SHARE_READ or FILE_SHARE_WRITE, nil, OPEN_EXISTING, 0, 0 );
      if hDevice=INVALID_HANDLE_VALUE then Exit;
      try
        srbControl.HeaderLength := SizeOf(SRB_IO_CONTROL);
        System.Move('SCSIDISK',srbControl.Signature,8);
        srbControl.Timeout := 2;
        srbControl.Length := DataSize;
        srbControl.ControlCode := IOCTL_SCSI_MINIPORT_IDENTIFY;
        pInData := PSendCmdInParams(PChar(@Buffer)+SizeOf(SRB_IO_CONTROL));
        pOutData := pInData;
        with pInData^ do
        begin
          cBufferSize := IDENTIFY_BUFFER_SIZE;
          bDriveNumber := 0;
          with irDriveRegs do
          begin
            bFeaturesReg := 0;
            bSectorCountReg := 1;
            bSectorNumberReg := 1;
            bCylLowReg := 0;
            bCylHighReg := 0;
            bDriveHeadReg := $A0;
            bCommandReg := IDE_ID_FUNCTION;
          end;
        end;
        if not DeviceIoControl( hDevice, IOCTL_SCSI_MINIPORT, @Buffer,
          BufferSize, @Buffer, BufferSize, cbBytesReturned, nil ) then Exit;
      finally
        CloseHandle(hDevice);
      end;
    end
  else
    begin // Windows 95 OSR2, Windows 98
      hDevice := CreateFile( '\\.\SMARTVSD', 0, 0, nil, CREATE_NEW, 0, 0 );
      if hDevice=INVALID_HANDLE_VALUE then Exit;
      try
        pInData := PSendCmdInParams(@Buffer);
        pOutData := PChar(@pInData^.bBuffer);
        with pInData^ do
        begin
          cBufferSize := IDENTIFY_BUFFER_SIZE;
          bDriveNumber := 0;
          with irDriveRegs do
          begin
            bFeaturesReg := 0;
            bSectorCountReg := 1;
            bSectorNumberReg := 1;
            bCylLowReg := 0;
            bCylHighReg := 0;
            bDriveHeadReg := $A0;
            bCommandReg := IDE_ID_FUNCTION;
          end;
        end;
        if not DeviceIoControl( hDevice, DFP_RECEIVE_DRIVE_DATA, pInData,
           SizeOf(TSendCmdInParams)-1, pOutData, W9xBufferSize,
           cbBytesReturned, nil ) then Exit;
      finally
        CloseHandle(hDevice);
      end;
    end;
    with PIdSector(PChar(pOutData)+16)^ do
    begin
      ChangeByteOrder(sSerialNumber,SizeOf(sSerialNumber));
      SetString(Result,sSerialNumber,SizeOf(sSerialNumber));
    end;
end;

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

var s : String;
    rc : DWORD;
begin
  s := GetIdeDiskSerialNumber;
  if s='' then
    begin
      rc := GetLastError;
      if rc=0 then WriteLn('IDE drive is not support SMART feature')
      else WriteLn(SysErrorMessage(rc));
    end
  else WriteLn('Disk serial number: ''', s,'''');
end.

Автор: Alex Konshin, akonshin@earthlink.net, Boston, USA

Информация о логических дисках

Теперь об информации о дисках:

исчерпывающую информацию по этому поводу дает функция GetVolumeInformation,
посмотри help, там все понятно (там и серийный номер диска, и тип файловой системы, и прочее и прочее).

Вот параметры FileSysFlags:

FS_CASE_IS_PRESERVED - (при записи на диск сохраняется регистр букв в его имени)
FS_CASE_SENSITIVE - (поддерживается поиск файлов с учетом регистра букв)
FS_UNICODE_STORED_ON_DISK - (поддерживается сохранение имен файлов в UniCode)
FS_PERSISTENT_ACLS - (поддерживаются списки контроля доступа (ACL). Только для NTFS)
FS_FILE_COMPRESSION - (поддерживается сжатие файлов на уровне системы)
FS_VOL_IS_COMPRESSED - (устройство представляет собой сжатый диск)

Определение типа диска:

function GetDriveType (Drive : byte) : string;
  var
    DriveLetter : Char;
    DriveType : uInt;
begin
DriveLetter := Char (Drive + $41);
DriveType := GetDriveType (PChar(DriveLetter + ':\'));
case DriveType of
0: Result := '?';
1: Result := 'Path does not exists';
Drive_Removable: Result := 'Removable';
Drive_Fixed: Result := 'Fixed';
Drive_Remote: Result := 'Remote';
Drive_CDROM: Result := 'CD-ROM';
Drive_RamDisk: Result := 'RAMDisk'
else Result := 'Unknown';
end;
end;

Может так попробовать:

procedure TMainForm.btnGetHandleClick(Sender: TObject);
var DriveHandle : HWND;
begin
case Win32Platform of
  VER_PLATFORM_WIN32_NT:
    begin
      DriveHandle := CreateFile ('\\.\Scsi0:', GENERIC_READ+GENERIC_WRITE,
                                FILE_SHARE_READ+FILE_SHARE_WRITE, nil,
                                OPEN_EXISTING, 0, 0);
      if DriveHandle <> INVALID_HANDLE_VALUE then
        MessageBox (MainForm.Handle, PChar(IntToStr(DriveHandle)),
                   PChar('Here is your handle:'), MB_ICONINFORMATION)
      else
         MessageBox (MainForm.Handle, PChar('Error!'), PChar('Error'),
                     MB_ICONERROR);
    end;
  VER_PLATFORM_WIN32_WINDOWS:
begin
  DriveHandle := CreateFile ('\\.\SMARTVSD', 0, 0, nil, CREATE_NEW, 0, 0 );
  if DriveHandle <> INVALID_HANDLE_VALUE then
    MessageBox (MainForm.Handle, PChar(IntToStr(DriveHandle)),
                PChar('Here is your handle:'), MB_ICONINFORMATION)
  else
    MessageBox (MainForm.Handle, PChar('Error!'), PChar('Error'), MB_ICONERROR);
end;
end; // case
end;

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

Информация о сетевых интерфейсах

unitnetinfo;

interface
uses Libc;

type
  INTERFACE_INFO = packed record
    Name: string;
    IPAddress: string;
    Broadcast: string;
    NetMask: string;
    IsUp: boolean;
    IsRun: boolean;
    IsBroadcast: boolean;
    IsMulticast: boolean;
    IsLoopBack: boolean;
    IsPPP: boolean;
  end;

  TAInfo = record
    INFO: array of INTERFACE_INFO;
  end;

function EnumInterfaces(var IInfo: TAInfo): Boolean;

implementation

function EnumInterfaces(var IInfo: TAInfo): Boolean;
var SHandle: integer;
  len: longint;
  bufChar;
  ifc: ifconf;
  pifr: pifreq;
  ifr: ifreq;
  lastlen, i: integer;
  pAddrChar;
begin
  Result := False;
//создать UDP сокет
  SHandle := Socket(AF_INET, SOCK_DGRAM, 0);
  if SHandle = INVALID_SOCKET then exit;

{
При вызове SIOCGIFCONF некоторые реализации
не возвращают ошибок, если буффер слишком мал
для хранения результата вызова (результат просто обрезается)
Поэтому надо сделать вызов, запомнить возвращенную длину,
увеличить буффер и сделать еще один вызов
ксли после этого вызова длины будут равны - OK!
иначе надо циклично увеличивать буффер.
}
  lastlen := 0;
  len := 100 * sizeof(ifreq);

  while true do
    begin
      buf := Malloc(len);
      ifc.ifc_len := len;
      PChar(ifc.ifc_ifcu) := buf;
      if ioctl(SHandle, SIOCGIFCONF, @ifc) < 0 then
        begin
          if (errno <> EINVAL) and (lastlen <> 0) then
            warn('ioctl error');
        end
      else
        begin
          if ifc.ifc_len = lastlen then break;
          lastlen := ifc.ifc_len;
        end;
      len := len + 10 * sizeof(ifreq);
      free(buf);
    end;
  Result := True;
//здесь результат получен полностью
//len - кол-во интерфейсов
  len := ifc.ifc_len div sizeof(ifreq);
  SetLength(IInfo.Info, len);

//указатель - на начало буфера
  pifr := ifc.ifc_ifcu.ifcu_req;
  for i := 0 to len - 1 do
    begin
      fillchar(ifr, sizeof(ifreq), 0);
  //считать очередную порцию данных
      move(pifr^, ifr, sizeof(ifreq));

  //имя интерфейса
      IInfo.INFO[i].Name := ifr.ifrn_name;
  //адрес интерфейса
      pAddr := inet_ntoa(ifr.ifru_addr.sin_addr);
      IInfo.INFO[i].IPAddress := pAddr;

  //ШВ адрес
      ioctl(SHandle, SIOCGIFBRDADDR, @ifr);
      pAddr := inet_ntoa(ifr.ifru_netmask.sin_addr);
      IInfo.INFO[i].Broadcast := pAddr;

  //маска сети
      ioctl(SHandle, SIOCGIFNETMASK, @ifr);
      pAddr := inet_ntoa(ifr.ifru_netmask.sin_addr);
      IInfo.INFO[i].NetMask := pAddr;

  //флаги
      ioctl(SHandle, SIOCGIFFLAGS, @ifr);

      IInfo.INFO[i].IsUP := (ifr.ifru_flags and IFF_UP) = IFF_UP;
      IInfo.INFO[i].IsRun := (ifr.ifru_flags and IFF_RUNNING) = IFF_RUNNING;
      IInfo.INFO[i].IsBroadcast := (ifr.ifru_flags and IFF_BROADCAST) = IFF_BROADCAST;
      IInfo.INFO[i].IsLoopBack := (ifr.ifru_flags and IFF_LOOPBACK) = IFF_LOOPBACK;
      IInfo.INFO[i].IsPPP := (ifr.ifru_flags and IFF_POINTOPOINT) = IFF_POINTOPOINT;
      IInfo.INFO[i].IsMulticast := (ifr.ifru_flags and IFF_MULTICAST) = IFF_MULTICAST;

      inc(pifr);
    end;

end;
end.

Взято с Исходников.Ru
Автор

pve

Информация о TClass

TObject - "корневой" объект.

TClass определен как Class of TObject. Переменная Class НЕ является указателем на экземпляр объекта. Это указатель на *ТИП* объекта Class.

var
Obj1: TWinControl;
  Class1: class of TWinControl;

Class1 := TWinControl - правильное присваивание. Мы не распределяем память, у нас нет экземпляра TWinControl, мы не можем вызвать Class1.OnClick.

Class1 - это *тип* TWinControl с тем же контекстом использования, что и "TWinControl".

Поскольку мы можем использовать TWinControl.Create, то также мы можем использовать и Class1.Create, при этом создавая новый экземпляр TWinControl.

С тех пор как TEdit - наследник TWinControl, Class1 := TEdit правильное присваивание и Class1.Create создает экземпляр TEdit.

Если у меня имеется переменная Obj2: TWinControl, и даже если я присвоил экземпляр TListbox Obj2, я не могу ссылаться на Obj2.Items, поскольку Obj2 определен как TWinControl, а TWinControl не имеет свойства Items.

Те же характеристики верны и для Class1. Class1 определен как Class of TWinControl, поэтому они имеют общий конструктор, определенный в классе TWinControl.

Это не пугает меня при создании дополнительных типов:

TMyObj1 = class(TEdit)
  constructor CreateMagic; virtual;
end;

TMyObj2 = class(TMyObj1)
  constructor CreateMagic; override;
end;

TMyClass = class of TMyObj;

var
  MyObj1: TMyObj1;
  MyObj2: TMyObj2;

function MakeAnother(AClass: TMyClass): TMyObj1;
begin
  Result := AClass.CreateMagic;
end;

begin
  MyObj2 := TMyObj2.CreateMagic;
  MyObj1 := MakeAnother(MyObj2.ClassType);
end.

Взято из

Советов по Delphi от

Сборник Kuliba

INI-файлы (чтение/запись)

Install BDE программы

Периодически муссируются вопросы типа 'Как установить BDE?' и т.п.
Предлагаю, как пример возможного решения проблемы, след. программу .

program InstallPrfSt;
{
Программа иллюстрирует, как установить BDE с поддержкой PARADOX 7.0
на "чистой машине" и создать алиас.
Пример использования в качестве простейшего инсталлятора для программы
C:\MyDir\MyProg.exe
1.Создайте каталог C:\MyDir\BDE и скопируйте в него след. файлы:
CHARSET.BLL
OTHER.BLL
IDAPI32.CFG
BLW32.DLL
IDAPI32.DLL
IDBAT32.DLL
IDPDX32.DLL
IDR20009.DLL
IDSQL32.DLL
BDEADMIN.EXE - по вкусу, т.к. необходимым не является.
2.Измените значение константы AliasName на имя необходимого вам алиаса.
3.Откомпиллируйте и запустите эту программу из каталога C:\MyDir.
ВHИМАHИЕ!!! Если на машине уже установлено BDE, то перед экспериментами
сохраните (на всякий случай) след. ключи из реестра:
[HKEY_LOCAL_MACHINE\SOFTWARE\Borland\Database Engine] и
[HKEY_LOCAL_MACHINE\SOFTWARE\Borland\BLW32].
Замечания, предложения по улучшению приветствуются.
Счастливо,
Константин Кочедыков / kostya@roadtech.saratov.su / }
{$APPTYPE CONSOLE}
uses
  Windows, BDE, Registry;
const
  AliasName: string = 'PrefStat';
var
  R: DBIResult;
  Path: string;

procedure WriteString(S1: string);
begin
  S1 := S1 + #0;
  AnsiToOem(@S1[1], @S1[1]);
  writeln(S1);
end;

function GetExePath(S1: string): string;
var
  I, K: Integer;
  S: string;
begin
  K := 1;
  S := '';
  for I := Length(S1) downto 1 do
    begin
      if S1[I] = '\' then
        begin
          K := I;
          Break;
        end;
    end;
  for I := 1 to K - 1 do
    S := S + S1[I];
  Result := S;
end;

procedure InstallBde;
const
  Bor: string = 'SOFTWARE\Borland';
var
  a: TRegistry;
  BPath: string;
begin
  BPath := PATH + '\BDE';
  a := TRegistry.Create;
  with a do
    begin
      RootKey := HKEY_LOCAL_MACHINE;
      OpenKey(Bor + '\Database Engine', True);
      WriteString('CONFIGFILE01', BPath + '\IDAPI32.CFG');
      WriteString('DLLPATH', BPath);
      WriteString('RESOURCE',
        '0009');
      WriteString('SaveConfig', 'WIN32');
      WriteString('UseCount', '2');
      CloseKey;
      OpenKey(Bor + '\BLW32', True);
      WriteString('BLAPIPATH', BPath);
      WriteString('LOCALE_LIB3', BPath + '\OTHER.BLL');
      WriteString('LOCALE_LIB4', BPath + '\CHARSET.BLL');
      CloseKey;
      OpenKey(Bor + '\Database Engine\Settings\SYSTEM\INIT', True);
      WriteString('AUTO ODBC', 'FALSE');
      WriteString('DATA REPOSITORY', '');
      WriteString('DEFAULT DRIVER', 'PARADOX');
      WriteString('LANGDRIVER', 'ancyrr');
      WriteString('LOCAL SHARE', 'FALSE');
      WriteString('LOW MEMORY USAGE LIMIT', '32');
      WriteString('MAXBUFSIZE', '2048');
      WriteString('MAXFILEHANDLES', '48');
      WriteString('MEMSIZE', '16');
      WriteString('MINBUFSIZE', '128');
      WriteString('SHAREDMEMLOCATION', '');
      WriteString('SHAREDMWriteString(' SQLQRYMODE', '');
        WriteString('SYSFLAGS', '0');
        WriteString('VERSION', '1.0');
        CloseKey;
        OpenKey(Bor + '\Database Engine\Settings\SYSTEM\FORMATS\DATE', True);
        WriteString('FOURDIGITYEAR', 'TRUE');
        WriteString('LEADINGZEROD', 'FALSE');
        WriteString('LEADINGZEROM', 'FALSE');
        WriteString('MODE', '1');
        WriteString('SEPARATOR', '.');
        WriteString('YEARBIASED', 'TRUE');
        CloseKey;
        OpenKey(Bor + '\Database Engine\Settings\SYSTEM\FORMATS\NUMBER', True);
        WriteString('DECIMALDIGITS', '2');
        WriteString('DECIMALSEPARATOR', ',');
        WriteString('LEADINGZERON', 'TRUE');
        WriteString('THOUSANDSEPARATOR', ' ');
        CloseKey;
        OpenKey(Bor + '\Database Engine\Settings\SYSTEM\FORMATS\TIME', True);
        WriteString('AMSTRING', 'AM');
        WriteString('MILSECONDS', 'FALSE');
        WriteString('PMSTRING', 'PM');
        WriteString('SECONDS', 'TRUE');
        WriteString('TWELVEHOUR', 'TRUE');
        CloseKey;
        OpenKey(Bor + '\Database Engine\Settings\REPOSITORIES', True);
        CloseKey;
        OpenKey(Bor + '\Database Engine\Settings\DRIVERS\PARADOX\INIT', True);
        WriteString('LANGDRIVER', 'ancyrr');
        WriteString('TYPE', 'FILE');
        WriteString('VERSION', '1.0');
        CloseKey;
        OpenKey(Bor + '\Database Engine\Settings\DRIVERS\PARADOX\TABLE
        CREATE',True);
        WriteString('BLOCK SIZE', '4096');
        WriteString('FILL FACTOR', '95');
        WriteString('LEVEL', '7');
        WriteString('STRICTINTEGRTY', 'TRUE');
        CloseKey;
    end;
  a.Free;
end;
begin
  Path := GetExePath(ParamStr(0));
  R := dbiInit(nil);
  if R <> DBIERR_NONE then
    begin
      WriteString('Инициализация BDE ...');
      InstallBDE;
    end;
  R := dbiInit(nil);
  if R = DBIERR_NONE then
    begin
      WriteString('Инициализация BDE прошла успешно');
      DbiDeleteAlias(nil, PChar(AliasName));
      R := DbiAddAlias(nil, PChar(AliasName), szPARADOX,
        PChar('PATH:' + Path + '\DB'), True);
      if R = DBIERR_NONE then
        WriteString('Псевдоним "' + AliasName + '" создан')
      else
        WriteString('Ошибка создания псевдонима "' + AliasName + '"');
      R := DbiCfgSave(nil, nil, Bool(-1));
      if R = DBIERR_NONE then
        WriteString('Файл конфигурации сохранён')
      else
        WriteString('Ошибка сохранения файла конфигурации');
      DbiExit;
    end
  else
    WriteString('Ошибка инициализации BDE');
end.

Константин Кочедыков / kostya@roadtech.saratov.su /

Взято с сайта

Installer

Этапы инсталляции

Дальше

Запомните одно важное правило: инсталлировать программу можно с человеческих носителей
(винчестеры, компакт-диски, ZIP-диски) и с дискет :) Если вы собираетесь написать инсталляцию
с дискет, которая явно не поместиться на одну дискету, то у вас есть шанс хорошо провести время :)

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

Эта в высшей степени корректная техника перестаёт работать при инсталляции с дискет.
Ваша программа, например, копирует четвёртую дискету и тут выясняется, что у неё (у программы)
пропал кусок кода. Какие проблемы? ? Windows пытается прочитать файл a:\setup.exe
и естественно его не находит (на четвёртой-то дискете? откуда?).

Только не паникуйте! Эта проблема давно решена, иначе вы не могли бы установить
на свой компьютер ни одной программы! Всё очень просто ? программа инсталляции копирует
себя и все необходимые файлы во временный каталог на жёсткий диск и перезапускает
себя с жёсткого диска. Это и есть первый этап инсталляции.
В зарубежных программах он обычно называется "Prepare to install".
Ещё раз обратите внимание на то, что совсем не обязательно выполнять этот этап,
если вы инсталлируетесь не с дискет, или если ваша инсталляция умещается на одну дискету.

На втором этапе программа инсталляции обычно показывает пользователю несколько страшных
предупреждений; что-то типа "если вы не заплатите за эту программу, то сидеть вам в тюрьме три пожизненных срока".
Я слышал, что некоторые пользователи со слабым сердецем даже умирали за компьютером от таких угроз :)

Реализация этого этапа до идиотизма тривиальна, поэтому мы и не будем на нём останавливаться подробно.

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

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

Следующий, пятый, этап ? настройка системного реестра (registry).
Достаточно тривиальная процедура, правда, при инсталляции большого продукта, записывать придёться очень много.

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

Наконец, финальная часть включает демонстрацию нескольких файлов (например, readme),
затем онлайновую регистрацию (подробно на ней я останавливаться не буду) и последнее
сообщение "Инсталляция успешно завершена".

Теперь мы можем перейти к подробному рассмотрению этапов. Сейчас вы узнаете, как это делается :)

Копирование программы во временный каталог

program Setup;

uses
  Windows,
  SysUtils;

const
  ReRunParameter = '/install_from_temp_directory';

var
  TempPath: array [0..MAX_PATH] of Char;
  SrcPath: String;

begin
  if ParamStr(1) = ReRunParameter then
    SrcPath := ParamStr(2)
  else
    if GetDriveType(PChar(ParamStr(0)[1] + ':\')) = DRIVE_REMOVABLE then
    begin
      // Если программа была запущена без ключа и с дискеты, то
      // копируем её во временный каталог и перезапускам
      // Текущее приложение завершаем.
      GetTempPath(MAX_PATH, TempPath);
      // Добавлям к пути временного каталога символ '\', если его там нет
      if (StrLen(TempPath) > 0) and (TempPath[StrLen(TempPath)] <> '\') then
        StrCat(TempPath, '\');
      // Копируем файл через вызов функции CopyFile из WinAPI
      CopyFile(PChar(ParamStr(0)), PChar(String(TempPath) + ExtractFileName(ParamStr(0))), False);
      // Запускаем файл с двумя параметрами
      WinExec(PChar(String(TempPath) + ExtractFileName(ParamStr(0)) + ' ' +
        ReRunParameter + ' ' + ExtractFilePath(ParamStr(0))), CmdShow);
      Exit;
    end
    else
      SrcPath := ExtractFilePath(ParamStr(0));
  // Здесь начинается программа инсталляции
  // Переменная SrcPath показывает нам, откуда надо копировать файлы
end.
Есть две грабли, на которые можно наступить в приведённом примере.
Первые лежат в вызове функции GetTempPath.
Если у вас нет переменных окружения TMP и TEMP,
то временным каталогом станет текущий каталог программы, то есть, фактически, ваша дискета.

Вы можете проверять, не находится ли временный каталог на
сменном диске (с помощью вызова GetDriveType), и, если находиться,
считать временным каталогом C:\TEMP (если его нет ? создайте самостоятельно).

Вторые грабли заключаются в том, что после завершения инсталляции программу
из временного каталога желательно удалить, но сделать этого вы не сможете,
поскольку программа в этот момент выполняется. Вспомните, что в Windows 95 и Windows NT
выполняющуся программу удалять нельзя

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

Примечание: Если для вас важен размер вашей инсталляции, вы можете взять только тот кусочек,
который приведён выше, и сделать из него отдельную программу (которая будет очень небольшого объёма).
Саму программу инсталляции вы предварительно сжимаете, а перед запуском распаковываете
её во временный каталог (а не копируете, как это сделано здесь).
Обратите внимание, что в этом случае программа должна распаковываться в любом случае,
а не только если она запущена с дискеты.

Запугивание пользователя законами об авторских правах

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

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

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

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

Имя пользователя и организация

Во время инсталляции, программы иногда запрашивают имя пользователя и его организацию.
Возможно, для работы вашей программы эти данные не понадобятся, но если они вам нужны, вы должны их запросить.
Как правило, программа инсталляции берёт эти данные из Windows
(поскольку при установке Windows пользователь их уже вводил) и просит всего лишь изменить их,
если это необходимо. Наш вопрос звучит так: где Windows хранит имя пользователя и организацию?
Я, правду сказать, не знаю. Но, пробежавшись по реестру, я обнаружил всего лишь два подходящих места,
содержащих эту информацию.
HKEY_LOCAL_MACHINE\Software\Microsoft NT\Windows\CurrentVersion\
HKEY_LOCAL_MACHINE\Software\Microsoft\Windows\CurrentVersion\
HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\
RegisteredOwner = 'Имя'
RegisteredOrganization = 'Организация'
В доступной мне версии Windows 95, эти значения хранятся в ветке
HKEY_LOCAL_MACHINE, а в Windows NT ? HKEY_CURRENT_USER (в подветках Windows или Windows NT).
Поскольку в этом вопросе нет ясности :) я предлагаю проверять обе ветки.
Версию операционной системы можно узнать с помощью функции GetVersionEx.

Куда копировать программу:

Можно сформулировать наш вопрос и по другому: где находиться каталог Program Files?
Некоторые инсталляции считают, что это C:\Program Files. В действительности, конечно,
он может находиться на другом диске, поэтому мы попробуем поискать его по другому... в реестре.

HKEY_LOCAL_MACHINE\Software\Microsoft\Windows\CurrentVersion\ ProgramFilesDir = 'D:\Program Files'

Можно воспользоваться функцией SHGetSpecialFolderLocation (это даже более корректно с точки зрения Microsoft).
Пример использования этой функции вы обнаружите несколькими файлами позже.
Для изменения каталога вы можете вызывать функции SelectDirectory или SHBrowseForFolder.
Можно также создать собственное окно диалога "Выбор каталога" с помощью компонента DirectoryListBox.
Подробнее о выборе каталога мы поговорим позднее, когда будем рассматривать тонкости процесса инсталляции.

Сколько осталось свободного места на диске

Программа инсталляции перед копированием файлов обязана проверить,
сколько на целевом диске осталось свободного дискового пространства.
Это делается при помощью функции GetDiskFreeSpace (из модуля Windows) или функции DiskFree (из модуля SysUtils).
Вторая функция ? это надстройка Delphi над Win API (в смысле, она вызывает GetDiskFreeSpace),
но у неё значительно меньше параметров.

Группы программ

Обычно программа инсталляции создаёт для новой программы новую группу.
Как правило, когда вы вводите название группы, рядом присутствует список,
в котром перечислены все существующие группы. Получить такой список можно двумя способами.
Один из них ? работа с DDE-сервером, который называется Program Manager.
Этот способ мы подробно рассмотрим чуть позже. Второй способ не очень сложен и
основан на том факте, что всё меню "Программы" находиться в одном из каталогов вашего диска.
Все подменю являются на самом деле подкаталогами, а пукнты ? обычными ссылками
(файлами с расширением .lnk). Путь к папке, содержащей меню "Программы",
вы можете найти в реестре:
HKEY_CURRENT_USER\Software\Microsoft\Windows\ CurrentVersion\Explorer\Shell Folders\ Programs =
'D:\WINNT\Profiles\mark\Главное меню\Программы'
Не очень сложно прочитать содержимое этого каталога с помощью функций FindFirst/FindNext.
Ниже мы и об этом поговорим подробнее, поскольку чтение содержимого каталогов потребуется
нам при написании универсальной процедуры копирования файлов.

Дальше

Автор: Неизвестен URL: www.delphi.agava.ru

Взято с сайта

b>Installing Kylix 3 Open Edition on Mandrake 9

How can I get Kylix 3 Open Edition installed and running on Mandrake 9?

Open a Super User Terminal, select "Sessions/New Root Midnight Commander" and in "/", create a directory "temp"

Download or copy the file kylix3_open.tar.gz into the "temp" directory you just created.

Check that all necessary programs are installed on your system:

Open kmenu/configuration/packaging/Remove Software or kpackage

Check for installation of the following:
kernel => 2.2 (mdk9.0 uses 2.4)
libgtk => 1.2 (mdk 9.0 uses 1.2-1.2.10-29)
libjpeg => 6.2 (mdk 9.0 uses 6.-66-25)
XIIR6 (XFree86) (mdk uses 4.2.1-3)
XFree86-dev (mdk9.0 uses 4.2.1-3)
glibc-dev (mdk9.0 uses 2.2.5-16)

Once you have verified that you have all of the necessary programs do the following:

In a Super User Terminal do:

cd /temp
tar zxf kylix3_open.tar.gz

In user terminal (NOT as root):

cd /temp/kylix3_open
./setup.sh

In Gui select "I Agree"
Now select "install"

Logout and log back in as same user to get the Borland Kylix entry in the KDE menu

In Borland Kylix 3 menu, select "register now"
In the Gui select "next"
In the Gui select 'Finish"
The Gui disappears and the registration process has completed.
The Kylix Delphi and Kylix C++ IDE's can now be run.

Interbase BLOB-поля

BLOB-поля отличаются от полей другого типа. Реально BLOB-поле имеет несколько подтипов (sub-type). Знание подтипа BLOB-поля существенно при создании приложения для работы с базами данных, которые включают в себя InterBase BLOB-поля. BLOB-поля могут быть трех подтипов: подтип 0, подтип 1 (два встроенных подтипа), и пользовательский подтип.

Подтип 0 BLOB-поля создается при выполнении команды CREATE, когда подтип не определен. Для ясности, в синтаксисе SQL все же рекомендуется явно указывать, что BLOB-поле относится к подтипу 0. Данный подтип BLOB-поля используется для хранения бинарных данных. InterBase не производит никакого анализа хранимых данных, он просто хранит данные в BLOB-поле байт-за-байтом. Наиболее частое применение BLOB-полей в приложениях Windows - хранение двоичных данных изображения, обычно отображаемое впоследствие компонентом TDBImage. Для этой цели подходит или BLOB-поле подтипа 0, или BLOB-поле пользовательского подтипа.

Второй встроенный подтип - 1. Данный подтип BLOB-поля разрабатывался для хранения текста. Обычно это данные свободного формата типа memo или заметок, отображаемых и редактируемых компонентом TDBMemo. Данный подтип BLOB-поля лучше подходит для хранения данных типа текст, чем поле, имеющее тип VARCHAR, поскольку, в отличие от поля типа VARCHAR, в режиме проектирования возможно задание ограничения по используемой областью памяти.

С помощью SQL-синтаксиса, подтип 1 BLOB-поля создается с указанием типа BLOB-поля, использованием ключевого слова SUB_TYPE и числа, указывающего на номер необходимого подтипа:

CREATE TABLE WITHBLOB
  (
    ID CHAR(3) NOT NULL PRIMARY KEY,
    MEMO BLOB SUB_TYPE 1,
    AMOUNT NUMERIC
  )

Помимо двух встроенных подтипов BLOB-поля, существует также подтип, определяемый пользователем. Такой подтип задается отрицательным целым значением совместно с ключевым словом SUB_TYPE. Фактически учитывается только "отрицательность" целого числа, его значение может быть произвольным и остается на усмотрение того, кто создает таблицу. Указание числа -1 идентично указанию числа -2. Единственная рекомендация для использования подтипа, определяемого пользователем - гарантия того, что в каждой строке таблицы BLOB-поле будет иметь только данный подтип, определяемый пользователем. InterBase не имеет критерия для оценки хранимого подтипа, поэтому вся ответственность по определению подходящего типа двоичных данных ложится на приложение. Никакой ошибки со стороны InterBase при загрузке неверного типа двоичных данных в пользовательский подтип BLOB-поля быть не может, но приложение может столкнуться с трудностями, если оно ожидает один тип данных, но ей передают другой.
BLOB-поле пользовательского подтипа может создаваться следующим синтаксисом SQL:

  CREATE TABLE IMAGE_DATA
  (
    FILENAME CHAR(12) NOT NULL PRIMARY KEY,
    BITMAP BLOB SUB_TYPE -1,
    EXEs BLOB SUB_TYPE -2,
  )
При пользовании таблицей, созданной с помощью приведенной выше команды, поле BITMAP может использоваться для хранения одного типа двоичных данных для всех записей. В нашем случае хранятся данные изображения. Поле EXEs подразумевает хранение выполнимых файлов, загружаемых с диска. Если приложение, использующее данную таблицу, по ошибке сохранит двоичные данные в поле BITMAP вместо EXEs, InterBase ошибки не выдаст, но приложение при этом столкнется с серьезными трудностями при отображении в компоненте TDBImage сохраненного выполнимого файла.
InterBase BLOB-поля и Delphi

При определении объектов TField для InterBase BLOB-полей в Delphi, следует относить различные подтипы BLOB-поля к производным типам TField следующим образом:

  Подтип 0:         TBlobField
  Подтип 1:         TMemoField
  Пользовательский: TBlobField

Поскольку, как встроенный подтип 0, так и пользовательский подтип, относятся к объектам TBlobField, то забота об определении используемого подтипа во время проектирования приложения ложится на программиста. Единственный способ отличить подтип 0 от пользовательского подтипа заключается в просмотре информации о метаданных таблицы, что не может быть сделано с помощью Delphi. Для просмотра метаданных таблицы может быть использована утилита Local InterBase Server под названием WISQL.
InterBase BLOB-поля и Database Desktop

Утилита Database Desktop, поставляемая с Delphi (DBD), не создает пользовательские подтипы. При создании в Database Desktop BLOB-полей для хранения бинарных данных, включая данные изображения, используйте тип поля "BLOB". Этим вы создадите BLOB-поле встроенного подтипа 0.

В DBD также возможно создание BLOB-поля типа TEXT BLOB. Это эквивалент встроенного подтипа 1 и может использоваться для хранения текста свободного формата. Так как он только функционален встроенному подтипу 1 BLOB-поля, то при просмотре таблицы утилитой WISQL, обозначение его подтипа может отличаться от действительного.

Взято из

Советов по Delphi от

Сборник Kuliba

Интернет программирование

Cодержание раздела:

ISAPI and CGI Applications get Errors Initializing the BDE.

Scenario: When my ISAPI or CGI Applications try to access the BDE they get an error when the BDE tries to initialize. The BDE appears to be installed correctly since regular desktop applications operate without any problems.

Suggestion: The user that runs under IIS may not have proper permissions set on the system Temp directory. One suggestions is to change the security settings to Full Control for the USERS user. Full Control must be set on Temp in addition to the directory having read, write permissions.

Исчезает главное меню Delphi, почему?

Дельфи до 6й версии неправильно распознают профили пользователей в 2000/XP. Надо установить Дельфи под тем пользователем под которым будете его использовать.

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

Использование BDE приложений в Peer-To-Peer сети

Сетью Peer-To-Peer (сеть, где каждая машина действует как клиент и как сервер) может быть одна из следующих сетей, включая другие сетевые платформы, совместимые с ними:

Windows 95
Windows NT
Lantastic
Netware Lite
BDE автоматически обнаруживает таблицы на сетевом диске, но он не может их определить на dedicated сервере или server/client. Dedicated-сервера уведомляют приложение клиента о том, что файл был изменен или заблокирован. Данная функциональность отсутствует в Peer-To-Peer (не-dedicated) сетях. Для ее включения в сетях Peer-To-Peer, установите "LOCAL SHARE" в TRUE в BDE Configuration Utility на странице System. Это должно быть сделано на всех клиентах BDE, которые имеют доступ к таблицам в сетях, указанных выше. В случае файловых серверов Novell данное требование не является необходимым.
Если используемые таблицы - таблицы Paradox, они также должны использовать каталог с сетевым контролем. Данный каталог должен находиться в сети для всех используемых клиентских приложений. Хорошим стилем считается использование отдельного каталога для приложения, сети и таблиц. Поясним примером:

<Каталогобщего доступа>
        |
        |--- <Каталог таблиц>
        |--- <Каталог Exe-файлов>
        |--- <Сетевой каталог>
Существуют две различных среды BDE, которые необходимо принимать во внимание:
Использование только 32-битных приложений BDE.
Использование только 32-битных приложений BDE совместно с 16-битными.
Установка только для 32-битных приложений
32-битное BDE полностью поддерживает соглашение об путях UNC вместе с длинными именами файлов. Рекомендуется использование соглашения UNC для всех сетевых соединений BDE. UNC позволяет обойтись без подключения (mapped) сетевых дисков. Это позволяет иметь доступ к таблицам и сетевым каталогам без необходимости заставлять пользователя подключать сетевые диски. UNC имеет следующий синтаксис:

\<Имя сервера>\<Имя каталога общего доступа>\<Путь к каталогу>+<Имя файла>
Вот простой пример стандартного псевдонима (alias) BDE с использованием UNC:
Псевдоним: MyUNCAlias
Тип: STANDARD
Путь: \\FooServer\FooShare\Sharedir\Tables
Драйвер по умолчанию: Paradox
Сетевой каталог может быть установлен и таким способом:
Драйвер: Paradox
Сетевой каталог: \\FooServer\FooShare\Sharedir\NetDir
Сетевой каталог может быть установлен во время выполнения приложения с помощью session.netfiledir (Delphi) или DbiSetProp (C++ / Delphi)
Если по какой-либо причине UNC не может использоваться в 32-битных приложениях, следуйте за следующими инструкциями для среды с 32-битными и 16-битными приложениями BDE.

Установка для 16-битных и 32-битных приложений BDE

Поскольку 16-битное Windows API не поддерживает UNC, ее не поддерживает и 16-битное BDE. Для того, чтобы позволить приложениям иметь общий доступ к таблицам, все клиенты должны подключить один и тот же каталог на сервере. Если сервер также используется и в качестве клиента, то все другие клиенты должны подключить его корневой каталог диска. Логический диск при этом у клиентов может быть разным. Вот несколько примеров с работающими и неработающими настройками:

Клиент1:
Путь: X:\Каталог общего доступа\Таблицы
Клиент2:
Путь: X:\Каталог общего доступа\Таблицы
Работоспособно

Клиент1: (Также машина с таблицами):
Путь: X:\Каталог общего доступа\Таблицы
Клиент2:
Путь: X:\Каталог общего доступа\Таблицы
Работоспособно

Клиент1: (Также машина с таблицами):
Путь: C:\Каталог общего доступа\Таблицы
Клиент2:
Путь: X:\Каталог общего доступа\Таблицы
Клиент3:
Путь: R:\Каталог общего доступа\Таблицы
Работоспособно

Клиент1:
Путь: X:\Каталог общего доступа\Таблицы
Клиент2:
Путь: X:\Таблицы (Где "X:\Таблицы" реально -
"X:\Каталог общего доступа\Таблицы", но имеющий
общий доступ в "Каталог общего доступа")
Неработоспособно. BDE должен иметь возможность
иметь доступ к файлу Network Control (управление
сетью).
Итог (установки для сетей Peer-To-Peer):
16- и/или 32-битные приложения:

В BDE Configuration Utility установите "LOCAL SHARE" в TRUE.
Не используйте UNC-имена.
Не используйте таблицы с длинными именами файлов.
Убедитесь в том, что все клиенты подключены к одному и тому же каталогу на сервере.
Только 32-битные приложения:
В BDE Configuration Utility установите "LOCAL SHARE" в TRUE.
Для получения доступа к сетевому каталогу и каталогу с таблицами используйте UNC-имена.
При невыполнении описанных выше шагов пользователи могут блокировать таблицы с получением следующей ошибки:
"Directory is controlled by other .NET file."
(Каталог управляется другим .NET-файлом)
"File: PDOXUSRS.LCK" ("Файл: PDOXUSRS.LCK")
"Directory: " (Каталог: )
ИЛИ

"Multiple .NET files in use."
(Используются несколько .NET-файлов.)
"File: PDOXUSRS.LCK"
(Файл: PDOXUSRS.LCK)

Взято с

Использование BDE в сети

1) Может ли мое приложение иметь доступ к файлам, расположенным на сетевых дисках?
Да.

2) Когда я попытался это сделать, программа выдала сообщение об ошибке "Not initialized for accessing network files" (не инициализировано для доступа к сетевым файлам).
Вероятно вам необходимо задать правильный путь к каталогу в поле 'NET DIR' файла IDAPI.CFG. Директория должна быть одна и быть доступна всем пользователям приложения с применением одинаковых подключенных сетевых дисков. (т.е.: если NET DIR указывает на F:\PUBLIC\NETDIR, пользователи с подключенным сетевым диском и имеющим путь G:\NETDIR доступа не получат).

3) Возможно ли запустить приложение, относящееся к описываемой категории, с сетевого диска без установленного на локальной машине BDE (за исключением возможных ссылок в локальном файле WIN.INI на копии элементов программы BDE/IDAPI, расположенных на сетевом диске)?
Да. Установите BDE в сети и затем добавьте следующие секции в файл WIN.INI каждой рабочей станции:

[IDAPI]
CONFIGFILE01=F:\IDAPI\IDAPI.CFG
DLLPATH=F:\IDAPI

[Borland Language Drivers]
LDPath=F:\IDAPI\LANGDRV
...пути должны отражать текущее месторасположение каталога IDAPI.

4) Для установки "NET DIR" мне нужно запустить BDECFG на каждой рабочей станции или просто сделать это на "сервере"?
C помощью утилиты BDECFG отредактируйте файл IDAPI.CFG и сохраните его в сетевом каталоге IDAPI. Следовательно, вам необходимо проделать данную операцию всего-лишь один раз.

5) Если мне нужно сделать это только на сервере, то как все рабочие станции узнают о месторасположении сетевых файлов ("NET DIR")?
Рабочая станция открывает файл IDAPI.CFG из каталога, указанного в WIN.INI, и уже оттуда читает настройки NET DIR.

Eryk

Взято из

Советов по Delphi от

Сборник Kuliba

Использование COM объекта Outlook

Пример отсылки письма используя COM объект Outlook

uses Outlook_TLB;

var outlook : _application;

Procedure Init;
begin
  outlook := Coapplication_.Create;
end;

procedure SendEmail;
begin
  with Outlook.CreateItem(olMailItem) as mailitem do
    begin
      To_ := 'email@email.com';
      cc:='email2@email.com';
      Subject := 'This is subject line';
      Attachments.Add('FileName',1,1,'This is attachment');
      Body :='This is email body';
      Send;
    end;
end;

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

Автор: Eddie Shipman

Пример использует VB Script для Outlook, который позволяет произвести такую операцию. Создаётся OLE-объект - 'Outlook.Application' и в него передаётся скрипт.

Совместимость: все версии Delphi

Измените recipientaddress@recipienthost.com на Ваш собственный e-mail
адресс. У Вас должен быть проинсталирован Outlook,

{Я не уверен, что это будет работать в Outlook Express.}

Примечание Vit: Это точно не будет работать в Outlook Express

uses ComObj; {Delphi 5}

procedure TForm1.Button1Click(Sender: TObject);
Const
  // константы OlItemType
  olMailItem = 0;
  olAppointmentItem = 1;
  olContactItem = 2;
  olTaskItem  = 3;
  olJournalItem = 4;
  olNoteItem = 5;
  olPostItem = 6;
  // константы OlAttachmentType
  olByValue = 1;
  olByReference = 4;
  olEmbeddedItem = 5;
  olOLE = 6;

var
  myOlApp, myItem, myRecipient, myAttachments: OleVariant;
begin
  // файл VBScript для создания почтового сообщения и прикрепления к нему файла
  myOlApp := CreateOLEObject('Outlook.Application');
  myItem := myOlApp.CreateItem(olMailItem);
  myItem.Subject := 'This is the Subject';
  myRecipient := myItem.Recipients.Add('recipientaddress@recipienthost.com');
  myItem.Body := #13;
  myItem.Body := myItem.Body + #13;
  myItem.Body := myItem.Body + 'Hello,' + #13;
  myItem.Body := myItem.Body + 'This code created this message and '+
                               ' sent it and I didn''t even have' + #13;
  myItem.Body := myItem.Body + 'to click the send button!!!' + #13;
  myItem.Body := myItem.Body + #13;
  myItem.Body := myItem.Body + 'If you have any more problems, let me know' +
#13;
  myItem.Body := myItem.Body + 'rename to blah.vbs and run like this:' + #13;
  myItem.Body := myItem.Body + 'wscript c:\blah.vbs' + #13;
  myItem.Body := myItem.Body + #13;
  myItem.Body := myItem.Body + 'Eddie' + #13;
  myItem.Body := myItem.Body + #13;
  myItem.Body := myItem.Body + #13;
  myItem.Body := myItem.Body + 'const'+ #13;
  myItem.Body := myItem.Body + '  // константы OlItemType'+ #13;
  myItem.Body := myItem.Body + '  olMailItem = 0;'+ #13;
  myItem.Body := myItem.Body + '  olAppointmentItem = 1;'+ #13;
  myItem.Body := myItem.Body + '  olContactItem = 2;'+ #13;
  myItem.Body := myItem.Body + '  olTaskItem  = 3;'+ #13;
  myItem.Body := myItem.Body + '  olJournalItem = 4;'+ #13;
  myItem.Body := myItem.Body + '  olNoteItem = 5;'+ #13;
  myItem.Body := myItem.Body + '  olPostItem = 6;'+ #13;
  myItem.Body := myItem.Body + '  // OlAttachmentType constants'+ #13;
  myItem.Body := myItem.Body + '  olByValue = 1;'+ #13;
  myItem.Body := myItem.Body + '  olByReference = 4;'+ #13;
  myItem.Body := myItem.Body + '  olEmbeddedItem = 5;'+ #13;
  myItem.Body := myItem.Body + '  olOLE = 6;'+ #13;
  myItem.Body := myItem.Body + #13;
  myItem.Body := myItem.Body + 'var'+ #13;
  myItem.Body := myItem.Body + '  myOlApp, myItem, myRecipient, myAttachments:
OleVariant;'+ #13;
  myItem.Body := myItem.Body + 'begin'+ #13;
  myItem.Body := myItem.Body + '  myOlApp :=
CreateObject(''Outlook.Application'')' + #13;
  myItem.Body := myItem.Body + '  myItem := myOlApp.CreateItem(olMailItem)' +
#13;
  myItem.Body := myItem.Body + '  myItem.Subject := ''This is the Subject''' +
#13;
  myItem.Body := myItem.Body + '  myItem.Body := ''This is the body''' + #13;
  myItem.Body := myItem.Body + '  myRecipient := myItem.Recipients.Add
('recipientaddress@recipienthost.com')' + #13;
  myItem.Body := myItem.Body + '  myAttachments := myItem.Attachments' + #13;
  myItem.Body := myItem.Body + '  // Теперь прикрепим файлы...' + #13;
  myItem.Body := myItem.Body + '  myAttachments.Add ''C:\blah.txt'', olByValue,
1, ''Blah.txt Attachment''' + #13;
  myItem.Body := myItem.Body + '  myItem.Send' + #13;
  myItem.Body := myItem.Body + '  myOlApp := VarNull;' + #13;
  myItem.Body := myItem.Body + '  myItem := VarNull;' + #13;
  myItem.Body := myItem.Body + '  myRecipient := VarNull;' + #13;
  myItem.Body := myItem.Body + '  myAttachments := VarNull;' + #13;
  myItem.Body := myItem.Body + 'end;' + #13;
  // Теперь прикрепим файлы...
  myAttachments := myItem.Attachments;
  myAttachments.Add('C:\blah.txt', olByValue, 1, 'Blah.txt Attachment');
  myItem.Send
  myOlApp := VarNull;
  myItem := VarNull;
  myRecipient := VarNull;
  myAttachments := VarNull;
End;

Использование функций перечисления WinAPI

Для получения информации о множественных объектах Windows (окнах, принтерах, шрифтах, настройках экрана и так далее - всего несколько десятков вариантов) используются функции, начинающиеся с Enum. Эти функции работают по принципу, аналогичному итератору TCollection.FirstThat, то есть они вызывают функцию, переданную им в качестве параметра для каждого перечисляемого объекта, передавая ей в параметрах данные объекта и, в последнем параметре, указатель на пользовательские данные, переданный функции EnumXXX. Перечисление продолжается до тех пор, пока не будут перечислены все объекты. Немедленно прекратить перечисление можно, возвратив False. Ниже приведен пример заполнения списка ListBox1 данными по всем окнам Windows в виде " класс - заголовок" по нажатию кнопки Button1.

functionAddWinInfo(WinHandle: HWnd; List: TStringList): Boolean;
stdcall;
var
  WinCaption,WinClass: array[0..255] of Char;
begin
  Result:=True;
  GetClassName(WinHandle,WinClass,SizeOf(WinClass));
  GetWindowText(WinHandle,WinCaption,SizeOf(WinCaption));
  List.Add(WinClass+' - '+WinCaption);
end;

procedure TfrmMain.Button1Click(Sender: TObject);
begin
  with ListBox1,Items do
  begin
    Clear;
    EnumWindows(@AddWinInfo,LParam(Items));
  end;
end;

Взято с

Использование HOOK в Дельфи

Что такое НООК?
НООК - это механизм перехвата сообщений, предоставляемый системой Microsoft Windows. Программист пишет специального вида функцию (НООК-функция), которая затем при помощи функции SetWindowsHookEx вставляется на верх стека НООК-функций системы. Ваша НООК-функция сама решает, передать ли ей сообщение в следующую НООК-функцию при помощи CallNextHookEx или нет.

Какие бывает НООК'и?
НООК бывают глобальные, контролирующие всю систему, так и локальные, ориентированные на какой-либо поток (Thread). Кроме того НООК различаются по типу перехватываемых сообщений (подробнее об этом - ниже). НООК несколько подтормаживают систему, поэтому ставить их рекомендуется только при необходимости, и кактолько необходимость в них отпадает - удалять.

Как создавать НООК?
НООК устанавливается в систему при помощи функции SetWindowsHookEx, вот её заголовок:

functionSetWindowsHookEx(idHook: Integer; lpfn: TFNHookProc; hmod: HINST; dwThreadId: DWORD): HHOOK;

idHook
константа, определяющая тип вставляемого НООК'а, должна быть одна из нижеследующих констант:
WH_CALLWNDPROC
вставляемая НООК-функция следит за всеми сообщения перед их отпралением в соответствующую оконную функцию
WH_CALLWNDPROCRET
вставляемая НООК-функция следит за всеми сообщениями после их отправления в оконную функцию
WH_CBT
вставляемая НООК-функция следит за окнами, а именно: за созданием, активацией, уничтожением, сменой размера; перед завершением системной команды меню, перед извлечением события мыши или клавиатуры из очереди сообщений, перед установкой фокуса и т.д.
WH_DEBUG
вставляемая НООК-функция следит за другими НООК-функциями.
WH_GETMESSAGE
вставляемая НООК-функция следит за сообщениями, посылаемыми в очередь сообщений.
WH_JOURNALPLAYBACK
вставляемая НООК-функция посылает сообщения, записанные до этого WH_JOURNALRECORD НООК'ом.
WH_JOURNALRECORD
эта НООК-функция записывает все сообщения куда-либо в специальном формате, причем позже они могут быть "воспроизведены" при помощи НООК'а WH_JOURNALPLAYBACK. Это в некотором роде аналог магнитофонной записи сообщений.
WH_KEYBOARD
вставляемая НООК-функция следит за сообщениями клавиатуры
WH_MOUSE
вставляемая НООК-функция следит за сообщениями мыши
WH_MSGFILTER
WH_SHELL
WH_SYSMSGFILTER
lpfn
указатель на непосредственно функцию. Обратите внимание, что если Вы ставите глобальный НООК, то НООК-функция обязательно должна находиться в некоторой DLL!!!
hmod
описатель DLL, в которой находится код функции.
dwThreadId
идентификатор потока, в который вставляется НООК
Подробнее о НООК-функциях смотри справку по Win32API.

Как удалять НООК?
НООК удаляется при помощи функции UnHookWindowsEx.

Пример использования НООК.
Ставим НООК, следящий за мышью (WH_MOUSE). Программа следит за нажатием средней кнопки мыши, и когда она нажимается, делает окно, находящееся непосредственно под указателем, поверх всех остальных (TopMost). Код самой НООК-функции помещен в библиотеку lib2.dll, туда же помещены и функции Start - для установки НООК, и Remove - для удаления НООК.

Файл sticker.dpr
program sticker;
uses windows, messages;
var
wc : TWndClassEx;
MainWnd : THandle;
Mesg : TMsg;
//экспортируем две функции из библиотеки с НООК'ами
procedure Start; external 'lib2.dll' name 'Start';
procedure Remove; external 'lib2.dll' name 'Remove';

function WindowProc(wnd:HWND; Msg : Integer; Wparam:Wparam; Lparam:Lparam):Lresult; stdcall;
var
nCode, ctrlID : word;
Begin
case msg of
wm_destroy :
   Begin
   Remove;//удаляем НООК
   postquitmessage(0); exit;
   Result:=0;
   End;
else
   Result:=DefWindowProc(wnd,msg,wparam,lparam);
end;
End;

begin
wc.cbSize:=sizeof(wc);
wc.style:=cs_hredraw or cs_vredraw;
wc.lpfnWndProc:=@WindowProc;
wc.cbClsExtra:=0;
wc.cbWndExtra:=0;
wc.hInstance:=HInstance;
wc.hIcon:=LoadIcon(0,idi_application);
wc.hCursor:=LoadCursor(0,idc_arrow);
wc.hbrBackground:=COLOR_BTNFACE+1;
wc.lpszMenuName:=nil;
wc.lpszClassName:='WndClass1';

RegisterClassEx(wc);

MainWnd:=CreateWindowEx(0,'WndClass1','Caption',ws_overlappedwindow,
           cw_usedefault,cw_usedefault,cw_usedefault,cw_usedefault,0,0,
           Hinstance,nil);
ShowWindow(MainWnd,CmdShow);
Start;//вставляем НООК

While GetMessage(Mesg,0,0,0) do
  begin
  TranslateMessage(Mesg);
  DispatchMessage(Mesg);
  end;
end.

Файл lib2.dpr

library lib2;
uses
windows, messages;
var
pt : TPoint;
theHook : THandle;
function MouseHook(nCode, wParam, lParam : integer) : Lresult; stdcall;
var
msg : PMouseHookStruct;
w : THandle;
style : integer;
Begin
if nCode<0 then
   begin
   result := CallNextHookEx(theHook, nCode, wParam, lParam);
   Exit;
   end;
msg := PMouseHookStruct(lParam);
case wParam of
WM_MBUTTONDOWN :
   pt := msg^.pt;
WM_MBUTTONUP :
   begin
   w := WindowFromPoint(pt);
   style := GetWindowLong(w, GWL_EXSTYLE);
   if (style and WS_EX_TOPMOST) <> 0 then
     begin //уже поверх всех - сделать обычным
     ShowWindow(w, sw_hide);
     SetWindowPos(w, HWND_NOTOPMOST, 0,0,0,0, SWP_NOMOVE or SWP_NOSIZE OR SWP_SHOWWINDOW);
     end
   else
     begin //сделать поверх остальных
     ShowWindow(w, sw_hide);
     SetWindowPos(w, HWND_TOPMOST, 0,0,0,0, SWP_NOMOVE OR SWP_NOSIZE OR SWP_SHOWWINDOW);
     end;
   end;
end;
Result := CallNextHookEx(theHook, nCode, wParam, lParam);
End;

procedure Start;
begin
theHook := SetWindowsHookEx(wh_mouse, @mouseHook, hInstance, 0);
if theHook = 0 then
   messageBox(0,'Error!','Error!',mb_ok);
end;

procedure Remove;
begin
UnhookWindowsHookEx(theHook);
end;

exports
Start index 1 name 'Start',
Remove index 2 name 'Remove';
end.

Всё.

(С) Автор статьи: Sergey Stolyarov
Development и Дельфи (http://MDelphi.far.ru).

Автор:

StayAtHome

Взято из

Использование HTTP в Delphi

Введение

В связи с все большим вниманием, которое привлекает к себе Интернет, все больше людей становятся заинтересованы в сетевых технологиях. Данная статья посвящена программированию на Borland Delphi с использованием одного из самых популярных Интернет-протоколов - HTTP.
А именно, здесь мы рассмотрим компонент TNMHTTP (NetMasters HTTP), который можно обнаружить на вкладке FastNet палитры компонентов Дельфи.
Начнем с теории. Если Вы уже знаете, что такое HTTP и зачем он нужен, то пропустите следующий раздел.

Зачем нужен HTTP

Итак, где же используется HTTP? Если Вы хотя бы чуть-чуть заглядывали на Интернет-странички и встречались с термином Web, то наверняка обратили внимание на то, что адреса страничек, как правило, начинаются с http://. Протокол HTTP (HyperText Transfer Protocol) позволяет принимать и посылать не только гипертекстовые документы (типа html), но и любые другие (тексты (txt), изображения (gif, jpg), и т.д.). Ниже приведены типовые задачи, для выполнения которых необходимо использовать HTTP:

Браузеры

- программы, позволяющие просматривать Интернет-странички;

Скачивальщики

- программы, позволяющие скачивать из Интернета странички, рисунки и другие документы;

Чаты

- программы, позволяющие общаться по сети. Часто документы HTTP используются для хранения сообщений (как, например, в конференциях).
- Это лишь список некоторых из стандартных направлений программирования с использованием HTTP. Вы можете применять этот протокол для любых своих целей. Например, автоматические системы обновления данных, посылка запросов в Интернетовские базы, и еще множество всяческих других возможностей!

Краткое описание свойств, методов и событий

Ниже приведена таблица, содержащая наиболее краткое описание основных свойств, методов и событий компонента TNMHTTP:

Свойства
Body - строка, содержащая либо путь к файлу, в который будет записано тело http-документа (если св-во InputFileMode равно True), либо непосредственно само тело (если св-во InputFileMode равно False). Тип: string;
Header - строка, содержащая либо путь к файлу, в который будет записан заголовок http-документа (если св-во InputFileMode равно True), либо непосредственно сам заголовок (если св-во InputFileMode равно False). Тип: string;
HeaderInfo - структура, содержащая различную информацию о http-документе (подробней см. в help-файле). Тип: THeaderInfo;
InputFileMode - тип записи результата. Значение True - запись в файлы, указанные в свойствах Body и Header, False - запись в сами эти свойства. Тип: Boolean;
OutputFileMode - тип отсылаемых данных (методами Put, Post и Trace). Значение True - данные для отправки содержатся в файлах, указанных при вызове этих методов, а False - в самих аргументах этих методов. Тип: Boolean;
Далее некоторые свойства, унаследованные от TPowerSock:
BytesRecvd, BytesSent, BytesTotal - количество отправленных, принятых и общее количество байтов соотвественно. Тип: LongInt;
Connected - показывает, установленно ли в данный момент соединение. Тип: Boolean;
BeenCanceled - показывает, было ли прервано соединение с сервером. Тип: Boolean;
Host - строка, содержащая хост-имя удаленного компьютера. Заполнять не надо, так как это свойство устанавливается автоматически при вызове методов Get, Put, Post и т.д. Тип: string. Port - Integer, содержащий порт удаленного компьютера (заполняется тоже автоматически);
TimeOut - таймаут в миллисекундах. Тип: Integer;
Еще есть множество свойств, но я пока остановлюсь на уже перечисленных. За дополнительной информацией обращайтесь к help-у по Дельфи.

Методы
Get(URL: string) - посылает запрос на указанный URL. Данные после выполнения этого запроса записываются в файлы или в сами свойства Body и Header (в зависимости от значения свойства InputFileMode);
Head(URL: string) - посылает запрос на указанный URL. Данные после выполнения этого запроса записываются в файл или в само свойство Header (в зависимости от значения свойства InputFileMode). В отличие от метода Get, при вызове Head запрос отсылается только на заголовок http-документа;
Post(URL, PostData: string) - посылает запрос на изменение http-документа (с адресом URL) на данные, содержащиеся в параметре PostData. Если OutputFileMode равен True, то в PostData должен содержаться путь к файлу, содержащему нужные данные.
Put(URL, PutData: string) - посылает запрос на создание http-документа (с адресом URL), содержащего данные, переданные в параметре PutData. Если OutputFileMode равен True, то в PostData должен содержаться путь к файлу, содержащему нужные данные.
Trace(URL, TraceData: string) - посылает запрос на получение отладочных данных (для отладки соединения с HTTP-сервером). Данные для запроса нужно указать в параметре TraceData. Если OutputFileMode равен True, то в TraceData должен содержаться путь к файлу, содержащему нужные данные.
Delete(URL: string) - посылает запрос на удаление http-документа (с адресом URL).
Далее некоторые методы, унаследованные от TPowerSock:
Abort и Cancel - прерывают соединение и обмен данными;
Disconnect - отсоединение от HTTP-сервера;

События
OnAuthenticationNeeded - возникает, когда сервер требует указания имени пользователя и пароля. В обработчике этого события (если оно возникнет) Вы должны ответить серверу, запонив нужными значениями соответствующие переменные. Примечание: Перед установлением соединения можно сразу заполнить поля UserID и Password в свойстве HeaderInfo;
OnAboutToSend - возникает, когда компонент TNMHTTP собирается отправлять данные (запрос). В обработчике этого события можно заполнить дополнительной информацией свойство SendHeader;
OnFailure - возникает, когда текущая операция завершилась неудачно, т.е. произошла ошибка;
OnRedirect - возникает, сервер переадресовал ссылку с указанной URL на другую ссылку. Установив параметр handled в значение True можно запретить переадресацию и остановиться на запрошенной URL. Значение по умолчанию - False;
OnSuccess - возникает, когда текущая операция завершилась успешно, т.е. запрос был выполнен без ошибок;
Далее некоторые методы, унаследованные от TPowerSock:
OnConnect - возникает, когда соединение с сервером успешно установлено;
OnDisconnect - возникает, когда соединение с сервером завершено;
OnConnectionFailed - возникает, когда соединение с сервером установить не удалось;
OnError - возникает, когда последняя операция была завершена с ошибкой;
OnHostResolved - возникает, когда от DNS получен IP-адрес указанного хоста;
OnInvalidHost - возникает, когда DNS вернул ошибку при попытке определить IP-адрес указанного хоста;
OnPacketRecvd - возникает, когда значения свойств BytesRecvd и BytesTotal изменены, т.е. была принята новая порция данных от сервера;
OnPacketSent - возникает, когда значения свойств BytesSent и BytesTotal изменены, т.е. была отправлена новая порция данных на сервер;
OnStatus - возникает, когда статус компонента был изменен (для обновления визуального оповещения пользователя);

Практика и примеры

Ну а теперь приступим к самому главному методу изучения - на примерах. Сразу замечу, что все приведенные здесь примеры можно скачать в полностью сделанных исходниках, щелкнув здесь.
И самый первый пример - программа, позволяющая определить, существует ли заданный URL:

Пример 1. Проверка существования указанной URL

{... Здесь идет заголовок файла и определение формы TForm1 и ее экземпляра Form1}

{В форму нужно поместить кнопку TButton и одно поле TEdit. При нажатии на кнопку вызывается обработчик события OnClick - Button1Click. Перед этим в TEdit нужно ввести адрес URL.
НЕ ЗАБУДЬТЕ ПОМЕСТИТЬ В ФОРМУ КОМПОНЕНТ TNMHTTP!}
procedure Button1Click(Sender: TObject);
begin
  {Пытаемя получить заголовок}
  NMHTTP1.Head(Edit1.Text);
  {Если URL неверный, то здесь выскочит ошибка}
end;

Пример 2. Скачивание указанной URL в заданный файл

{...Здесь идет заголовок файла и определение формы TForm1 и ее экземпляра Form1}

{В форму нужно поместить кнопку TButton и три поля TEdit. При нажатии на кнопку вызывается обработчик события OnClick - Button1Click. Перед этим в первый TEdit нужно ввести адрес URL, во второй - имя файла для заголовка, а в третий - имя файла для тела странички (html).
НЕ ЗАБУДЬТЕ ПОМЕСТИТЬ В ФОРМУ КОМПОНЕНТ TNMHTTP!}
procedure Button1Click(Sender: TObject);
begin
  {Пытаемся получить http-документ}
  {Результат надо записать в файлы}
  NMHTTP1.InputFileMode := True;
  {А здесь указываем в какие именно файлы}
  NMHTTP1.Header := Edit2.Text;
  NMHTTP1.Body := Edit3.Text;
  NMHTTP1.Get(Edit1.Text);
end;

Пример 3. Одновременное скачивание указанных URL в заданный каталог

{... Здесь идет заголовок файла и определение формы TForm1 и ее экземпляра Form1}

{Описание класса отдельного процесса}
type
  THTTPThread = class(TThread)
  private
     {Для каждого процесса - создаем свой компонент TNMHTTP}
    FHTTP: TNMHTTP;
  protected
{Execute вызывается при запуске процесса; override - заменяем существующую процедуру базового класса TThread}
    procedure Execute; override;
{DoWork - созданная нами функция, выполнение которой синхронизируется в Execute}
    procedure DoWork;
  public
{URL - созданная нами строка, указывающая процессу, какой URL ему нужно скачать}
    URL: string;
  end;

{В форму нужно поместить три кнопки TButton, одно поле TEdit и один список TListBox. При нажатии на кнопку Button1 вызывается обработчик события OnClick - Button1Click. Перед этим в TEdit нужно ввести путь к каталогу, в котором будут храниться скачанные файлы, а ListBox1 нужно заполнить списком URL-ов для скачивания (с помощью кнопок Add (Button2) и Delete (Button3)).}
procedure TForm1.Button3Click(Sender: TObject);
begin
  {Удаление выделенного URL из списка}
  if ListBox1.ItemIndex >= 0 then
    ListBox1.Items.Delete(ListBox1.ItemIndex);
end;

procedure TForm1.Button2Click(Sender: TObject);
  var s: string;
begin
  {Добавление URL в список}
  s := InputBox('Добавить','Введите URL:','');
  if s <> '' then
    ListBox1.Items.Add(s);
end;

procedure TForm1.Button1Click(Sender: TObject);
  var i: Integer;
begin
  {Проверка на существование каталога}
  if Length(Edit1.Text) > 0 then
    if not DirectoryExists(Edit1.Text) then
      MkDir(Edit1.Text);
  {Далее идет создание для каждого URL в списке своего процесса}
  for i := 0 to ListBox1.Items.Count-1 do begin
    with THTTPThread.Create(True) do begin
      {Создаем приостановленную задачу, указываем ей ее URL и запускаем ее}
      URL := ListBox1.Items[i];
      Resume;
    end;
  end;
end;

  {Операторы процесса THTTPThread}

procedure THTTPThread.Execute;
begin
  {Делаем так, чтобы каждый процесс выполнялся одновременно с другими (синхронизация)}
  Synchronize(DoWork);
end;

procedure THTTPThread.DoWork;
  var i: Integer;
begin
  {Создаем компонент TNMHTTP}
  FHTTP := TNMHTTP.Create(Form1);
  {Результат надо записывать в файлы}
  FHTTP.InputFileMode := True;
  {Подбираем имена для файлов}
  i := 1;
  while FileExists(Form1.Edit1.Text+'\page'+IntToStr(i)+'.htm') do
    Inc(i);
  {Указываем, в какие именно файлы класть результат}
  FHTTP.Body := Form1.Edit1.Text+'\body'+IntToStr(i)+'.htm';
  FHTTP.Header := Form1.Edit1.Text+'\header'+IntToStr(i)+'.txt';
  {Пытаемся послать запрос}
  FHTTP.Get(URL);
  {Перед завершением процесса не забываем освободить память из-под компонента}
  FHTTP.Free;
end;

Замечания по алгоритмам типовых задач

Если Вы собираетесь создать скачивалку сайтов, то Вам необходимо учитывать следующее (решить следующие проблемы):
·Нужно скачивать не только саму страничку в формате HTML, но и все входящие в нее рисунки (gif, jpg, и т.д.);
·в некоторых случаях удобно скачивать не одну страничку, а несколько страниц, ссылки на которые находятся на первой из скачиваемых страничек. При этом нужно учитывать, что на страничке могут находиться и ссылки на другие сайты, поэтому необходимо анализировать скачиваемые ссылки (чтобы случайно не скачать весь Интернет). Для решения задачи со скачиванием нескольких страничек нужно использовать рекурсию;
·необходимо качественно информировать пользователя о ходе закачки. Т.е. показывать общее и скачанное количество информации;
·после скачивания нужно заменить Интернетовские ссылки на локальные, чтобы можно было просматривать странички в режиме offline.
·

Эпилог

В этой статье отображены основные приемы работы с компонентом TNMHTTP в Дельфи. Если у Вас есть вопросы - скидывайте их мне на E-mail: snick@mailru.com, а еще лучше - пишите в конференции этого сайта (Delphi. Общие вопросы), чтобы и другие пользователи смогли увидеть Ваш вопрос и попытаться на него ответить!
Замечу, что TNMHTTP - не единственный компонент, релизующий доступ по протоколу HTTP. Есть и его аналоги с более расширенными возможностями, например, набор компонентов ICS (Internet Component Suite), в состав которого входит даже компонент FTPServer, позволяющий легко запрограммировать свой собственный сервер FTP для Windows. Этот набор можно скачать на сайте Delphi Super Page.
Карих Николай. Московская область, г.Жуковский

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

Использование классовых методов для выявления утечек памяти

Class Methods aply to the class level, in other words you donґt need an instance to call the method

I wish we could define class objects as well, but they doesnґt exist in Object Pascal, so we will do a trick, we are going to define a variable in the implementation section of the unit, this variable will hold the number of instances the class will have in a moment in time. Object Oriented purist might claim about it, but it works, nobody is perfect (not even Delphi!).

For example say you need to create instances of a class named TFoo, so you create the following Unit.

We will define two class procedures: AddInstance(to increse the counter of instances) and ReleaseInstance(to decrese the number of instances), these are called in the constructor and the destructor acordingly. Finally we define a class function NumOfInstances which returns the actual number of instances.

Add a Initilialization and a Finalization section to the Unit, in the Finalization section ask if the number of instances is <> 0, if this is the case you known that you didinґt destroy all the objects that you created.

unitU_Foo;

interface

uses
  Classes, Windows, SysUtils;

type
  TFoo = class
  private
    class procedure AddInstance;
    class procedure ReleaseInstance;
  public
    constructor Create;
    destructor Destroy; override;
    class function NumOfInstances: Integer;
  end;

implementation

var
  TFoo_Instances: Integer = 0;

  { TFoo }

class procedure TFoo.AddInstance;
begin
  Inc(TFoo_Instances);
end; //end of TFoo.AddInstance

constructor TFoo.Create;
begin
  AddInstance;
end; //end of TFoo.Create

destructor TFoo.Destroy;
begin
  ReleaseInstance;
  inherited;
end; //end of TFoo.Destroy

class function TFoo.NumOfInstances: Integer;
begin
  Result := TFoo_Instances;
end; //end of TFoo.NumOfInstances

class procedure TFoo.ReleaseInstance;
begin
  Dec(TFoo_Instances);
end; //end of TFoo.ReleaseInstance

initialization

finalization

  if TFoo_Instances <> 0 then
    MessageBox(0,
      PChar(Format('%d instances of TFoo active', [TFoo_Instances])),
      'Warning', MB_OK or MB_ICONWARNING);

end.

Взято с

Delphi Knowledge Base

Использование компонента TServerSocket

Автор: Brian Pedersen

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

Совместимость: Delphi 3.x (или выше)

Вообще-то, создать многопотоковый сервер, который ожидает пришедшие сообщения на сокете довольно просто. В Delphi для этой цели достаточно использовать компонент TServerSocket.

Давайте рассмотрим структуру работы данного компонента:

- Добавляем TServerSocket в Вашу основную форму.
- Устанавливаем свойство Servertype в stThreadBlocking
- Создаём новый "unit" (показанный ниже) содержащий поток сервера.

Устанавливаем следующий код на OnSocketGetThread

procedure TfrmMain.fSocketGetThread(Sender: TObject;
  ClientSocket: TServerClientWinSocket;
  var SocketThread: TServerClientThread);
begin
  // Здесь создаём объект TServerThread, который я привожу ниже.
  // Новый объект создаётся каждый раз, когда когда установлен канал связи.
  SocketThread := TServerThread.Create( FALSE, ClientSocket );
end;

TServerThread - это объект, который я создаю самостоятельно. Объект наследуется от TServerClientThread и содержит код, который обычно читает и пишет данные из/в сокет.

Созданный "unit", содержит следующий код:

unit serverthread;

interface

uses
  windows, scktcomp, SysUtils, Classes, Forms;

type
  EServerThread = class( Exception );
  // serverthread это потомок TServerClientThread
  TServerThread = class( TServerClientThread )
    private
      fSocketStream : TWinSocketStream;
    public
      procedure ClientExecute; override;
      // ClientExecute отменяет
      // TServerClientThread.ClientExecute
      // и содержит код, который
      // выполняется при старте потока
  end;

implementation

procedure TServerThread.ClientExecute;
begin
  inherited FreeOnTerminate := TRUE;
  try
    fSocketStream := TWinSocketStream.Create( ClientSocket,
                                              100000 );
    // 100000 - это таймаут в миллисекундах.
    try
      while ( not Terminated ) and ( ClientSocket.Connected ) do
      try
        // В это место обычно помещается код,
        // ожидающий входных данных, читающий из сокета или пишущий в него
        // Пример, приведённый ниже, показывает, что можно добавить в данную
        // секцию программы.
      except on e:exception do
        begin
          // Если произошла ошибка, то закрываем сокет и выходим
          ClientSocket.Close;
          Terminate;
        end;
      end;
    finally
      fSocketStream.Free;
    end;
  except on e:exception do
    begin
      // Если произошла ошибка, то закрываем сокет и выходим
      ClientSocket.Close;
      Terminate;
    end;
  end;
end;

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

if ( not Terminated ) and
   ( not fSocketStream.WaitForData( 1000000 ) ) then
begin
  // Обработчик таймаута (т.е. если по истечении 1000000 миллисекунд
  // от клиента не пришло запроса
end;
// В сокете есть входящие данные!

Для чтения данных, Вам понадобится создать буфер для хранения полученных данных. Обычно буфер - это PByteArray или массив символов. В этом примере я обозвал буфер как fRequest который является массивом символов. Кроме того я ожидаю фиксированное количество байт. Массив имеет постоянный размер REQUESTSIZE.

var
  ac, readlen : integer;
begin
  FillChar( fRequest, REQUESTSIZE, 0 );
  ac := 0;
  repeat
    readlen := fSocketStream.Read( fRequest[ac],
                                   1024 );
    // считываем блоки по 1024 байт, до тех пор, пока буфер
    // не заполнится
    ac := ac+readlen;
  until ( readlen = 0 ) or ( ac = REQUESTSIZE );
end;

Если readlen равно 0, значит больше нет входящих данных. Функция Чтения завершается через 100000 миллисекунд после запуска в TWinSocketStream.Create(). Если Вы не знаете сколько времени нужно ожидать запроса от клиента, то чем меньше будет таймаут, тем лучше. В большинстве случаев максимальный таймаут не должен превышать 30 секунд.

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

fSocketStream.WriteBuffer( fRep, fReplySize );

fRep это буфер, содержащий ответ на запрос клиента, и fReplySize - это размер буфера.

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

Использование компонентов Decision Support System при генерации отчетов в QuickReport

Возможно ли использование компонентов Decision Support System при генерации отчетов в QuickReport и, если да, то каким образом? Если QuickReport не подходит для этих целей, то какие другие варианты вы можете посоветовать?

Самый простой способ - использовать компоненты TQRLabel, текст в которых динамически меняется во время печати (то есть способ, которым можно напечатать все, что угодно, написав при этом немного кода). В принципе можно записать двухмерное сечение куба во временную таблицу или в компонент TClientDataSet, написав соответствующий цикл, и сделать отчет на ее основе.

Использование DecisionQuery в качестве источника данных для отчета также вполне возможно.

Другие возможные варианты - это использование автоматизации Word или Excel либо вычисление сумм внутри отчета. Можно также использовать другие генераторы отчетов - например, с помощью Crystal Reports можно создавать отчеты, содержащие кросс-таблицы.

Наталия Елманова
Взято с Исходников.ru

Использование ловушек, блокировка мышки, клавиатуры и т.д.

Возможные вариации: Любые вопросы, связанные с постановкой хука. Например "Как отследить [что-то]", "Как подменить [какое-то действие]", "Как заблокировать комбинации клавиш, как заблокировать определённые действия", "Как не дать запускаться определённым приложениям, не дать открываться определённым окнам?", "Как получить список запущенных оконных приложений?" и т.д.

Рабочий пример глобальной блокировки правой кнопки мыши:
DLL:

library Project2;
Uses Windows,Messages;
Var SysHook:HHook=0;

Function SysMsgProc(Code:Integer; WParam:LongInt; LParam:LongInt):LongInt; stdcall;
Var Msg:TMessage;
Begin
IF Code=HC_ACTION then
  Case TMsg(Pointer(LParam)^).Message OF
   WM_RBUTTONDOWN,WM_RBUTTONUP,WM_RBUTTONDBLCLK: TMsg(Pointer(LParam)^).Message:=WM_NULL
   else Result:=CallNextHookEx(SysHook,Code,WParam,LParam);
  End;
end;

procedure Hook(Flag:Boolean); export; stdcall;
Begin
IF Flag then SysHook:=SetWindowsHookEx(WH_GETMESSAGE,@SysMsgProc,HInstance,0) Else
  Begin
   UnhookWindowsHookEx(SysHook);
   SysHook:=0;
  End;
End;

exports Hook;

{$R *.res}

begin
end.

----------------------------
Project:

unit Unit1;

interface

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

type
  MyProcType = procedure (Flag: Boolean); stdcall;

type
  TForm1 = class(TForm)
    Button1: TButton;
    Button2: TButton;
    procedure FormMouseDown(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
    procedure Button1Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;
  HDLL:HWND;

implementation

{$R *.dfm}

procedure TForm1.FormMouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
IF Button=mbRight then ShowMessage('Right mouse key pressed');
end;

procedure TForm1.Button1Click(Sender: TObject);
Var Hook: MyProcType;
Begin
@Hook:=nil;
HDLL:=LoadLibrary(PChar('project2.dll'));
IF HDLL>HINSTANCE_ERROR then
  Begin
   @Hook:=GetProcAddress(HDLL,'Hook');
   Hook(True);
  End else MessageDlg('Ошибка загрузки DLL.',mtError,[mbIgnore],0);
end;

procedure TForm1.Button2Click(Sender: TObject);
Var Hook: MyProcType;
Begin
@Hook:=nil;
IF HDLL>HINSTANCE_ERROR then
  Begin
   @Hook:=GetProcAddress(HDLL,'Hook');
   Hook(False);
  End;
End;

procedure TForm1.FormDestroy(Sender: TObject);
begin
Button2.Click;
end;

end.

Файлы для демонстрации можно взять здесь: http://coolsong.narod.ru/hook.rar
Работает так: при неустановленном хуке правая кнопка работает (о чём свидетельствует нажатие правой кнопки мыши - событие TForm.onMouseDown и сообщение). После установки хука кнопкой "Install", события от мыши перестают обрабатываться (сообщение "Right mouse key pressed" не выдаётся). после снятия хука (кнопка "Remove") - всё возвращается к первоначальному состоянию.

Если требуется перехватывать клавиши, тогда из вышеобозначенной теории нам известны варианты: WH_KEYBOARD, WH_KEYBOARD_LL или WH_GETMESSAGE+WM_CHAR/WM_KEYDOWN/UP
Однако, если требуется перехватить всего лишь отдельную клавишу, будь то одну либо с нажатым Ctrl, Alt, Shift, рациональней для этого воспользоваться назначением горячей клавиши, через RegisterHotKey().
Рабочий пример такого приёма:

type
  TForm1 = class(TForm)
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
  protected
    procedure hotykey(var msg: TMessage); message WM_HOTKEY;
  end;

var
  Form1: TForm1;
  id, id2: Integer;

implementation

{$R *.DFM}

procedure TForm1.hotykey(var msg: TMessage);
begin
  if (msg.LParamLo = MOD_CONTROL) and (msg.LParamHi = 81) then
    begin
      ShowMessage('Ctrl + Q wurde gedrьckt !');
    end;

  if (msg.LParamLo = MOD_CONTROL) and (msg.LParamHi = 82) then
    begin
      ShowMessage('Ctrl + R wurde gedrьckt !');
    end;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
  id := GlobalAddAtom('hotkey');
  RegisterHotKey(handle, id, mod_control, 81);

  id2 := GlobalAddAtom('hotkey2');
  RegisterHotKey(handle, id2, mod_control, 82);
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
  UnRegisterHotKey(handle, id);
  UnRegisterHotKey(handle, id2);
end;

Блокировка клавиатуры/мыши.

Родственная тема, поэтому помещена в этот же вопрос.

Итак, заблокировать можно хуком. Но в некоторых случаях можно обойтись и "малой кровью".
Вы можете использовать ф-ию BlockInput. Она живёт в user32.dll Также она блокирует одновременно и мышь.

Procedure BlockInput(ABlockInput : Boolean); stdcall; external 'USER32.DLL';

BlockInput(True); - заблокировать

BlockInput(False); - разблокировать

Однако имейте ввиду, что BlockInput() не заблокирует CAD. Кроме того, её работа блокируется по нажатию трёх пальцев.Для блокировки CAD в w9x, мы можем использовать режим скринсэйвера, в NT, увы никак.
Ф-ия BlockInput() явилась продолжением ф-ии EnableHardwareInput(), которая как мы знаем использовалась в 16-разрядных приложениях.
Кроме того, для блокировки, мы можем использовать некоторые недокументированные возможности, однако их недастаток в том, что обратно клавиатуру/мышь уже включить нельзя:

"rundll32 keyboard,disable" - заблокироовать клавиатуру
"rundll32 mouse,disable" - заблокировать мышь

Запустить эти команды мы можем самое простое через ShellExecute() или WinExec():
ShellExecute(Application.Handle,'open','C:\Windows\Rundll32.exe',
'команда','C:\Windows',SW_HIDE);

Автор Song

Использование многомерного массива

typeRecType = integer; {<-- здесь задается тип элементов массива}

const MaxRecItem = 65520 div sizeof(RecType);

type = MyArrayType = array[0..MaxRecItem] of RecType;
type = MyArrayTypePtr = ^MyArrayType;

var MyArray: MyArrayTypePtr;
begin
  ItemCnt := 10; {количество элементов массива, которые необходимо распределить}
  GetMem(MyArray, ItemCnt * sizeof(MyArray[1])); {распределение массива}
  MyArray^[3] := 10; {доступ к массиву}
  FreeMem(MyArray, ItemCnt * sizeof(MyArray[1])); {освобождаем массив после работы с ним}
end;

- Michael Day

Взято из

Советов по Delphi от

Сборник Kuliba

Использование нумерации в TFields

Я хочу хранить журнал транзакций в таблице Paradox и хотел бы писать и читать коды транзаций вместо простых целых чисел, которые они представляют в данный момент...

Можете попробовать сделать так:

typeTcodes = (c1,c2,c3,c4);

var code: Tcodes;

code := Tcodes(Table1Field1.AsInteger);
if code in [c2,c4] then .....
Table1Field1.AsInteger := Integer(code);

Взято из

Использование обработчика OnHint при наличии нескольких форм

В Online Help и в Visual Component Library Reference описан пример обработчика
события OnHint объекта TApplication. Пример показывает, как можно использовать
панель для отображения подсказок (hint), связанных с другими компонентами. В
примере обработчик OnHint устанавливается во время обработки события OnCreate
для формы; в программе, включающей более чем одну форму, будет трудно
использовать эту технику.

Перемещение присваивания обработчика OnHint из события OnCreate формы в
событие OnActivate позволит различным формам данного приложения работать с
подсказками, как им нужно.

Ниже приведен измененный пример из OnLine Help и VCL Reference.

type
  TForm1 = class(TForm)
    Button1: TButton;
    Panel1: TPanel;
    Edit1: TEdit;
    procedure FormActivate(Sender: TObject);
  private
    { Private declarations }
  public
    procedure DisplayHint(Sender: TObject);
  end;

implementation

{$R *.DFM}

procedure TForm1.DisplayHint(Sender: TObject);
begin
  Panel1.Caption := Application.Hint;
end;

procedure TForm1.FormActivate(Sender: TObject);
begin
  Application.OnHint := DisplayHint;
end;

Источник:

Использование открытых интерфейсов

Одной и наиболее сильных сторон среды программирования Delphi является ее открытая архитектура, благодаря которой Delphi допускает своего рода метапрограммирование, позволяя "программировать среду программирования". Такой подход переводит Delphi на качественно новый уровень систем разработки приложений и позволяет встраивать в этот продукт дополнительные инструментальные средства, поддерживающие практически все этапы создания прикладных систем. Столь широкий спектр возможностей открывается благодаря реализованной в Delphi концепции так называемых открытых интерфейсов, являющихся связующим звеном между IDE (Integrated Development Environment) и внешними инструментами. Данная статья посвящена открытым интерфейсам Delphi и представляет собой обзор представляемых ими возможностей.

В Delphi определены шесть открытых интерфейсов: Tool Interface, Design Interface, Expert Interface, File Interface, Edit Interface и Version Control Interface. Вряд ли в рамках данной статьи нам удалось бы детально осветить и проиллюстрировать возможности каждого из них. Более основательно разобраться в рассматриваемых вопросах вам помогут исходные тексты Delphi, благо разработчики снабдили их развернутыми комментариями. Объявления классов, представляющих открытые интерфейсы, содержатся в соответствующих модулях в каталоге ...\Delphi\Source\ToolsAPI.

Design Interface (модуль DsgnIntf.pas)
предоставляет средства для создания редакторов свойств и редакторов компонентов. Редакторы свойств и компонентов ? это тема, достойная отдельного разговора, поэтому напомним лишь, что редактор свойства контролирует поведение Инспектора Объектов при попытке изменить значение соответствующего свойства, а редактор компонента активизируется при двойном нажатии левой кнопки мыши на изображении помещенного на форму компонента.
Version Control Interface (модуль VCSIntf.pas)
предназначен для создания систем контроля версий. Начиная с версии 2.0, Delphi поддерживает интегрированную систему контроля версий Intersolv PVCS, поэтому в большинстве случаев в разработке собственной системы нет необходимости. По этой причине рассмотрение Version Control Interface мы также опустим.
File Interface (модуль FileIntf.pas)
позволяет переопределить рабочую файловую систему IDE, что дает возможность выбора собственного способа хранения файлов (в Memo-полях на сервере БД, например).
Edit Interface (модуль EditIntf.pas)
предоставляет доступ к буферу исходных текстов, что позволяет проводить анализ кода и выполнять его генерацию, определять и изменять позицию курсора в окне редактора кода, а также управлять синтаксическим выделением исходного текста. Специальные классы предоставляют интерфейсы к помещенным на форму компонентам (определение типа компонента, получение ссылок на родительский и дочерние компоненты, доступ к свойствам, передача фокуса, удаление и т.д.), к самой форме и к ресурсному файлу проекта. Также Edit Interface позволяет идентифицировать так называемые модульные нотификаторы, определяющие реакцию на такие события, как изменение исходного текста модуля, модификация формы, переименование компонента, сохранение, переименование или удаление модуля, изменение ресурсного файла проекта и т. д.
Tool Interface (модуль ToolIntf.pas)
предоставляет разработчикам средства для получения общей информации о состоянии IDE и выполнения таких действий, как открытие, сохранение и закрытие проектов и отдельных файлов, создание модуля, получение информации о текущем проекте (число модулей и форм, их имена и т. д.), регистрация файловой системы, организация интерфейсов к отдельным модулям и т.д. В дополнение к модульным нотификаторам Tool Interface определяет add-in нотификаторы, уведомляющие о таких событиях, как открытие/закрытие файлов и проектов, загрузка и сохранение desktop-файла проекта, добавление/исключение модулей проекта, инсталляция/деинсталляция пакетов, компиляция проекта, причем в отличие от модульных нотификаторов add-in нотификаторы позволяют отменить выполнение некоторых событий. Кроме того, Tool Interface предоставляет средства доступа к главному меню IDE Delphi, позволяя встраивать в него дополнительные пункты.
Expert Interface (модуль ExptIntf.pas)
представляет собой основу для создания экспертов ? программных модулей, встраиваемых в IDE c целью расширения ее функциональности. В качестве примера эксперта можно привести входящий в Delphi Database Form Wizard, выполняющий генерацию формы для просмотра и изменения содержимого таблицы БД.
Эксперты бывают нескольких типов (стилей):

Стиль Описание
esStandard Для каждого эксперта такого стиля IDE добавляет пункт меню Tools/..., при выборе которого эксперт активизируется (IDE вызывает его метод Execute)
esForm
esProject IDE рассматривает эксперты данного стиля как шаблоны форм/проектов и помещает активизирующие их изображения в галерею Object Repository.
esAddIn Эксперты подобного стиля обеспечивают собственный интерфейс с IDE

Класс каждого эксперта является потомком базового класса TIExpert, содержащего серию абстрактных методов, которые необходимо перекрыть в порождаемом классе:

Метод Описание
GetName Должен возвращать имя эксперта
GetAuthor Должен возвращать имя автора эксперта. Это имя отображается в Object Repository
GetComment Должен возвращать комментарий (1-2 предложения), поясняющий назначение эксперта. Используется в Object Repository
GetPage Должен возвращать название страницы Object Repository, на которую IDE поместит соответствующее эксперту изображение
GetGlyph Должен возвращать дескриптор (HICON, в Delphi 1.0 ? HBITMAP) соответствующего эксперту изображения в ObjectRepository
GetStyle Должен возвращать константу, соответствующую стилю эксперта (esStandard/esForm/esProject/esAddIn)
GetState Если возвращаемое множество содержит константу esChecked, IDE пометит соответствующий эксперту пункт меню "галочкой", а если множество содержит константу esEnabled, то IDE сделает этот пункт меню доступным для выбора
GetIDString Должен возвращать строку ? идентификатор эксперта, уникальную среди всех установленных экспертов. По соглашению, формат этой строки таков:
Имя_Компании.Назначение_эксперта,
например: Borland.WidgetExpert
GetMenuText Должен возвращать текст, отображаемый в пункте меню эксперта. Этот метод вызывается каждый раз, когда раскрывается родительское меню, что позволяет сделать пункт меню контекстно-чувствительным
Execute Вызывается при вызове эксперта через меню или Object Repository (в зависимости от стиля)

Набор методов, подлежащих перекрытию, зависит от стиля эксперта:

Метод esStandard esForm esProject esAddIn
GetName + + + +
GetAuthor + +
GetComment + +
GetPage + +
GetGlyph + +
GetStyle + + + +
GetState +
GetIDString + + + +
GetMenuText +
Execute + + +

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

В качестве иллюстрации создадим простой эксперт в стиле esStandard, который при выборе соответствующего ему пункта меню Delphi выводит сообщение о том, что он запущен. Как видно из вышеприведенной таблицы, стиль esStandard обязывает перекрыть шесть методов:

unitexmpl_01;

{ STANDARD EXPERT }

interface

uses
  Dialogs, ExptIntf;

type
  { класс эксперта является потомком базового класса TIExpert }
  TEMyExpert = class( TIExpert)
    function GetName: string; override;
    function GetStyle: TExpertStyle; override;
    function GetIDString: string; override;
    function GetMenuText: string; override;
    function GetState: TExpertState; override;
    procedure Execute; override;
end;

procedure register;

implementation

{ возвращаем имя эксперта }
function TEMyExpert.GetName: string;
begin
  Result := 'My Simple Expert 1';
end;

{ возвращаем стиль эксперта }
function TEMyExpert.GetStyle: TExpertStyle;
begin
  Result := esStandard;
end;

{ возвращаем строку - идентификатор эксперта }
function TEMyExpert.GetIDString: string;
begin
  Result := 'Doomy.SimpleAddInExpert_1';
end;

{ возвращаем текст пункта меню }
function TEMyExpert.GetMenuText: string;
begin
  Result := 'Simple Expert 1';
end;

{ возвращаем множество, характеризующее состояние пункта меню эксперта }
{ (доступность, наличие "галочки"); в данном случае пункт меню доступен, }
{ а "галочка" отсутствует }
function TEMyExpert.GetState: TExpertState;
begin
  Result := [esEnabled];
end;

{ при выборе пункта меню эксперта отображаем сообщение }
procedure TEMyExpert.Execute;
begin
  MessageDlg('Standard Expert Started!', mtInformation, [mbOK], 0);
end;

{ регистрируем эксперт }
procedure register;
begin
  RegisterLibraryExpert( TEMyExpert.Create);
end;

end.

Для того чтобы эксперт был "приведен в действие", необходимо выбрать пункт меню Component/Install Component ... , выбрать в диалоге Browse модуль, содержащий эксперт (в нашем случае exmpl_01.pas), нажать ОК, и после компиляции пакета dclusr30.dpk в главном меню Delphi в разделе Help должен появиться пункт Simple Expert 1, при выборе которого появляется информационное сообщение "Standard Expert started!".

Почему Delphi помещает пункт меню эксперта в раздел Help, остается загадкой. Если вам не нравится то, что пункт меню появляется там, где угодно Delphi, а не там, где хотите вы, возможен следующий вариант: создать эксперт в стиле add-in, что исключает автоматическое создание пункта меню, а пункт меню добавить "вручную", используя средства Tool Interface. Это позволит задать местоположение нового пункта в главном меню произвольным образом. Для добавления пункта меню используется класс TIToolServices ? основа Tool Interface ? и классы TIMainMenuIntf, TIMenuItemIntf, реализующие интерфейсы к главному меню IDE и его пунктам. Экземпляр ToolServices класса TIToolServices создается самой IDE при ее инициализации. Обратите внимание на то, что ответственность за освобождение интерфейсов к главному меню Delphi и его пунктам целиком ложится на разработчика. Попутно немного усложним функциональную нагрузку эксперта: при активизации своего пункта меню он будет выдавать справку об имени проекта, открытого в данный момент в среде:

unit exmpl_02;

{ ADD-IN EXPERT, ДОБАВЛЕНИЕ ПУНКТА В ГЛАВНОЕ МЕНЮ IDE DELPHI }
interface

uses
  Classes, Dialogs, ToolIntF, ExptIntf, Menus;

type
  { класс эксперта является потомком базового класса TIExpert }
  TEMyExpert = class( TIExpert)
  private
    MenuItem: TIMenuItemIntf;
  public
    constructor Create;
    destructor Destroy; override;
    function GetName: string; override;
    function GetStyle: TExpertStyle; override;
    function GetIDString: string; override;
    procedure MenuItemClick( Sender: TIMenuItemIntf);
end;

procedure register;

function AddIDEMenuItem( const Caption, name, PreviousItemName: string;
const ShortCutKey: Char; OnClick: TIMenuClickEvent): TIMenuItemIntf;

implementation

{ добавляем пункт в главное меню IDE Delphi: }
{ 1) текст вставляемого пункта меню - 'Simple Expert 2'; }
{ 2) идентификатор вставляемого пункта меню - 'ViewMyExpertItem2'; }
{ 3) идентификатор пункта меню, перед которым добавляется новый }
{ пункт меню - 'ViewWatchItem' (для Delphi 5 - 'ViewWatchesItem');}
{ 4) горячая клавиша вставляемого пункта - 'Ctrl + 2'; }
{ 5) обработчик события, соответствующего выбору вставляемого пункта }
{ меню - MenuItemClick }
constructor TEMyExpert.Create;
begin
  inherited Create;
  MenuItem:= AddIDEMenuItem( 'Simple Expert 2', 'ViewMyExpertItem2',
  {$IFDEF VER130}
  'ViewWatchesItem', '2', MenuItemClick);
  {$ELSE}
  'ViewWatchItem', '2', MenuItemClick);
  {$ENDIF}
end;

destructor TEMyExpert.Destroy;
begin
  if Assigned( MenuItem) then
    MenuItem.Free;
  inherited Destroy;
end;

{ при выборе пункта меню эксперта отображаем сообщение, содержащее }
{ имя активного проекта }
procedure TEMyExpert.MenuItemClick( Sender: TIMenuItemIntf);
begin
  MessageDlg( 'Current project name is ' + ToolServices.GetProjectName,
  mtInformation, [mbOK], 0);
end;

{ возвращаем имя эксперта }
function TEMyExpert.GetName: string;
begin
  Result := 'My Simple Expert 2';
end;

{ возвращаем стиль эксперта }
function TEMyExpert.GetStyle: TExpertStyle;
begin
  Result := esAddIn;
end;

{ возвращаем строку - идентификатор эксперта }
function TEMyExpert.GetIDString: string;
begin
  Result := 'Doomy.SimpleAddInExpert_2';
end;

function AddIDEMenuItem( const Caption, name, PreviousItemName: string;
const ShortCutKey: Char; OnClick: TIMenuClickEvent): TIMenuItemIntf;
var
  MainMenu: TIMainMenuIntf;
  MenuItems, PreviousItem, ParentItem: TIMenuItemIntf;
begin
  Result:= nil;
  { получаем интерфейс пунктов главного меню IDE }
  MainMenu:= ToolServices.GetMainMenu;
  if Assigned( MainMenu) then
    try
      { получаем интерфейс пунктов верхнего уровня меню }
      MenuItems:= MainMenu.GetMenuItems;
      if Assigned( MenuItems) then
        try
          { ищем пункт меню перед которым необходимо вставить новый пункт }
          PreviousItem:= MainMenu.FindMenuItem( PreviousItemName);
          if Assigned( PreviousItem) then
            try
              { получаем интерфейс к родительскому пункту меню }
              ParentItem:= PreviousItem.GetParent;
              if Assigned( ParentItem) then
                try
                  { вставляем новый пункт меню и в качестве результата функции }
                  { возвращаем его интерфейс }
                  Result:= ParentItem.InsertItem( PreviousItem.GetIndex, Caption,
                  name, '', ShortCut( Word( ShortCutKey), [ssCtrl]), 0, 0,
                  [mfVisible, mfEnabled], OnClick);
                finally
                  { освобождаем интерфейс родительского пункта меню }
                  ParentItem.Free;
                end;
            finally
              { освобождаем интерфейс пункта меню перед которым вставили }
              { новый пункт }
              PreviousItem.Free;
            end;
        finally
          { освобождаем интерфейс пунктов верхнего уровня меню }
          MenuItems.Free;
        end;
    finally
      { освобождаем интерфейс главного меню IDE }
      MainMenu.Free;
    end;
end;

procedure register;
begin
  { регистрируем эксперт }
  RegisterLibraryExpert( TEMyExpert.Create);
end;

end.

В этом примере центральное место занимает функция AddIDEMenuItem, осуществляющая добавление пункта меню в главное меню IDE Delphi. В качестве параметров ей передаются текст нового пункта меню, его идентификатор, идентификатор пункта, перед которым вставляется новый пункт, символьное представление клавиши, которая вместе с клавишей Ctrl может использоваться для быстрого доступа к новому пункту, и обработчик события, соответствующего выбору нового пункта. Мы добавили новый пункт меню в раздел View перед пунктом Watches.

Теперь познакомимся с нотификаторами. Определим add-in нотификатор, отслеживающий моменты закрытия/открытия проектов и корректирующий соответствующим образом поле, хранящее имя активного проекта (реализацию методов, не претерпевших изменений по сравнению с предыдущим примером, для краткости опустим):

unit exmpl_03;

{ ИСПОЛЬЗОВАНИЕ ADD-IN НОТИФИКАТОРОВ }
interface

uses
  Classes, Dialogs, ToolIntF, ExptIntf, Menus;

type
  TEMyExpert = class;

  { касс add-in нотификатора порождаем от TIAddInNotifier}
  TAddInNotifier = class(TIAddInNotifier)
  private
    Expert: TEMyExpert;
  public
    constructor Create( anExpert: TEMyExpert);
    procedure FileNotification( NotifyCode: TFileNotification;
    const FileName: string; var Cancel: Boolean); override;
end;

  { класс эксперта является потомком базового класса TIExpert }
  TEMyExpert = class( TIExpert)
  private
    ProjectName: string;
    MenuItem: TIMenuItemIntf;
    AddInNotifier: TAddInNotifier;
  public
    constructor Create;
    destructor Destroy; override;
    function GetName: string; override;
    function GetStyle: TExpertStyle; override;
    function GetIDString: string; override;
    procedure MenuItemClick( Sender: TIMenuItemIntf);
end;

procedure register;

function AddIDEMenuItem( const Caption, name, PreviousItemName: string;
const ShortCutKey: Char; OnClick: TIMenuClickEvent): TIMenuItemIntf;

implementation

constructor TAddInNotifier.Create;
begin
  inherited Create;
  Expert := anExpert;
end;

procedure TAddInNotifier.FileNotification( NotifyCode: TFileNotification;
const FileName: string; var Cancel: Boolean);
begin
  with Expert do
    case NotifyCode of
      fnProjectOpened:
        ProjectName:= FileName; { открытие проекта }
      fnProjectClosing:
        ProjectName:= 'unknown' { закрытие проекта }
    end;
end;

constructor TEMyExpert.Create;
begin
  inherited Create;
  { добавляем пункт в главное меню IDE Delphi }
  MenuItem:= AddIDEMenuItem( 'Simple Expert 3', 'ViewMyExpertItem3',
  {$IFDEF VER130}
  'ViewWatchesItem', '3', MenuItemClick);
  {$ELSE}
  'ViewWatchItem', '3', MenuItemClick);
  {$ENDIF}
  try
    { создаем add-in нотификатор }
    AddInNotifier:= TAddInNotifier.Create( Self);
    { регистрируем add-in нотификатор }
    ToolServices.AddNotifier( AddInNotifier);
  except
    AddInNotifier:= nil;
  end;
  { инициализируем поле, хранящее имя активного проекта }
  ProjectName:= ToolServices.GetProjectName;
end;

destructor TEMyExpert.Destroy;
begin
  if Assigned( MenuItem) then
    MenuItem.Free;
  if Assigned( AddInNotifier) then
  begin
    { снимаем регистрацию add-in нотификатора }
    ToolServices.RemoveNotifier( AddInNotifier);
    { уничтожаем add-in нотификатор }
    AddInNotifier.Free;
  end;
  inherited Destroy;
end;

{ при выборе пункта меню эксперта отображаем сообщение, содержащее }
{ имя активного проекта }
procedure TEMyExpert.MenuItemClick( Sender: TIMenuItemIntf);
begin
  MessageDlg( 'Current project name is ' + ProjectName,
  mtInformation, [mbOK], 0);
end;

...

end.

Для реализации нотификатора мы определили класс TAddInNotifier, являющийся потомком TIAddInNotifier, и перекрыли метод FileNotification. IDE будет вызывать этот метод каждый раз, когда происходит событие, на которое способен среагировать add-in нотификатор (каждое такое событие обозначается соответствующей константой типа TFileNotification). Поле Expert в классе TAddInNotifier служит для обратной связи с экспертом (метод TAddInNotifier.FileNotification). В деструкторе эксперта регистрация нотификатора снимается, и нотификатор уничтожается.

А теперь проиллюстрируем использование модульных нотификаторов. Создадим add-in эксперт, выдающий сообщения о каждом акте сохранения проектного файла (реализацию уже знакомых нам методов для краткости не приводим):

unit exmpl_04;

{ ИСПОЛЬЗОВАНИЕ МОДУЛЬНЫХ НОТИФИКАТОРОВ }

interface

uses
  Classes, Dialogs, ToolIntF, ExptIntf, Menus
  {$IFDEF VER130}, EditIntf{$ENDIF};

type
  { класс модульного нотификатора порождаем от TIModuleNotifier }
  TModuleNotifier = class( TIModuleNotifier)
  private
    FileName: string;
  public
    constructor Create(const aFileName: string);
    procedure Notify( NotifyCode: TNotifyCode); override;
    {$IFDEF VER130}
    procedure ComponentRenamed(ComponentHandle: Pointer;
    const OldName, NewName: string); override;
    {$ELSE}
    procedure ComponentRenamed( const oldName, newName: string); override;
    {$ENDIF}
end;

  TEMyExpert = class;

  { класс add-in нотификатора порождаем от TIAddInNotifier}
  TAddInNotifier = class(TIAddInNotifier)
  private
    Expert: TEMyExpert;
  public
    constructor Create( anExpert: TEMyExpert);
    procedure FileNotification( NotifyCode: TFileNotification;
    const FileName: string; var Cancel: Boolean); override;
end;

  { класс эксперта является потомком базового класса TIExpert }
  TEMyExpert = class( TIExpert)
  private
    AddInNotifier: TAddInNotifier;
    ModuleInterface: TIModuleInterface;
    ModuleNotifier: TModuleNotifier;
  public
    constructor Create;
    destructor Destroy; override;
    function GetName: string; override;
    function GetStyle: TExpertStyle; override;
    function GetIDString: string; override;
    procedure AddModuleNotifier( const FileName: string);
    procedure RemoveModuleNotifier;
end;

procedure register;

implementation

constructor TModuleNotifier.Create(const aFileName: string);
begin
  inherited Create;
  FileName := aFileName;
end;

procedure TModuleNotifier.Notify( NotifyCode: TNotifyCode);
begin
  { если произошло сохранение соответствующего нотификатору файла, }
  { то выдаем сообщение об этом }
  if NotifyCode = ncAfterSave then
    MessageDlg(FileName + 'saved', mtInformation, [mbOK], 0);
end;

procedure TModuleNotifier.ComponentRenamed;
begin
  { ничего здесь не делаем, но метод необходимо перекрыть }
end;

procedure TAddInNotifier.FileNotification( NotifyCode: TFileNotification;
const FileName: string; var Cancel: Boolean);
begin
  with Expert do
    case NotifyCode of
      fnProjectOpened: { открытие проекта }
        { добавляем модульный нотификатор }
        AddModuleNotifier( FileName);
      fnProjectClosing: { закрытие проекта }
        { освобождаем модульный нотификатор }
        RemoveModuleNotifier;
    end;
end;

constructor TEMyExpert.Create;
begin
  inherited Create;
  try
    { создаем add-in нотификатор }
    AddInNotifier:= TAddInNotifier.Create( Self);
    { регистрируем add-in нотификатор }
    ToolServices.AddNotifier( AddInNotifier);
  except
    AddInNotifier:= nil;
  end;
  { добавляем модульный нотификатор }
  AddModuleNotifier( ToolServices.GetProjectName);
end;

destructor TEMyExpert.Destroy;
begin
  if Assigned( AddInNotifier) then
  begin
    { снимаем регистрацию add-in нотификатора }
    ToolServices.RemoveNotifier( AddInNotifier);
    { уничтожаем add-in нотификатор }
    AddInNotifier.Free;
  end;
  { освобождаем модульный нотификатор }
  RemoveModuleNotifier;
  inherited Destroy;
end;

procedure TEMyExpert.AddModuleNotifier;
begin
  { если модульный нотификатор для проектного файла уже зарегистрирован, }
  { то никаких действий не выполняем, во избежание появления дубликатов }
  { нотификаторов; в противном случае дубликаты могли бы появиться, }
  { например, при открытии Delphi: один нотификатор добавился бы при }
  { создании эксперта (в конструкторе класса эксперта), а второй - при }
  { открытии проекта (в TAddNotifier.FileNotification }
  if Assigned( ModuleInterface) and Assigned( ModuleNotifier) then
    Exit;
  try
    { получаем интерфейс модуля }
    ModuleInterface:= ToolServices.GetModuleInterface( FileName);
    try
      { создаем модульный нотификатор }
      ModuleNotifier:= TModuleNotifier.Create( FileName);
      { регистрируем модульный нотификатор }
      ModuleInterface.AddNotifier( ModuleNotifier);
    except
      ModuleNotifier:= nil;
    end;
  except
    ModuleInterface:= nil;
  end;
end;

procedure TEMyExpert.RemoveModuleNotifier;
begin
  if Assigned(ModuleNotifier) then
  begin
    if Assigned( ModuleInterface) then
      { снимаем регистрацию модульного нотификатора }
      ModuleInterface.RemoveNotifier( ModuleNotifier);
    { уничтожаем модульный нотификатор }
    ModuleNotifier.Free;
    ModuleNotifier:= nil;
  end;
  if Assigned( ModuleInterface) then
  begin
    { освобождаем модульный интерфейс }
    ModuleInterface.Free;
    ModuleInterface:= nil;
  end;
end;

...

end.

В данном примере add-in эксперт отслеживает события, соответствующие открытию/закрытию проектов. При каждом открытии проекта регистрируется модульный нотификатор, соответствующий файлу проекта. В плане реализации модульные нотификаторы схожи с add-in нотификаторами: мы определяем класс TModuleNotifier, являющийся потомком TIModuleNotifier и перекрываем его методы Notify и ComponentRenamed. IDE вызывает метод Notify при возникновении определенных событий, имеющих отношение к данному модулю; внутри этого метода и определяется реакция на то или иное событие. Метод ComponentRenamed вызывается при изменении имени компонента, лежащего на форме модуля. Обратите внимание на то, что мы не используем этот метод, но обязаны его перекрыть, иначе при изменении имени компонента будет происходить вызов абстрактного метода базового класса, что приводит к непредсказуемым последствиям. Регистрация модульного нотификатора является несколько более сложным процессом по сравнению с регистрацией add-in нотификатора: сначала мы получаем интерфейс модуля (TIModuleInterface), а затем с помощью интерфейса модуля регистрируем нотификатор. При закрытии проекта регистрация модульного нотификатора снимается (снова с использованием TIModuleInterface), и нотификатор уничтожается.

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

unit exmpl_05;

{ ОПРЕДЕЛЕНИЕ ПОЗИЦИИ КУРСОРА }
interface

uses
  SysUtils, Classes, Dialogs, ToolIntF, ExptIntf, EditIntf, Menus;

type
  { класс эксперта является потомком базового класса TIExpert }
  TEMyExpert = class( TIExpert)
  private
    MenuItem: TIMenuItemIntf;
  public
    constructor Create;
    destructor Destroy; override;
    function GetName: string; override;
    function GetStyle: TExpertStyle; override;
    function GetIDString: string; override;
    procedure MenuItemClick( Sender: TIMenuItemIntf);
    function GetCursorPos: TEditPos;
end;

procedure register;

function AddIDEMenuItem( const Caption, name, PreviousItemName: string;
const ShortCutKey: Char; OnClick: TIMenuClickEvent): TIMenuItemIntf;

implementation

{ при выборе пункта меню эксперта отображаем сообщение, содержащее }
{ имя активного проекта }
procedure TEMyExpert.MenuItemClick( Sender: TIMenuItemIntf);
var
  CurPos: TEditPos;
begin
  CurPos:= GetCursorPos;
  if CurPos.Line > 0 then
    MessageDlg( 'Current file: ' + ToolServices.GetCurrentFile + #13 +
    'Current cursor position: ' + IntToStr( CurPos.Line) +
    ', ' + IntToStr( CurPos.Col), mtInformation, [mbOK], 0);
end;

function TEMyExpert.GetCursorPos: TEditPos;
var
  ModuleInterface: TIModuleInterface;
  EditorInterface: TIEditorInterface;
  EditView: TIEditView;
  FileName: string;
begin
  { определяем имя активного файла }
  FileName:= ToolServices.GetCurrentFile;
  Result.Line:= 0;
  Result.Col:= 0;
  { для простоты определяем позицию только в pas- файлах }
  if ExtractFileExt( FileName) = '.pas' then
  begin
    { получаем интерфейс модуля }
    ModuleInterface:= ToolServices.GetModuleInterface( FileName);
    try
      { получаем интерфейс редактора кода }
      EditorInterface:= ModuleInterface.GetEditorInterface;
      try
        { получаем интерфейс представления модуля в редакторе }
        { передавая методу GetView индекс нужного нам представления; }
        { если файл открыт в нескольких окнах редактора кода, то для }
        { простоты берем первое (хотя конечно, это не совсем }
        { правильно }
        EditView:= EditorInterface.GetView( 0);
        try
          Result:= EditView.CursorPos;
        finally
          EditView.Free;
        end;
      finally
        EditorInterface.Free;
      end;
    finally
      ModuleInterface.Free;
    end;
  end;
end;

...

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

модульный интерфейс (TIModuleInterface);
интерфейс редактора кода (TIEditorInterface);
интерфейс представления модуля в окне редактора (TIEditView).
Если при выборе пункта меню эксперта активным является файл с исходным текстом (*.pas), то выдается сообщение, содержащее имя активного файла и текущую позицию курсора в нем. Если активным является не pas-файл, то сообщение не выдается.

Для получения имени активного файла используется метод GetCurrentFile класса TIToolServices.

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

Взято с

Использование SMTP Relay Server

Использование SMTP Relay Server - отсылка письма напрямую минуя любые промежуточные сервера (пример взят из библиотеки Indy). Для отсылки письма с использованием компонентов Indy. Пример для Delphi 7 (скорее всего будет работать и в Delphi 6), для Kylix 3 нужны небольшие исправления для перевода в CLX приложение (сама функциональность та же).

Пример модуля:

unit fMain;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  IdTCPConnection, IdTCPClient, IdMessageClient, IdSMTP, IdComponent,
  IdUDPBase, IdUDPClient, IdDNSResolver, IdBaseComponent, IdMessage,
  StdCtrls, ExtCtrls, ComCtrls, IdAntiFreezeBase, IdAntiFreeze;

type
  TfrmMain = class(TForm)
    IdMessage: TIdMessage;
    IdDNSResolver: TIdDNSResolver;
    IdSMTP: TIdSMTP;
    Label1: TLabel;
    sbMain: TStatusBar;
    Label2: TLabel;
    edtDNS: TEdit;
    Label3: TLabel;
    Label4: TLabel;
    edtSender: TEdit;
    Label5: TLabel;
    edtRecipient: TEdit;
    Label6: TLabel;
    edtSubject: TEdit;
    Label7: TLabel;
    mmoMessageText: TMemo;
    btnSendMail: TButton;
    btnExit: TButton;
    IdAntiFreeze: TIdAntiFreeze;
    Label8: TLabel;
    edtTimeOut: TEdit;
    Label9: TLabel;
    Label10: TLabel;
    procedure btnExitClick(Sender: TObject);
    procedure btnSendMailClick(Sender: TObject);
  public
  fMailServers : TStringList;
  Function PadZero(s:String):String;
  Function GetMailServers:Boolean;
  Function ValidData : Boolean;
  Procedure SendMail; OverLoad;
  Function SendMail(aHost : String):Boolean; OverLoad;
  Procedure LockControls;
  procedure UnlockControls;
  Procedure Msg(aMessage:String);
  end;

var
  frmMain: TfrmMain;

implementation

{$R *.DFM}

procedure TfrmMain.btnExitClick(Sender: TObject);
begin
application.terminate;
end;

procedure TfrmMain.btnSendMailClick(Sender: TObject);
begin
Msg('');
LockControls;
if ValidData then SendMail;
UnlockControls;
Msg('');
end;

function TfrmMain.GetMailServers: Boolean;
var
  i,x : integer;
  LDomainPart : String;
  LMXRecord : TMXRecord;
begin
if not assigned(fmailServers) then fMailServers := TStringList.Create;
fmailServers.clear;
  Result := true;
  with IdDNSResolver do
  begin
  QueryResult.Clear;
  QueryRecords := [qtMX];
  Msg('Setting up DNS query parameters');
  Host := edtDNS.text;
  ReceiveTimeout := StrToInt(edtTimeOut.text);
  // Extract the domain part from recipient email address
  LDomainPart := copy(edtRecipient.text,pos('@',edtRecipient.text)+1,length(edtRecipient.text));
  // the domain name to resolve
  try
  Msg('Resolving DNS');
  Resolve(LDomainPart);
  if QueryResult.Count > 0 then
    begin
      for i := 0 to QueryResult.Count - 1 do
        begin
        LMXRecord := TMXRecord(QueryResult.Items[i]);
        fMailServers.Append(PadZero(IntToStr(LMXRecord.Preference)) + '=' + LMXRecord.ExchangeServer);
        end;
    // sort in order of priority and then remove extra data
    fMailServers.Sorted := false;
    for i := 0 to fMailServers.count - 1 do
      begin
      x := pos('=',fMailServers.Strings[i]);
      if x > 0 then fMailServers.Strings[i] :=
        copy(fMailServers.Strings[i],x+1,length(fMailServers.Strings[i]));
      end;
    fMailServers.Sorted := true;
    fMailServers.Duplicates := dupIgnore;
    Result := true;
    end
  else
    begin
    Msg('No response from DNS server');
    MessageDlg('There is no response from the DNS server !', mtInformation, [mbOK], 0);
    Result := false;
    end;
  except
  on E : Exception do
    begin
    Msg('Error resolving domain');
    MessageDlg('Error resolving domain: ' + e.message, mtInformation, [mbOK], 0);
    Result := false;
    end;
  end;
  end;
end;

// Used in DNS preferance sorting
procedure TfrmMain.LockControls;
var i : integer;
begin
edtDNS.enabled := false;
edtSender.enabled := false;
edtRecipient.enabled := false;
edtSubject.enabled := false;
mmoMessageText.enabled := false;
btnExit.enabled := false;
btnSendMail.enabled := false;
end;

procedure TfrmMain.UnlockControls;
begin
edtDNS.enabled := true;
edtSender.enabled := true;
edtRecipient.enabled := true;
edtSubject.enabled := true;
mmoMessageText.enabled := true;
btnExit.enabled := true;
btnSendMail.enabled := true;
end;

function TfrmMain.PadZero(s: String): String;
begin
if length(s) < 2 then s := '0' + s;
Result := s;
end;

procedure TfrmMain.SendMail;
var i : integer;
begin
if GetMailServers then
  begin
  with IdMessage do
    begin
    Msg('Assigning mail message properties');
    From.Text := edtSender.text;
    Sender.Text := edtSender.text;
    Recipients.EMailAddresses := edtRecipient.text;
    Subject := edtSubject.text;
    Body := mmoMessageText.Lines;
    end;
  for i := 0 to fMailServers.count -1 do
    begin
    Msg('Attempting to send mail');
    if SendMail(fMailServers.Strings[i]) then
      begin
      MessageDlg('Mail successfully sent and available for pickup by recipient !',
mtInformation, [mbOK], 0);
      Exit;
      end;
    end;
  // if we are here then something went wrong .. ie there were no available servers to accept our mail!
  MessageDlg('Could not send mail to remote server - please try again later.', mtInformation, [mbOK], 0);
  end;
if assigned(fMailServers) then FreeAndNil(fMailServers);
end;

function TfrmMain.SendMail(aHost: String): Boolean;
begin
Result := false;
with IdSMTP do
  begin
  Caption := 'Trying to sendmail via: ' + aHost;
  Msg('Trying to sendmail via: ' + aHost);
  Host := aHost;
  try
  Msg('Attempting connect');
  Connect;
  Msg('Successful connect ... sending message');
  Send(IdMessage);
  Msg('Attempting disconnect');
  Disconnect;
  msg('Successful disconnect');
  Result := true;
  except on E : Exception do
    begin
    if connected then try disconnect; except end;
    Msg('Error sending message');
    result := false;
    ShowMessage(E.Message);
    end;
  end;
  end;
Caption := '';
end;

function TfrmMain.ValidData: Boolean;
var ErrString:string;
begin
Result := True;
ErrString := '';
if trim(edtDNS.text) = '' then ErrString := ErrString +  #13 + #187 + 'DNS server not filled in';
if trim(edtSender.text) = '' then ErrString := ErrString + #13 + #187 + 'Sender email not filled in';
if trim(edtRecipient.text) = '' then ErrString := ErrString +  #13 + #187 + 'Recipient not filled in';
if ErrString <> '' then
  begin
  MessageDlg('Cannot proceed due to the following errors:'+#13+#10+ ErrString, mtInformation, [mbOK], 0);
  Result := False;
  end;
end;

procedure TfrmMain.Msg(aMessage: String);
begin
sbMain.SimpleText := aMessage;
application.ProcessMessages;
end;

end.

Форма для модуля:

object frmMain: TfrmMain
  Left = 243
  Top = 129
  Width = 448
  Height = 398
  Caption = 'INDY - SMTP Relay Demo'
  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 Label1: TLabel
    Left = 7
    Top = 8
    Width = 311
    Height = 26
    Caption =
      'Demonstrates sending mail directly to a users mailbox on a remot' +
      'e mailserver - this negates the need for a local SMTP server'
    Font.Charset = DEFAULT_CHARSET
    Font.Color = clGray
    Font.Height = -11
    Font.Name = 'MS Sans Serif'
    Font.Style = []
    ParentFont = False
    WordWrap = True
  end
  object Label2: TLabel
    Left = 8
    Top = 64
    Width = 111
    Height = 13
    Caption = 'DNS server IP address:'
  end
  object Label3: TLabel
    Left = 8
    Top = 123
    Width = 104
    Height = 13
    Caption = 'Sender email address:'
  end
  object Label4: TLabel
    Left = 288
    Top = 64
    Width = 49
    Height = 13
    Caption = 'Required !'
    Font.Charset = DEFAULT_CHARSET
    Font.Color = clGray
    Font.Height = -11
    Font.Name = 'MS Sans Serif'
    Font.Style = []
    ParentFont = False
  end
  object Label5: TLabel
    Left = 8
    Top = 150
    Width = 115
    Height = 13
    Caption = 'Recipient email address:'
  end
  object Label6: TLabel
    Left = 8
    Top = 177
    Width = 72
    Height = 13
    Caption = 'Subject of mail:'
  end
  object Label7: TLabel
    Left = 8
    Top = 204
    Width = 66
    Height = 13
    Caption = 'Message text:'
  end
  object Label8: TLabel
    Left = 8
    Top = 91
    Width = 95
    Height = 13
    Caption = 'DNS server timeout:'
  end
  object Label9: TLabel
    Left = 336
    Top = 124
    Width = 49
    Height = 13
    Caption = 'Required !'
    Font.Charset = DEFAULT_CHARSET
    Font.Color = clGray
    Font.Height = -11
    Font.Name = 'MS Sans Serif'
    Font.Style = []
    ParentFont = False
  end
  object Label10: TLabel
    Left = 336
    Top = 148
    Width = 49
    Height = 13
    Caption = 'Required !'
    Font.Charset = DEFAULT_CHARSET
    Font.Color = clGray
    Font.Height = -11
    Font.Name = 'MS Sans Serif'
    Font.Style = []
    ParentFont = False
  end
  object sbMain: TStatusBar
    Left = 0
    Top = 352
    Width = 440
    Height = 19
    Panels = <>
  end
  object edtDNS: TEdit
    Left = 128
    Top = 60
    Width = 153
    Height = 21
    TabOrder = 1
  end
  object edtSender: TEdit
    Left = 128
    Top = 119
    Width = 205
    Height = 21
    TabOrder = 2
  end
  object edtRecipient: TEdit
    Left = 128
    Top = 146
    Width = 205
    Height = 21
    TabOrder = 3
  end
  object edtSubject: TEdit
    Left = 128
    Top = 173
    Width = 205
    Height = 21
    TabOrder = 4
  end
  object mmoMessageText: TMemo
    Left = 128
    Top = 200
    Width = 205
    Height = 113
    TabOrder = 5
  end
  object btnSendMail: TButton
    Left = 258
    Top = 321
    Width = 75
    Height = 25
    Caption = 'Send mail !'
    TabOrder = 6
    OnClick = btnSendMailClick
  end
  object btnExit: TButton
    Left = 356
    Top = 8
    Width = 75
    Height = 25
    Caption = 'E&xit'
    TabOrder = 7
    OnClick = btnExitClick
  end
  object edtTimeOut: TEdit
    Left = 128
    Top = 87
    Width = 61
    Height = 21
    TabOrder = 8
    Text = '5000'
  end
  object IdMessage: TIdMessage
    AttachmentEncoding = 'MIME'
    BccList = <>
    CCList = <>
    Encoding = meMIME
    Recipients = <>
    ReplyTo = <>
    Left = 12
    Top = 236
  end
  object IdDNSResolver: TIdDNSResolver
    Port = 53
    ReceiveTimeout = 60
    QueryRecords = []
    Left = 12
    Top = 268
  end
  object IdSMTP: TIdSMTP
    MaxLineAction = maException
    ReadTimeout = 0
    Port = 25
    AuthenticationType = atNone
    Left = 12
    Top = 204
  end
  object IdAntiFreeze: TIdAntiFreeze
    Left = 12
    Top = 300
  end
end

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

Использование SQLMonitor (DBExpress)

Следи за собой - будь осторожен или использование SQLMonitor.
Итак, остался всего один компонент на закладке dbExpress, не обследованный нами - это SQLMonitor. Как вы уже догадались - его задача - это протоколирование событий, происходящих в программе при обращении к базе данных. Протокол может выводиться как в StringList, так и файл.

Создадим новый проект (File/ New Application). На главную форму положим SQLConection, SQLClientDataSet. Настроим SQLConnection на соединение с БД, а SQLClientDataSet на получение данных через SQLConnection. Свойства Connected SQLConnection и Active SQLClientDataSet установим в True. Все стандартно.

Теперь положим на форму компонент - SQL Monitor. Обглядим, какими свойствами И событиями он обладает:

Active Boolean Активность монитора- вкл/выкл
AutoSave Boolean Авто сохранение протокола в файл, имя файла должно быть указано в св-ве FileName
FileName String Имя файла для сохранения протокола. Если св-во AutoSave установлено в true, то в указанный файл протокол записывается автоматически, если AutoSave :=false, то FileName используется как файл по умолчанию, для методов LoadFromFile, SaveToFile
SQLConnection TSQLConnection Соединение с БД, работа с которым будет протколироваться
TraceList TStrings Содержимое протокола
Методы
LoadFromFile (AFileName:string) Загрузить протокол из файла
SaveToFile (AFileName:string) Сохранить протокол в файл
События
OnLogTrace TTraceLogEvent Генерируется сразу после вставки нового сообщения в протокол
OnTrace TTraceEvent Генерируется при наличии сообщения для протокола, перед его вставкой
Что нам остается сделать - в компоненте SQLMonitor1 установить свойство SQLConnection равным SQLConnection1, а затем свойство Active SQLMonitor1 установим в True. Для вывода сообщений расположим на форме компонент Memo. Для его заполнения создадим обработчик события OnLogTrace компонента SQLMonitor1 со следующим кодом:

Memo1.Clear;
Memo1.LinesAddString(SQLMonitor1.TraceList);

Все запускаем полученное приложение - читаем протокол.

У меня возник по поводу использования монитора только один вопрос (Кто идет за "Клинским"? :) А как отслеживать не все события, а только какие-то определенные? Ответ нашелся довольно быстро.

Структура CBInfo:pSQLTraceDesc имеет поле eTraceCat, содержащее категорию произошедшего события. Однако у меня значение этого поля всегда было равно 256. Таким образом, нам остается только анализировать текст сообщения, находящийся в поле pszTrace вышеуказанной структуры.

Ну вот и все. Ваши замечания и предложения я рад буду увидеть в почтовом ящике mgoblin@mail.ru

Автор: Mike Goblin

Взято из

с разрешения автора.

Использование таблиц Access при помощи ODBC

Из приложений Delphi вы можете получить доступ к .MDB-файлам Microsoft Access, используя драйверы ODBC. Delphi действительно может дать все необходимое, но некоторые вещи не столь очевидные. Вот шаги для достижения вашей цели.

Что вам нужно: Первое: проверьте, установлен ли ODBC Administrator (файл ODBCADM.EXE в WINDOWS\SYSTEM, вам также необходим файл DBCINST.DLL для установки новых драйверов и ODBC.DLL). Администратор ODBC должен присутствовать в Панели Управления в виде иконки ODBC. Если у вас его не было, то после установки Delphi он должен появиться. Если вы получаете сообщение типа "Your ODBC is not up-to-date IDAPI needs ODBC greater then 2.0", у вас имеется старая версия администратора и вы должны обновить ее до версии, включенной в поставку Delphi. Проверьте, имеете ли вы доступ к драйверу Access ODBC, установленному в Windows. Вы можете сделать это, щелкнув на "Drivers" в диалоговом окне "Data Sources", появляющемся при запуске ODBC Administrator. Delphi должна в диалоге добавить пункты Access Files (*.mdb) и Access Data (*.mdb), работающие с файлами Access 1.10 и использующие драйвер SIMBA.DLL (имейте в виду, что для данного DLL необходимы также файлы RED110.DLL и SIMADMIN.DLL, устанавливаемые для вас Delphi). Данные файлы должны поставляться с дистрибутивом вашей программы как часть ReportSmith Runtime библиотеки. Если вы хотите работать с файлами Access 2.0 или 2.5, вам необходимо иметь другой набор драйверов от Microsoft. Ключевой файл - MSAJT200.DLL, также необходимы файлы MSJETERR.DLL и MSJETINT.DLL. В США набор ODBC Desktop Drivers, Version 2.0. стоит $10.25. Он также доступен в январском выпуске MSDN, Level 2 (Development Platform) CD4 \ODBC\X86 как часть ODBC 2.1 SDK. Очевидно есть обновление этих драйверов для файлов Access 2.5 на форуме MSACCESS CompuServe. Имейте в виду, что драйвер Access ODBC, поставляемый с некоторыми приложениями Microsoft (например, MS Office) могут использоваться только другими MS-приложениями. К сожалению, они могут сыграть с вами злую шутку: сначала заработать, а потом отказать в совершенно неподходящий момент! Поэтому не обращайте внимания (запретите себе обращать внимание!) на строчку "Access 2.0 for MS Office (*.mdb)" в списке драйверов ODBC Administrator. Вы можете установить новые ODBC драйверы с помощью ODBC Administrator в Панели Управления.

Добавление источника данных ODBC (Data Source): если у вас имеются все необходимые файлы, можете начинать. Представленный здесь пример использует драйвер Access 1.10, обеспечиваемый Delphi. Используя ODBC Administrator, установите источник данных для ваших файлов Access: щелчок на кнопке "Add" в окне "data sources" выведет диалог "Add Data Source", выберите Access Files (*.mdb) (или что-либо подходящее, в зависимости от установленных драйверов). В диалоге "ODBC Microsoft Access Setup" необходимо ввести имя в поле "Data Source Name". В данном примере мы используем "My Test". Введите описание "Data Source" в поле Description. Щелкните на "Select Database" для открытия диалога "Select Database". Перейдите в директорию, где хранятся ваши Access .MDB-файлы и выберите один. Мы выберем файл TEST.MDB в директории C:\DELPROJ\ACCESS. Нажмите OK в диалоге "Setup". Теперь в списке источников данных (Data Sources) должен появиться "My Test" (Access Files *.mdb). Нажмите Close для выхода из ODBC Administrator. Используя этот метод, вы можете установить и другие, необходимые вам, источники данных.

Настройка Borland Database Engine: загрузите теперь Borland Database Engine (BDE) Configuration Utility. На странице "Drivers" щелкните на кнопке New ODBC Driver. Имейте в виду, что это добавит драйвер Access в BDE и полностью отдельное управление дополнительно к драйверам Access в Windows, устанавливаемым при помощи ODBC Administrator. В открывшемся диалоге Add ODBC Driver в верхнем поле редактировании введите ACCESS (или что-то типа этого). BDE автоматически добавит на первое место ODBC_. В combobox, расположенном немного ниже, выберите Access Files (*.mdb). Выберите Data Source в следующем combobox (Default Data Source Name), это должен быть источник данных, который вы установили с помощью ODBC Administration Utility. Здесь можно не беспокоиться о вашем выборе, поскольку позднее это можно изменить (позже вы узнаете как это можно сделать). Нажмите OK. После установки драйвера BDE, вы можете использовать его более чем с одним источником данных ODBC, применяя различные псевдонимы (Alias) для каждого ODBC Data Source. Для установки псевдонима переключитесь на страницу "Aliases" и нажмите на кнопку "New Alias". В диалоговом окне "Add New Alias" введите необходимое имя псевдонима в поле "Alias Name". В нашем примере мы используем MY_TEST (не забывайте, что пробелы в псевдониме недопустимы). В combobox Alias Type выберите имя ODBC-драйвера, который вы только что создали (в нашем случае ODBC_ACCESS). Нажмите OK. Если вы имеете более одного ODBC Data Source, измените параметр ODBC DSN ("DSN" = "Data Source Name") в списке "Parameters" псевдонима на подходящий источник данных ODBC Data Source, как установлено в ODBC Administrator. Имейте в виду, что вы не должны ничего добавлять в параметр Path (путь), так как ODBC Data Source уже имеет эту информацию. Если вы добавляете параметр Path, убедитесь, что путь правильный, в противном случае ничего работать не будет! Теперь сохраните конфигурацию BDE, выбирая пункты меню File|Save, и выходите из Database Engine Configuration Utility.

В Delphi: Создайте новый проект и расположите на форме компоненты Table и DataSource из вкладки Data Access палитры компонентов. Затем из вкладки Data Controls выберите компонент DBGrid и также расположите его на форме. В Table, в Инспекторе Объектов, назначьте свойству DatabaseName псевдоним MY_TEST, установленный нами в BDE Configuration Utility. Теперь спуститесь ниже и раскройте список TableName. Вас попросят зарегистрироваться в базе данных Access MY_TEST. Обратите внимание, что если бюджет не установлен, то User Name и Password можно не заполнять, просто нажмите на кнопку OK. После некоторой паузы раскроется список, содержащий доступные таблицы для ODBC Data Source указанного псевдонима BDE. Выберите TEST. В DataSource, в Инспекторе Объектов, назначьте свойству DataSet таблицу Table1. В DBGrid, также в Инспекторе Объектов, назначьте свойству DataSource значение DataSource1. Возвратитесь к таблице, и в том же Инспекторе Объектов установите свойство Active в True. Данные из таблицы TEST отобразятся в табличной сетке. Это все! Одну вещь все-таки стоит упомянуть: если вы создаете приложение, использующее таблицы Access и запускаете его из-под Delphi IDE, то при попытке изменения данных в таблице(ах) вы получите ошибку. Если же вы запустите скомпилированный .EXE-файл вне Delphi (предварительно Delphi закрыв), то все будет ОК. Сообщения об ошибках ODBC, к несчастью, очень туманные и бывает достаточно трудно понять его источник в вашем приложении, в этом случае проверьте установку ODBC Administrator и BDE Configuration Utility, они также могут помочь понять источник ошибки. Для получения дополнительной информации обратитесь к ODBC 2.0 Programmer's Reference или SDK Guide от Microsoft Press (ISBN 1-55615-658-8, цена в США составляет $24.95). В этом документе вы получите исчерпывающую информацию о возможных ошибках при использовании Access-файлов посредством ODBC. Также здесь вы можете найти рапорты пользователей о найденных ошибках, в том числе и при использовании Delphi. Более того, я выяснил, что большинство описанных проблем возникает при неправильных настройках ODBC, т.е. те шаги, которые я описал выше. Надеюсь, что с развитием технологии доступа к базам данных такие сложности уйдут в прошлое. Кроме того, имейте в виду, что если вам необходимо создать новую таблицу Access 1.10, вы можете воспользоваться Database Desktop, включаемый в поставку Delphi.

Авторы данной технологии Ralph Friedman (CompuServe 100064,3102), Bob Swart и Chris Frizelle.

Взято из

Советов по Delphi от

Сборник Kuliba

Может кто-нибудь, предпочтительно из персонала Borland, ПОЖАЛУЙСТА, дать мне ПОЛНЫЙ рассказ о том, как с помощью Delphi и сопутствующего программного обеспечения получить доступ и работать с базами данных MS Access. Среди прочего, мне необходимо узнать...

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

Драйвер ODBC, предусмотренный для доступа к Access 2.0, разработан только для работы в пределах среды Microsoft Office. Для работы со связкой ODBC/Access в Delphi, вам необходим Microsoft ODBC Desktop Driver kit, part# 273-054-030, доступный через Microsoft Direct за $10.25US (если вы живете не в США, воспользуйтесь службой WINEXT). Он также доступен в январском выпуске MSDN, Level 2 (Development Platform) CD4 \ODBC\X86 как часть ODBC 2.1 SDK. Имейте в виду, что смена драйверов (в частности Desktop Drivers) может негативно сказаться на работе других приложений Microsoft. Для информации (и замечаний) обращайтесь в форум WINEXT.

Также вам необходимы следующие файлы ODBC:

Минимум:
  ODBC.DLL       03.10.1994, Версия 2.00.1510
  ODBCINST.DLL   03.10.1994, Версия 2.00.1510
  ODBCINST.HLP   11.08.1993
  ODBCADM.EXE    11.08.1993, Версия 1.02.3129

Рекомендуется:
  ODBC.DLL       12.07.1994, Версия 2.10.2401
  ODBCINST.DLL   12.07.1994, Версия 2.10.2401
  ODBCINST.HLP   12.07.1994
  ODBCADM.EXE    12.07.1994, Версия 2.10.2309

Нижеследующие шаги приведут вас к искомой цели:

1.Используя администратора ODBC, установите источник данных (datasource) для вашей базы данных. Не забудьте задать путь к вашему mdb-файлу. Для нашего примера создайте источник с именем MYDSN.
2.Загрузите утилиту BDE Configuration.
3.Выберите пункт "New Driver".
4.Назначьте драйверу имя (в нашем случае ODBC_MYDSN).
5.В выпадающем списке драйверов выберите "Microsoft Access Driver (*.mdb)
6.В выпадающем списке имен выберите MYDSN
7.Перейдите на страницу "Alias" (псевдонимы).
8.Выберите "New Alias" (новый псевдоним).
9.Введите MYDSN в поле имени.
10.Для Alias Type (тип псевдонима) выберите ODBC_MYDSN.
11.На форме Delphi разместите компоненты DataSource, Table, и DBGrid.
12.Установите DBGrid1.DataSource на DataSource1.
13.Установите DataSource1.DataSet на Table1.
14.Установите Table1.DatabaseName на MYDSN.
15.В свойстве TableName компонента Table1 щелкните на стрелочку "вниз" и вы увидите диалог "Login". Нажмите OK и после короткой паузы вы увидите список всех имен ваших таблиц. Выберите одно.
16.Установите свойство Active Table1 в True и данные вашей таблицы появятся в табличной сетке.

Примечание Vit: с появлением и продвижением микрософтом OLE DB и реализацией в Дельфи ADO (начиная с версии 5.0) работа с MS Access через ODBC перестала быть актуальной. За исключением особых случаев рекомендуется пользоваться именно ADO линейкой компонентов для связи с MS Access

Использование указателей на целое

Сначала вы должны создать тип:

Type
Pinteger: ^Integer;

Var
MyPtr : Pinteger;

Мне кажется, что в начале вы использовали плохой пример, имеет смысл использовать 32-битный указатель для 16-битной величины или распределять 10 байт для переменной.

Pascal позволяет вам использовать методы NEW и DISPOSE, которые автоматически распределяют и освобождают правильные размеры блока.

Например,

NEW(MyPtr) = GetMem(MyPtr, Sizeof(MyPtr))

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

Для полноты, это должно быть:

NEW(MyPtr) = GetMem(MyPtr, SizeOf(MyPtr^));

SizeOf(MyPtr) всегда будет равен 4 байта, как 16-битный указатель.

Если я правильно разобрался в том, что вы хотите (динамический массив целых, количество элеметнов которого может быть известно только во время выполнения приложения), вы можете сделать так:

Type
  pIntArr = ^IntArr;
  IntArr  = Array[1..1000] of Integer;
Var
  MyPtr : pIntArr;
Begin
  GetMem(MyPtr, 10); { 10 = SizeOf(Integer) * 5 !!)
  { MyPtr[2]:=1; }
  // <<<< Заполняем массив >>>>
  MyPtr[2]^:=1;
  FreeMem(MyPtr,10);
End;

Технология похожа на ту, которуя Delphi использует при работе с pchar. Синтаксис очень похож:

type
  intarray = array[0..20000] of integer;

procedure TForm1.Button1Click(Sender: TObject);
var
  xptr:  ^IntArray;
begin
  GetMem(xptr, 10);
  xptr^[idx] := 1;  { где idx от 0 до 4, поскольку мы
                      имеем 10 байте = 5 целых }
  FreeMem(xptr, 10);
end;

Обратите внимание на то, в вам в действительности нет необходимости распределять массив для 20,000 элементов, но проверка диапазона Delphi не будет работать, если диапазон равен 20,000. (Предостережение будущим пользователям!)

Взято с

Использование WSAAsyncSelect в DLL

Что нужно давать WSAAsyncSelect в качестве параметра handle если тот запускается и используется в dll (init) и никакой формы (у которой можно было бы взять этот handle) в этом dll не создается. Что бы такого сделать чтобы работало?

const
WM_ASYNCSELECT = WM_USER+0;
type
TNetConnectionsManager = class(TObject)
protected
FWndHandle : HWND;
procedure WndProc( var MsgRec : TMessage );
...
end;

constructor TNetConnectionsManager.Create
begin
inherited Create;
FWndHandle := AllocateHWnd(WndProc);
...
end;

destructor TNetConnectionsManager.Destroy;
begin
...
if FWndHandle<>0 then DeallocateHWnd(FWndHandle);
inherited Destroy;
end;

procedure TNetConnectionsManeger.WndProc( var MsgRec : TMessage );
begin
with MsgRec do
   if Msg=WM_ASYNCSELECT then
     WMAsyncSelect(MsgRec)
   else
     DefWindowProc( FWndHandle, Msg, wParam, lParam );
end;

Hо pекомендую посмотpеть WinSock2, в котоpом можно:

WSAEventSelect( FSocket, FEventHandle, FD_READ or FD_CLOSE );
WSAWaitForMultipleEvents( ... );
WSAEnumNetworkEvents( FSocket, FEventHandle, lpNetWorkEvents );

То есть, обойтись без окон и без очеpеди сообщений windows, а заодно иметь возможность pаботать и с IPX/SPX, и с netbios.
Свой winsock2.pas я вчеpа кинул в RU.DELPHI.DB, если кто имеет такой из дpугих источников - свистните погpомче.

Автор: Alex Konshin
alexk@msmt.spb.su
(2:5030/217)

Автор:

StayAtHome

Взято из

Использоватние Drag and Drop для заполнения полей в TWebBrowser?

{
  This example shows how to fill out fields in your webbrowser by
  dragging the content of Label1 to a field of your webbrowser}

procedure TForm1.FormCreate(Sender: TObject);
begin
  label1.DragMode := dmAutomatic;
end;

procedure TForm1.WebBrowserDragOver(Sender, Source: TObject; X,
  Y: Integer; State: TDragState; var Accept: Boolean);
var
  item: Variant;
begin
  //check if document is interactive
  if (Webbrowser.ReadyState and READYSTATE_INTERACTIVE) = 3 then
  begin
    item := WebBrowser.OleObject.Document.elementFromPoint(x, y);
    if Source is TLabel then
      Accept := True;
    Accept := (item.tagname = 'INPUT') and ((item.type = 'text') or
      (item.type = 'password')) or (item.tagname = 'TEXTAREA');
  end;
end;

procedure TForm1.WebBrowserDragDrop(Sender, Source: TObject; X,
  Y: Integer);
var
  item: Variant;
begin
  //check if document is interactive
  if (Webbrowser.ReadyState and READYSTATE_INTERACTIVE) = 3 then
  begin
    item       := WebBrowser.OleObject.Document.elementFromPoint(x, y);
    item.Value := label1.Caption;
  end;
end;

Взято с сайта

Из Paradox в Access при помощи ADO

(Перевод одноимённой статьи с сайта delphi.about.com )

В данной статье мы обратим внимание на компонент TADOCommand и использование языка SQL DDL (Data Definition Language), с целью помочь Вам с проблемой переноса данных BDE/Paradox в ADO/Access.

Язык определения данных (Data Definition Language)
Не многие программисты создают базу данных программным путём, большинство из нас для этого используют некую визуальную среду наподобие MS Access для построения файла MDB. Но иногда нам всё таки приходится создавать и удалять базу данных, а так же объекты базы данных программным путём. Для этого используется наиболее распространённая на сегодняшний день технология Structured Query Language Data Definition Language (SQL DDL). Выраджения языка определения данных (DDL) - это SQL выражения, которые поддерживают определения или объявления объектов базы данных (например, CREATE TABLE, DROP TABLE, CREATE INDEX либо подобные им).
В рамки данной статьи не входит детальное ознакомление с языком DDL. Если Вы знакомы с языком SQL DML (Data Manipulation Language - это выражения типа SELECT, UPDATE и DELETE), то DDL не будет для Вас серьёзным барьером. Обратите внимание, что работа с DDL может быть весьма ухищрённой, так как каждый производитель базы данных може включать в неё собственные расширения для SQL.

Давайте взглянем на простейший пример выражения CREATE TABLE:

CREATE TABLE PhoneBook(
  Name TEXT(50)
  Tel TEXT(50)
);

Данное DDL выражение (для MS Access) в время выполнения создаст новую таблицу с названием PhoneBook. Таблица PhoneBook будет иметь два поля: Name и Tel. Оба поля имеют строковый тип (TEXT) и размер поля 50 символов.

TFieldDef.DataType
Очевидно, что в Access тип данных, представленный строкой это TEXT. В Paradox это STRING. Чтобы передать таблицы Paradox в Access, нам необходимо знать какие типы данных присутствуют и, соответственно их имена. При работе в BDE с таблицами Paradox, TFieldDef.DataType определяет тип физического поля в (dataset) таблице. Поэтому для успешного перенесения данных из таблиц Paradox в Access Вам необходимо создать функцию, которая бы преобразовывала соотвествующие типы полей Paradox в типы Access.
Давайте посмотрим на пример функции, которая проверяет тип поля (fd) и возвращает соответствующий тип Access, а заоодно и размер поля, который необходим для выражения CREATE TABLE DDL.

function AccessType(fd:TFieldDef):string;
begin
case fd.DataType of
  ftString: Result:='TEXT('+IntToStr(fd.Size)+')';
  ftSmallint: Result:='SMALLINT';
  ftInteger: Result:='INTEGER';
  ftWord: Result:='WORD';
  ftBoolean: Result:='YESNO';
  ftFloat : Result:='FLOAT';
  ...
else
  Result:='TEXT(50)';
end;
end;

ADOX
ADOX - это расширения ADO для Data Definition Language а так же для модели защиты (ADOX). ADOX предоставляет разработчикам богатый набор инструментов для получения доступа к структуре, модели защиты, а так же процедурам, хранимым в базе данных.

Для использования ADOX в Delphi, Вам необходимы установить библиотеку типа ADOX.
1. Select Project | Import Type Library
3. Выберите "Microsoft ADO Ext 2.x for DDL and Security (Version 2.x)"
4. Измените "TTable" на "TADOXTable"
5. Измените "TColumn" на "TADOXColumn"
6 .Измените "TIndex" на "TADOXIndex"
7. Нажмите кнопку Install (перекомпиляция пакетов (packages))
8. Нажмите один раз OK и дважды Yes
9. File | Close All | Yes

На вершине объектной модели ADOX находится объект Catalog. Он обеспечивает доступ к набору Таблиц (Tables), Видов (Views) и Процедур, который используется для работы со структурой базы данных, а так же к набору Пользователей (Users) и рупп (Groups), которые используются для авторизации доступа. Каждый объект Catalog связан только с одним подключением к источнику данных.

Давайте оставим ADOX (пока) и перейдём к ADOExpress.

TADOCommand
В ADOExpress компонент TADOCommand - это VCL представление объекта ADO Command. Объект Command представляет команду (запрос или выражение), которая может быть обработана источником данных. Команды могут быть выполнены методом Execute, используемым в ADOCommand. TADOCommand чаще всего используется для исполнения команд языка определения данных (DDL) SQL. Свойство CommandText содержит в себе саму команду. Свойство CommandType используется для того, как интерпретировать свойство CommandText. Тип cmdText используется для указания инструкции DDL. Впринципе, использовать компонент ADOCommand для получения данных из таблицы, запросов или хранимых процедур не имеет смысла, но никто не запрещает Вам пользоваться данным компонентов и в таких целях.

Итак, самое время приступить к реальному программированию...

Приведённый ниже проект демонстрирует следующее:
Получение списка всех таблиц из BDE, использование TFieldDefs чтобы получить определения (имя, тип данных, размер, и т.д.) полей в таблице, создание инструкции CREATE TABLE и копирование данных из таблицы BDE/Paradox в таблицу ADO/Access.

Давайте решим эту задачу по шагам:
GUI
Запускаем Delphi - получаем новый проект с пустой формой. Добавляем две кнопки, один ComboBox и один компонент Memo. Далее добавляем компоненты TTable, TADOTable, TADOConnection и TADOCommand. Чтобы установить следующие свойства, используем Object Inspector (оставьте все другие свойства как есть - например, Memo будет иметь имя по умолчанию: Memo1):

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

procedure TForm1.FormCreate(Sender: TObject);
begin
Session.GetTableNames('DBDEMOS',
                       '*.db',False, False,
                       cboBDETblNames.Items);
end;

В самом начале ComboBox содержит имена таблиц (Paradox) в базе данных DBDEMOS. В нижеприведённом коде мы выберем таблицу Country.

Следующая наша задача - это создание инструкции CREATE TABLE DDL. Это делается в процедуре OnClick кнопки 'Construct Create command':

procedure TForm1.Button1Click(Sender: TObject);
//Кнопка 'Construct Create command'
var i:integer;
    s:string;
begin
BDETable.TableName:=cboBDETblNames.Text;
BDETable.FieldDefs.Update;

s:='CREATE TABLE ' + BDETable.TableName + ' (';
with BDETable.FieldDefs do begin
  for i:=0 to Count-1 do begin
   s:=s + ' ' + Items[i].Name;
   s:=s + ' ' + AccessType(Items[i]);
   s:=s + ',';
  end; //for
  s[Length(s)]:=')';
end;//with

Memo1.Clear;
Memo1.lines.Add (s);
end;

Вышеприведённый код просто анализирует определения полей для выбранной таблицы (cboBDETblNames) и генерирует строку, которая будет использоваться свойством CommandText компоненты TADOCommand.

Например, когда Вы выбираете таблицу Country, то Memo будет заполнен следующей строкой:

CREATE TABLE country (
  Name TEXT(24),
  Capital TEXT(24),
  Continent TEXT(24),
  Area FLOAT,
  Population FLOAT
)

И в заключении, пример для кнопки 'Create Table and copy data' , которая удаляет таблицу (DROP..EXECUTE), создаёт таблицу (CREATE..EXECUTE), и затем копирует данные в новую таблицу (INSERT...POST). Так же присутствует некоторая обработка ошибок, но код будет выходить на ошибку, если, например, (новая) таблица ещё не существует (в случае удаления).

procedure TForm1.Button2Click(Sender: TObject);
//Кнопка 'Create Table and copy data'
var i:integer;
    tblName:string;
begin
tblName:=cboBDETblNames.Text;

//обновляем
Button1Click(Sender);

//удаление & создание таблицы
ADOCommand.CommandText:='DROP TABLE ' + tblName;
ADOCommand.Execute;

ADOCommand.CommandText:=Memo1.Text;
ADOCommand.Execute;

ADOTable.TableName:=tblName;

//копируем данные
BDETable.Open;
ADOTable.Open;
try
  while not BDETable.Eof do begin
   ADOTable.Insert;
   for i:=0 to BDETable.Fields.Count-1 do begin
    ADOTable.FieldByName
   (BDETable.FieldDefs[i].Name).Value :=
      BDETable.Fields[i].Value;
   end;//for
   ADOTable.Post;
   BDETable.Next
  end;//while
finally
  BDETable.Close;
  ADOTable.Close;
end;//try
end;

Вот и всё. Теперь проверьте Вашу базу данных Access...вуаля :) теперь в ней находится таблица Country со всеми данными из DBDEMOS.

Однако некоторые вопросы остались без ответа, например: как добавлять индексы в таблицу (CREATE INDEX ON ...), или как создавать пустую базу данных Access.

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

Из строки в массив и наоборот

functionStrToArrays(str, r: string; out Temp: TStrings): Boolean;
var
  j: integer;
begin
  if temp <> nil then
  begin
    temp.Clear;
    while str <> '' do
    begin
      j := Pos(r,str);
      if j=0 then
        j := Length(str) + 1;
      temp.Add(Copy(Str,1,j-1));
      Delete(Str,1,j+length(r)-1);
    end;
    Result:=True;
  end
  else
    Result:=False;
end;

function ArrayToStr(str: TStrings; r: string): string;
var
  i: integer;
begin
  Result:='';
  if str = nil then
    Exit;
  for i := 0 to Str.Count-1 do
    Result := Result + Str.Strings[i] + r;
end;

Взято с

Изменение цветовой палитры изображения

Мне необходимо изменить цветовую палитру изображения с помощью SetBitmapBits, но у меня, к сожалению, ничего не получается.

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

Взамен я предлагаю использовать функции DIB API. Вот некоторый код, позволяющий вам изменять таблицу цветов. Просто напишите метод с такими же параметрами, как у TFiddleProc и и изменяйте ColorTable, передаваемое как параметр. Затем просто вызовите процедуру FiddleBitmap, передающую TBitmap и ваш fiddle-метод, например так:

FiddleBitmap(MyBitmap, Fiddler ) ;

type
  TFiddleProc = procedure(var ColorTable: TColorTable) of object;

const
  LogPaletteSize = sizeof(TLogPalette) + sizeof(TPaletteEntry) * 255;

function PaletteFromDIB(BitmapInfo: PBitmapInfo): HPalette;
var
  LogPalette: PLogPalette;
  i: integer;
  Temp: byte;
begin
  with BitmapInfo^, bmiHeader do
  begin
    GetMem(LogPalette, LogPaletteSize);
    try
      with LogPalette^ do
      begin
        palVersion := $300;
        palNumEntries := 256;
        Move(bmiColors, palPalEntry, sizeof(TRGBQuad) * 256);
        for i := 0 to 255 do
          with palPalEntry[i] do
          begin
            Temp := peBlue;
            peBlue := peRed;
            peRed := Temp;
            peFlags := PC_NOCOLLAPSE;
          end;

        { создаем палитру }
        Result := CreatePalette(LogPalette^);
      end;
    finally
      FreeMem(LogPalette, LogPaletteSize);
    end;
  end;
end;

{ Следующая процедура на основе изображения создает DIB,
изменяет ее таблицу цветов, создавая тем самым новую палитру,
после чего передает ее обратно изображению. При этом
используется метод косвенного вызова, с помощью которого
изменяется палитра цветов - ей передается array[ 0..255 ] of TRGBQuad. }

procedure FiddleBitmap(Bitmap: TBitmap; FiddleProc: TFiddleProc);
const
  BitmapInfoSize = sizeof(TBitmapInfo) + sizeof(TRGBQuad) * 255;
var
  BitmapInfo: PBitmapInfo;
  Pixels: pointer;
  InfoSize: integer;
  ADC: HDC;
  OldPalette: HPalette;
begin
  { получаем DIB }
  GetMem(BitmapInfo, BitmapInfoSize);
  try
    { меняем таблицу цветов - ПРИМЕЧАНИЕ: она использует 256 цветов DIB }
    FillChar(BitmapInfo^, BitmapInfoSize, 0);
    with BitmapInfo^.bmiHeader do
    begin
      biSize := sizeof(TBitmapInfoHeader);
      biWidth := Bitmap.Width;
      biHeight := Bitmap.Height;
      biPlanes := 1;
      biBitCount := 8;
      biCompression := BI_RGB;
      biClrUsed := 256;
      biClrImportant := 256;
      GetDIBSizes(Bitmap.Handle, InfoSize, biSizeImage);

      { распределяем место для пикселей }
      Pixels := GlobalAllocPtr(GMEM_MOVEABLE, biSizeImage);
      try
        { получаем пиксели DIB }
        ADC := GetDC(0);
        try
          OldPalette := SelectPalette(ADC, Bitmap.Palette, false);
          try
            RealizePalette(ADC);
            GetDIBits(ADC, Bitmap.Handle, 0, biHeight, Pixels, BitmapInfo^,
              DIB_RGB_COLORS);
          finally
            SelectPalette(ADC, OldPalette, true);
          end;
        finally
          ReleaseDC(0, ADC);
        end;

        { теперь изменяем таблицу цветов }
        FiddleProc(PColorTable(@BitmapInfo^.bmiColors)^);

        { создаем палитру на основе новой таблицы цветов }
        Bitmap.Palette := PaletteFromDIB(BitmapInfo);
        OldPalette := SelectPalette(Bitmap.Canvas.Handle, Bitmap.Palette,
          false);
        try
          RealizePalette(Bitmap.Canvas.Handle);
          StretchDIBits(Bitmap.Canvas.Handle, 0, 0, biWidth, biHeight, 0, 0,
            biWidth, biHeight,
            Pixels, BitmapInfo^, DIB_RGB_COLORS, SRCCOPY);
        finally
          SelectPalette(Bitmap.Canvas.Handle, OldPalette, true);
        end;
      finally
        GlobalFreePtr(Pixels);
      end;
    end;
  finally
    FreeMem(BitmapInfo, BitmapInfoSize);
  end;
end;

{ Пример "fiddle"-метода }

procedure TForm1.Fiddler(var ColorTable: TColorTable);
var
  i: integer;
begin
  for i := 0 to 255 do
    with ColorTable[i] do
    begin
      rgbRed := rgbRed * 9 div 10;
      rgbGreen := rgbGreen * 9 div 10;
      rgbBlue := rgbBlue * 9 div 10;
    end;
end;

Взято из

Изменение данных в таблице

Теперь последний штрих о работе с таблицами. Мы разобрали способы обратиться к нужному столбцу и нужной записи, их поиск и чтение значений. А как записать новое значение? Для этого есть методы Edit, Append, Insert, Post и Cancel.

1) Надо изменить текущую запись.
Table1.edit; //переводим таблицу в режим редактирования
Table1.fieldbyname('Category').asString:='New value';//изменяем поле
Table1.post;//сохраняем изменения

2) Надо добавить новую запись.
Table1.append; //переводим таблицу в режим добавления новой записи
Table1.fieldbyname('Category').asString:='New value';//присваиваем значение полей
Table1.post;//сохраняем изменения

Итого, как видим изменения данных производятся точно так же как и чтение, но перед изменением КАЖДОЙ записи таблица должна быть переведена в режим редактирования, а после изменения КАЖДОЙ записи изменения должны быть сохранены.

В режим редактирования таблицу переводят следующие методы:
Edit - редактирование текущей записи
Append - добавление записи в конец таблицы
Insert - вставка записи перед текущей

Для выхода из режима редактирования служат методы:
Post - запомнить изменения и выйти из режима редактирования
Cancel - отменить сделанные изменения и выйти из режима редактирования

Изменение месторасположения *.NET-файла

Кто-нибудь знает как изменить месторасположение файла PDOXUSRS.NET во время выполнения программы?

DbiSetProp(hSessionHandle,sesNetFile, pchar('c:\newdir'));

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

- Scott Frolich

Взято из

Советов по Delphi от

Сборник Kuliba

Изменение размеров колонок в StringGrid

Ниже приведён примен кода, который позволяет автоматически подогнать размер колонки в компененте TStringGrid, под размер самой длинной строки текста в колонке:

procedure AutoSizeGridColumn(Grid : TStringGrid;
                              column : integer);
var
  i : integer;
  temp : integer;
  max : integer;
begin
  max := 0;
  for i := 0 to (Grid.RowCount - 1) do begin
    temp := Grid.Canvas.TextWidth(grid.cells[column, i]);
    if temp > max then max := temp;
  end;
  Grid.ColWidths[column] := Max + Grid.GridLineWidth + 3;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  AutoSizeGridColumn(StringGrid1, 1);
end;

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

Изменение регистра букв

В Delphi есть три функции для изменения регистра: upcase, lowercase, uppercase.
Но они работают только для латинского алфавита.
Чтобы сделать аналогичные функции для русского алфавита я
использовал то, что в кодировке Windows-1251 буквы расставлены по алфавиту,
как большие, так и маленькие.
То есть номер большой буквы связан с номером маленькой константой.
И в русском, и в английском алфавитах маленькие буквы находятся
за большими с разностью в 32 символа.
Здесь реализованы четыре функции: upcase и locase для
изменения регистра одного символа, и uppercase и lowercase для изменения регистра строки

function UpCase(ch: char): char;
begin
  if (ch in ['a'..'z', 'а'..'я'])
    then result := chr(ord(ch) - 32)
    else result := ch;
end;

function LoCase(ch: char): char;
begin
  if (ch in ['A'..'Z', 'А'..'Я'])
    then result := chr(ord(ch) + 32)
    else result := ch;
end;

function UpperCase(s: string): string;
var
  i: integer;
begin
  result := s;
  for i := 1 to length(result) do
    if (result[i] in ['a'..'z', 'а'..'я'])
      then result[i] := chr(ord(result[i]) - 32);
end;

function LowerCase(s: string): string;
var
  i: integer;
begin
  result := s;
  for i := 1 to length(result) do
    if (result[i] in ['A'..'Z', 'А'..'Я'])
      then result[i] := chr(ord(result[i]) + 32);
end;

procedure TForm1.Button1Click(Sender: TObject);
const
  s = 'zZцЦ.';
var
  i: integer;
begin
  Form1.Caption := 'DownCase: ';
  for i := 1 to Length(s) do
    Form1.Caption := Form1.Caption + LoCase(s[i]);
  Form1.Caption := Form1.Caption + ' UpCase: ';
  for i := 1 to Length(s) do
    Form1.Caption := Form1.Caption + UpCase(s[i]);
  Form1.Caption := Form1.Caption + ' UpperCase: ' +
    UpperCase(s);
  Form1.Caption := Form1.Caption + ' LowerCase: ' +
    LowerCase(s);
end;

Взято с сайта