Math - математика, статистика, финансы

Math - математика, статистика, финансы

Тригонгометрические функции:

function ArcCos(X: Extended): Extended;
function ArcSin(X: Extended): Extended;
function ArcTan2(Y, X: Extended): Extended; Арктангенс X/Y возвращает угол в квадранте
procedure SinCos(Theta: Extended; var Sin, Cos: Extended) register; возвращает сразу и синус и косинус, вычисления в 2 раза быстрее чем Sin, Cos по отдельности
function Tan(X: Extended): Extended;
function Cotan(X: Extended): Extended;
function Hypot(X, Y: Extended): Extended; Возвращает значение гипотенузы по катетам

Конвертация углов



function DegToRad(Degrees: Extended): Extended;
function RadToDeg(Radians: Extended): Extended;
function GradToRad(Grads: Extended): Extended;
function RadToGrad(Radians: Extended): Extended;
function CycleToRad(Cycles: Extended): Extended;
function RadToCycle(Radians: Extended): Extended;

Гиперболические функции

function Cosh(X: Extended): Extended;
function Sinh(X: Extended): Extended;
function Tanh(X: Extended): Extended;
function ArcCosh(X: Extended): Extended;
function ArcSinh(X: Extended): Extended;
function ArcTanh(X: Extended): Extended;

Логарифмы, экспоненты и возведение в степень

function LnXP1(X: Extended): Extended; - натуральный логариф x+1 (для более высокой точности при x близких к нулю)
function Log10(X: Extended): Extended; - десятичный логарифм
function Log2(X: Extended): Extended; - логарифм по основанию 2
function LogN(Base, X: Extended): Extended; - логарифм по произвольному основанию
function IntPower(Base: Extended; Exponent: Integer): Extended register;
function Power(Base, Exponent: Extended): Extended;

Разные функции

procedure Frexp(X: Extended; var Mantissa: Extended; var Exponent: Integer) register; - возвращает мантису и экспоненту
function Ldexp(X: Extended; P: Integer): Extended register; - возвращает X*2**P
function Ceil(X: Extended):Integer; - округляет до ближайшего большего целого
function Floor(X: Extended): Integer; - округляет до ближайшего меньшего целого
function Poly(X: Extended; const Coefficients: array of Double): Extended; вычисление полинома

Статистические функции

function Mean(const Data: array of Double): Extended; среднее арифметическое
function Sum(const Data: array of Double): Extended register; сумма ряда
function SumInt(const Data: array of Integer): Integer register; сумма ряда целых чисел
function SumOfSquares(const Data: array of Double): Extended; сумма квадратов
procedure SumsAndSquares(const Data: array of Double; var Sum, SumOfSquares: Extended) register; сумма и сумма квадратов одной функцией
function MinValue(const Data: array of Double): Double; минимальное значение в ряду
function MinIntValue(const Data: array of Integer): Integer; минимальное значение в ряду целых
function Min(A,B) минимальное значение из 2х чисел (overload функции для Integer, Int64, Single, Double, Extended)
function MaxValue(const Data: array of Double): Double;
function MaxIntValue(const Data: array of Integer): Integer;
function Max(A,B);
function StdDev(const Data: array of Double): Extended; стандартное отклонение
procedure MeanAndStdDev(const Data: array of Double; var Mean, StdDev: Extended); - среднее арифметическое и стандартное отклонение
function PopnStdDev(const Data: array of Double): Extended; распределение стандартного отклонения (Population Standard Deviation)
function Variance(const Data: array of Double): Extended;
function PopnVariance(const Data: array of Double): Extended; (Population Variance)
function TotalVariance(const Data: array of Double): Extended;
function Norm(const Data: array of Double): Extended; среднее квадратичное (Sqrt(SumOfSquares))
procedure MomentSkewKurtosis(const Data: array of Double;
var M1, M2, M3, M4, Skew, Kurtosis: Extended); основные статистические моменты
function RandG(Mean, StdDev: Extended): Extended; - случайные числа с Гауссовским распределением

Финансовые функции

function DoubleDecliningBalance(Cost, Salvage: Extended; Life, Period: Integer): Extended;
function FutureValue(Rate: Extended; NPeriods: Integer; Payment, PresentValue: Extended; PaymentTime: TPaymentTime): Extended;
function InterestPayment(Rate: Extended; Period, NPeriods: Integer; PresentValue,
FutureValue: Extended; PaymentTime: TPaymentTime): Extended;
function InterestRate(NPeriods: Integer;
Payment, PresentValue, FutureValue: Extended; PaymentTime: TPaymentTime): Extended;
function InternalRateOfReturn(Guess: Extended;
const CashFlows: array of Double): Extended;
function NumberOfPeriods(Rate, Payment, PresentValue, FutureValue: Extended;
PaymentTime: TPaymentTime): Extended;
function NetPresentValue(Rate: Extended; const CashFlows: array of Double;
PaymentTime: TPaymentTime): Extended;
function Payment(Rate: Extended; NPeriods: Integer;
PresentValue, FutureValue: Extended; PaymentTime: TPaymentTime): Extended;
function PeriodPayment(Rate: Extended; Period, NPeriods: Integer;
PresentValue, FutureValue: Extended; PaymentTime: TPaymentTime): Extended;
function PresentValue(Rate: Extended; NPeriods: Integer;
Payment, FutureValue: Extended; PaymentTime: TPaymentTime): Extended;
function SLNDepreciation(Cost, Salvage: Extended; Life: Integer): Extended;
function SYDDepreciation(Cost, Salvage: Extended; Life, Period: Integer): Extended;

Матрицы в Delphi

Матрицы в Delphi

Автор: Andrew M. Omutov

Уважаемые сограждане. В ответ на вопросы Круглого Стола, в основном, от собратьев студентов, публикую алгоритмы матричного исчисления. В них нет ничего сложного, все базируется на функциях стандартного Borland Pascal еще версии 7.0.

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

Перечень функций этой библиотеки:

UnitMatrix;

interface

type
   MatrixPtr = ^MatrixRec;
   MatrixRec = record
     MatrixRow   : byte;
     MatrixCol   : byte;
     MatrixArray : pointer;
   end;
   MatrixElement = real;

(* Функция возвращает целочисленную степень *)
function IntPower(X,n : integer) : integer;

(* Функция создает квадратную матрицу *)
function  CreateSquareMatrix(Size : byte) : MatrixPtr;

(* Функция создает прямоугольную матрицу *)
function  CreateMatrix(Row,Col : byte) : MatrixPtr;

(* Функция дублирует матрицу *)
function  CloneMatrix(MPtr : MatrixPtr) : MatrixPtr;

(* Функция удаляет матрицу и возвращает TRUE в случае удачи *)
function  DeleteMatrix(var MPtr : MatrixPtr) : boolean;

(* Функция заполняет матрицу указанным числом *)
function  FillMatrix(MPtr : MatrixPtr;Value : MatrixElement) : boolean;

(* Функция удаляет матрицу MPtr1 и присваивает ей значение MPtr2 *)
function  AssignMatrix(var MPtr1 : MatrixPtr;MPtr2 : MatrixPtr) : MatrixPtr;

(* Функция отображает матрицу на консоль *)
function  DisplayMatrix(MPtr : MatrixPtr;_Int,_Frac : byte) : boolean;

(* Функция возвращает TRUE, если матрица 1x1 *)
function  IsSingleMatrix(MPtr : MatrixPtr) : boolean;

(* Функция возвращает TRUE, если матрица квадратная *)
function  IsSquareMatrix(MPtr : MatrixPtr) : boolean;

(* Функция возвращает количество строк матрицы *)
function  GetMatrixRow(MPtr : MatrixPtr) : byte;

(* Функция возвращает количество столбцов матрицы *)
function  GetMatrixCol(MPtr : MatrixPtr) : byte;

(* Процедура устанавливает элемент матрицы *)
procedure SetMatrixElement(MPtr : MatrixPtr;Row,Col : byte;Value : MatrixElement);

(* Функция возвращает элемент матрицы *)
function  GetMatrixElement(MPtr : MatrixPtr;Row,Col : byte) : MatrixElement;

(* Функция исключает векторы из матрицы *)
function  ExcludeVectorFromMatrix(MPtr : MatrixPtr;Row,Col : byte) : MatrixPtr;

(* Функция заменяет строку(столбец) матрицы вектором *)
function  SetVectorIntoMatrix(MPtr,VPtr : MatrixPtr;_Pos : byte) : MatrixPtr;

(* Функция возвращает детерминант матрицы *)
function  DetMatrix(MPtr : MatrixPtr) : MatrixElement;

(* Функция возвращает детерминант треугольной матрицы *)
function  DetTriangularMatrix(MPtr : MatrixPtr) : MatrixElement;

(* Функция возвращает алгебраическое дополнение элемента матрицы *)
function  AppendixElement(MPtr : MatrixPtr;Row,Col : byte) : MatrixElement;

(* Функция создает матрицу алгебраических дополнений элементов матрицы *)
function  CreateAppendixMatrix(MPtr : MatrixPtr) : MatrixPtr;

(* Функция транспонирует матрицу *)
function TransponeMatrix(MPtr : MatrixPtr) : MatrixPtr;

(* Функция возвращает обратную матрицу *)
function ReverseMatrix(MPtr : MatrixPtr) : MatrixPtr;

(* Функция умножает матрицу на число *)
function MultipleMatrixOnNumber(MPtr : MatrixPtr;Number : MatrixElement) : MatrixPtr;

(* Функция умножает матрицу на матрицу *)
function MultipleMatrixOnMatrix(MPtr1,MPtr2 : MatrixPtr) : MatrixPtr;

(* Функция суммирует две матрицы *)
function AddMatrixOnMatrix(MPtr1,MPtr2 : MatrixPtr) : MatrixPtr;

(* Функция вычитает из первой матрицы вторую *)
function SubMatrixOnMatrix(MPtr1,MPtr2 : MatrixPtr) : MatrixPtr;

(* Функция решает систему методом Гаусса и возвращает LU-матрицы *)
(* Результат функции - вектор-столбец решений                    *)

function GausseMethodMatrix(MPtr,VPtr : MatrixPtr;var LPtr,UPtr,BPtr : MatrixPtr) : MatrixPtr;


implementation


function IntPower(X,n : integer) : integer;
var
  Res,i : integer;
begin
  if n < 1 then IntPower:= 0
  else begin
    Res:= X;
    for i:=1 to n-1 do Res:= Res*X;
    IntPower:= Res;
  end;
end;


function CreateSquareMatrix(Size : byte) : MatrixPtr;
var
  TempPtr : MatrixPtr;
begin
  TempPtr:= nil;
  GetMem(TempPtr,SizeOf(MatrixRec));
  if TempPtr = nil then begin
    CreateSquareMatrix:= nil;
    Exit;
  end;
  with TempPtr^ do begin
    MatrixRow:= Size;
    MatrixCol:= Size;
    MatrixArray:= nil;
    GetMem(MatrixArray,Size*Size*SizeOf(MatrixElement));
    if MatrixArray = nil then begin
      FreeMem(TempPtr,SizeOf(MatrixRec));
      CreateSquareMatrix:= nil;
      Exit;
    end;
  end;
  FillMatrix(TempPtr,0);
  CreateSquareMatrix:= TempPtr;
end;


function CreateMatrix(Row,Col : byte) : MatrixPtr;
var
  TempPtr : MatrixPtr;
begin
  TempPtr:= nil;
  GetMem(TempPtr,SizeOf(MatrixRec));
  if TempPtr = nil then begin
    CreateMatrix:= nil;
    Exit;
  end;
  with TempPtr^ do begin
    MatrixRow:= Row;
    MatrixCol:= Col;
    MatrixArray:= nil;
    GetMem(MatrixArray,Row*Col*SizeOf(MatrixElement));
    if MatrixArray = nil then begin
      FreeMem(TempPtr,SizeOf(MatrixRec));
      CreateMatrix:= nil;
      Exit;
    end;
  end;
  FillMatrix(TempPtr,0);
  CreateMatrix:= TempPtr;
end;


function DeleteMatrix(var MPtr : MatrixPtr) : boolean;
begin
  if MPtr = nil then DeleteMatrix:= FALSE
  else with MPtr^ do begin
    if MatrixArray <> nil then
      FreeMem(MatrixArray,MatrixRow*MatrixCol*SizeOf(MatrixElement));
    FreeMem(MPtr,SizeOf(MatrixRec));
    MPtr:= nil;
    DeleteMatrix:= TRUE;
  end;
end;


function CloneMatrix(MPtr : MatrixPtr) : MatrixPtr;
var
  TempPtr : MatrixPtr;
  i,j     : byte;
begin
  if MPtr = nil then CloneMatrix:= nil
  else with MPtr^ do begin
    TempPtr:= CreateMatrix(MPtr^.MatrixRow,MPtr^.MatrixCol);
    if TempPtr <> nil then begin
      for i:= 1 to MatrixRow do
        for j:= 1 to MatrixCol do
          SetMatrixElement(TempPtr,i,j,GetMatrixElement(MPtr,i,j));
      CloneMatrix:= TempPtr;
    end else CloneMatrix:= nil;
  end;
end;



function FillMatrix(MPtr : MatrixPtr;Value : MatrixElement) : boolean;
var
  i,j : byte;
begin
  if MPtr = nil then FillMatrix:= FALSE
  else with MPtr^ do begin
    for i:= 1 to MatrixRow do
      for j:= 1 to MatrixCol do
        SetMatrixElement(MPtr,i,j,Value);
    FillMatrix:= TRUE;
  end;
end;


function AssignMatrix(var MPtr1 : MatrixPtr;MPtr2 : MatrixPtr) : MatrixPtr;
begin
  DeleteMatrix(MPtr1);
  MPtr1:= MPtr2;
  AssignMatrix:= MPtr1;
end;


function DisplayMatrix(MPtr : MatrixPtr;_Int,_Frac : byte) : boolean;
var
  i,j : byte;
begin
  if MPtr = nil then DisplayMatrix:= FALSE
  else with MPtr^ do begin
    for i:= 1 to MatrixRow do begin
      for j:= 1 to MatrixCol do
        write(GetMatrixElement(MPtr,i,j) : _Int : _Frac);
      writeln;
    end;
    DisplayMatrix:= TRUE;
  end;
end;


function IsSingleMatrix(MPtr : MatrixPtr) : boolean;
begin
  if MPtr <> nil then with MPtr^ do begin
    if (MatrixRow = 1) and (MatrixCol = 1) then
      IsSingleMatrix:= TRUE
    else IsSingleMatrix:= FALSE;
  end else IsSingleMatrix:= FALSE;
end;


function IsSquareMatrix(MPtr : MatrixPtr) : boolean;
begin
  if MPtr <> nil then with MPtr^ do begin
    if MatrixRow = MatrixCol then
      IsSquareMatrix:= TRUE
    else IsSquareMatrix:= FALSE;
  end else IsSquareMatrix:= FALSE;
end;

function GetMatrixRow(MPtr : MatrixPtr) : byte;
begin
  if MPtr <> nil then GetMatrixRow:= MPtr^.MatrixRow
  else GetMatrixRow:= 0;
end;

function GetMatrixCol(MPtr : MatrixPtr) : byte;
begin
  if MPtr <> nil then GetMatrixCol:= MPtr^.MatrixCol
  else GetMatrixCol:= 0;
end;

procedure SetMatrixElement(MPtr : MatrixPtr;Row,Col : byte;Value : MatrixElement);
var
  TempPtr : ^MatrixElement;
begin
  if MPtr <> nil then
    if (Row <> 0) or (Col <> 0) then with MPtr^ do begin
      pointer(TempPtr):= pointer(MatrixArray);
      Inc(TempPtr,MatrixRow*(Col-1)+Row-1);
      TempPtr^:= Value;
    end;
end;


function GetMatrixElement(MPtr : MatrixPtr;Row,Col : byte) : MatrixElement;
var
  TempPtr : ^MatrixElement;
begin
  if MPtr <> nil then begin
    if (Row <> 0) and (Col <> 0) then with MPtr^ do begin
      pointer(TempPtr):= pointer(MatrixArray);
      Inc(TempPtr,MatrixRow*(Col-1)+Row-1);
      GetMatrixElement:= TempPtr^;
    end else GetMatrixElement:= 0;
  end else GetMatrixElement:= 0;
end;


function ExcludeVectorFromMatrix(MPtr : MatrixPtr;Row,Col : byte) : MatrixPtr;
var
  NewPtr           : MatrixPtr;
  NewRow, NewCol   : byte;
  i,j              : byte;
  DiffRow, DiffCol : byte;
begin
  if MPtr <> nil then with MPtr^ do begin

    if Row = 0 then NewRow:= MatrixRow
    else NewRow:= MatrixRow-1;
    if Col = 0 then NewCol:= MatrixCol
    else NewCol:= MatrixCol-1;

    NewPtr:= CreateMatrix(NewRow, NewCol);
    if (NewPtr = nil) or (NewPtr^.MatrixArray = nil) then begin
      ExcludeVectorFromMatrix:= nil;
      Exit;
    end;

    DiffRow:= 0;
    DiffCol:= 0;
    for i:= 1 to MatrixRow do begin
      if i = Row then DiffRow:= 1
      else  for j:= 1 to MatrixCol do if j = Col then DiffCol:= 1
        else SetMatrixElement(NewPtr,i-DiffRow,j-DiffCol,
          GetMatrixElement(MPtr,i,j));
      DiffCol:= 0;
    end;

    ExcludeVectorFromMatrix:= NewPtr;
  end else ExcludeVectorFromMatrix:= nil;
end;


function SetVectorIntoMatrix(MPtr,VPtr : MatrixPtr;_Pos : byte) : MatrixPtr;
var
  TempPtr : MatrixPtr;
  i       : byte;
begin
  if (MPtr <> nil) and (VPtr <> nil) then begin
    TempPtr:= CloneMatrix(MPtr);
    if TempPtr = nil then begin
      SetVectorIntoMatrix:= nil;
      Exit;
    end;
    if VPtr^.MatrixRow = 1 then begin
      for i:= 1 to TempPtr^.MatrixCol do
        SetMatrixElement(TempPtr,_Pos,i,GetMatrixElement(VPtr,1,i));
    end else begin
      for i:= 1 to TempPtr^.MatrixRow do
        SetMatrixElement(TempPtr,i,_Pos,GetMatrixElement(VPtr,i,1));
    end;
    SetVectorIntoMatrix:= TempPtr;
  end else SetVectorIntoMatrix:= nil;
end;


function DetMatrix(MPtr : MatrixPtr) : MatrixElement;
var
  TempPtr : MatrixPtr;
  i,j     : byte;
  Sum     : MatrixElement;
begin
  if IsSquareMatrix(MPtr) then begin
    if not IsSingleMatrix(MPtr) then begin
      TempPtr:= nil;
      Sum:= 0;
      for j:= 1 to GetMatrixCol(MPtr) do begin
        AssignMatrix(TempPtr,ExcludeVectorFromMatrix(MPtr,1,j));
        Sum:= Sum+IntPower(-1,j+1)*GetMatrixElement(MPtr,1,j)*DetMatrix(TempPtr);
      end;
      DeleteMatrix(TempPtr);
      DetMatrix:= Sum;
    end else DetMatrix:= GetMatrixElement(MPtr,1,1);
  end else DetMatrix:= 0;
end;


function DetTriangularMatrix(MPtr : MatrixPtr) : MatrixElement;
var
  i       : byte;
  Sum     : MatrixElement;
begin
  if IsSquareMatrix(MPtr) then begin
    Sum:= 1;
    for i:= 1 to MPtr^.MatrixRow do
      Sum:= Sum*GetMatrixElement(MPtr,i,i);
    DetTriangularMatrix:= Sum;
  end else DetTriangularMatrix:= 0;
end;


function AppendixElement(MPtr : MatrixPtr;Row,Col : byte) : MatrixElement;
var
  TempPtr : MatrixPtr;
begin
  if IsSquareMatrix(MPtr) then begin
    TempPtr:= ExcludeVectorFromMatrix(MPtr,Row,Col);
    if TempPtr = nil then begin
      AppendixElement:= 0;
      Exit;
    end;
    AppendixElement:= IntPower(-1,Row+Col)*DetMatrix(TempPtr);
    DeleteMatrix(TempPtr);
  end else AppendixElement:= 0;
end;


function CreateAppendixMatrix(MPtr : MatrixPtr) : MatrixPtr;
var
  TempPtr : MatrixPtr;
  i,j     : byte;
begin
  if (MPtr <> nil) or (MPtr^.MatrixArray <> nil) or
     (not IsSquareMatrix(MPtr)) then with MPtr^ do begin
    TempPtr:= CreateMatrix(MatrixCol,MatrixRow);
    for i:= 1 to MatrixRow do
      for j:= 1 to MatrixCol do
        SetMatrixElement(TempPtr,i,j,AppendixElement(MPtr,i,j));
    CreateAppendixMatrix:= TempPtr;
  end else CreateAppendixMatrix:= nil;
end;



function TransponeMatrix(MPtr : MatrixPtr) : MatrixPtr;
var
  TempPtr : MatrixPtr;
  i,j     : byte;
begin
  if (MPtr <> nil) or (MPtr^.MatrixArray <> nil) then with MPtr^ do begin
    TempPtr:= CreateMatrix(MatrixCol,MatrixRow);
    for i:= 1 to MatrixRow do
      for j:= 1 to MatrixCol do
        SetMatrixElement(TempPtr,j,i,GetMatrixElement(MPtr,i,j));
    TransponeMatrix:= TempPtr;
  end else TransponeMatrix:= nil;
end;


function ReverseMatrix(MPtr : MatrixPtr) : MatrixPtr;
var
  TempPtr     : MatrixPtr;
  Determinant : MatrixElement;
begin
  if MPtr <> nil then begin
    TempPtr:= nil;
    AssignMatrix(TempPtr,CreateAppendixMatrix(MPtr));
    AssignMatrix(TempPtr,TransponeMatrix(TempPtr));
    Determinant:= DetMatrix(MPtr);
    if (TempPtr = nil) or (Determinant = 0) then begin
      DeleteMatrix(TempPtr);
      ReverseMatrix:= nil;
      Exit;
    end;
    AssignMatrix(TempPtr,MultipleMatrixOnNumber(TempPtr,1/Determinant));
    ReverseMatrix:= TempPtr;
  end else ReverseMatrix:= nil;
end;



function MultipleMatrixOnNumber(MPtr : MatrixPtr;Number : MatrixElement) : MatrixPtr;
var
  TempPtr : MatrixPtr;
  i,j     : byte;
begin
  if MPtr <> nil then with MPtr^ do begin
    TempPtr:= CreateMatrix(MatrixRow,MatrixCol);
    if TempPtr = nil then begin
      MultipleMatrixOnNumber:= nil;
      Exit;
    end;
    for i:= 1 to MatrixRow do
      for j:= 1 to MatrixCol do
        SetMatrixElement(TempPtr,i,j,GetMatrixElement(MPtr,i,j)*Number);
    MultipleMatrixOnNumber:= TempPtr;
  end else MultipleMatrixOnNumber:= nil;
end;


function MultipleMatrixOnMatrix(MPtr1,MPtr2 : MatrixPtr) : MatrixPtr;
var
  TempPtr : MatrixPtr;
  i,j,k   : byte;
begin
  if (MPtr1 <>  nil) and (MPtr2 <> nil) then begin
    TempPtr:= CreateMatrix(MPtr1^.MatrixRow,MPtr2^.MatrixCol);
    if TempPtr = nil then begin
      MultipleMatrixOnMatrix:= nil;
      Exit;
    end;
    for i:= 1 to TempPtr^.MatrixRow do
      for j:= 1 to TempPtr^.MatrixCol do
        for k:= 1 to MPtr1^.MatrixCol do
          SetMatrixElement(TempPtr,i,j,GetMatrixElement(TempPtr,i,j)+
            GetMatrixElement(MPtr1,i,k)*GetMatrixElement(MPtr2,k,j));
    MultipleMatrixOnMatrix:= TempPtr;
  end else MultipleMatrixOnMatrix:= nil;
end;



function AddMatrixOnMatrix(MPtr1,MPtr2 : MatrixPtr) : MatrixPtr;
var
  TempPtr : MatrixPtr;
  i,j,k   : byte;
begin
  if (MPtr1 <>  nil) and (MPtr2 <> nil) then begin
    TempPtr:= CreateMatrix(MPtr1^.MatrixRow,MPtr2^.MatrixCol);
    if TempPtr = nil then begin
      AddMatrixOnMatrix:= nil;
      Exit;
    end;
    for i:= 1 to TempPtr^.MatrixRow do
      for j:= 1 to TempPtr^.MatrixCol do
        SetMatrixElement(TempPtr,i,j,GetMatrixElement(Mptr1,i,j)+
          GetMatrixElement(MPtr2,i,j));
    AddMatrixOnMatrix:= TempPtr;
  end else AddMatrixOnMatrix:= nil;
end;


function SubMatrixOnMatrix(MPtr1,MPtr2 : MatrixPtr) : MatrixPtr;
var
  TempPtr : MatrixPtr;
  i,j,k   : byte;
begin
  if (MPtr1 <>  nil) and (MPtr2 <> nil) then begin
    TempPtr:= CreateMatrix(MPtr1^.MatrixRow,MPtr2^.MatrixCol);
    if TempPtr = nil then begin
      SubMatrixOnMatrix:= nil;
      Exit;
    end;
    for i:= 1 to TempPtr^.MatrixRow do
      for j:= 1 to TempPtr^.MatrixCol do
        SetMatrixElement(TempPtr,i,j,GetMatrixElement(MPtr1,i,j)-
          GetMatrixElement(MPtr2,i,j));
    SubMatrixOnMatrix:= TempPtr;
  end else SubMatrixOnMatrix:= nil;
end;



function GausseMethodMatrix(MPtr,VPtr : MatrixPtr;var LPtr,UPtr,BPtr : MatrixPtr) : MatrixPtr;
var
  TempPtr  : MatrixPtr;
  TempVPtr : MatrixPtr;
  TempLPtr : MatrixPtr;
  TempUPtr : MatrixPtr;
  XSum     : MatrixElement;
  i,j,k    : byte;
begin
  if (MPtr <> nil) and (VPtr <> nil) then begin

    TempUPtr:= CloneMatrix(MPtr);
    if TempUPtr = nil then begin
      GausseMethodMatrix:= nil;
      Exit;
    end;
    TempLPtr:= CreateMatrix(MPtr^.MatrixRow,MPtr^.MatrixCol);
    if TempLPtr = nil then begin
      DeleteMatrix(TempUPtr);
      GausseMethodMatrix:= nil;
      Exit;
    end;
    TempVPtr:= CloneMatrix(VPtr);
    if TempVPtr = nil then begin
      DeleteMatrix(TempLPtr);
      DeleteMatrix(TempUPtr);
      GausseMethodMatrix:= nil;
      Exit;
    end;
    TempPtr:= CreateMatrix(MPtr^.MatrixRow,1);
    if TempPtr = nil then begin
      DeleteMatrix(TempVPtr);
      DeleteMatrix(TempLPtr);
      DeleteMatrix(TempUPtr);
      GausseMethodMatrix:= nil;
      Exit;
    end;

    for j:= 1 to MPtr^.MatrixCol-1 do begin
      SetMatrixElement(TempLPtr,j,j,1);
      for i:= j+1 to MPtr^.MatrixRow do begin
        SetMatrixElement(TempLPtr,i,j,GetMatrixElement(TempUPtr,i,j)/
          GetMatrixElement(TempUPtr,j,j));
        for k:= j to MPtr^.MatrixCol do begin
          SetMatrixElement(TempUPtr,i,k,GetMatrixElement(TempUPtr,i,k)-
            GetMatrixElement(TempLPtr,i,j)*GetMatrixElement(TempUPtr,j,k));
        end;
        SetMatrixElement(TempVPtr,i,1,GetMatrixElement(TempVPtr,i,1)-
          GetMatrixElement(TempLPtr,i,j)*GetMatrixElement(TempVPtr,j,1));
      end;
    end;

    SetMatrixElement(TempLPtr,TempLPtr^.MatrixRow,TempLPtr^.MatrixCol,1);
    SetMatrixElement(TempPtr,TempPtr^.MatrixRow,1,
      GetMatrixElement(TempVPtr,TempVPtr^.MatrixRow,1)/
      GetMatrixElement(TempUPtr,TempUPtr^.MatrixRow,TempUPtr^.MatrixCol));

    for j:= MPtr^.MatrixCol-1 downto 1 do begin
      XSum:= 0;
      for k:= j+1 to MPtr^.MatrixCol do
        XSum:= XSum+GetMatrixElement(TempUPtr,j,k)*
          GetMatrixElement(TempPtr,k,1);
      SetMatrixElement(TempPtr,j,1,(GetMatrixElement(TempVPtr,j,1)-XSum)/
        GetMatrixElement(TempUPtr,j,j));
    end;

    LPtr:= TempLPtr;
    UPtr:= TempUPtr;
    BPtr:= TempVPtr;
    GausseMethodMatrix:= TempPtr;
  end else GausseMethodMatrix:= nil;
end;

end.




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

Важные, на мой взгляд, замечания. НЕ СТЕСНЯЙТЕСЬ использовать подход, использующий стандартный тип Pascal - record - в объектах мало чего хорошего в межкомпиляторном взаимодействии. Да и, кстати, использование типа record до сих пор является самым быстрым способом математических расчетов, в отличиие от ООП. Частенько простое 2+2=4 дает существенный выигрыш по времени выполнения, по сравнению с объектным подходом, а если математических вычислений в Вашей программе великое множество....

Взято с

MDI приложения

MDI приложения

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

MediaPlayer

MediaPlayer

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

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

Memo too large

Memo too large

В BDE есть крутая ошибка, достаточно известная всем, кроме Borland'a. Поскольку они ее еще с 1й Delphi не исправили. Этот баг проявляется как Access Violation в программе при обращении к таблице IB, которая содержит более одного поля типа VARCHAR (или CHAR) размером > 255. Причем, первое поле меньшего, а второе большего размера. Если поменять местами поля или сделать их одного размера, то все нормально.

Эффект имеет место только с IB, вроде.

Взято из

Меню дочерних MDI-форм

Меню дочерних MDI-форм

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

Так, например, если ваше MDI-меню имеет:
[Файл] [Вид] [О программе] (со значениями индексов групп 1 5 10) (Значения не имеют никакого значения (извините за невольный каламбур), они используются только лишь для сортировки),

а меню дочерней MDI-формы имеет:
[Файл] [Редактирование] (и им присвоены значения 1 и 3),

то при открытии дочернего MDI-окна пункт меню [Файл] заменит соответствующий пункт меню родительской MDI-формы. Пункт меню [Редактирование] будет расположен перед пунктами [Вид] и [О программе] родительской формы.

Это может оказаться весьма полезным, поскольку меню [Файл] MDI-формы в нормальной ситуации может содержать меньшее количество пунктов меню по сравнению с ситуацией, когда имеется открытая дочерняя MDI-форма.

К примеру, в описанной выше ситуации в меню [Файл] MDI-формы необходимы только пункты [Сохранить] или [Закрыть], а в случае отсутствия дочерних окон - [Открыть] и [Новое].

Все описанные выше пункты вы должны ввести в меню дочерней формы, поскольку оно заменит существующий пункт [Файл].

Вы все еще можете использовать код родительской формы в дочерней.

Так, если у вас имеется процедура "parent.open1click", вы можете вызывать ее из меню [Файл] дочернего окна после его открытия.

Взято с

Menu

Menu

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















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

Мерцание формы

Мерцание формы

Как бы это осуществить рисование в окне без его дурацкого мерцания и без помощи создания виртуального изображения в памяти? WM_SETREDRAW здесь поможет?

Попробуйте этот код. Даже если некоторые компоненты имеют пару BeginUpdate / EndUpdate, то для таких компонентов, как TTreeView, интенсивное рисование может послужить причиной перемещения полосы прокрутки и появления других "барабашек". В таких ситуаций вместо дескриптора элемента управления используйте родительский дескриптор.



procedureBeginScreenUpdate(hwnd: THandle);
begin
  if (hwnd = 0) then
    hwnd := Application.MainForm.Handle;
  SendMessage(hwnd, WM_SETREDRAW, 0, 0);
end;

procedure EndScreenUpdate(hwnd: THandle; erase: Boolean);
begin
  if (hwnd = 0) then
    hwnd := Application.MainForm.Handle;
  SendMessage(hwnd, WM_SETREDRAW, 1, 0);
  RedrawWindow(hwnd, nil, 0, DW_FRAME + RDW_INVALIDATE +
    RDW_ALLCHILDREN + RDW_NOINTERNALPAINT);
  if (erase) then
    Windows.InvalidateRect(hwnd, nil, True);
end;

Взято из

Метрики принтера

Метрики принтера

При печати с помощью TPrinter могу ли я определить момент, когда достигнут конец листа? Возможно ли получить высоту базовой строки с назначенным шрифтом?

Font.Height дает вам высоту шрифта в пикселях с учетом интервала.
Как мне преобразовать высоту в пикселях в дюймы печатаемой страницы?

Не делайте этого, используйте у TPrinter свойства PageHeight и PageWidth.
Хорошо, но я еще что - то не учел.Например, я использую шрифт Courier New размером 9 точек:
Printer.Canvas.Font.Height = -12
Printer.PageHeight = 3150

Даже отбрасывая загадку унарного минуса, я получаю 3150 div 12, или 262 строк на страницу.

Посмотри электронную справку по теме 'Printer.Canvas.TextHeight'.Это свойство покажет вам, какую высоту будет использовать 'текущий шрифт'.Это то, что вы должны использовать для определения 'количество строк на странице'.Например, шрифт Courier New размером 9 точек имеет значение TextHeight, равное 40. Поделите 3150 на эту величину и вы получите 78 'строк', почти правильную величину для 9 - точечного шрифта, если принимать во внимание то, что на дюйме помещается примерно 8 строк.
Для определения количества точек на дюйм(как горизонтально, так и вертикально)можно использовать API функцию GetDeviceCaps.Полученные значения позволят вам правильно преобразовать пиксели в дюймы.
Значение - 12 для 9 - точечного шрифта Courier - это высота шрифта для устройства с разрешением 96 DPI(например, ваш экран).Попробуйте назначить величину 9 свойству Size после того как вы вызвали BeginDoc и посмотрите на значение свойства Height.Это должно быть значительно большей величиной.
Вызывая команду Printer.NewPage, вы _не_ начинаете печать очередной строки, а заставляете принтер закончить печать на текущем листе и начать печать сверху нового листа(кажется, принтер HPLJ IIIP понимает эту команду иначе).После вызова Printer.NewPage следующая строка печатается примерно в полдюйме от верха бумаги.
Кроме того, приведу здесь текст моей текущей программы для печати текста компонента Memo с заголовком на каждой странице:


procedurebtPrintMemoWithHeader(Memo: TCustomMemo;
  Printer: TPrinter;
  PrintDialog: TPrintDialog;
  HeaderText: string;
  TopMargin, BottomMargin, LeftMargin: Integer);
var
  FirstPage: Boolean;
  i, LinesPerPage, CurrentLine, Line: Integer;
  PrintText: System.Text;
  LeftMarginString, Header: string;
begin
  if PrintDialog.Execute then
    begin
      with Printer do
        begin
          AssignPrn(PrintText);
          Rewrite(PrintText);
{Заполняем левую часть строки определенным количеством пробелов.}
          LeftMarginString := '';
          for i := 0 to LeftMargin do
            LeftMarginString := LeftMarginString + ' ';
{Назначаем принтеру такой же шрифт, как и в компоненте Memo.:\}
          Canvas.Font := (Memo as TMemo).Font;
{Вычисляем количество строк на странице.}
          LinesPerPage := PageHeight div Canvas.TextHeight('X');
          LinesPerPage := LinesPerPage - 8 - TopMargin - BottomMargin;
          CurrentLine := LinesPerPage;
          FirstPage := True;
{Печать Memo.}
          for Line := 0 to Memo.Lines.Count - 1 do
            begin
{Если конец страницы, начинаем новую.}
              if CurrentLine >= LinesPerPage then
                begin
{Печатаем "Form Feed", если это не новая страница принтера.}
                  if not FirstPage then Write(PrintText, #12); {Если не первая страница, то меняем лист}
                  FirstPage := False;
{Печатаем определенное количество пустых строк для верхнего поля.}
                  for i := 0 to TopMargin do
                    Writeln(PrintText, '');
{Форматируем и печатаем строку заголовока.}
                  Header := Format('Страница %s     %s  %s     %s'#13#10,
                    [IntToStr(Printer.PageNumber), DateToStr(Date),
                    TimeToStr(Time), HeaderText]);
                  Write(PrintText, LeftMarginString);
                  Writeln(PrintText, Header);
{Сбрасываем номер текущей строки на 1 для следующей страницы.}
                  CurrentLine := 1;
                end;
{Печатаем строку из Memo.}
              Write(PrintText, LeftMarginString);
              Writeln(PrintText, Memo.Lines[Line]);
              Inc(CurrentLine);
            end;
          CloseFile(PrintText);
        end;
    end;
end;

Взято из

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

Сборник Kuliba

Midas и COM. Советы и Приемы

Midas и COM. Советы и Приемы

Автор: Bill Todd
Перевод: Михаил Голованов

Статья показывает, как писать приложения, использующие несколько модулей, которые связываются через COM и совместно используют Midas сервер. Освещаются вопросы перемещения файлов, массивов и других структур данных c использованием COM.

Вы можете не нуждаться в распределенных приложениях, но вы нуждаетесь в Midas

Borland разрабатывал Midas как инструмент для создания многоуровневых распределенных приложений. Но Midas - лучший способ построить любое приложение баз данных, особенно большое приложение, даже, когда Вы не нуждаетесь в распределенной базе данных.

Транзакции в настольных базах данных

Если Вы работаете с Paradox или Dbase таблицами, и нуждаетесь в поддержке транзакций, Вы ограничены, потому что единственный уровень изоляции транзакции read uncommited (также грязное чтение). Вдобавок ко всему, невозможно произвести откат при возникновении аварийной ситуации , т.е аварийный отказ может оставлять вашу базу данных в несогласованном состоянии. Однако, если Вы используете ClientDataSet, Вы действительно получаете транзакции и автоматический откат в аварийных ситуациях.

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

ClientDataSet содержит все изменения в памяти в свойстве Delta, пока Вы не вызывете ApplyUpdates. Это означает, что при аварии произойдет откат транзакции, потому что все изменения в Delta будут потеряны. Единственый недостаток в использовании ClientDataSet, то, что аварийный отказ, во время выполнения ApplyUpdates, может все еще оставлять вашу базу данных в несогласованном состоянии. Однако, Если Вы вызываете ApplyUpdates достаточно часто достаточно, чтобы гарантировать, что только несколько записей модифицируются, модификация происходит в течении долей секунды. Это - намного меньшее окно уязвимости, чем использование локальных транзакций, где база данных может находится в несогласованном состоянии с момента первого изменения до проведения или отката транзакции. Для пользователя, вручную вносящего изменения, это время может быть несколько минут.

Улучшение параллельности работы баз данных

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

Кэшируемые изменения были первоначально добавлены к Delphi, чтобы преодолеть эту проблему, и ClientDataSet является развитием этой идеи. Если Вы используете ClientDataSets, чтобы редактировать ваши данные, изменения сохранятся в локальной копии данных - в кэше ClientDataSet. База данных не содержит сделанных изменений, пока Вы не вызываете ApplyUpdates. Так как транзакция активна на сервере только, во время обращения к ApplyUpdates т.е обычно на доли секунды, блокировки не задерживается в течение длительного времени, и параллелизм улучшается.

Обеспечение нескольких платформ серверов баз данных

Предположим, что Вы пишете приложение для рынка. Вы знаете, что некоторые из ваших потенциальных заказчиков уже выбрали платформу сервера базы данных, так что Вы должны создать версии вашего приложения, для выполнения на Oracle, Microsoft SQL и Interbase. Компоненты, используемые, для работы с базами данных различны. Для Interbase самый лучший выбор Interbase Express, для MS SQL , самый лучший выбор - ADO Express и для Oracle, Вы можете использовать или BDE или ADO Express.

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

Создание модульных приложений

Объединение Midas с COM позволяет, создавать большие сложные приложения из множества COM серверов, которые совместно используют общее соединение базы данных. Использование Midas и COM вместе:

Делает групповую разработку проще, позволяя каждому члену группы работать над модулем, который может компилироваться и тестироваться независимо.
Делает многомодульные приложения проще - устанавлиаются только те модули, которые нужны пользователю.
Допускает, чтобы все модули совместно использовали общее соединение базы данных.
Делает модули доступными независимо от языка программирования, который используется.
Делает проще поддержку баз данных.
Следующие разделы этой статьи посвящены разработке простого приложения, которое показывает совместное использование Midas и COM. Также рассмотрены обратные вызовы от COM сервера к клиенту. Мы разработаем модульное приложение. Создадим очень простой пример, который состоит из Midas сервера и двух Midas клиентов. Первый Midas клиент будет главной формой приложения, отображающей данные из таблиц Customer и Order. Это приложение - EXE. Второй Midas клиент отобразит данные из таблицы Order и выполнен как внутренний сервер автоматизации. Midas сервер также выполнен как DLL внутреннего сервера автоматизации. Роли трех модулей могут немного смутить Вас. Чтобы разъяснить кто, что делает следующая таблица показывает каждое приложение и его назначение

Приложение Назначение Роль Реализация
DemoDllServer Обеспечивает соединение с базой данных Midas сервер ActiveX Library DLL
DemoClient Содержит форму для таблицы Customer Midas клиент
COM клиент EXE
DemoOrders Содержит форму таблицы Order Midas клиент COM сервер ActiveX Library DLL

Разработка Midas сервера

Midas сервер имеет только одну необычную возможность. Он выполнен как DLL, так что не будет отображать форму или показывать иконку в панели задач. В то время как наличие отображаемой формы сервера может быть допустимым для распределенной системы, где никто обычно не видит экран машины - Midas сервера, это - плохая идея для приложения, где сервер и клиент выполнится на одном PC, потому что пользователь может быть введен в заблуждение дополнительной иконкой и может пробовать закрывать сервер. Решение состоит в том, чтобы выполнить Midas сервер как DLL, так чтобы он не имел никакого интерфейса пользователя. При выполнении Midas сервера в виде DLL также улучшается производительность. Для создания Midas сервера как DLL, выберем меню File | New из меню и затем закладку ActiveX репозитария объектов. Двойным щелчком левой кнопки мыши на иконке ActiveX Library создаст новый проект ActiveX библиотеки. С тех пор как Midas использует COM, чтобы обработать связь между Midas клиентом и Midas сервером, ActiveX библиотека используется, чтобы обеспечить требуемую поддержку COM.

После этого процесс создания сервера в виде DLL ничем не отличается от разработки EXE. Выберите File | New, перейдите к странице Multitier, и добавьте Remote Data Module (удаленный модуль данных ) к проекту. Рисунок 1 показывает удаленный модуль данных для типового приложения.


Рис.1. Удаленный модуль данных
Это приложение написано в типичном стиле клиента / сервера. Когда пользователь открывает приложение, никакие данные не отображаются. Взамен пользователь должен ввести некоторые критерии выбора(выделения), которые выберут приемлемое число записей. Чтобы реализовать этот подход, предложение SQL для CustomerQry компонента:

select* from Customer
where CustNo = -1

Это позволяет открывать Customer ClientDataSet в приложении DemoClient немедленно без отображения любых данных, т.к нет никаких записей в таблице Customer, чей номер заказчика является отрицательным. И DataSetProvider (CustomerProv) и DataSource (CustomerSrc) соединены с CustomerQry, устанавкой их свойств DataSet в CustomerQry. В свойстве Options DataSetProvider poAllowCommandText установлен в True, так что клиентское приложение может изменять свойство SQL CustomerQry, чтобы выбрать различные записи из таблицы Customer. OrdersQry обеспечивает выборку записей текущего заказчика. Свойство SQL установлено в:

select * from Orders
where (CustNo =:CustNo)

Свойство DataSource установлено в CustomerSrc, таким образом значение параметра :CustNo будет обеспечено в соответствии с текущей записью в CustomerQry. Это приводит к сохранению в наборе данных Customer данных о заказах, в виде вложенного набора данных.

Приложение DemoOrders позволяет пользователю искать записи в таблице Order по номеру заказа или всем заказы по номеру заказчика. Чтобы обеспечивать доступ к всем заказам необходим второй компонент TQuery - OrdersAllQry, который не связан с CustomerQry. Свойство SQL установлено, чтобы не выбирать никаких записей, т.е номер заказа - минус один. DataSetProvider для OrdersAllQry также имеет poAllowCommandText равный True. Так как этот Midas сервер - DLL, Вы не можете зарегистрировать его, запустив на выполнение. Вместо этого, выберите Run | Register ActiveX Server из меню Delphi, чтобы cкомпилировать и затем зарегистрировать Midas сервер.

Midas сервер в типичных трех уровнех распределенных приложениях не, только обеспечивает соединение с базой данных, но может также обеспечивать бизнес логику или другие сервисы. Однако, в этой статье мы обсуждаем приложение, состоящее из нескольких модулей. Все модули будут Midas клиентами, использующими один Midas сервер и и клиент, и сервер работают на той же самой машине. Предположим, что Вы пишете приложение, используя эту архитектуру. Если Вы должны поддерживать несколько видов серверов баз данных, Вы можете захотеть ограничить код Midas сервера только, тем кодом, который является специфическими для специфической базы данных, типа Oracle или Microsoft SQL Server, и хранить весь общий для баз данных код клиентских модулях. Это позволит Вам, поддерживать несколько Midas серверов для различных баз данных без дублирования кода.

Разработка COM Клиента

Рисунок 2 показывает главную форму приложения. Она состоит из двух DBGRID и двух DBNAVIGATOR. Верхний DBGRID и DBNAVIGATOR отображают информацию о заказчике и нижний DBGRID и DBNAVIGATOR - таблицу заказов.

Модуль данных содержит компонент DCOMCONNECTION, два ClientDataSet и два DataSources. Имя DCOMCONNECTION компонента - DemoConn, и св-во ServerName установлено в DemoDllSrvr.DllDemoServer. Свойство RemoteServer CustomerCds установлено в DemoConn, и ProviderName установлено равным CustomerProv. Свойство DataSetField компонента OrdersCds установлено в CustomerCdsOrdersQry, чтобы получить данные из вложенного набора данных. Меню Edit содержит диалог поиска, который отображает диалог, показанный на рисунке 4. Диалог дает возможность выбирать заказчика по номеру или выбирать все записи с определенным состоянием, используя метод FindCustomer в модуле данных CustomerDm. Реализацию данного метода Вы можете посмотреть в коде приложения.



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

Создание COM сервера

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

Чтобы создать приложение Orders, выберите закладку ActiveX репозитарии и двойным щелчком мыши пункт ActiveX Library. Добавьте форму и модуль данных к приложению. Законченная форма изображена на рисунке 5 и модуль данных на рисунке 6.




Компонент DCOMCONNECTION на рисунке 6, OrdersConn, соединяется с Midas сервером, DemoDllSrvr.DllDemoServer, так же как компонент DCOMCONNECTION модуле данных заказчиков. Свойство RemoteServer OrdersCds установлено в OrdersConn, и ProviderName установлено в OrdersAllProv.

Следующий шаг превратит этоту DLL в сервер автоматизации. Вернитесь к закладке ActiveX репозитария, двойной щелчок на мастере построения объекта автоматизации (ActiveX Object), и введите значение OrdersServer для имени CoClass. Также проверьте установку переключателя Generate Event Support Code. В редакторе библиотеки типов (Type Library Editor) добавьте методы к интерфейсу IORDERSERVER (таблица) и затем нажмите кнопку Refresh.

Метод Параметры Возвращаемое значение
FindByOrderNo OrderNo long
FindByCustNo CustNo long
OpenOrdersForm
CloseOrders
FindCustomer
GetCustNo CustNo Variant *



procedure TOrderServer.FindByOrderNo(OrderNo: Integer);
begin
  OrderDm.FindByOrderNo(OrderNo);
end;

procedure TOrderServer.FindByCustNo(CustNo: Integer);
begin
  OrderDm.FindByCustNo(CustNo);
end;

procedure TOrderServer.OpenOrdersForm;
begin
  OrderDm := TOrderDm.Create(nil);
  OrderForm := TOrderForm.Create(nil);
  OrderForm.Show;
end;




рис.7. Методы FindByOrderNo, FindByCustNo, OpenOrdersForm



implementation
uses FindOrderF;
{$R *.DFM}

procedure TOrderDm.FindOrder;
{Displays the Find Order dialog. Calls the appropriate find method based on
which edit box on the Find Order dialog has a value.}
begin
  FindOrderForm := TFindOrderForm.Create(Self);
  try
    with FindOrderForm do
    begin
      ShowModal;
      if OrderNoEdit.Text <> '' then
        FindByOrderNo(StrToInt(OrderNoEdit.Text))
      else if CustNoEdit.Text <> '' then
        FindByCustNo(StrToInt(CustNoEdit.Text))
      else
        MessageDlg('You must enter an order number or customer number.',
          mtError, [mbOK], 0);
    end; //with
  finally
    FindOrderForm.Free;
  end; //try
end;

procedure TOrderDm.FindByOrderNo(OrderNo: Integer);
{Finds an Order record given its OrderNo.}
begin
  with OrdersCds do
  begin
    Close;
    CommandText := 'SELECT * FROM Orders WHERE ' +
      '(OrderNo = ' + IntToStr(OrderNo) + ')';
    Open;
  end;
end;




Рис. 8. Методы модуля данных OrdersDM



procedure TOrderDm.FindByCustNo(CustNo: Integer);
{Finds all of the Order records for the specified Customer.}
begin
  with OrdersCds do
  begin
    Close;
    CommandText := 'SELECT * FROM Orders WHERE ' + '(CustNo = ' +
      IntToStr(CustNo) + ')';
    Open;
  end;
end;




Первые два метода, FindByOrderNo и FindByCustNo вызывают методы с тем же самым именем в модуле данных заказов. Реализация модуля данных заказов приведена на рисунке 8. Оба метода закрывают ClientDataSet заказов, устанавливают новое SQL предложение в тексте команды и затем вновь открывают ClientDataSet. При открытии ClientDataSet значение в CommandText передается к Midas серверу и затем в свойство SQL компонента OrdersAllQry прежде, чем запрос будет открыт. Программа работы с заказчиками вызывает эти методы для поиска по номеру заказа или для вывода всех заказов, сделанных заказчиком. Третий метод, OpenOrdersForm, создает модуль данных, OrderDm, и отображает форму заказов OrdersForm. Программа работы с заказчиками вызывает этот метод для отображения формы заказов.

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

Обратный вызов COM клиенту

Используя вышеописанные методы наше приложение, может вызывать методы на COM сервере, чтобы сформировать заказ и найти заказы по номеру или по принадлежности к заказчику. Однако, COM сервер должен быть способным передавать данные клиенту по двум причинам. Первая, когда пользователь просматривает заказ, он должен иметь возможность отобразить запись заказчика для этого заказа. Другими словами, форма заказов должна уметь сообщить форме заказчика о необходимости найти нужного заказчика и отобразить себя. Вторая проблема состоит в том, что COM сервер показывает форму заказов в режиме modeless. Это означает, что COM клиент не может знать о закрытии COM сервер. Единственое решение состоит в том, что COM сервер должен сообщить COM клиенту, когда пользователь закрывает форму заказов.

Имеются три способа для связи сервера с клиентом.

Первый, добавить объект автоматизации к клиентскому приложению, так чтобы сервер мог соединяться с клиентом и вызывать методы интерфейса объекта автоматизации. Это означает, что приложение, которое содержит форму заказчика является, и COM клиентом, и COM сервером по отношению к DLL заказов и DLL является, и клиентом и сервером по отношению к приложению заказчика.


Второй метод включает создание интерфейса обратного вызова к клиентскому приложению. Чтобы сделать это, Вы должны добавить интерфейс клиенту и создавать экземпляр объекта, который реализует интерфейс. Когда COM клиент соединяется с COM сервером создается экземпляр объекта обратного вызова, затем вызывают метод COM сервера и передают ссылку на интерфейс, как параметр, к COM серверу. Используя эту ссылку сервер может вызывать методы клиента.


Третья методика позволяет серверу инициировать события на клиенте через dispinterface сервера. Это самый простой способ при реализации в Delphi 5 благодаря мастерам, которые делают большинство работы. Хотя данная методика имеет некоторые ограничения, она пригодна для большинства приложений, так что это - метод, используемый в этой статье. Ключ к использованию событий - установка переключателя Generate Event Support Code при добавлении объекта автоматизации к COM серверу. Установка переключателя добавляет два интерфейса к библиотеке типов COM сервера. Мы уже добавили методы первого интерфейса, IORDERSERVER. Второй интерфейс - dispatch интерфейс IORDERSERVEREVENTS. Настало время, чтобы открыть Редактор Библиотеки Типов снова и добавить два метода к интерфейсу IorderServerEvents. Первый OnCloseOrders и второй OnFindCustomer. После добавления события OnFindCustomer выберем закладку параметров, затем нажимаем кнопку Add, чтобы добавить новый параметр. Назовите параметр CustNo, тип Long. OnCloseOrders событие будет возникать, когда пользователь закрывает форму заказов, извещая COM клиента о возможности закрытия соединения с заказами на COM сервере. OnFindCustomer событие будет возникать, когда пользователь выбирает пункт меню View | Customer . Это событие сообщит COM клиенту, что необходимо найти и отобразить запись заказчика, чей номер соответствует номеру заказчика текущей записи заказа.


procedure TOrderServer.CloseOrders;
begin
  FEvents.OnCloseOrders;
end;

procedure TOrderServer.FindCustomer;
begin
  FEvents.OnFindCustomer(OrderDm.OrdersCdsCustNo.AsInteger);
end;

 


Рис.9 Генерация событий

Код обработчиков событий приведен на рисунке 9. CloseOrders и FindCustomer - методы, которые были добавлены к IORDERSERVER ранее. CloseOrders вызывается из обработчика события OnDestroy формы заказов. FindCustomer вызывается из обработчика события OnClick пункта меню View | Customer.

Чтобы вызывать эти методы, Вы должны иметь ссылку на объект OrderServer. Чтобы получать эту ссылку, сделаны два изменения, показанные на рисунках 10 и 11, в модуле OrdersAuto. Глобальная переменная OrderServer добавлена к разделу интерфейса модуля. Добавлена строка в методе Initialize объекта TORDERSERVER, устанавливающая глобальную переменню OrderServer в Self. Переменная OrderServer теперь обеспечивает ссылку на объект автоматизации OrderServer, который может использоваться, чтобы вызвать методы из формы Заказов в обработчике OnDestroy и обработчиком OnClick пункта меню или в любом месте приложения DemoOrders. Обратите внимание, что, если Вы только хотите возбуждать событие из метода в интерфейсе IORDERSERVER, Вы можете опускать эти два изменения. Мы нуждались в ссылке к объекту Automation только, потому что мы нуждались в генерации событий из в любом месте приложения.



var
  OrderServer: TOrderServer;




Рис. 10 Объявление переменной ссылки на объект автоматизации



procedure TOrderServer.Initialize;
begin
  inherited Initialize;
  FConnectionPoints := TConnectionPoints.Create(Self);
  if AutoFactory.EventTypeInfo <> nil then
    FConnectionPoint := FConnectionPoints.CreateConnectionPoint(
      AutoFactory.EventIID, ckSingle, EventConnect)
  else
    FConnectionPoint := nil;
  OrderServer := Self;
end;

 


Рис.11 Инициализация ссылки на OrderServer

Последний шаг реализация события в COM клиенте. В проекте DemoClient, открытом в IDE, выберите Project | Import Type Library из меню, чтобы отобразить диалог импорта, показанный на рисунке 12. Выберите библиотеку DemoOrders в окне списка, и удостоверьтесь, что флажок Generate Component Wrapper установлен. Это создаст компонент, типа TORDERSERVER, и добавит его к вашей палитре компонентов. Когда Вы нажмете кнопку Install, Вас будут спрашивать, хотите ли Вы устанавливать этот компонент в новый пакет или существующий пакет. Вы возможно найдете это более удобным поместить все компоненты сервера для проекта, над которым Вы работаете в их собственном пакете. Чтобы вы не делали, не устанавливайте этот компонент в существующие пакеты компонентов Delphi. Выбрав щелкните пакета ОК, затем Yes в диалоге, сообщающем Вам, что пакет будет сформирован и затем установлен. Компонент, который создан - оболочка вокруг COM сервера и может использоваться, чтобы соединиться с сервером и вызывать методы. Компонент OrderServer также имеет событие для каждого события, которое Вы добавили к интерфейсу IORDERSERVEREVENTS в COM сервере.



Рис.12 Диалог импорта библиотеки типов
Киньте TORDERSERVER компонент на форму заказчика, и назовите его OrderServer. Установите свойство AutoConnect в False, так что соединение с COM сервером не будет открыто автоматически, когда программа стартует. Переключитесь на закладку Events инспектора объектов, и создайте обработчики событий OnCloseOrders и OnFindCustomer . Код для обоих обработчиков события показывается на рисунке 13.



procedure TCustomerForm.OrderServerCloseOrders(Sender: TObject);
begin
  OrderServer.Disconnect;
end;

procedure TCustomerForm.OrderServerFindCustomer(Sender: TObject;
  CustNo: Integer);
begin
  CustomerDm.FindByCustNo(CustNo);
  Show;
end;

 


Рис. 13 Обработчики событий

Осталось реализовать обработчик события OnClick для меню File | Orders и всплывающее меню сетки Orders. Код для этих обработчиков события показывается на рисунке 14.



procedure TCustomerForm.Orders1Click(Sender: TObject);
begin
  OrderServer.Connect;
  OrderServer.OpenOrdersForm;
end;

procedure TCustomerForm.ShowThisOrder1Click(Sender: TObject);
begin
  with OrderServer do
  begin
    Connect;
    OpenOrdersForm;
    FindByOrderNo(CustomerDm.OrdersCds.FieldByName('OrderNo').AsInteger);
  end; //with
end;

procedure TCustomerForm.ShowAllOrdersForThisCustomer1Click(Sender: TObject);
begin
  with OrderServer do
  begin
    Connect;
    OpenOrdersForm;
    FindByCustNo(CustomerDm.OrdersCds.FieldByName('CustNo').AsInteger);
  end; //with
end;




Рис. 14 Обработчик пункта меню

Перемещение Данных Между Сервером и Клиентом

Что Вы делаете, когда хотите переместить данные, который не сохранены в таблице базы данных между COM сервером и COM клиентом? Заполните Variant, и передайте это как параметр. Обратите внимание, что я не говорю Midas сервера и клиента, а любого COM сервера и клиента. В то время как некоторые из методов в этом разделе будут демонстрироваться с Midas сервером, и клиент, будет использовать интерфейс IAPPSERVER они будут работать в равной степени хорошо работать между любым COM сервером и клиентом, использующим любой интерфейс.

Передача Табличных Данных

Если Вам необходимо передать табличные данные, самый простой способ - это использовать ClientDataSet и передать данные как показано в приложении PassData. Это приложение состоит из COM сервера и COM клиента. Основная форма клиента, показанная на рисунке 15, содержит Database, Query, DataSetProvider, ClientDataSet и DataSource, соединенный с DBGRID для отображения данных таблицы заказчика из DBDEMOS. Обработчик события OnClick кнопки Send Data показан на рисунке 16.



Рис. 15 Главная форма COM клиента



procedure TMainForm.SendBtnClick(Sender: TObject);
begin
  PassDataServer := CoPassData.Create;
  PassDataServer.PassData(CustCds.Data);
end;

 


Рис. 16 Обработчик события нажатия кнопки Send Data

Клиентское приложение использует модуль интерфейса библиотеки типов сервера, так что можно соединяться с сервером, вызывая coclass's сервера, использовать метод Create и получить ссылку интерфейс. PassDataServer объявлена как закрытая переменная формы типа - IPASSDATA. IPASSDATA - интерфейс, реализованный COM сервером. Вторая строка вызывает метод PassData интерфейса IPASSDATA и передает свойство Data ClientDataSet как параметр.

Рисунок 17 показывает метод PassData сервера. Этот метод получает параметр типа OleVariant, который используется, чтобы передать свойство Data ClientDataSet от клиента к серверу. Форма главного приложения сервера содержит ClientDataSet, DataSource и DBGRID. Код на рисунке 17 присваивает значение параметра CdsData свойству Data ClientDataSet и открывает ClientDataSet.



procedure TPassData.PassData(CdsData: OleVariant);
begin
  with MainForm.CustCds do
  begin
    Data := CdsData;
    Open;
  end; // with
end;

 


Рис 17 Метод PassData

Если необходимо передать изменения, которые были сделаны пользователем в ClientDataSet, содержащиеся в свойстве Delta ClientDataSet, добавьте другой параметр OleVariant, и присвойте дельту этому параметру. К сожалению, свойство Delta - доступно только для чтения, так что Вы не можете назначать параметр Delta свойству Delta ClientDataSet. Обратите внимание, что ClientDataSet не соединен с удаленным сервером или провайдером в этом примере, хотя это и возможно.

Передача данных Flat файла

Одна из интересных особенностей Midas - то, что данные, которые Midas сервер посылает клиенту, могут храниться где угодно. То есть не обязательно в таблице базы данных. Один из методов в приложении выборки PassOther обеспечивает данные Midas клиенту из CSV файла ASCII. Самый простой способ делать это состоит в том, чтобы разместить ClientDataSet и DataSetProvider в удаленном модуле данных сервера. Используйте инспектор объектов, чтобы редактировать свойство FieldDefs ClientDataSet и добавить определения полей. Затем написать обработчик события BeforeGetRecords для DataSetProvider, который получает данные, в этом случае из файла ASCII, и загрузит их в ClientDataSet. DataSetProvider затем получает данные из ClientDataSet и посылает их клиентскому приложению нормальным способом. Рисунок 18 показывает обработчик события BeforeGetRecords.



procedure TPassOther.TextProvBeforeGetRecords(Sender: TObject; var OwnerData:
  OleVariant);
var
  AFile: TextFile;
  FieldVals: TStringList;
  Rec: string;
begin
  FieldVals := TStringList.Create;
  try
    with TextCds do
    begin
      {If the ClientDataSet is active empty it otherwise create it using
      the FildDefs entered at design time. Calling CreateDataSet both
      creates the in memory dataset and opens the ClientDataSet.}
      if Active then
        EmptyDataSet
      else
        CreateDataSet;
      {Open the ASCII file.}
      AssignFile(AFile, OwnerData);
      Reset(AFile);
      {Loop through the ASCII file. Read each record and assign it to the
      CommaText property of the TStringList FieldVals.
      This parses the record and assigns each field to a string in the StringList.
      Insert a new record in the ClientDataSet
      and assign the StringList elements to the fields.}
      while not System.EOF(AFile) do
      begin
        Readln(AFile, Rec);
        FieldVals.Clear;
        FieldVals.CommaText := Rec;
        Insert;
        FieldByName('Name').AsString := FieldVals[0];
        FieldByName('Date').AsDateTime := StrToDate(FieldVals[1]);
        FieldByName('Unit').AsString := FieldVals[2];
        Post;
      end; //while
      System.CloseFile(AFile);
      {Be sure to reposition the ClientDataSet to the first record
      so the DataSetProvider will start with the first
      record when building its data packet to send to the client.}
      First;
    end; //with finally FieldVals.Free;
  end; //try
end;




В начале обработчика BeforeGetRecords создается StringList FieldVals, который используется для просмотра записей из разделенного запятой файла ASCII (csv). Затем это проверяет открытие ClientDataSet, и если он открыт очищает его. Если не открыт вызывает CreateDataSet который, и создает набор данных в памяти, используя FieldDefs, определенный во временя разработки и открывает ClientDataSet. AssignFile и Reset открывают файл ASCII. Обратите внимание, что имя файла в обращении к AssignFile - параметр OwnerData, переданный обработчику события. OwnerData позволяет клиенту передавать любую информацию серверу, устанавливая значение параметра OwnerData в событии BeforeGetRecords ClientDataSet клиентского приложения. OwnerData - Variant, Вы можете передавать любомой типу данных, включая массив вариантов. Это дает Вам возможность передать любое количество значений любого типа.

Цикл while читает запись из текстового файла в строковую переменную Rec, очищает StringList, и устанавливает значение свойства CommaText StringList в Rec. Когда Вы назначаете строку CommaText анализируется наличие любых запятых или пробелов, которые не включены в кавычки, и каждая подстрока записывается в элемент StringList.

Затем, новая запись вставляется в ClientDataset, и значения из StringList присваиваются полям. Новая запись закрепляется. По достижении конца текстового файла CloseFile закрывает файл ASCII. Затем, обращение к First перемещает курсор ClientDataSet к первой записи. Это важно, потому что DataSetProvider начнет с текущей записи, когда будет формировать пакет данных, чтобы послать клиенту. Если Вы оставляете ClientDataSet, позиционированный в последнюю запись, последняя запись единственная, которая будет послана Midas клиенту. В заключение, обращение к методу Free StringList освобождает память.

На клиентских местах все гораздо проще. Когда Вы открываете ClientDataSet в клиентском приложении генерируется событие BeforeGetRecords. Рисунок 19 показывает код для события клиента BeforeGetRecords.



procedure TMainDm.TextCdsBeforeGetRecords(Sender: TObject;
  var OwnerData: OleVariant);
begin
  {Assign the file name to OwnerData which is
  passed to the Midas client automatically.}
  OwnerData := ExtractFilePath(Application.ExeName) + 'text.txt';
end;




Рис. 19 Обработчик события BeforeGetRecords

Единственая вещь, которая выполняется здесь - то, что имя текстового файла записывается в параметр OwnerData. OwnerData автоматически отправляется Midas серверу, где, появляется как параметр для BeforeGetRecords события DataSetProvider.

Отсылка файла, который не требуется отображать пользователю

Использование ClientDataSet удобно для данных, которые Вы хотите отображать на форме. Но предположим, что Вы должны передать файл, который не надо отображать в ClientDataSet от COM сервера к клиенту. Это совершенно, просто, даже если Вы должны послать файл который является слишком большим, чтобы размещаться в память. Закладка File типового приложения содержит кнопку Copy File и компонент Memo. Рисунок 20 - код из обработчика события OnClick этой кнопки. Процедура начинается с объявления константы ArraySize, которая содержит размер массива, используемого для передачи файлов от COM сервера к клиенту. Эта типовая программа отображает блоки чтения данных из сервера в компоненте Memo на форме. В приложении, где Вы передаете большое количество данных и сохраняете их в памяти или пишете в файлу, Вы могли бы использовать намного больший размер массива, например 4КБ или 16КБ, чтобы передать большее количество данных за одно обращения к серверу.

Так как мы хотим помещать данные в компонент Memo, строка байтов, возвращенных из сервера должна быть интерпретирована как строковая переменная, в этом случае S. Обращение к SetLength устанавливает размер S равным размеру массива. Затем компонент DCOMCONNECTION открывается, чтобы установить соединение с сервером, и Memo очищается.

Пересылка файла выполнена тремя пользовательскими методами, добавленными к интерфейсу приложения IAPPSERVER сервера, используя Редактор Библиотеки типов. Первый, OpenFile, берет один параметр - имя файла, который будет перемещен. Цикл while вызывает второй метод IAPPSERVER, GetFileData. GetFileData передает вариант, VDATA, как возвращаемый параметр и размер массива и возвращает число байт фактически прочитанных из файла. Это будет размер массива для каждого блока за исключением последнего, который может содержать меньшее количество байтов, если размер файла - не четный множитель блочного размера. Если число байтов, возвращенных обращением к GetFileData - нуль, конец файла был достигнут, и цикл с условием продолжения покидается.

Следующий шаг должен поместить байты, возвращенные в массиве в строковую переменную, S, и добавлять строку к компоненту Memo. Чтобы обращаться к данным в вариантном массиве, быстрее массив блокирован обращением к VarArrayLock (VDATA), который возвращает указатель на фактический массив данных в варианте. Указатель сохраняется в переменной PDATA, которая объявлена с типом PBYTEARRAY. PBYTEARRAY объявлен в модуле System как указатель на массив типа "байт". Данные перемещаются от массива в строковую переменную вызывом Move(PDATA ^, S [1], ByteCount). Процедура Move копирует определенное число байтов из одного участка в памяти в другой. Первый параметр - исходное расположение, второй параметр - адресат, и третий параметр - число копируемых байтов. Обратите внимание, что Move не выполняет никакую проверку ошибок любого вида, так будьте внимательным, чтобы использовать правильные параметры, потому что странные вещи случатся во времени выполнения, если Вы записываете в неправильную область памяти. Кроме того, Move не выполняет никакой контроль соответствия типов. Вы можете перемещать любую комбинацию разрядов в строку или любой другой вид переменной. Если только данные переместились от массива в строку, массив разблокируется, и строка добавляется в Memo.После копирования происходит обращение к третьему методу IAPPSERVER - CloseFile для закрытия файл на сервере.



procedure TMainForm.CopyFileBtnClick(Sender: TObject);
const
  ArraySize = 20;
var
  VData: Variant;
  PData: PByteArray;
  S: string;
  ByteCount: Integer;
begin
  with MainDm.Conn do
  begin
    {Allocate the string variable S to hold the number of bytes
    returned in the variant array.}
    SetLength(S, ArraySize);
    {Connect to the Midas server and empty the memo component.}
    if not Connected then
      Open;
    Memo.Lines.Clear;
    {Call the server's OpenFile method. This creates the TFileStream
    on the server that is used to read the file. The name of the file
    to read is passed as a parameter.}
    AppServer.OpenFile(ExtractFilePath(Application.ExeName) + 'text.txt');
    {Read data from the server until the entire file has been read.}
    while True do
    begin
      {Read a block of data from the server. GetFileData returns the actual
      number of bytes read. The parameter is a variant array of bytes
      passed by reference.}
      VData := Unassigned;
      ByteCount := AppServer.GetFileData(VData, ArraySize);
      {If the number of bytes read is zero the end of the file has been reached.}
      if ByteCount = 0 then
        Break;
      {Lock the variant array and get a pointer to the array values.}
      PData := VarArrayLock(VData);
      try
        {The read that reaches the end of the file may return fewer bytes
     than requested. If so, resize the string variable to hold the
     number of bytes actually read.}
        if ByteCount < ArraySize then
          SetLength(S, ByteCount);
        {Move the data from the variant array to the string variable.}
        Move(PData^, S[1], ByteCount);
      finally
        VarArrayUnlock(VData);
      end; //try
      Memo.Lines.Add(S);
    end; //while
    AppServer.CloseFile;
  end; //with
end;




На стороне сервера методы OpenFile, GetFileData и CloseFile были добавлены к интерфейсу IAPPSERVER, используя редактор библиотеки типа. Рисунок 21 показывает код из удаленного модуля данных для OpenFile метода. OpenFile содержит одиночную строку программы, которая создает объект FileStream для файла, переданного как параметр метода. Файл открыт в режиме чтения и разделен для чтения, но никакая запись не допускается. FileStream назначен к переменной Fs, которая является закрытой переменной удаленного модуля данных.



procedure TPassOther.OpenFile(FileName: OleVariant);
begin
  {Create the TFileStream object in read mode. Allow other applications
  to read the text file but not write to it.}
  Fs := TFileStream.Create(FileName, fmOpenRead or fmShareDenyWrite);
end;




Рис. 21 Метод OpenFile

Рисунок 22 показывает метод GetFileData. Этот метод имеет выходной параметр, который является вариантом и возвращает массив байтов, содержащих данные файла. После создания вариантного массива GetFileData блокирует его для быстрого доступа и получает указатель, возвращенный VarArrayLock в локальную переменную PDATA. Затем вызывается метод чтения FileStream, передавая адрес PDATA, указывающий на массив, чтобы сохранить данные и передающий VarArrayHighBound (Данные, 1) + 1, поскольку число байтов всегда равно размеру массива. Число байтов прочитанных фактически возвращается функцией. В заключение, обращение к VarArrayUnlock разблокирует вариантный массив.



function TPassOther.GetFileData(out Data: OleVariant;
  ArraySize: Integer): Integer;
var
  PData: PByteArray;
begin
  Data := VarArrayCreate([0, ArraySize - 1], varByte);
  {Lock the variant array and get a pointer to the array of bytes.
   This makes access to the variant array much faster.}
  PData := VarArrayLock(Data);
  try
    {Read data from the TFileStream. The number of bytes to read is
    the high bound of the variant array plus one (because the array
    is zero based). The number of bytes actually read is
    returned by this function.}
    Result := Fs.Read(PData^, VarArrayHighBound(Data, 1) + 1);
  finally
    VarArrayUnlock(Data);
  end; //try
end;




Рис. 22 Метод GetFileData

Рисунок 23 показывает метод CloseFile, который освобождает объект FileStream и устанавливает переменную Fs к nil. Обработчик события OnDestroy для удаленного модуля данных также освобождает FileStream, если Fs - не nil, на случай если клиентская программа не вызывает CloseFile.



procedure TPassOther.CloseFile;
begin
  if Assigned(Fs) then
  begin
    Fs.Free;
    Fs := nil;
  end;
end;

 


Рис. 23 Метод CloseFile

Пересылка массивов или других структур, находящихся в памяти

Вы можете также переслать массив или любую другую структуру данных, которая существует в памяти, заполняя в вариантный массив байтов. Рисунок 24 показывает метод выборки GetArray Midas сервера. Этот метод объявляет массив Integer размером 10 элементов. Вариант, VDATA, передан по ссылке клиентским приложением. GetArray вызывает VarArrayCreate, чтобы создать вариантный массив байтов, чей размер равнен размеру целочисленного массива, который будет возвращен. Затем вариантный массив блокируется, целочисленный массив перемещается в него, и вариантный массив разблокируется.



procedure TPassOther.GetArray(var VData: OleVariant);
var
  IntArray: array[1..10] of Integer;
  I: Integer;
  PData: PByteArray;
begin
  {Put some numbers in the array.}
  for I := 1 to 10 do
    IntArray[I] := I;
  {Create the variant array of bytes. Set the upper bound to the size
  of the array minus one because the array is zero based.}
  VData := VarArrayCreate([0, SizeOf(IntArray) - 1], varByte);
  {Lock the variant array for faster access then copy the array to the
  variant array and unlock the variant array.}
  PData := VarArrayLock(Vdata);
  try
    Move(IntArray, PData^, SizeOf(IntArray));
  finally
    VarArrayUnlock(VData);
  end; //try
end;




Рис. 24 Метод GetArray



procedure TMainForm.CopyArrayBtnClick(Sender: TObject);
var
  IntArray: array[1..10] of Integer;
  VData: Variant;
  PData: PByteArray;
  I: Integer;
begin
  {Connect to the server application.}
  if not MainDm.Conn.Connected then
    MainDm.Conn.Open;
  {Call the server's GetArray method and pass a variant parameter.}
  MainDm.Conn.AppServer.GetArray(VData);
  {Lock the variant array, copy the data to the
  array and unlock the variant array.}
  PData := VarArrayLock(VData);
  try
    Move(PData^, IntArray, SizeOf(IntArray));
  finally
    VarArrayUnlock(VData);
  end; //try
  {Display the array values in the memo.}
  for I := 1 to 10 do
    ArrayMemo.Lines.Add(IntToStr(IntArray[I]));
end;




Рис.25 Обработчик OnClick

Рисунок 25 показывает OnClick обработчик события для кнопки Copy Array в приложении PassOther. Этот метод соединяется с Midas сервером, вызывая метод Open компонента DcomConnection. Затем вызывает GetArray метод сервера, передавая вариант как параметр. Затем вариант который теперь содержит массив блокируется и данные перемещаются из вариантного массива байтов в целочисленный массив IntArray. В заключение вариантный массив разблокируется, и целые числа отображаются в компоненте Memo на форме.

Заключение

Midas обеспечивает мощный гибкий способ работs с и локальными базами и c удаленными серверами. Это оказывается настолько полезным, чтобы стать краеугольным камнем нового Borland DB Express.

От переводчика:

К сожалению из-за большого объема данной статьи невозможно до конца выправить стилистику и т.д. Если Вы обнаружили какие-либо ошибки, имеете вопросы и предложения, я с радостью приму их по адресу mgoblin@mail.ru.

Взято с

Минимальное оконное приложение без VCL

Минимальное оконное приложение без VCL

program WinMin;

uses Windows, Messages;

const AppName = 'WinMin';

Var 
Window : HWnd;   
Message : TMsg;   
WindowClass : TWndClass;   

function WindowProc (Window : HWnd; Message, WParam : Word; LParam : LongInt) : LongInt; stdcall;
begin
WindowProc := 0;  
case Message of  
wm_Destroy :begin   
PostQuitMessage (0);   
Exit;   
end;  
end; // case  
WindowProc := DefWindowProc (Window, Message, WParam, LParam);   
end;

begin
with WindowClass do   
begin  
Style := cs_HRedraw or cs_VRedraw;   
lpfnWndProc := @WindowProc;   
cbClsExtra := 0;   
cbWndExtra := 0;   
hInstance := 0;   
hIcon := LoadIcon (0, idi_Application);  
hCursor := LoadCursor (0, idc_Arrow);   
hbrBackground := GetStockObject (White_Brush);   
lpszMenuName := '';   
lpszClassName := AppName;   
end;  
If RegisterClass (WindowClass) = 0 then Halt (255);   
Window := CreateWindow(AppName,   
'Win_Min',   
ws_OverlappedWindow,   
cw_UseDefault,   
cw_UseDefault,   
cw_UseDefault,   
cw_UseDefault,   
0,   
0,   
HInstance,   
nil);   
ShowWindow (Window, CmdShow);   
UpdateWindow (Window);   
while GetMessage (Message, 0, 0, 0) do   
begin  
TranslateMessage (Message);   
DispatchMessage (Message);   
end;  
Halt   
end.

М. Краснов. "OpenGL и графика в проектах Delphi".

Пример прислан Spawn
Взято с Vingrad.ru

Мне нужны временные таблицы, но их нет в IB. Что делать?

Мне нужны временные таблицы, но их нет в IB. Что делать?

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


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

Многострочные ячейки в StringGrid.

Многострочные ячейки в StringGrid.

Сперва необходимо установить свойство DefaultDrawing в False. Далее, необходимо вставить следующий код в обработчик события OnDrawCell:


procedure TForm1.StringGrid1DrawCell(Sender: TObject;
                                     Col, Row: Longint;
                                     Rect: TRect;
                                     State: TGridDrawState);
var
   Line1: string;
   Line2: string;
   ptr: integer;
   padding: integer;
   hGrid: TStringGrid;

begin
  hGrid:= (Sender as TStringGrid);
  ptr := Pos(';', hGrid.Cells[Col, Row]);
  if ptr > 0 then
  begin
     Line1 := Copy(hGrid.Cells[Col, Row], 1, ptr - 1);
     Line2 := Copy(hGrid.Cells[Col, Row], ptr + 1,
                   Length(hGrid1.Cells[Col,Row]) - ptr);
  end
  else Line1 := hGrid.Cells[Col, Row];
  hGrid.Canvas.FillRect(Rect);
  hGrid.Canvas.TextOut(Rect.Left, Rect.Top + 2, Line1);
  if ptr > 0 then
     hGrid.Canvas.TextOut(Rect.Left, Rect.Top -
                          hGrid.Canvas.Font.Height + 3, Line2);
end;

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

StringGrid1.RowHeights[0] := StringGrid1.DefaultRowHeight * 2 ;



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

Модем

Модем

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

Модификация настроек BDE

Модификация настроек BDE

Is there a way to change the IDAPI.CFG file from Delphi coding using the BDE API, since I wish to avoid having my users utilize the BDECFG.EXE utility?

Answer:

Here is a unit that is supposed to allow changing the config file:

unitCFGTOOL;

interface

uses
  SysUtils, Classes, DB, DbiProcs, DbiTypes, DbiErrs;

type
  TBDEConfig = class(TComponent)
  private
    FLocalShare: Boolean;
    FMinBufSize: Integer;
    FMaxBufSize: Integer;
    FSystemLangDriver: string;
    FParadoxLangDriver: string;
    FMaxFileHandles: Integer;
    FNetFileDir: string;
    FTableLevel: string;
    FBlockSize: Integer;
    FDefaultDriver: string;
    FStrictIntegrity: Boolean;
    FAutoODBC: Boolean;

    procedure Init;
    procedure SetLocalShare(Value: Boolean);
    procedure SetMinBufSize(Value: Integer);
    procedure SetMaxBufSize(Value: Integer);
    procedure SetSystemLangDriver(Value: string);
    procedure SetParadoxLangDriver(Value: string);
    procedure SetMaxFileHandles(Value: Integer);
    procedure SetNetFileDir(Value: string);
    procedure SetTableLevel(Value: string);
    procedure SetBlockSize(Value: Integer);
    procedure SetDefaultDriver(Value: string);
    procedure SetAutoODBC(Value: Boolean);
    procedure SetStrictIntegrity(Value: Boolean);
    procedure UpdateCFGFile(path, item, value: string);

  protected

  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
  published
    property LocalShare: Boolean read FLocalShare write SetLocalShare;
    property MinBufSize: Integer read FMinBufSize write SetMinBufSize;
    property MaxBufSize: Integer read FMaxBufSize write SetMaxBufSize;
    property SystemLangDriver: string read FSystemLangDriver write
      SetSystemLangDriver;
    property ParadoxLangDriver: string read FParadoxLangDriver write
      SetParadoxLangDriver;
    property MaxFileHandles: Integer read FMaxFileHandles write SetMaxFileHandles;
    property NetFileDir: string read FNetFileDir write SetNetFileDir;
    property TableLevel: string read FTableLevel write SetTableLevel;
    property BlockSize: Integer read FBlockSize write SetBlockSize;
    property DefaultDriver: string read FDefaultDriver write SetDefaultDriver;
    property AutoODBC: Boolean read FAutoODBC write SetAutoODBC;
    property StrictIntegrity: Boolean read FStrictIntegrity write SetStrictIntegrity;

  end;

procedure Register;

implementation

function StrToBoolean(Value: string): Boolean;
begin
  if (UpperCase(Value) = 'TRUE') or (UpperCase(Value) = 'ON') or
    (UpperCase(Value) = 'YES') or (UpperCase(Value) = '.T.') then
    Result := True
  else
    Result := False;
end;

function BooleanToStr(Value: Boolean): string;
begin
  if Value then
    Result := 'TRUE'
  else
    Result := 'FALSE';
end;

procedure Register;
begin
  RegisterComponents('Data Access', [TBDEConfig]);
end;

procedure TBDEConfig.Init;
var
  h: hDBICur;
  pCfgDes: pCFGDesc;
  n, v: string;
begin
  Check(DbiOpenCfgInfoList(nil, dbiREADWRITE, cfgPersistent, '\SYSTEM\INIT', h));
  GetMem(pCfgDes, sizeof(CFGDesc));
  try
    FillChar(pCfgDes^, sizeof(CFGDesc), #0);
    while (DbiGetNextRecord(h, dbiWRITELOCK, pCfgDes, nil) = DBIERR_NONE) do
    begin
      n := StrPas(pCfgDes^.szNodeName);
      v := StrPas(pCfgDes^.szValue);
      if n = 'LOCAL SHARE' then
        FLocalShare := StrToBoolean(v)
      else if n = 'MINBUFSIZE' then
        FMinBufSize := StrToInt(v)
      else if n = 'MAXBUFSIZE' then
        FMaxBufSize := StrToInt(v)
      else if n = 'MAXFILEHANDLES' then
        FMaxFileHandles := StrToInt(v)
      else if n = 'LANGDRIVER' then
        FSystemLangDriver := v
      else if n = 'AUTO ODBC' then
        FAutoODBC := StrToBoolean(v)
      else if n = 'DEFAULT DRIVER' then
        FDefaultDriver := v;
    end;
    if (h <> nil) then
      DbiCloseCursor(h);
    Check(DbiOpenCfgInfoList(nil, dbiREADWRITE, cfgPersistent,
      '\DRIVERS\PARADOX\INIT', h));
    FillChar(pCfgDes^, sizeof(CFGDesc), #0);
    while (DbiGetNextRecord(h, dbiWRITELOCK, pCfgDes, nil) = DBIERR_NONE) do
    begin
      n := StrPas(pCfgDes^.szNodeName);
      v := StrPas(pCfgDes^.szValue);
      if n = 'NET DIR' then
        FNetFileDir := v
      else if n = 'LANGDRIVER' then
        FParadoxLangDriver := v;
    end;
    if (h <> nil) then
      DbiCloseCursor(h);
    Check(DbiOpenCfgInfoList(nil, dbiREADWRITE, cfgPersistent,
      '\DRIVERS\PARADOX\TABLE CREATE', h));
    FillChar(pCfgDes^, sizeof(CFGDesc), #0);
    while (DbiGetNextRecord(h, dbiWRITELOCK, pCfgDes, nil) = DBIERR_NONE) do
    begin
      n := StrPas(pCfgDes^.szNodeName);
      v := StrPas(pCfgDes^.szValue);
      if n = 'LEVEL' then
        FTableLevel := v
      else if n = 'BLOCK SIZE' then
        FBlockSize := StrToInt(v)
      else if n = 'STRICTINTEGRITY' then
        FStrictIntegrity := StrToBoolean(v);
    end;
  finally
    FreeMem(pCfgDes, sizeof(CFGDesc));
    if (h <> nil) then
      DbiCloseCursor(h);
  end;
end;

procedure TBDEConfig.SetLocalShare(Value: Boolean);
begin
  UpdateCfgFile('\SYSTEM\INIT', 'LOCAL SHARE', BooleanToStr(Value));
  FLocalShare := Value;
end;

procedure TBDEConfig.SetMinBufSize(Value: Integer);
begin
  UpdateCfgFile('\SYSTEM\INIT', 'MINBUFSIZE', IntToStr(Value));
  FMinBufSize := Value;
end;

procedure TBDEConfig.SetMaxBufSize(Value: Integer);
begin
  UpdateCfgFile('\SYSTEM\INIT', 'MAXBUFSIZE', IntToStr(Value));
  FMaxBufSize := Value;
end;

procedure TBDEConfig.SetSystemLangDriver(Value: string);
begin
  UpdateCfgFile('\SYSTEM\INIT', 'LANGDRIVER', Value);
  FSystemLangDriver := Value;
end;

procedure TBDEConfig.SetParadoxLangDriver(Value: string);
begin
  UpdateCfgFile('\DRIVERS\PARADOX\INIT', 'LANGDRIVER', Value);
  FParadoxLangDriver := Value;
end;

procedure TBDEConfig.SetMaxFileHandles(Value: Integer);
begin
  UpdateCfgFile('\SYSTEM\INIT', 'MAXFILEHANDLES', IntToStr(Value));
  FMaxFileHandles := Value;
end;

procedure TBDEConfig.SetNetFileDir(Value: string);
begin
  UpdateCfgFile('\DRIVERS\PARADOX\INIT', 'NET DIR', Value);
  FNetFileDir := Value;
end;

procedure TBDEConfig.SetTableLevel(Value: string);
begin
  UpdateCfgFile('\DRIVERS\PARADOX\TABLE CREATE', 'LEVEL', Value);
  FTableLevel := Value;
end;

procedure TBDEConfig.SetBlockSize(Value: Integer);
begin
  UpdateCfgFile('\DRIVERS\PARADOX\TABLE CREATE', 'BLOCK SIZE', IntToStr(Value));
  FBlockSize := Value;
end;

procedure TBDEConfig.SetStrictIntegrity(Value: Boolean);
begin
  UpdateCfgFile('\DRIVERS\PARADOX\TABLE CREATE', 'STRICTINTEGRITY',
    BooleanToStr(Value));
  FStrictIntegrity := Value;
end;

procedure TBDEConfig.SetDefaultDriver(Value: string);
begin
  UpdateCfgFile('\SYSTEM\INIT', 'DEFAULT DRIVER', Value);
  FDefaultDriver := Value;
end;

procedure TBDEConfig.SetAutoODBC(Value: Boolean);
begin
  UpdateCfgFile('\SYSTEM\INIT', 'AUTO ODBC', BooleanToStr(Value));
  FAutoODBC := Value;
end;

procedure TBDEConfig.UpdateCFGFile;
var
  h: hDbiCur;
  pCfgDes: pCFGDesc;
  pPath: array[0..127] of char;
begin
  StrPCopy(pPath, Path);
  Check(DbiOpenCfgInfoList(nil, dbiREADWRITE, cfgPersistent, pPath, h));
  GetMem(pCfgDes, sizeof(CFGDesc));
  try
    FillChar(pCfgDes^, sizeof(CFGDesc), #0);
    while (DbiGetNextRecord(h, dbiWRITELOCK, pCfgDes, nil) = DBIERR_NONE) do
    begin
      if StrPas(pCfgDes^.szNodeName) = item then
      begin
        StrPCopy(pCfgDes^.szValue, value);
        Check(DbiModifyRecord(h, pCfgDes, True));
      end;
    end;
  finally
    FreeMem(pCfgDes, sizeof(CFGDesc));
    if (h <> nil) then
      DbiCloseCursor(h);
  end;
end;

constructor TBDEConfig.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  Init;
end;

destructor TBDEConfig.Destroy;
begin
  inherited Destroy;
end;

end.

Problem/Question/Abstract:

How can my program access the idapi.cfg file and probably change its INIT (Local Share etc.) section?

Answer:

For 32bit only. You can of course use the registry to determine the default CFG File instead of passing it as a parameter here:

procedure ModifyCFG(const ACFGFile, AValue, AEntry, ACFGPath: string; SaveAsWin31:
  bool);
var
  hCfg: hDBICfg;
  pRecBuf, pTmpRec: pByte;
  pFields: pFLDDesc;
  Count: word;
  i: integer;
  Save: boolean;
  Reg: TRegistry;
const
  RegSaveWIN31: array[bool] of string = ('WIN32', 'WIN31');
begin
  hCfg := nil;
  pFields := nil;
  pRecBuf := nil;
  Save := False;
  Check(DbiOpenConfigFile(PChar(ACFGFile), False, hCfg));
  try
    Check(DbiCfgPosition(hCfg, PChar(ACfgPath))); {neccessary...?}
    Check(DbiCfgGetRecord(hCfg, PChar(ACfgPath), Count, nil, nil));
    pRecBuf := AllocMem(succ(Count) * 128); {128 additional safety...}
    pFields := AllocMem(Count * sizeof(FLDDesc));
    Check(DbiCfgGetRecord(hCfg, PChar(ACfgPath), Count, pFields, pRecBuf));
    for i := 1 to Count do
    begin
      if StrPas(pFields^.szName) = AEntry then
      begin
        pTmpRec := pRecBuf;
        Inc(pTmpRec, 128 * (i - 1));
        StrPCopy(PChar(pTmpRec), AValue);
      end;
      inc(pFields);
    end;
    dec(pFields, Count);
    Check(DbiCfgModifyRecord(hCfg, PChar(ACfgPath), Count, pFields, pRecBuf));
    Save := True;
  finally
    if hCfg <> nil then
      Check(DbiCloseConfigFile(hCfg, Save, True, SaveAsWin31));
    if pRecBuf <> nil then
      FreeMem(pRecBuf, succ(Count) * 128);
    if pFields <> nil then
      FreeMem(pFields, Count * sizeof(FLDDesc));
  end;
  {update registry SAVECONFIG value}
  Reg := TRegistry.Create;
  try
    Reg.RootKey := HKEY_LOCAL_MACHINE;
    if not Reg.OpenKey('SOFTWARE\Borland\Database Engine', False) then
      ShowMessage('Configuration Path not found')
    else
    begin
      Reg.LazyWrite := False;
      Reg.WriteString('SAVECONFIG', RegSaveWIN31[SaveAsWin31]);
      Reg.CloseKey;
    end;
  finally
    Reg.Free;
  end;
  {DbiExit/Init to re-read cfg... make absolutely sure there are no active 
   DB components when doing this (it's is best done by a loader app)}
  Session.Close;
  Session.Open;
end;

ACFGPath would be '\SYSTEM\INIT\', AEntry would be 'LOCAL SHARE' und AValue would be 'TRUE' or 'FALSE'.

Взято с

Delphi Knowledge Base

Модуль данных для каждого MDIChild

Модуль данных для каждого MDIChild

Когда во время разработки вы устанавливаете "DataSource"-свойство в БД-компонентах для указания на модуль данных, VCL во время выполнения приложения будет пытаться создать связь с существующим TDataModule, основываясь на его свойтсве Name. Так, если вы добавите модуль данных к вашему проекту и переместите его в свойстве проекта из колонки автоматически создаваемых форм в колонку доступных, вы сможете разработать форму, содержащую элементы управления для работы с базами данных, после чего несколькими строчками кода можете создать экземпляр формы, имеющий экземпляр собственного модуля данных.

С помощью Репозитория создайте "standard MDI application" (стандартное MDI-приложение), в котором модуль TMDICHild будет похож на приведенный ниже. Добавленные строки имеют комментарий {!}. Хитрости спрятаны в конструкторе create и задании другого порядка следования операторов.

unitChildwin;

interface

uses Windows, Classes, Graphics, Forms, Controls,
  ExtCtrls, DBCtrls, StdCtrls, Mask, Grids, DBGrids,
  DataM; {!} // Модуль TDataModule1

type
  TMDIChild = class(TForm)
    DBGrid1: TDBGrid;
    DBGrid2: TDBGrid;
    DBEdit1: TDBEdit;
    DBEdit2: TDBEdit;
    DBNavigator1: TDBNavigator;
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
  private
    { Private declarations }
  public
    { Public declarations }
    {!} DM: TDataModule1;
    {!} constructor Create(AOwner: TComponent); override;
  end;

implementation

{$IFDEF XOXOXOX} // DataM должен находиться в секции interface. Необходимо для среды

uses DataM; // времени проектирования. Определение "XOXOXOX" подразумевает,
{$ENDIF} // что это никогда не будет определено, но чтобы компилятор видел это.

{$R *.DFM}

{!} constructor TMDIChild.Create;
{!}
begin
  {!} DM := TDataModule1.Create(Application);
  {!} inherited Create(AOwner);
  {!} DM.Name := '';
  {!}
end;

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

end.

Взято из

Моя собственная база данных

Моя собственная база данных

Моя собственная база данных
( Перевод одноимённой статьи с сайта delphi.about.com )

В статье рассматривается работа с бинарными файлами из Delphi, а так же использование Object Pascal для управления записью, чтением и изменением собственных типов файлов.

Постановка задачи: Допустим, мне нужно в приложении Delphi сохранять некоторую информацию на диск. Мне не охото работать с текстовыми файлами, так как просмотр и обновление информации в них довольно муторное занятие. Преобладать будут операции записи и чтения, в то время как операции изменения и апдейта будут присутствовать в меньшей степени. Вся информация будет хранится в переопределённом типе данных Pascal Record. Итак, какой подход мне лучше всего использовать?

BDE плюс Paradox или Access, ... спасибо, не надо...Не хотелось бы испытывать мороку с BDE. Использовать текстовые файлы ASCII ? Не пойдёт. Нужна хоть какая-то минимальная защита, а текстовые файлы "полностью видимы". Оказывается, ответ на данный вопрос кроется в Delphi, а именно в непечатных файлах (или файлы некоторых типов/бинарные файлы).

Файлы
В Delphi существует три класса файлов: typed, text, и untyped. Файлы typed - это файлы, которые содержат данные определённого типа, такие как Double, Integer или предварительно определённый тип Record. Текстовые файлы содержат читаемые символы ASCII. Файлы Untyped используются в том случае, если мы хотим работать с файлом через определённую структуру.

Файлы Typed
В отличие от тектовых файлов, которые содержат строки, завершающиеся комбинацией CR/LF, файлы typed содержат данные, взятые из определённой структуры данных.

Например, следующее объявление создаёт запись с именем TMember и массив переменных типа TMember, который мы будем использовать для хранения нашей информации.

type
  TMember = record
    Name : string[50];
    eMail : string[30];
    Posts : LongInt;
  end;
  
 var Members : array[1..50] of TMember;

Перед тем, как мы сможем записать информацию на диск, нам необходимо объявить переменную типа file. Следующая строка объявляет переменную файла F:

 var F : file of TMember;

Обратите внимание: Чтобы создать файл typed в Delphi, мы используем следующий синтакс:
var SomeTypedFile : file of SomeType
Базовый тип (SomeType) для файла может быть скалярным (наподобие Double), массивом или записью. Он не может быть длинной строкой, динамическим массивом, классом, объектом или указателем.

Чтобы начать работать с файлом из Delphi нам надо связать файл на диске с переменной файла в нашей программе. Для этого используем процедуру AssignFile.

 AssignFile(F, 'Members.dat')

Как только связь с внешним файлом установлена, переменную F необходимо 'открыть' для подготовки её к чтению или записи. Для открытия существующего файла мы используем процедуру Reset либо Rewrite для создания нового файла. После того, как программа закончит обработку файла, его необходимо закрыть при помощи процедуры CloseFile. Сразу после закрытия файла, связанный с ним внешний файл будет обновлён. Затем переменную файла можно связать с другим внешним файлом. Вообще, мы должны всегда производить обработку исключительных ситуаций, так как при работе с файлами может происходить довольно много ошибок. Например, если мы вызовем CloseFile для файла, который уже закрыт, то Delphi выдаст ошибку I/O. С другой стороны, если мы попробуем закрыть файл, до вызова AssignFile, то результаты могут быть непредсказуемыми.

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

 var F : file of TMember;
begin
 AssignFile(F,'members.dat');
 Rewrite(F);
 try
  for i:= 1 to 50 do
   Write (F, Members[i]);
 finally
  CloseFile(F);
 end;
end;

Чтение
Для получения всей информации из файла 'members.dat' используется следующий код:

 var Member: TMember
     F : file of TMember;
begin
 AssignFile(F,'members.dat');
 Reset(F);
 try
  while not Eof(F) do begin
   Read (F, Member);
 {  Что-нибудь делаем с данными; }
  end;
 finally
  CloseFile(F);
 end;
end;

Обратите внимание: Eof это функция проверки конца файла (EndOfFile). Мы используем эту функцию, чтобы не выйти за пределы файла (за пределы последней, сохранённой записи).

Поиск и позиционирование
Обычно, доступ к файлам осуществляется последовательно. При чтении из файла (используя стандартную процедуру Read) или при записи (используя стандартную процедуру Write), текущая позиция в файле перемещается на следующий по порядку компонент (следующая запись). К файлам typed так же можно обращаться через стандартную процедуру Seek, которая перемещает текущую позицию в файле на указанный компонент. Для определения текущей позиции в файле и размера файла можно использовать функции FilePos и FileSize.

{устанавливаем на начало -  на первую запись}
Seek(F, 0);

{устанавливаем на 5-ю запись}
Seek(F, 5);

{Переходим в конец - "после" последней записи}
Seek(F, FileSize(F));

Изменение и обновление
Мы разобрались как записывать и считывать из файла массив Members. А что, если нам нужно найти десятую запись и изменить в ней e-mail? Давайте посмотрим на процедуру, которая делает это:

procedure ChangeEMail
  (const RecN : integer; const NewEMail : string);
var DummyMember : TMember;
begin
 {связывание, открытие, блок обработки исключений}
 Seek(F, RecN);
 Read(F, DummyMember);
 DummyMember.Email := NewEMail;
 {чтение перемещается на следующую запись, для этого необходимо
 вернуться на первоначальную запись, а затем записать}
 Seek(F, RecN);
 Write(F, DummyMember);
 {закрываем файл}
end;

Всё готово
Итак, теперь мы имеем всё, что нам нужно для реализации нашей задачи. Мы можем записать информацию на диск, считать её, и даже изменить некоторые данные (например, e-mail) в "середине" файла.

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

Можно ли динамически изменять свойство owner компонента во время выполнения программы?

Можно ли динамически изменять свойство owner компонента во время выполнения программы?

Вы можете менять свойство "owner" и после создания компонента с помощью методов InsertComponent() и RemoveComponent().

Взято из
DELPHI VCL FAQ

Перевод с английского   
Подборку, перевод и адаптацию материала подготовил Aziz(JINX)
специально для

Можно ли динамически менять какая форма считается главной в приложении во время работы программы?

Можно ли динамически менять какая форма считается главной в приложении во время работы программы?

Можно, но только во время загрузки приложения. Чтобы сделать это выберите "View->Project Source" и измените код инициализации приложения, так что порядок создания форм зависил от какого-то условия.
Примечание: Вам придется редактировать этот код, если Вы добавите в приложение новые формы.

begin
  Application.Initialize;
  if < какое - то условие > then
    begin
      Application.CreateForm(TForm1, Form1);
      Application.CreateForm(TForm2, Form2);
    end
  else
    begin
      Application.CreateForm(TForm2, Form2);
      Application.CreateForm(TForm1, Form1);
    end;
end.
Application.Run;

Можно ли использовать иконку как картинку на кнопке TSpeedButton?

Можно ли использовать иконку как картинку на кнопке TSpeedButton?

uses ShellApi;

procedure TForm1.FormShow(Sender: TObject);
var
  Icon: TIcon;
begin
  Icon := TIcon.Create;
  Icon.Handle := ExtractIcon(0, 'C:\WINDOWS\NOTEPAD.EXE', 1);
  SpeedButton1.Glyph.Width := Icon.Width;
  SpeedButton1.Glyph.Height := Icon.Height;
  SpeedButton1.Glyph.Canvas.Draw(0, 0, Icon);
  Icon.Free;
end;

Можно ли из Delphi рисовать в любой части экрана или в чужом окне?

Можно ли из Delphi рисовать в любой части экрана или в чужом окне?

Для этого надо воспользоваться функциями API. Получить контекст чужого окна, либо всего экрана:

function GetDC(Wnd: HWnd): HDC;

где Wnd - указатель на нужное окно, или 0 для получения контекста всего экрана.
И далее, пользуясь функциями API, нарисовать все что надо.

PROCEDURE DrawOnScreen; 
VAR ScreenDC: hDC; 
BEGIN 
  ScreenDC := GetDC(0); {получить контекст экрана} 
  Ellipse(ScreenDC, 0, 0, 200, 200); {нарисовать} 
  ReleaseDC(0,ScreenDC); {освободить контекст} 
END; 

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


Зайцев О.В.
Владимиров А.М.
Взято с Исходников.ru

Можно ли изменить число колонок и их ширину в компоненте TFileListBox?

Можно ли изменить число колонок и их ширину в компоненте TFileListBox?

В приведенном примере FileListBox приводится к типу TDirectoryListBox - таким образом можно добавиь дополнительные колонки.

with TDirectoryListBox(FileListBox1) do 
begin
  Columns := 2;
  SendMessage(Handle, LB_SETCOLUMNWIDTH, Canvas.TextWidth('WWWWWWWW.WWW'),0);
end;

Можно ли изменить вид текстового курсора (каретки) edit'а или другого элемента?

Можно ли изменить вид текстового курсора (каретки) edit'а или другого элемента?

Можно! В примере показано как создать два цветных "bitmap'а": "улыбчивый" и "хмурый" и присвоить их курсору edit'а. Для этого нужно перехватить оконную процедуру edit'а. Чтобы сделать это заменим адрес оконной процедуры Edit'а нашим собственным, а старую оконную процедуру будем вызывать по необходимости. Пример показывает "улыбчивый" курсор при наборе текста и "хмурый" при забое клавишей backspace.

unit caret1;

interface

{$IFDEF WIN32}
uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls;
{$ELSE}
uses
  WinTypes, WinProcs, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls;
{$ENDIF}

type
  TForm1 = class(TForm)
    Edit1: TEdit;
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
  private
  {Private declarations}
  public
  {Public declarations}
    CaretBm: TBitmap;
    CaretBmBk: TBitmap;
    OldEditsWindowProc: Pointer;
  end;

var
  Form1: TForm1;

implementation
{$R *.DFM}

type
{$IFDEF WIN32}
  WParameter = LongInt;
{$ELSE}
  WParameter = Word;
{$ENDIF}
  LParameter = LongInt;

{New windows procedure for the edit control}

function NewWindowProc(WindowHandle: hWnd; TheMessage: WParameter; ParamW: WParameter;
  ParamL: LParameter): LongInt
{$IFDEF WIN32} stdcall; {$ELSE}; export; {$ENDIF}
begin
{Call the old edit controls windows procedure}
  NewWindowProc := CallWindowProc(Form1.OldEditsWindowProc, WindowHandle,
    TheMessage, ParamW, ParamL);
  if TheMessage = WM_SETFOCUS then
    begin
      CreateCaret(WindowHandle, Form1.CaretBm.Handle, 0, 0);
      ShowCaret(WindowHandle);
    end;
  if TheMessage = WM_KILLFOCUS then
    begin
      HideCaret(WindowHandle);
      DestroyCaret;
    end;
  if TheMessage = WM_KEYDOWN then
    begin
      if ParamW = VK_BACK then
        CreateCaret(WindowHandle, Form1.CaretBmBk.Handle, 0, 0)
      else
        CreateCaret(WindowHandle, Form1.CaretBm.Handle, 0, 0);
      ShowCaret(WindowHandle);
    end;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
{Create a smiling bitmap using the wingdings font}
  CaretBm := TBitmap.Create;
  CaretBm.Canvas.Font.Name := 'WingDings';
  CaretBm.Canvas.Font.Height := Edit1.Font.Height;
  CaretBm.Canvas.Font.Color := clWhite;
  CaretBm.Width := CaretBm.Canvas.TextWidth('J') + 2;
  CaretBm.Height := CaretBm.Canvas.TextHeight('J') + 2;
  CaretBm.Canvas.Brush.Color := clBlue;
  CaretBm.Canvas.FillRect(Rect(0, 0, CaretBm.Width, CaretBm.Height));
  CaretBm.Canvas.TextOut(1, 1, 'J');
{Create a frowming bitmap using the wingdings font}
  CaretBmBk := TBitmap.Create;
  CaretBmBk.Canvas.Font.Name := 'WingDings';
  CaretBmBk.Canvas.Font.Height := Edit1.Font.Height;
  CaretBmBk.Canvas.Font.Color := clWhite;
  CaretBmBk.Width := CaretBmBk.Canvas.TextWidth('L') + 2;
  CaretBmBk.Height := CaretBmBk.Canvas.TextHeight('L') + 2;
  CaretBmBk.Canvas.Brush.Color := clBlue;
  CaretBmBk.Canvas.FillRect(Rect(0, 0, CaretBmBk.Width, CaretBmBk.Height));
  CaretBmBk.Canvas.TextOut(1, 1, 'L');
{Hook the edit controls window procedure}
  OldEditsWindowProc := Pointer(SetWindowLong(Edit1.Handle, GWL_WNDPROC,
    LongInt(@NewWindowProc)));
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
{Unhook the edit controls window procedure and clean up}
  SetWindowLong(Edit1.Handle, GWL_WNDPROC, LongInt(OldEditsWindowProc));
  CaretBm.Free;
  CaretBmBk.Free;
end;

Можно ли как-то уменьшить мерцание при перерисовке компонента?

Можно ли как-то уменьшить мерцание при перерисовке компонента?

Если добавить флаг csOpaque (непрозрачный) к свойству ControlStyle компонента
- то фон компонента перерисовываться не будет.

constructor TMyControl.Create;
begin
  inherited;
  ControlStyle := ControlStyle + [csOpaque];
end;

Можно ли обратиться к колонке или строке grid'а по заголовку?

Можно ли обратиться к колонке или строке grid'а по заголовку?

В следующем примере приведены две функции: GetGridColumnByName() и GetGridRowByName(), которые возвращают колонку или строку, имеющую заданный заголовок (caption).

procedure TForm1.FormCreate(Sender: TObject);
begin
  StringGrid1.Rows[1].Strings[0] := 'This Row';
  StringGrid1.Cols[1].Strings[0] := 'This Column';
end;

function GetGridColumnByName(Grid: TStringGrid; ColName: string): integer;
var
  i: integer;
begin
  for i := 0 to Grid.ColCount - 1 do
    if Grid.Rows[0].Strings[i] = ColName then
      begin
        Result := i;
        exit;
      end;
  Result := -1;
end;

function GetGridRowByName(Grid: TStringGrid; RowName: string): integer;
var
  i: integer;
begin
  for i := 0 to Grid.RowCount - 1 do
    if Grid.Cols[0].Strings[i] = RowName then
      begin
        Result := i;
        exit;
      end;
  Result := -1;
end;

procedure TForm1.Button1Click(Sender: TObject);
var
  Column: integer;
  Row: integer;
begin
  Column := GetGridColumnByName(StringGrid1, 'This Column');
  if Column = -1 then
    ShowMessage('Column not found')
  else
    ShowMessage('Column found at ' + IntToStr(Column));
  Row := GetGridRowByName(StringGrid1, 'This Row');
  if Row = -1 then
    ShowMessage('Row not found')
  else
    ShowMessage('Row found at ' + IntToStr(Row));
end;

Можно ли отключить определенный элемент в RadioGroup?

Можно ли отключить определенный элемент в RadioGroup?

В примере показано как получить доступ к отдельным элементам компонента TRadioGroup.


procedure TForm1.Button1Click(Sender: TObject);
begin
  TRadioButton(RadioGroup1.Controls[1]).Enabled := False;
end;

Можно-ли поместить БД IB на CD-ROM?

Можно-ли поместить БД IB на CD-ROM?

В IB 4.x и 5.x база данных должна быть всегда доступна на запись, т.к. даже простая выборка (чтение) из БД стартует транзакцию, а информация о транзакции должна быть записана в БД.

Возможность работать с read-only базами данных, а следовательно и помещать их на CD-ROM, появилась только в IB 6.0 и Firebird. Для того, чтобы сделать БД read-only, достаточно выполнить команду

gfix database.gdb -mode read_only 

перед этим рекомендуется сделать backup/restore базе данных, предварительно установив флаг no_reserve в true (ключ -use у gfix), чтобы данные в БД были максимально уплотнены.
Также возможно установить режим read_only прямо при restore соответствующей опцией gbak.

Подробнее по режиму read_only см. документацию по IB6.


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

Можно ли создать форму, которая получает дополнительные параметры в методе Сreate?

Можно ли создать форму, которая получает дополнительные параметры в методе Сreate?

Просто замените конструктор Create класса Вашей формы.

unit Unit2;

interface

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

type
  TForm2 = class(TForm)
  private
  {Private declarations}
  public
    constructor CreateWithCaption(aOwner: TComponent; aCaption: string);
  {Public declarations}
  end;

var
  Form2: TForm2;

implementation

{$R *.DFM}

constructor TForm2.CreateWithCaption(aOwner: TComponent; aCaption: string);
begin
  Create(aOwner);
  Caption := aCaption;
end;

uses Unit2;

procedure TForm1.Button1Click(Sender: TObject);
begin
  Unit2.Form2 := Unit2.TForm2.CreateWithCaption(Application, 'My Caption');
  Unit2.Form2.Show;
end;

Можно-ли создать индекс по полю view?

Можно-ли создать индекс по полю view?

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

Если вы хотите использовать индексы в компоненте TTable, то делать это нужно не через свойство IndexName, а указывая поле, по которому вы хотите отсортировать таблицу или view, непосредственно в свойстве IndexFieldNames. SQL-сервер сам разберется, есть-ли по такому полю индекс, и сможет-ли он использовать его для ускорения обработки запросов.


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

Можно-ли создать пользователя БД при помощи SQL-команды?

Можно-ли создать пользователя БД при помощи SQL-команды?

Нет. Единственно правильный способ - использовать Server Manager. (Tasks | User Security), либо утилиту командной строки GSEC, либо IB user API (для IB 5.x). См. www.ibase.ru/download.htm, www.borland.com/devsupport/bde/.


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

Можно ли удалять из списка TDriveComboBox диски которые отключены?

Можно ли удалять из списка TDriveComboBox диски которые отключены?

На некоторых laptop компьютерах может не быть флоппи дисковода. Можно ли удалять из списка TDriveComboBox диски которые отключены?

В примере TDriveComboBox не показывает дисководы, которые не готовы. (not ready). Учтите что на многих компьютерах будет ощутимая задержка при поверке plug&play флоппи дисковода.

procedure TForm1.FormCreate(Sender: TObject);
var
  i: integer;
  OldErrorMode: Word;
  OldDirectory: string;
begin
  OldErrorMode := SetErrorMode(SEM_NOOPENFILEERRORBOX);
  GetDir(0, OldDirectory);
  i := 0;
  while i <= DriveComboBox1.Items.Count - 1 do
    begin
{$I-}
      ChDir(DriveComboBox1.Items[i][1] + ':\');
{$I+}
      if IoResult <> 0 then
        DriveComboBox1.Items.Delete(i)
      else
        inc(i);
    end;
  ChDir(OldDirectory);
  SetErrorMode(OldErrorMode);
end;

Можно-ли в запросах делать поиск по BLOB?

Можно-ли в запросах делать поиск по BLOB?

Да. Поиск по строковым (CHAR, VARCHAR) полям или по BLOB можно производить при помощи операторов CONTAINING, STARTING WITH и LIKE. Например

SELECT * FROM MYTABLE 
WHERE BLOBFIELD CONTAINING 'sometext'; 

Поиск по умолчанию считается case-insensitive (регистро-нечувствительный), поэтому для латинских букв строку поиска можно задавать строчными буквами (в нижнем регистре). В этом случае при поиске 'sometext' в ответ войдут записи с 'sometext', 'SOMETEXT' и 'SomeText'. К сожалению, для BLOB невозможно указать COLLATE для правильного перевода русских букв в верхний регистр, поэтому поиск слов, содержащих русские буквы, будет производиться только по точному совпадению.

При поиске подтип BLOB (SUB_TYPE 0 или 1 - текст или binary) не имеет значения, т.к. подтип имеет значение только для приложения, или для фильтров BLOB. BLOB-ы разных подтипов хранятся абсолютно одинаковым способом.


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

Можно ли задать шаг в For?

Можно ли задать шаг в For?

Fori:=0 to Maximum do if i mod step = 0 then
begin

end; 

Переменная Step и есть нужный шаг

Автор:

Vit

Взято из

MS Exchange API

MS Exchange API

MS Exchange API via CDO (Collaboration Data Objects)

CDO (Collaboration Data Objects) Base Library.

( Talking to MS-Exchange server.)

This is a vast subject that is beyond the scope of this article to detail all here. This library provides the basic building blocks for someone who wants to develop using CDO. There are many references on the Net, but your best source is the CDO.HLP file that ships on the Exchange CD or site http://www.cdolive.com/start.htmhttp://www.cdolive.com/start.htm. The cdolive.com site is an excellent reference site which discusses all aspects including installation, versions and also downloads. (CDO.HLP is downloadable from here)

My basic class provides the following functionality ..

Utility functions and methods

function CdoNothing(Obj : OleVariant) : boolean;
    function CdoDefaultProfile : string;
    function VarNothing : IDispatch;

    procedure CdoDisposeList(WorkList : TList);
    procedure CdoDisposeObjects(WorkStrings : TStrings);
    procedure CdoDisposeNodes(WorkData : TTreeNodes);

Create constructors that allow Default profile logon,Specific profile logon and an Impersonated user logon with profile. (This is required for successful logon in Windows Service Applications)

      constructor Create; overload;
   constructor Create(const Profile : string); overload;
   constructor Create(const Profile : string;
                       const UserName : string;
                       const Domain : string;
                       const Password : string); overload;
   
Methods for loading stringlists, treeviews etc. and Object iteration.

     function LoadAddressList(StringList : TStrings) : boolean;
   function LoadObjectList(const FolderOle : OleVariant; 
                           List : TList) : boolean;
   function LoadEMailTree(TV : TTreeView; 
                          Expand1stLevel : boolean = false;
                          SubjectMask : string = '') : boolean;
   function LoadContactList(const FolderOle : OleVariant;
                            Items : TStrings) : boolean; overload;
   function LoadContactList(const FolderName : string;
                            Items : TStrings) : boolean; overload;
   procedure ShowContactDetails(Contact : OleVariant);

The above load various lists into stringlists,lists or treeviews. Freeing of lists,object constructs within these data structures are freed at each successive call to the load, however the final Deallocation is the responsibility of the developer, You can do this yourself or use the utility functions CdoDisposeXXX(). See code documentation for further understanding.

   function First(const FolderOle : OleVariant; 
                  out ItemOle : OleVariant) : boolean;
   function Last(const FolderOle : OleVariant; 
                 out ItemOle : OleVariant) : boolean;
   function Next(const FolderOle : OleVariant; 
                 out ItemOle : OleVariant) : boolean;
   function Prior(const FolderOle : OleVariant; 
                  out ItemOle : OleVariant) : boolean;
   function AsString(const ItemOle : Olevariant; 
                     const FieldIdConstant : DWORD) : string;

The above provide iterations thru object such as Inbox,Contacts etc. The AsString returns a fields value from the object such as Email Address,Name,Company Name etc. (There are miriads of these defined in the CONST section "Field Tags").

Properties

         property CurrentUser : OleVariant read FCurrentUser;
     property Connected : boolean read FConnected;
     property LastErrorMess : string read FlastError;
     property LastErrorCode : DWORD read FlastErrorCode;
     property InBox : OleVariant read FOleInBox;
     property OutBox : OleVariant read FOleOutBox;
     property DeletedItems : Olevariant read FOleDeletedItems;
     property SentItems : Olevariant read FOleSentItems;
     property GlobalAddressList : Olevariant read FOleGlobalAddressList;
     property Contacts : Olevariant read FOleContacts;
     property Session : OleVariant read FOleSession;
     property Version : string read GetFVersion;
     property MyName : string read FMyName;
     property MyEMailAddress : string read FMyEMailAddress;

The Create constructor sets up the predefined objects InBox, OutBox, DeletedItems, SentItems, GlobalAddressList, Session and Contacts. The other properties are self explanatary.

As I mentioned earlier the functionality of CDO is vast as objects such as InBox have many methods and properties that included Updating,Inserting Deleting etc. The CDO.HLP file will help to expose these for you. My class is the base of CDO to help simplify building applications and is probably best demonstrated by code snippet examples. Believe me a whole book could be written on this subject, but it is well worth studying as a faster alternative to using MS Outlook API.

uses Cdo_Lib;
var
  Cdo: TcdoSession;
  MailItem: OleVariant;

  // Iterate thru Emails in InBox
begin
  Cdo := TCdoSession.Create;

  if Cdo.Active then
  begin
    Cdo.First(Cdo.InBox, MailItem);

    while true do
    begin
      if not Cdo.Nothing(MailItem) then
      begin
        Subject := MailItem.Subject;

        EMailAddress := Cdo.AsString(MailItem.Sender, CdoPR_EMAIL_AT_ADDRESS);
        EMailName := MailItem.Sender.Name;
        BodyText := MailItem.Text;

        // Do something with data and delete the EMail
        MailItem.Delete;
        // Get the next Email
      end;

      MailItem := Cdo.Next(Cdo.Inbox.MailItem);
    end;
  end;
  Cdo.Free;
end;

// Example of loading emails into a treeview and displaying on treeview click

unit UBrowse;
interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  ComCtrls, ToolWin, Menus, ExtCtrls, StdCtrls, Buttons, ImgList,
  CDO_Lib;

type
  TFBrowse = class(TForm)
    Panel1: TPanel;
    Panel3: TPanel;
    Label1: TLabel;
    Label2: TLabel;
    lbFrom: TLabel;
    lbDate: TLabel;
    Memo1: TMemo;
    Panel2: TPanel;
    OKBtn: TBitBtn;
    tvCalls: TTreeView;
    ImageList1: TImageList;
    StatusBar1: TStatusBar;
    procedure FormShow(Sender: TObject);
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
    procedure tvCallsClick(Sender: TObject);
    procedure btnPrintClick(Sender: TObject);
  private
    { Private declarations }
    Doc: OleVariant;
    Cdo: TCdoMapiSession;
  public
    { Public declarations }
  end;

var
  FBrowse: TFBrowse;

implementation

{$R *.DFM}

procedure TFBrowse.FormShow(Sender: TObject);
var
  TN: TTreeNode;
begin
  Screen.Cursor := crHourGlass;
  Application.ProcessMessages;
  Cdo := TCdoMapiSession.Create;
  Cdo.LoadEMailTree(tvCalls, true, '*Support ---*');
  tvCalls.SortType := stText;
  TN := tvCalls.Items[0];
  TN.Expand(false);
  tvCalls.SetFocus;
  Screen.Cursor := crDefault;
end;

procedure TFBrowse.FormClose(Sender: TObject; var Action: TCloseAction);
begin
  CdoDisposeNodes(TvCalls.Items);
  Cdo.Free;
end;

procedure TFBrowse.tvCallsClick(Sender: TObject);
var
  TN: TTreeNode;
begin
  TN := tvCalls.Selected;
  Memo1.Clear;
  lbFrom.Caption := '';
  lbDate.Caption := '';
 
  if TN.Data <> nil then
  begin
    Doc := TOleVarPtr(TN.Data)^;
    btnPrint.Enabled := true;
    Memo1.Text := Doc.Text;
    lbFrom.Caption := Doc.Sender.Name;
    lbDate.Caption := FormatDateTime('dd/mm/yyyy hh:nn', Doc.TimeSent);
  end;
end;

end.

unit CDO_Lib;

// =============================================================================
// CDO and MAPI Library (See CDO.HLP)
//
// The object model for the CDO Library is hierarchical. The following table
// shows the containment hierarchy. Each indented object is a child of the
// object under which it is indented. An object is the parent of every object
// at the next level of indentation under it. For example, an Attachments
// collection and a Recipients collection are both child objects of a
// Message object, and a Messages collection is a parent object of a
// Message object. However, a Messages collection is not a parent object of a
// Recipients collection.
//
//  Session
//        AddressLists collection
//              AddressList
//                    Fields collection
//                          Field
//                    AddressEntries collection
//                          AddressEntry
//                                Fields collection
//                                      Field
//                          AddressEntryFilter
//                                Fields collection
//                                      Field
//        Folder (Inbox or Outbox)
//              Fields collection
//                    Field
//              Folders collection
//                    Folder
//                          Fields collection
//                                Field
//                          [ Folders ... Folder ... ]
//                          Messages collection
//                                AppointmentItem
//                                      RecurrencePattern
//                                GroupHeader
//                                MeetingItem
//                                Message
//                                      Attachments collection
//                                            Attachment
//                                                  Fields collection
//                                                        Field
//                                      Fields collection
//                                            Field
//                                      Recipients collection
//                                            Recipient
//                                                  AddressEntry
//                                                        Fields collection
//                                                              Field
//                                MessageFilter
//                                      Fields collection
//                                            Field
//        InfoStores collection
//              InfoStore
//                    Fields collection
//                          Field
//                    Folder [as expanded under Folders]
//
//  The notation "[ Folders ... Folder ... ]" signifies that any Folder object
//  can contain a Folders collection of subfolders, and each subfolder can
//  contain a Folders collection of more subfolders, nested to an
//  arbitrary level.
// =============================================================================

interface

uses Forms, Windows, SysUtils, Classes, Registry, ComObj, Variants, ComCtrls,
  Controls, Masks;

const
  // MAPI Property Tags

  // Field Tags
  CdoPR_7BIT_DISPLAY_NAME = $39FF001E;
  CdoPR_AB_DEFAULT_DIR = $3D060102;
  CdoPR_AB_DEFAULT_PAB = $3D070102;
  CdoPR_AB_PROVIDER_ID = $36150102;
  CdoPR_AB_PROVIDERS = $3D010102;
  CdoPR_AB_SEARCH_PATH = $3D051102;
  CdoPR_AB_SEARCH_PATH_UPDATE = $3D110102;
  CdoPR_ACCESS = $0FF40003;
  CdoPR_ACCESS_LEVEL = $0FF70003;
  CdoPR_ACCOUNT = $3A00001E;
  CdoPR_ACKNOWLEDGEMENT_MODE = $00010003;
  CdoPR_ADDRTYPE = $3002001E;
  CdoPR_ALTERNATE_RECIPIENT = $3A010102;
  CdoPR_ALTERNATE_RECIPIENT_ALLOWED = $0002000B;
  CdoPR_ANR = $360C001E;
  CdoPR_ASSISTANT = $3A30001E;
  CdoPR_ASSISTANT_TELEPHONE_NUMBER = $3A2E001E;
  CdoPR_ASSOC_CONTENT_COUNT = $36170003;
  CdoPR_ATTACH_ADDITIONAL_INFO = $370F0102;
  CdoPR_ATTACH_DATA_BIN = $37010102;
  CdoPR_ATTACH_DATA_OBJ = $3701000D;
  CdoPR_ATTACH_ENCODING = $37020102;
  CdoPR_ATTACH_EXTENSION = $3703001E;
  CdoPR_ATTACH_FILENAME = $3704001E;
  CdoPR_ATTACH_LONG_FILENAME = $3707001E;
  CdoPR_ATTACH_LONG_PATHNAME = $370D001E;
  CdoPR_ATTACH_METHOD = $37050003;
  CdoPR_ATTACH_MIME_TAG = $370E001E;
  CdoPR_ATTACH_NUM = $0E210003;
  CdoPR_ATTACH_PATHNAME = $3708001E;
  CdoPR_ATTACH_RENDERING = $37090102;
  CdoPR_ATTACH_SIZE = $0E200003;
  CdoPR_ATTACH_TAG = $370A0102;
  CdoPR_ATTACH_TRANSPORT_NAME = $370C001E;
  CdoPR_ATTACHMENT_X400_PARAMETERS = $37000102;
  CdoPR_AUTHORIZING_USERS = $00030102;
  CdoPR_AUTO_FORWARD_COMMENT = $0004001E;
  CdoPR_AUTO_FORWARDED = $0005000B;
  CdoPR_BEEPER_TELEPHONE_NUMBER = $3A21001E;
  CdoPR_BIRTHDAY = $3A420040;
  CdoPR_BODY = $1000001E;
  CdoPR_BODY_CRC = $0E1C0003;
  CdoPR_BUSINESS_ADDRESS_CITY = $3A27001E;
  CdoPR_BUSINESS_ADDRESS_COUNTRY = $3A26001E;
  CdoPR_BUSINESS_ADDRESS_POST_OFFICE_BOX = $3A2B001E;
  CdoPR_BUSINESS_ADDRESS_POSTAL_CODE = $3A2A001E;
  CdoPR_BUSINESS_ADDRESS_STATE_OR_PROVINCE = $3A28001E;
  CdoPR_BUSINESS_ADDRESS_STREET = $3A29001E;
  CdoPR_BUSINESS_FAX_NUMBER = $3A24001E;
  CdoPR_BUSINESS_HOME_PAGE = $3A51001E;
  CdoPR_BUSINESS_TELEPHONE_NUMBER = $3A08001E;
  CdoPR_BUSINESS2_TELEPHONE_NUMBER = $3A1B001E;
  CdoPR_CALLBACK_TELEPHONE_NUMBER = $3A02001E;
  CdoPR_CAR_TELEPHONE_NUMBER = $3A1E001E;
  CdoPR_CELLULAR_TELEPHONE_NUMBER = $3A1C001E;
  CdoPR_CHILDRENS_NAMES = $3A58101E;
  CdoPR_CLIENT_SUBMIT_TIME = $00390040;
  CdoPR_COMMENT = $3004001E;
  CdoPR_COMMON_VIEWS_ENTRYID = $35E60102;
  CdoPR_COMPANY_MAIN_PHONE_NUMBER = $3A57001E;
  CdoPR_COMPANY_NAME = $3A16001E;
  CdoPR_COMPUTER_NETWORK_NAME = $3A49001E;
  CdoPR_CONTACT_ADDRTYPES = $3A54101E;
  CdoPR_CONTACT_DEFAULT_ADDRESS_INDEX = $3A550003;
  CdoPR_CONTACT_EMAIL_ADDRESSES = $3A56101E;
  CdoPR_CONTACT_ENTRYIDS = $3A531102;
  CdoPR_CONTACT_VERSION = $3A520048;
  CdoPR_CONTAINER_CLASS = $3613001E;
  CdoPR_CONTAINER_CONTENTS = $360F000D;
  CdoPR_CONTAINER_FLAGS = $36000003;
  CdoPR_CONTAINER_HIERARCHY = $360E000D;
  CdoPR_CONTAINER_MODIFY_VERSION = $36140014;
  CdoPR_CONTENT_CONFIDENTIALITY_ALGORITHM_ID = $00060102;
  CdoPR_CONTENT_CORRELATOR = $00070102;
  CdoPR_CONTENT_COUNT = $36020003;
  CdoPR_CONTENT_IDENTIFIER = $0008001E;
  CdoPR_CONTENT_INTEGRITY_CHECK = $0C000102;
  CdoPR_CONTENT_LENGTH = $00090003;
  CdoPR_CONTENT_RETURN_REQUESTED = $000A000B;
  CdoPR_CONTENT_UNREAD = $36030003;
  CdoPR_CONTENTS_SORT_ORDER = $360D1003;
  CdoPR_CONTROL_FLAGS = $3F000003;
  CdoPR_CONTROL_ID = $3F070102;
  CdoPR_CONTROL_STRUCTURE = $3F010102;
  CdoPR_CONTROL_TYPE = $3F020003;
  CdoPR_CONVERSATION_INDEX = $00710102;
  CdoPR_CONVERSATION_KEY = $000B0102;
  CdoPR_CONVERSATION_TOPIC = $0070001E;
  CdoPR_CONVERSION_EITS = $000C0102;
  CdoPR_CONVERSION_PROHIBITED = $3A03000B;
  CdoPR_CONVERSION_WITH_LOSS_PROHIBITED = $000D000B;
  CdoPR_CONVERTED_EITS = $000E0102;
  CdoPR_CORRELATE = $0E0C000B;
  CdoPR_CORRELATE_MTSID = $0E0D0102;
  CdoPR_COUNTRY = $3A26001E;
  CdoPR_CREATE_TEMPLATES = $3604000D;
  CdoPR_CREATION_TIME = $30070040;
  CdoPR_CREATION_VERSION = $0E190014;
  CdoPR_CURRENT_VERSION = $0E000014;
  CdoPR_CUSTOMER_ID = $3A4A001E;
  CdoPR_DEF_CREATE_DL = $36110102;
  CdoPR_DEF_CREATE_MAILUSER = $36120102;
  CdoPR_DEFAULT_PROFILE = $3D04000B;
  CdoPR_DEFAULT_STORE = $3400000B;
  CdoPR_DEFAULT_VIEW_ENTRYID = $36160102;
  CdoPR_DEFERRED_DELIVERY_TIME = $000F0040;
  CdoPR_DELEGATION = $007E0102;
  CdoPR_DELETE_AFTER_SUBMIT = $0E01000B;
  CdoPR_DELIVER_TIME = $00100040;
  CdoPR_DELIVERY_POINT = $0C070003;
  CdoPR_DELTAX = $3F030003;
  CdoPR_DELTAY = $3F040003;
  CdoPR_DEPARTMENT_NAME = $3A18001E;
  CdoPR_DEPTH = $30050003;
  CdoPR_DETAILS_TABLE = $3605000D;
  CdoPR_DISC_VAL = $004A000B;
  CdoPR_DISCARD_REASON = $00110003;
  CdoPR_DISCLOSE_RECIPIENTS = $3A04000B;
  CdoPR_DISCLOSURE_OF_RECIPIENTS = $0012000B;
  CdoPR_DISCRETE_VALUES = $0E0E000B;
  CdoPR_DISPLAY_BCC = $0E02001E;
  CdoPR_DISPLAY_CC = $0E03001E;
  CdoPR_DISPLAY_NAME = $3001001E;
  CdoPR_DISPLAY_NAME_PREFIX = $3A45001E;
  CdoPR_DISPLAY_TO = $0E04001E;
  CdoPR_DISPLAY_TYPE = $39000003;
  CdoPR_DL_EXPANSION_HISTORY = $00130102;
  CdoPR_DL_EXPANSION_PROHIBITED = $0014000B;
  CdoPR_EMAIL_ADDRESS = $3003001E;
  CdoPR_EMAIL_AT_ADDRESS = $39FE001E;
  CdoPR_END_DATE = $00610040;
  CdoPR_ENTRYID = $0FFF0102;
  CdoPR_EXPIRY_TIME = $00150040;
  CdoPR_EXPLICIT_CONVERSION = $0C010003;
  CdoPR_FILTERING_HOOKS = $3D080102;
  CdoPR_FINDER_ENTRYID = $35E70102;
  CdoPR_FOLDER_ASSOCIATED_CONTENTS = $3610000D;
  CdoPR_FOLDER_TYPE = $36010003;
  CdoPR_FORM_CATEGORY = $3304001E;
  CdoPR_FORM_CATEGORY_SUB = $3305001E;
  CdoPR_FORM_CLSID = $33020048;
  CdoPR_FORM_CONTACT_NAME = $3303001E;
  CdoPR_FORM_DESIGNER_GUID = $33090048;
  CdoPR_FORM_DESIGNER_NAME = $3308001E;
  CdoPR_FORM_HIDDEN = $3307000B;
  CdoPR_FORM_HOST_MAP = $33061003;
  CdoPR_FORM_MESSAGE_BEHAVIOR = $330A0003;
  CdoPR_FORM_VERSION = $3301001E;
  CdoPR_FTP_SITE = $3A4C001E;
  CdoPR_GENDER = $3A4D0002;
  CdoPR_GENERATION = $3A05001E;
  CdoPR_GIVEN_NAME = $3A06001E;
  CdoPR_GOVERNMENT_ID_NUMBER = $3A07001E;
  CdoPR_HASATTACH = $0E1B000B;
  CdoPR_HEADER_FOLDER_ENTRYID = $3E0A0102;
  CdoPR_HOBBIES = $3A43001E;
  CdoPR_HOME_ADDRESS_CITY = $3A59001E;
  CdoPR_HOME_ADDRESS_COUNTRY = $3A5A001E;
  CdoPR_HOME_ADDRESS_POST_OFFICE_BOX = $3A5E001E;
  CdoPR_HOME_ADDRESS_POSTAL_CODE = $3A5B001E;
  CdoPR_HOME_ADDRESS_STATE_OR_PROVINCE = $3A5C001E;
  CdoPR_HOME_ADDRESS_STREET = $3A5D001E;
  CdoPR_HOME_FAX_NUMBER = $3A25001E;
  CdoPR_HOME_TELEPHONE_NUMBER = $3A09001E;
  CdoPR_HOME2_TELEPHONE_NUMBER = $3A2F001E;
  CdoPR_ICON = $0FFD0102;
  CdoPR_IDENTITY_DISPLAY = $3E00001E;
  CdoPR_IDENTITY_ENTRYID = $3E010102;
  CdoPR_IDENTITY_SEARCH_KEY = $3E050102;
  CdoPR_IMPLICIT_CONVERSION_PROHIBITED = $0016000B;
  CdoPR_IMPORTANCE = $00170003;
  CdoPR_INCOMPLETE_COPY = $0035000B;
  CdoPR_INITIAL_DETAILS_PANE = $3F080003;
  CdoPR_INITIALS = $3A0A001E;
  CdoPR_INSTANCE_KEY = $0FF60102;
  CdoPR_INTERNET_APPROVED = $1030001E;
  CdoPR_INTERNET_ARTICLE_NUMBER = $0E230003;
  CdoPR_INTERNET_CONTROL = $1031001E;
  CdoPR_INTERNET_DISTRIBUTION = $1032001E;
  CdoPR_INTERNET_FOLLOWUP_TO = $1033001E;
  CdoPR_INTERNET_LINES = $10340003;
  CdoPR_INTERNET_MESSAGE_ID = $1035001E;
  CdoPR_INTERNET_NEWSGROUPS = $1036001E;
  CdoPR_INTERNET_NNTP_PATH = $1038001E;
  CdoPR_INTERNET_ORGANIZATION = $1037001E;
  CdoPR_INTERNET_PRECEDENCE = $1041001E;
  CdoPR_INTERNET_REFERENCES = $1039001E;
  CdoPR_IPM_ID = $00180102;
  CdoPR_IPM_OUTBOX_ENTRYID = $35E20102;
  CdoPR_IPM_OUTBOX_SEARCH_KEY = $34110102;
  CdoPR_IPM_RETURN_REQUESTED = $0C02000B;
  CdoPR_IPM_SENTMAIL_ENTRYID = $35E40102;
  CdoPR_IPM_SENTMAIL_SEARCH_KEY = $34130102;
  CdoPR_IPM_SUBTREE_ENTRYID = $35E00102;
  CdoPR_IPM_SUBTREE_SEARCH_KEY = $34100102;
  CdoPR_IPM_WASTEBASKET_ENTRYID = $35E30102;
  CdoPR_IPM_WASTEBASKET_SEARCH_KEY = $34120102;
  CdoPR_ISDN_NUMBER = $3A2D001E;
  CdoPR_KEYWORD = $3A0B001E;
  CdoPR_LANGUAGE = $3A0C001E;
  CdoPR_LANGUAGES = $002F001E;
  CdoPR_LAST_MODIFICATION_TIME = $30080040;
  CdoPR_LATEST_DELIVERY_TIME = $00190040;
  CdoPR_LOCALITY = $3A27001E;
  CdoPR_LOCATION = $3A0D001E;
  CdoPR_MAIL_PERMISSION = $3A0E000B;
  CdoPR_MANAGER_NAME = $3A4E001E;
  CdoPR_MAPPING_SIGNATURE = $0FF80102;
  CdoPR_MDB_PROVIDER = $34140102;
  CdoPR_MESSAGE_ATTACHMENTS = $0E13000D;
  CdoPR_MESSAGE_CC_ME = $0058000B;
  CdoPR_MESSAGE_CLASS = $001A001E;
  CdoPR_MESSAGE_DELIVERY_ID = $001B0102;
  CdoPR_MESSAGE_DELIVERY_TIME = $0E060040;
  CdoPR_MESSAGE_DOWNLOAD_TIME = $0E180003;
  CdoPR_MESSAGE_FLAGS = $0E070003;
  CdoPR_MESSAGE_RECIP_ME = $0059000B;
  CdoPR_MESSAGE_RECIPIENTS = $0E12000D;
  CdoPR_MESSAGE_SECURITY_LABEL = $001E0102;
  CdoPR_MESSAGE_SIZE = $0E080003;
  CdoPR_MESSAGE_SUBMISSION_ID = $00470102;
  CdoPR_MESSAGE_TO_ME = $0057000B;
  CdoPR_MESSAGE_TOKEN = $0C030102;
  CdoPR_MHS_COMMON_NAME = $3A0F001E;
  CdoPR_MIDDLE_NAME = $3A44001E;
  CdoPR_MINI_ICON = $0FFC0102;
  CdoPR_MOBILE_TELEPHONE_NUMBER = $3A1C001E;
  CdoPR_MODIFY_VERSION = $0E1A0014;
  CdoPR_MSG_STATUS = $0E170003;
  CdoPR_NDR_DIAG_CODE = $0C050003;
  CdoPR_NDR_REASON_CODE = $0C040003;
  CdoPR_NEWSGROUP_NAME = $0E24001E;
  CdoPR_NICKNAME = $3A4F001E;
  CdoPR_NNTP_XREF = $1040001E;
  CdoPR_NON_RECEIPT_NOTIFICATION_REQUESTED = $0C06000B;
  CdoPR_NON_RECEIPT_REASON = $003E0003;
  CdoPR_NORMALIZED_SUBJECT = $0E1D001E;
  CdoPR_OBJECT_TYPE = $0FFE0003;
  CdoPR_OBSOLETED_IPMS = $001F0102;
  CdoPR_OFFICE_LOCATION = $3A19001E;
  CdoPR_OFFICE_TELEPHONE_NUMBER = $3A08001E;
  CdoPR_OFFICE2_TELEPHONE_NUMBER = $3A1B001E;
  CdoPR_ORGANIZATIONAL_ID_NUMBER = $3A10001E;
  CdoPR_ORIG_MESSAGE_CLASS = $004B001E;
  CdoPR_ORIGIN_CHECK = $00270102;
  CdoPR_ORIGINAL_AUTHOR_ADDRTYPE = $0079001E;
  CdoPR_ORIGINAL_AUTHOR_EMAIL_ADDRESS = $007A001E;
  CdoPR_ORIGINAL_AUTHOR_ENTRYID = $004C0102;
  CdoPR_ORIGINAL_AUTHOR_NAME = $004D001E;
  CdoPR_ORIGINAL_AUTHOR_SEARCH_KEY = $00560102;
  CdoPR_ORIGINAL_DELIVERY_TIME = $00550040;
  CdoPR_ORIGINAL_DISPLAY_BCC = $0072001E;
  CdoPR_ORIGINAL_DISPLAY_CC = $0073001E;
  CdoPR_ORIGINAL_DISPLAY_NAME = $3A13001E;
  CdoPR_ORIGINAL_DISPLAY_TO = $0074001E;
  CdoPR_ORIGINAL_EITS = $00210102;
  CdoPR_ORIGINAL_ENTRYID = $3A120102;
  CdoPR_ORIGINAL_SEARCH_KEY = $3A140102;
  CdoPR_ORIGINAL_SENDER_ADDRTYPE = $0066001E;
  CdoPR_ORIGINAL_SENDER_EMAIL_ADDRESS = $0067001E;
  CdoPR_ORIGINAL_SENDER_ENTRYID = $005B0102;
  CdoPR_ORIGINAL_SENDER_NAME = $005A001E;
  CdoPR_ORIGINAL_SENDER_SEARCH_KEY = $005C0102;
  CdoPR_ORIGINAL_SENSITIVITY = $002E0003;
  CdoPR_ORIGINAL_SENT_REPRESENTING_ADDRTYPE = $0068001E;
  CdoPR_ORIGINAL_SENT_REPRESENTING_EMAIL_ADDR = $0069001E;
  CdoPR_ORIGINAL_SENT_REPRESENTING_ENTRYID = $005E0102;
  CdoPR_ORIGINAL_SENT_REPRESENTING_NAME = $005D001E;
  CdoPR_ORIGINAL_SENT_REPRESENTING_SEARCH_KEY = $005F0102;
  CdoPR_ORIGINAL_SUBJECT = $0049001E;
  CdoPR_ORIGINAL_SUBMIT_TIME = $004E0040;
  CdoPR_ORIGINALLY_INTENDED_RECIP_ADDRTYPE = $007B001E;
  CdoPR_ORIGINALLY_INTENDED_RECIP_EMAIL_ADDR = $007C001E;
  CdoPR_ORIGINALLY_INTENDED_RECIP_ENTRYID = $10120102;
  CdoPR_ORIGINALLY_INTENDED_RECIPIENT_NAME = $00200102;
  CdoPR_ORIGINATING_MTA_CERTIFICATE = $0E250102;
  CdoPR_ORIGINATOR_AND_DL_EXPANSION_HISTORY = $10020102;
  CdoPR_ORIGINATOR_CERTIFICATE = $00220102;
  CdoPR_ORIGINATOR_DELIVERY_REPORT_REQUESTED = $0023000B;
  CdoPR_ORIGINATOR_NON_DELIVERY_REPORT_REQ = $0C08000B;
  CdoPR_ORIGINATOR_REQUESTED_ALTERNATE_RECIP = $0C090102;
  CdoPR_ORIGINATOR_RETURN_ADDRESS = $00240102;
  CdoPR_OTHER_ADDRESS_CITY = $3A5F001E;
  CdoPR_OTHER_ADDRESS_COUNTRY = $3A60001E;
  CdoPR_OTHER_ADDRESS_POST_OFFICE_BOX = $3A64001E;
  CdoPR_OTHER_ADDRESS_POSTAL_CODE = $3A61001E;
  CdoPR_OTHER_ADDRESS_STATE_OR_PROVINCE = $3A62001E;
  CdoPR_OTHER_ADDRESS_STREET = $3A63001E;
  CdoPR_OTHER_TELEPHONE_NUMBER = $3A1F001E;
  CdoPR_OWN_STORE_ENTRYID = $3E060102;
  CdoPR_OWNER_APPT_ID = $00620003;
  CdoPR_PAGER_TELEPHONE_NUMBER = $3A21001E;
  CdoPR_PARENT_DISPLAY = $0E05001E;
  CdoPR_PARENT_ENTRYID = $0E090102;
  CdoPR_PARENT_KEY = $00250102;
  CdoPR_PERSONAL_HOME_PAGE = $3A50001E;
  CdoPR_PHYSICAL_DELIVERY_BUREAU_FAX_DELIVERY = $0C0A000B;
  CdoPR_PHYSICAL_DELIVERY_MODE = $0C0B0003;
  CdoPR_PHYSICAL_DELIVERY_REPORT_REQUEST = $0C0C0003;
  CdoPR_PHYSICAL_FORWARDING_ADDRESS = $0C0D0102;
  CdoPR_PHYSICAL_FORWARDING_ADDRESS_REQUESTED = $0C0E000B;
  CdoPR_PHYSICAL_FORWARDING_PROHIBITED = $0C0F000B;
  CdoPR_PHYSICAL_RENDITION_ATTRIBUTES = $0C100102;
  CdoPR_POST_FOLDER_ENTRIES = $103B0102;
  CdoPR_POST_FOLDER_NAMES = $103C001E;
  CdoPR_POST_OFFICE_BOX = $3A2B001E;
  CdoPR_POST_REPLY_DENIED = $103F0102;
  CdoPR_POST_REPLY_FOLDER_ENTRIES = $103D0102;
  CdoPR_POST_REPLY_FOLDER_NAMES = $103E001E;
  CdoPR_POSTAL_ADDRESS = $3A15001E;
  CdoPR_POSTAL_CODE = $3A2A001E;
  CdoPR_PREFERRED_BY_NAME = $3A47001E;
  CdoPR_PREPROCESS = $0E22000B;
  CdoPR_PRIMARY_CAPABILITY = $39040102;
  CdoPR_PRIMARY_FAX_NUMBER = $3A23001E;
  CdoPR_PRIMARY_TELEPHONE_NUMBER = $3A1A001E;
  CdoPR_PRIORITY = $00260003;
  CdoPR_PROFESSION = $3A46001E;
  CdoPR_PROFILE_NAME = $3D12001E;
  CdoPR_PROOF_OF_DELIVERY = $0C110102;
  CdoPR_PROOF_OF_DELIVERY_REQUESTED = $0C12000B;
  CdoPR_PROOF_OF_SUBMISSION = $0E260102;
  CdoPR_PROOF_OF_SUBMISSION_REQUESTED = $0028000B;
  CdoPR_PROVIDER_DISPLAY = $3006001E;
  CdoPR_PROVIDER_DLL_NAME = $300A001E;
  CdoPR_PROVIDER_ORDINAL = $300D0003;
  CdoPR_PROVIDER_SUBMIT_TIME = $00480040;
  CdoPR_PROVIDER_UID = $300C0102;
  CdoPR_RADIO_TELEPHONE_NUMBER = $3A1D001E;
  CdoPR_RCVD_REPRESENTING_ADDRTYPE = $0077001E;
  CdoPR_RCVD_REPRESENTING_EMAIL_ADDRESS = $0078001E;
  CdoPR_RCVD_REPRESENTING_ENTRYID = $00430102;
  CdoPR_RCVD_REPRESENTING_NAME = $0044001E;
  CdoPR_RCVD_REPRESENTING_SEARCH_KEY = $00520102;
  CdoPR_READ_RECEIPT_ENTRYID = $00460102;
  CdoPR_READ_RECEIPT_REQUESTED = $0029000B;
  CdoPR_READ_RECEIPT_SEARCH_KEY = $00530102;
  CdoPR_RECEIPT_TIME = $002A0040;
  CdoPR_RECEIVE_FOLDER_SETTINGS = $3415000D;
  CdoPR_RECEIVED_BY_ADDRTYPE = $0075001E;
  CdoPR_RECEIVED_BY_EMAIL_ADDRESS = $0076001E;
  CdoPR_RECEIVED_BY_ENTRYID = $003F0102;
  CdoPR_RECEIVED_BY_NAME = $0040001E;
  CdoPR_RECEIVED_BY_SEARCH_KEY = $00510102;
  CdoPR_RECIPIENT_CERTIFICATE = $0C130102;
  CdoPR_RECIPIENT_NUMBER_FOR_ADVICE = $0C14001E;
  CdoPR_RECIPIENT_REASSIGNMENT_PROHIBITED = $002B000B;
  CdoPR_RECIPIENT_STATUS = $0E150003;
  CdoPR_RECIPIENT_TYPE = $0C150003;
  CdoPR_RECORD_KEY = $0FF90102;
  CdoPR_REDIRECTION_HISTORY = $002C0102;
  CdoPR_REFERRED_BY_NAME = $3A47001E;
  CdoPR_REGISTERED_MAIL_TYPE = $0C160003;
  CdoPR_RELATED_IPMS = $002D0102;
  CdoPR_REMOTE_PROGRESS = $3E0B0003;
  CdoPR_REMOTE_PROGRESS_TEXT = $3E0C001E;
  CdoPR_REMOTE_VALIDATE_OK = $3E0D000B;
  CdoPR_RENDERING_POSITION = $370B0003;
  CdoPR_REPLY_RECIPIENT_ENTRIES = $004F0102;
  CdoPR_REPLY_RECIPIENT_NAMES = $0050001E;
  CdoPR_REPLY_REQUESTED = $0C17000B;
  CdoPR_REPLY_TIME = $00300040;
  CdoPR_REPORT_ENTRYID = $00450102;
  CdoPR_REPORT_NAME = $003A001E;
  CdoPR_REPORT_SEARCH_KEY = $00540102;
  CdoPR_REPORT_TAG = $00310102;
  CdoPR_REPORT_TEXT = $1001001E;
  CdoPR_REPORT_TIME = $00320040;
  CdoPR_REPORTING_DL_NAME = $10030102;
  CdoPR_REPORTING_MTA_CERTIFICATE = $10040102;
  CdoPR_REQUESTED_DELIVERY_METHOD = $0C180003;
  CdoPR_RESOURCE_FLAGS = $30090003;
  CdoPR_RESOURCE_METHODS = $3E020003;
  CdoPR_RESOURCE_PATH = $3E07001E;
  CdoPR_RESOURCE_TYPE = $3E030003;
  CdoPR_RESPONSE_REQUESTED = $0063000B;
  CdoPR_RESPONSIBILITY = $0E0F000B;
  CdoPR_RETURNED_IPM = $0033000B;
  CdoPR_ROW_TYPE = $0FF50003;
  CdoPR_ROWID = $30000003;
  CdoPR_RTF_COMPRESSED = $10090102;
  CdoPR_RTF_IN_SYNC = $0E1F000B;
  CdoPR_RTF_SYNC_BODY_COUNT = $10070003;
  CdoPR_RTF_SYNC_BODY_CRC = $10060003;
  CdoPR_RTF_SYNC_BODY_TAG = $1008001E;
  CdoPR_RTF_SYNC_PREFIX_COUNT = $10100003;
  CdoPR_RTF_SYNC_TRAILING_COUNT = $10110003;
  CdoPR_SEARCH = $3607000D;
  CdoPR_SEARCH_KEY = $300B0102;
  CdoPR_SECURITY = $00340003;
  CdoPR_SELECTABLE = $3609000B;
  CdoPR_SEND_INTERNET_ENCODING = $3A710003;
  CdoPR_SEND_RICH_INFO = $3A40000B;
  CdoPR_SENDER_ADDRTYPE = $0C1E001E;
  CdoPR_SENDER_EMAIL_ADDRESS = $0C1F001E;
  CdoPR_SENDER_ENTRYID = $0C190102;
  CdoPR_SENDER_NAME = $0C1A001E;
  CdoPR_SENDER_SEARCH_KEY = $0C1D0102;
  CdoPR_SENSITIVITY = $00360003;
  CdoPR_SENT_REPRESENTING_ADDRTYPE = $0064001E;
  CdoPR_SENT_REPRESENTING_EMAIL_ADDRESS = $0065001E;
  CdoPR_SENT_REPRESENTING_ENTRYID = $00410102;
  CdoPR_SENT_REPRESENTING_NAME = $0042001E;
  CdoPR_SENT_REPRESENTING_SEARCH_KEY = $003B0102;
  CdoPR_SENTMAIL_ENTRYID = $0E0A0102;
  CdoPR_SERVICE_DELETE_FILES = $3D10101E;
  CdoPR_SERVICE_DLL_NAME = $3D0A001E;
  CdoPR_SERVICE_ENTRY_NAME = $3D0B001E;
  CdoPR_SERVICE_EXTRA_UIDS = $3D0D0102;
  CdoPR_SERVICE_NAME = $3D09001E;
  CdoPR_SERVICE_SUPPORT_FILES = $3D0F101E;
  CdoPR_SERVICE_UID = $3D0C0102;
  CdoPR_SERVICES = $3D0E0102;
  CdoPR_SPOOLER_STATUS = $0E100003;
  CdoPR_SPOUSE_NAME = $3A48001E;
  CdoPR_START_DATE = $00600040;
  CdoPR_STATE_OR_PROVINCE = $3A28001E;
  CdoPR_STATUS = $360B0003;
  CdoPR_STATUS_CODE = $3E040003;
  CdoPR_STATUS_STRING = $3E08001E;
  CdoPR_STORE_ENTRYID = $0FFB0102;
  CdoPR_STORE_PROVIDERS = $3D000102;
  CdoPR_STORE_RECORD_KEY = $0FFA0102;
  CdoPR_STORE_STATE = $340E0003;
  CdoPR_STORE_SUPPORT_MASK = $340D0003;
  CdoPR_STREET_ADDRESS = $3A29001E;
  CdoPR_SUBFOLDERS = $360A000B;
  CdoPR_SUBJECT = $0037001E;
  CdoPR_SUBJECT_IPM = $00380102;
  CdoPR_SUBJECT_PREFIX = $003D001E;
  CdoPR_SUBMIT_FLAGS = $0E140003;
  CdoPR_SUPERSEDES = $103A001E;
  CdoPR_SUPPLEMENTARY_INFO = $0C1B001E;
  CdoPR_SURNAME = $3A11001E;
  CdoPR_TELEX_NUMBER = $3A2C001E;
  CdoPR_TEMPLATEID = $39020102;
  CdoPR_TITLE = $3A17001E;
  CdoPR_TNEF_CORRELATION_KEY = $007F0102;
  CdoPR_TRANSMITABLE_DISPLAY_NAME = $3A20001E;
  CdoPR_TRANSPORT_KEY = $0E160003;
  CdoPR_TRANSPORT_MESSAGE_HEADERS = $007D001E;
  CdoPR_TRANSPORT_PROVIDERS = $3D020102;
  CdoPR_TRANSPORT_STATUS = $0E110003;
  CdoPR_TTYTDD_PHONE_NUMBER = $3A4B001E;
  CdoPR_TYPE_OF_MTS_USER = $0C1C0003;
  CdoPR_USER_CERTIFICATE = $3A220102;
  CdoPR_USER_X509_CERTIFICATE = $3A701102;
  CdoPR_VALID_FOLDER_MASK = $35DF0003;
  CdoPR_VIEWS_ENTRYID = $35E50102;
  CdoPR_WEDDING_ANNIVERSARY = $3A410040;
  CdoPR_X400_CONTENT_TYPE = $003C0102;
  CdoPR_X400_DEFERRED_DELIVERY_CANCEL = $3E09000B;
  CdoPR_XPOS = $3F050003;
  CdoPR_YPOS = $3F060003;

  // General
  PR_IPM_PUBLIC_FOLDERS_ENTRYID = $66310102;
  CdoDefaultFolderCalendar = 0;
  CdoDefaultFolderContacts = 5;
  CdoDefaultFolderDeletedItems = 4;
  CdoDefaultFolderInbox = 1;
  CdoDefaultFolderJournal = 6;
  CdoDefaultFolderNotes = 7;
  CdoDefaultFolderOutbox = 2;
  CdoDefaultFolderSentItems = 3;
  CdoDefaultFolderTasks = 8;

  // Message Recipients
  CdoTo = 1;
  CdoCc = 2;
  CdoBcc = 3;

  // Attachment Types
  CdoFileData = 1;
  CdoFileLink = 2;
  CdoOLE = 3;
  CdoEmbeddedMessage = 4;

  // AddressEntry DisplayType
  CdoUser = 0; //   A local messaging user.
  CdoDistList = 1; //   A public distribution list.
  CdoForum = 2; //   A forum, such as a bulletin board or a public folder.
  CdoAgent = 3; //   An automated agent, such as Quote-of-the-Day.
  CdoOrganization = 4;
  //   A special address entry defined for large groups, such as a helpdesk.
  CdoPrivateDistList = 5; //   A private, personally administered distribution list.
  CdoRemoteUser = 6; //   A messaging user in a remote messaging system.

  // Error Codes
  CdoE_OK = 0;
  CdoE_ACCOUNT_DISABLED = $80040124;
  CdoE_AMBIGUOUS_RECIP = $80040700;
  CdoE_BAD_CHARWIDTH = $80040103;
  CdoE_BAD_COLUMN = $80040118;
  CdoE_BAD_VALUE = $80040301;
  CdoE_BUSY = $8004010B;
  CdoE_CALL_FAILED = $80004005;
  CdoE_CANCEL = $80040501;
  CdoE_COLLISION = $80040604;
  CdoE_COMPUTED = $8004011A;
  CdoE_CORRUPT_DATA = $8004011B;
  CdoE_CORRUPT_STORE = $80040600;
  CdoE_DECLINE_COPY = $80040306;
  CdoE_DISK_ERROR = $80040116;
  CdoE_END_OF_SESSION = $80040200;
  CdoE_EXTENDED_ERROR = $80040119;
  CdoE_FAILONEPROVIDER = $8004011D;
  CdoE_FOLDER_CYCLE = $8004060B;
  CdoE_HAS_FOLDERS = $80040609;
  CdoE_HAS_MESSAGES = $8004060A;
  CdoE_INTERFACE_NOT_SUPPORTED = $80004002;
  CdoE_INVALID_ACCESS_TIME = $80040123;
  CdoE_INVALID_BOOKMARK = $80040405;
  CdoE_INVALID_ENTRYID = $80040107;
  CdoE_INVALID_OBJECT = $80040108;
  CdoE_INVALID_PARAMETER = $80070057;
  CdoE_INVALID_TYPE = $80040302;
  CdoE_INVALID_WORKSTATION_ACCOUNT = $80040122;
  CdoE_LOGON_FAILED = $80040111;
  CdoE_MISSING_REQUIRED_COLUMN = $80040202;
  CdoE_NETWORK_ERROR = $80040115;
  CdoE_NO_ACCESS = $80070005;
  CdoE_NO_RECIPIENTS = $80040607;
  CdoE_NO_SUPPORT = $80040102;
  CdoE_NO_SUPPRESS = $80040602;
  CdoE_NON_STANDARD = $80040606;
  CdoE_NOT_ENOUGH_DISK = $8004010D;
  CdoE_NOT_ENOUGH_MEMORY = $8007000E;
  CdoE_NOT_ENOUGH_RESOURCES = $8004010E;
  CdoE_NOT_FOUND = $8004010F;
  CdoE_NOT_IN_QUEUE = $80040601;
  CdoE_NOT_INITIALIZED = $80040605;
  CdoE_NOT_ME = $80040502;
  CdoE_OBJECT_CHANGED = $80040109;
  CdoE_OBJECT_DELETED = $8004010A;
  CdoE_PASSWORD_CHANGE_REQUIRED = $80040120;
  CdoE_PASSWORD_EXPIRED = $80040121;
  CdoE_SESSION_LIMIT = $80040112;
  CdoE_STRING_TOO_LONG = $80040105;
  CdoE_SUBMITTED = $80040608;
  CdoE_TABLE_EMPTY = $80040402;
  CdoE_TABLE_TOO_BIG = $80040403;
  CdoE_TIMEOUT = $80040401;
  CdoE_TOO_BIG = $80040305;
  CdoE_TOO_COMPLEX = $80040117;
  CdoE_TYPE_NO_SUPPORT = $80040303;
  CdoE_UNABLE_TO_ABORT = $80040114;
  CdoE_UNABLE_TO_COMPLETE = $80040400;
  CdoE_UNCONFIGURED = $8004011C;
  CdoE_UNEXPECTED_ID = $80040307;
  CdoE_UNEXPECTED_TYPE = $80040304;
  CdoE_UNKNOWN_CPID = $8004011E;
  CdoE_UNKNOWN_ENTRYID = $80040201;
  CdoE_UNKNOWN_FLAGS = $80040106;
  CdoE_UNKNOWN_LCID = $8004011F;
  CdoE_USER_CANCEL = $80040113;
  CdoE_VERSION = $80040110;
  CdoE_WAIT = $80040500;
  CdoW_APPROX_COUNT = $00040482;
  CdoW_CANCEL_MESSAGE = $00040580;
  CdoW_ERRORS_RETURNED = $00040380;
  CdoW_NO_SERVICE = $00040203;
  CdoW_PARTIAL_COMPLETION = $00040680;
  CdoW_POSITION_CHANGED = $00040481;

type
  TOleVarPtr = ^OleVariant;

  TCdoMapiSession = class(TObject)
  private
    FImpersonated: boolean;
    FLastErrorCode: DWORD;
    FMyName,
      FMyEMailAddress,
      FLastError: string;
    FCurrentUser,
      FOleGlobalAddressList,
      FOleDeletedItems,
      FOleOutBox, FOleSentItems,
      FOleInbox, FOleContacts,
      FOleSession: OleVariant;
    FConnected: boolean;
    function GetFVersion: string;
  protected
    procedure SetOleFolders;
  public
    // System
    constructor Create; overload;
    constructor Create(const Profile: string); overload;
    constructor Create(const Profile: string;
      const UserName: string;
      const Domain: string;
      const Password: string); overload;
    destructor Destroy; override;

    // User
    function LoadAddressList(StringList: TStrings): boolean;
    function LoadObjectList(const FolderOle: OleVariant; List: TList): boolean;
    function LoadEMailTree(TV: TTreeView; Expand1stLevel: boolean = false;
      SubjectMask: string = ''): boolean;
    function LoadContactList(const FolderOle: OleVariant;
      Items: TStrings): boolean; overload;
    function LoadContactList(const FolderName: string;
      Items: TStrings): boolean; overload;
    procedure ShowContactDetails(Contact: OleVariant);

    function First(const FolderOle: OleVariant; out ItemOle: OleVariant): boolean;
    function Last(const FolderOle: OleVariant; out ItemOle: OleVariant): boolean;
    function Next(const FolderOle: OleVariant; out ItemOle: OleVariant): boolean;
    function Prior(const FolderOle: OleVariant; out ItemOle: OleVariant): boolean;
    function AsString(const ItemOle: Olevariant; const FieldIdConstant: DWORD):
      string;

    // Properties
    property CurrentUser: OleVariant read FCurrentUser;
    property Connected: boolean read FConnected;
    property LastErrorMess: string read FlastError;
    property LastErrorCode: DWORD read FlastErrorCode;
    property InBox: OleVariant read FOleInBox;
    property OutBox: OleVariant read FOleOutBox;
    property DeletedItems: Olevariant read FOleDeletedItems;
    property SentItems: Olevariant read FOleSentItems;
    property GlobalAddressList: Olevariant read FOleGlobalAddressList;
    property Contacts: Olevariant read FOleContacts;
    property Session: OleVariant read FOleSession;
    property Version: string read GetFVersion;
    property MyName: string read FMyName;
    property MyEMailAddress: string read FMyEMailAddress;
  end;

  // Function Prototypes
function CdoNothing(Obj: OleVariant): boolean;
function CdoDefaultProfile: string;
procedure CdoDisposeList(WorkList: TList);
procedure CdoDisposeObjects(WorkStrings: TStrings);
procedure CdoDisposeNodes(WorkData: TTreeNodes);

function VarNothing: IDispatch;

// -----------------------------------------------------------------------------
implementation

// ===================================
// Emulate VB function IS NOTHING
// ===================================

function CdoNothing(Obj: OleVariant): boolean;
begin
  Result := IDispatch(Obj) = nil;
end;

// ============================================
// Emulate VB function VarX := Nothing
// ============================================

function VarNothing: IDispatch;
var
  Retvar: IDispatch;
begin
  Retvar := nil;
  Result := Retvar;
end;

// ============================================
// Get Default Message profile from registry
// ============================================

function CdoDefaultProfile: string;
var
  WinReg: TRegistry;
  Retvar: string;
begin
  Retvar := '';
  WinReg := TRegistry.Create;

  if
    WinReg.OpenKey('\Software\Microsoft\Windows NT\CurrentVersion\Windows Messaging Subsystem\Profiles', false) then
  begin
    Retvar := WinReg.ReadString('DefaultProfile');
    WinReg.CloseKey;
  end;

  WinReg.Free;
  Result := Retvar;
end;

// =================================================
// Disposes of any memory allocations in a TList
// =================================================

procedure CdoDisposeList(WorkList: TList);
var
  i: integer;
begin
  if WorkList <> nil then
    for i := 0 to WorkList.Count - 1 do
      if WorkList[i] <> nil then
        dispose(WorkList[i]);
end;

// ====================================================
// Disposes of any memory allocations in a TStringList
// ====================================================

procedure CdoDisposeObjects(WorkStrings: TStrings);
var
  i: integer;
begin
  if WorkStrings <> nil then
    for i := 0 to WorkStrings.Count - 1 do
      if WorkStrings.Objects[i] <> nil then
        dispose(TOleVarPtr(WorkStrings.Objects[i]));
end;

// ====================================================
// Disposes of any memory allocations in a TTreeView
// ====================================================

procedure CdoDisposeNodes(WorkData: TTreeNodes);
var
  i: integer;
  TN: TTreeNode;
begin
  if WorkData <> nil then
  begin
    for i := 0 to WorkData.Count - 1 do
    begin
      TN := WorkData[i];
      if TN.Data <> nil then
        dispose(TOleVarPtr(TN.Data));
    end;
  end;
end;

// -----------------------------------------------------------------------------
// TCdoMapiSession
// -----------------------------------------------------------------------------

// ================
// Default Profile
// ================

constructor TCdoMapiSession.Create;
begin
  FImpersonated := false;
  FLastError := '';
  FLastErrorCode := CdoE_OK;
  try
    FOleSession := CreateOleObject('MAPI.Session');
    FOleSession.Logon(CdoDefaultProfile);
    SetOleFolders;
  except
    on E: Exception do
    begin
      FLastError := E.Message;
      FLastErrorCode := CdoE_LOGON_FAILED;
      FConnected := false;
    end;
  end;
end;

// ===========================
// With Specified Profile
// ===========================

constructor TCdoMapiSession.Create(const Profile: string);
begin
  FImpersonated := false;
  try
    FOleSession := CreateOleObject('MAPI.Session');
    FOleSession.Logon(Profile);
    SetOleFolders;
  except
    on E: Exception do
    begin
      FLastError := E.Message;
      FLastErrorCode := CdoE_LOGON_FAILED;
      FConnected := false;
    end;
  end;
end;

// ======================================================
// Impersonate amother user and use specified profile
// ======================================================

constructor TCdoMapiSession.Create(const Profile: string;
  const UserName: string;
  const Domain: string;
  const Password: string);
var
  SecurityH: THandle;
begin
  FImpersonated := false;
  try
    LogonUser(PChar(UserName), PChar(Domain), PChar(Password),
      LOGON32_LOGON_SERVICE,
      LOGON32_PROVIDER_DEFAULT, SecurityH);
    FImpersonated := ImpersonateLoggedOnUser(SecurityH);
    FOleSession := CreateOleObject('MAPI.Session');
    FOleSession.Logon(Profile, Password, false, true);
    SetOleFolders;
  except
    on E: Exception do
    begin
      FLastError := E.Message;
      FLastErrorCode := CdoE_LOGON_FAILED;
      FConnected := false;
    end;
  end;
end;

// ======================
// Free and Clean up
// ======================

destructor TCdoMapiSession.Destroy;
begin
  if FConnected then
    FOleSession.LogOff;
  FCurrentUser := Unassigned;
  FOleGlobalAddressList := Unassigned;
  FOleSentItems := Unassigned;
  FOleContacts := Unassigned;
  FOleOutBox := Unassigned;
  FOleDeletedItems := Unassigned;
  FOleInBox := Unassigned;
  FOleSession := Unassigned;
  if FImpersonated then
    RevertToSelf;
  inherited Destroy;
end;

// =======================================================
// Addition initialization called by Create() oveloads
// =======================================================

procedure TCdoMapiSession.SetOleFolders;
begin
  try
    FOleGlobalAddressList :=
      FOleSession.AddressLists['Global Address List'].AddressEntries;
  except
    FOleGlobalAddressList := VarNothing;
  end;

  try
    FOleContacts := FOleSession.AddressLists['Contacts'].AddressEntries;
  except
    FOleContacts := VarNothing;
  end;

  try
    FOleInBox := FOleSession.InBox.Messages;
  except
    FOleInBox := VarNothing;
  end;

  try
    FOleOutBox := FOleSession.OutBox.Messages;
  except
    FOleOutBox := VarNothing;
  end;

  try
    FOleDeletedItems :=
      FOleSession.GetDefaultFolder(CdoDefaultFolderDeletedItems).Messages;
  except
    FOleDeletedItems := VarNothing;
  end;

  try
    FOleSentItems := FOleSession.GetDefaultFolder(CdoDefaultFolderSentItems).Messages;
  except
    FOleSentItems := VarNothing;
  end;

  try
    FCurrentUser := FOleSession.CurrentUser;
    FMyName := FCurrentUser.Name;
  except
    FCurrentUser := VarNothing;
  end;

  FConnected := true;
  FMyEMailAddress := AsString(FCurrentUser, CdoPR_EMAIL_AT_ADDRESS);
end;

// ======================
// Return CDO Version
// ======================

function TCdoMapiSession.GetFVersion: string;
begin
  if FConnected then
    Result := FOleSession.Version
  else
    Result := 'Not Connected';
end;

// ========================================================
// Fill a string list with all available address lists
// ========================================================

function TCdoMapiSession.LoadAddressList(StringList: TStrings): boolean;
var
  Addr: OleVariant;
  i: integer;
  Retvar: boolean;
begin
  Retvar := false;

  if FConnected then
  begin
    StringList.Clear;
    try
      Addr := FOleSession.AddressLists;
      for i := 1 to Addr.Count do
        StringList.Add(Addr.Item[i].Name);
      Retvar := true;
    except
      on E: Exception do
      begin
        FLastError := E.Message;
        FLastErrorCode := CdoE_NOT_FOUND;
      end;
    end;

    Addr := Unassigned;
  end;

  Result := Retvar;
end;

// =================================================
// Iteration functions
// =================================================

function TCdoMapiSession.First(const FolderOle: OleVariant;
  out ItemOle: OleVariant): boolean;
var
  Retvar: boolean;
begin
  Retvar := true;

  if FConnected then
  begin
    try
      ItemOle := FolderOle.GetFirst;
      if CdoNothing(ItemOle) then
      begin
        Retvar := false;
      end;
    except
      on E: Exception do
      begin
        FLastError := E.Message;
        FLastErrorCode := CdoE_NOT_FOUND;
        Retvar := false;
      end;
    end;
  end
  else
    Retvar := false;

  Result := Retvar;
end;

function TCdoMapiSession.Last(const FolderOle: OleVariant;
  out ItemOle: OleVariant): boolean;
var
  Retvar: boolean;
begin
  Retvar := true;

  if FConnected then
  begin
    try
      ItemOle := FolderOle.GetLast;
      if CdoNothing(ItemOle) then
      begin
        Retvar := false;
      end;
    except
      on E: Exception do
      begin
        FLastError := E.Message;
        FLastErrorCode := CdoE_NOT_FOUND;
        Retvar := false;
      end;
    end;
  end
  else
    Retvar := false;

  Result := Retvar;
end;

function TCdoMapiSession.Next(const FolderOle: OleVariant;
  out ItemOle: OleVariant): boolean;
var
  Retvar: boolean;
begin
  Retvar := true;

  if FConnected then
  begin
    try
      ItemOle := FolderOle.GetNext;
      if CdoNothing(ItemOle) then
      begin
        Retvar := false;
      end;
    except
      on E: Exception do
      begin
        FLastError := E.Message;
        FLastErrorCode := CdoE_NOT_FOUND;
        Retvar := false;
      end;
    end;
  end
  else
    Retvar := false;

  Result := Retvar;
end;

function TCdoMapiSession.Prior(const FolderOle: OleVariant;
  out ItemOle: OleVariant): boolean;
var
  Retvar: boolean;
begin
  Retvar := true;

  if FConnected then
  begin
    try
      ItemOle := FolderOle.GetPrior;
      if CdoNothing(ItemOle) then
      begin
        Retvar := false;
      end;
    except
      on E: Exception do
      begin
        FLastError := E.Message;
        FLastErrorCode := CdoE_NOT_FOUND;
        Retvar := false;
      end;
    end;
  end
  else
    Retvar := false;

  Result := Retvar;
end;

// =========================
// Field Get Routines
// =========================

function TCdoMapiSession.AsString(const ItemOle: Olevariant;
  const FieldIdConstant: DWORD): string;
var
  Retvar: string;
begin
  if FConnected then
  begin
    // Special case for EMail Address - Resolve to normal form
    if FieldIdConstant = CdoPR_EMAIL_AT_ADDRESS then
    begin
      try
        RetVar := ItemOle.Fields[CdoPR_EMAIL_AT_ADDRESS];
      except
        try
          Retvar := ItemOle.Fields[CdoPR_EMAIL_ADDRESS];
        except
          on E: Exception do
          begin
            FLastError := E.Message;
            FLastErrorCode := CdoE_INVALID_OBJECT;
            Retvar := '';
          end;
        end;
      end;
    end
    else
    begin
      try
        RetVar := ItemOle.Fields[FieldIdConstant];
      except
        on E: Exception do
        begin
          FLastError := E.Message;
          FLastErrorCode := CdoE_INVALID_OBJECT;
          Retvar := '';
        end;
      end;
    end;
  end
  else
    Retvar := '';

  Result := Retvar;
end;

// ================================================
// Load EMail folders Messages into a TTreeView
// Allocations in Nodes are freed at each call to
// LoadEMailTree, but you are responsible to call
// CdoDisposeNodes or dispose of the allocations
// yourself at Application end
// ================================================

function TCdoMapiSession.LoadEMailTree(TV: TTreeView;
  Expand1stLevel: boolean = false;
  SubjectMask: string = ''): boolean;
var
  DocPtr: TOleVarPtr;
  Item: OleVariant;
  TN, RN, XN: TTreeNode;
  Retvar,
    Images: boolean;

  procedure AddTree(const Name: string; Folder: Olevariant);
  begin
    if First(Folder, Item) then
    begin
      TN := TV.Items.AddChildObject(RN, Name, nil);
      if Images then
      begin
        TN.ImageIndex := 0;
        TN.SelectedIndex := 0;
      end;

      while true do
      begin
        if (SubjectMask = '') or (MatchesMask(Item.Subject, SubjectMask)) then
        begin
          New(DocPtr);
          DocPtr^ := Item;
          if Item.Subject = '' then
            XN := TV.Items.AddChildObject(TN, '<No Subject> - ' + Item.Sender.Name,
              DocPtr)
          else
            XN := TV.Items.AddChildObject(TN, Item.Subject, DocPtr);

          if Images then
          begin
            XN.ImageIndex := 1;
            XN.SelectedIndex := 1;
          end;
        end;

        if not Next(Folder, Item) then
          break;
      end;
    end;
  end;

begin
  Retvar := false;

  if FConnected then
  begin
    Screen.Cursor := crHourGlass;
    Application.ProcessMessages;
    CdoDisposeNodes(TV.Items);
    TV.Items.Clear;
    TV.Items.BeginUpdate;
    TN := nil;
    RN := nil;
    RN := TV.Items.AddObject(RN, 'Personal Folders', nil);
    Images := (TV.Images <> nil) and (TV.Images.Count >= 2);
    if Images then
    begin
      RN.ImageIndex := 0;
      RN.SelectedIndex := 0;
    end;

    try
      AddTree('Inbox', InBox);
      AddTree('Outbox', OutBox);
      AddTree('Sent Items', SentItems);
      AddTree('Deleted Items', DeletedItems);
      Retvar := true;
    except
      on E: Exception do
      begin
        FLastError := E.Message;
        FLastErrorCode := CdoE_CALL_FAILED;
      end;
    end;

    if Expand1stLevel then
      TV.Items[0].Expand(false);
    TV.Items.EndUpdate;
    Screen.Cursor := crDefault;
    Item := Unassigned;
    Screen.Cursor := crDefault;
  end;

  Result := Retvar;
end;

// =============================================================
// Load Contact list into a TStringList
// Allocations in Objects are freed at each call to
// LoadEMailTree, but you are responsible to call
// CdoDisposeObjects or dispose of the allocations yourself at
// Application end.
//
// Format "[LastName FirstName]EMailAddress"
// ===============================================================

function TCdoMapiSession.LoadContactList(const FolderOle: OleVariant;
  Items: TStrings): boolean;
var
  ContactPtr: TOleVarPtr;
  Contact: OleVariant;
  AddrType,
    FullName,
    LastName, FirstName, Email: string;
  Retvar: boolean;
begin
  Retvar := false;

  if FConnected then
  begin
    Screen.Cursor := crHourGlass;
    Application.ProcessMessages;
    CdoDisposeObjects(Items);
    Items.Clear;
    Items.BeginUpdate;

    try
      if First(FolderOle, Contact) then
      begin
        while true do
        begin
          LastName := trim(AsString(Contact, CdoPR_SURNAME));
          FirstName := trim(AsString(Contact, CdoPR_GIVEN_NAME));
          EMail := AsString(Contact, CdoPR_EMAIL_AT_ADDRESS);
          AddrType := AsString(Contact, CdoPR_ADDRTYPE);

          if (EMail <> '') and (AddrType <> 'FAX') then
          begin
            New(ContactPtr);
            ContactPtr^ := Contact;
            FullName := trim(LastName + ' ' + FirstName);
            Items.AddObject('[' + FullName + ']' + EMail, TObject(ContactPtr));
          end;

          if not Next(FolderOle, Contact) then
            break;
        end;

        Retvar := true;
      end;
    except
      on E: Exception do
      begin
        FLastError := E.Message;
        FLastErrorCode := CdoE_CALL_FAILED;
      end;
    end;

    Items.EndUpdate;
    Contact := Unassigned;
    Screen.Cursor := crDefault;
  end;

  Result := Retvar;
end;

function TCdoMapiSession.LoadContactList(const FolderName: string;
  Items: TStrings): boolean;
var
  Contacts: OleVariant;
  Retvar: boolean;
begin
  Retvar := false;

  if FConnected then
  begin
    try
      Contacts := FOleSession.AddressLists[FolderName].AddressEntries;
      if not CdoNothing(Contacts) then
      begin
        Retvar := LoadContactList(Contacts, Items);
      end;
      Contacts := Unassigned;
    except
      on E: Exception do
      begin
        CdoDisposeObjects(Items);
        Items.Clear;
        FLastError := E.Message;
        FLastErrorCode := CdoE_CALL_FAILED;
      end;
    end;
  end;

  Result := Retvar;
end;

// =============================================================
// Load Folder list into a TList
// Allocations in Objects are freed at each call to
// LoadObjectList, but you are responsible to call
// CdoDisposeList or dispose of the allocations yourself at
// Application end.
// ===============================================================

function TCdoMapiSession.LoadObjectList(const FolderOle: OleVariant;
  List: TList): boolean;
var
  ItemPtr: TOleVarPtr;
  Item: OleVariant;
  Retvar: boolean;
begin
  Retvar := false;

  if FConnected then
  begin
    Screen.Cursor := crHourGlass;
    Application.ProcessMessages;
    CdoDisposeList(List);
    List.Clear;

    try
      if First(FolderOle, Item) then
      begin
        while true do
        begin
          New(ItemPtr);
          ItemPtr^ := Item;
          List.Add(ItemPtr);

          if not Next(FolderOle, Item) then
            break;
        end;
      end;
    except
      on E: Exception do
      begin
        CdoDisposeList(List);
        List.Clear;
        FLastError := E.Message;
        FLastErrorCode := CdoE_CALL_FAILED;
      end;
    end;

    Item := Unassigned;
    Screen.Cursor := crDefault;
  end;

  Result := Retvar;
end;

// =================================================================
// The CDO method Details() gives an error if cancel is pressed
// =================================================================

procedure TCdoMapiSession.ShowContactDetails(Contact: OleVariant);
begin
  if not CdoNothing(Contact) then
  try
    Contact.Details(Application.Handle);
  except
    // Not interested - either a dialog appears or not
  end;
end;

end.

Взято с

Delphi Knowledge Base

Multiple records found, but only one was expected

Multiple records found, but only one was expected

При выполнении некоторых живых запросов, возвращающих единственную запись, BDE ругается

Автор: Nomadic

При выполнении некоторых живых запросов, возвращающих единственную запись, BDE ругается 'multiple records found, but only one was expected'.
Запросы вида

SELECT c, b, a, q FROM T WHERE b = :b,

где ключ c, но BDE посчитала ключом a. Интересный запрос, да? Такое впечатление, что, поскольку ключом в исходной таблице являлась третья колонка, то Дельфы посчитали ключом третью колонку.
Перестановкой SELECT a, b, c, q... все исправилось. Я решил теперь использовать в таких (live) запросах только SELECT *.

My Kylix application won't run outside the IDE.

My Kylix application won't run outside the IDE.

Why is it when I try to run my Kylix App outside the IDE I get this message:
"error loading shared libraries: libqtintf.so: cannot open shared file: No such file or directory"?


This message and similar ones occur when ../kylix/bin is not included in your path when trying to use CLX components. Running /usr/kylix/bin/kylixpath is a short fix, but you can also add the line to your .bashrc file to set the paths whenever you start a shell. Be sure to change the appropriate .bashrc (ie. for user jbrown /home/jbrown/.bashrc).

Example .bashrc:
------------------------------
#.bashrc

..
source /usr/kylix/bin/kylixpath
..

------------------------------

Мышка

Мышка

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


















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

Мышка/клавиатура

Мышка/клавиатура

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

·
·  
·  
·  
·  
·  
·  
·  
·  
·  
·  
·  
·  
·  
·  
·  
·  
·  
·  
·  
·  
·  
·  
·  
·  
·  

·
·  
·  
·  
·  
·  
·  
·  
·  
·  
·  
·  
·  
·  

Набор dialup соединения по умолчанию

Набор dialup соединения по умолчанию

Для w9x, me:

procedureTForm1.Button1Click(Sender: TObject);
var cmd, par, fil, dir: PChar;
begin
  Cmd := 'open';
  Fil := 'rasdial.exe';
  Par := PChar(edtEntry.Text + ' ' + EdtUser.Text + ' ' + EdtPass.Text);
  Dir := 'C:';
  ShellExecute(Handle, Cmd, Fil, Par, Dir, SW_SHOWMINNOACTIVE);
end;

procedure TForm1.Button2Click(Sender: TObject);
var Cmd, Par, Fil, Dir: PChar;
begin
  Cmd := 'open';
  Fil := 'rasdial.exe';
  Par := PChar(EdtEntry.Text + ' /DISCONNECT');
  Dir := 'C:';
  ShellExecute(Handle, Cmd, Fil, Par, Dir, SW_SHOWMINNOACTIVE);
end;


uses Registry, Windows;

function DUNDialDefault(Hide: Boolean): Boolean;
var Reg: TRegistry;
  TempResult: Boolean;
  Name, Con: string;
  ASW: Integer;
begin
  with TRegistry.Create do
  try
    RootKey := HKEY_CURRENT_USER;
    if OpenKey('\RemoteAccess', False) then
      begin
        TempResult := True;
        Name := ReadString('Default');
      end
    else
      TempResult := False;
  finally
    Free;
  end;
  if TempResult then
    begin
      if Hide then
        ASW := SW_HIDE
      else
        ASW := SW_SHOWDEFAULT;
      Con := 'rnaui.dll,RnaDial ' + Name;
      ShellExecute(0, nil, 'rundll32.exe', PChar(Con), 'C:\windows\', ASW);
    end; {IF}
  Result := TempResult;
end;

Для Nt, w2k, XP:

Uses ..., WinInet;

InternetAutoDial (INTERNET_AUTODIAL_FORCE_ONLINE, Handle);
Handle - окно, из которого вызывается функция.

Автор:

Song

Взято из

Над какой закладкой курсор в TabControl?

Над какой закладкой курсор в TabControl?

functionForm1.ItemAtPos(TabControlHandle : HWND; X, Y : Integer) : Integer;
var
  HitTestInfo : TTCHitTestInfo;
  HitIndex : Integer;
begin
  HitTestInfo.pt.x := X;
  HitTestInfo.pt.y := Y;
  HitTestInfo.flags := 0;
  HitIndex := SendMessage(TabControlHandle, TCM_HITTEST, 0, Longint(@HitTestInfo));
  Result := HitIndex;
end;

Взято с

Нахождение угла между радиус вектором и осью OX

Нахождение угла между радиус вектором и осью OX

functionangl(y,x:extended):extended;  assembler; 
 asm 
  fld y   {СТЕК!!! Сначала у, потом х} 
  fld x 
  fpatan 
 end; 

вывод ответа:
s:=angl(0,1)*180/pi; {Т.к возвращается угол в радианах} 
writeln(s:0:0); 

Автор

Bink (Новиков Виктор)

Найти и выделить текст в TWebBrowser?

Найти и выделить текст в TWebBrowser?

{....} 

  private 
    procedure SearchAndHighlightText(aText: string); 
     
{....} 

procedure TForm1.SearchAndHighlightText(aText: string); 
var 
  i: Integer; 
begin 
  for i := 0 to WebBrowser1.OleObject.Document.All.Length - 1 do 
  begin 
    if Pos(aText, WebBrowser1.OleObject.Document.All.Item(i).InnerText) <> 0 then 
    begin 
      WebBrowser1.OleObject.Document.All.Item(i).Style.Color := '#FFFF00'; 
      WebBrowser1.OleObject.Document.All.Item(i).ScrollIntoView(True); 
    end; 
  end; 
end; 

procedure TForm1.Button1Click(Sender: TObject); 
begin 
  SearchAndHighlightText('some text...'); 
end; 

Взято с сайта

Найти smtp mailserver по умолчанию?

Найти smtp mailserver по умолчанию?

{ 
  Here is some code I successfully used te determine 
  the DEFAULT mailaccount, which is used in 
  Outlook Express, to send outgoing mail via SMTP. 
} 

procedure TForm1.ReadRegistryDefaults; 
var 
  Registry: TRegistry; 
  AccountStr: string; 
begin 
  Registry := TRegistry.Create; 
  try 
    Registry.RootKey := hkey_CURRENT_USER; 
    if Registry.OpenKey('software\microsoft\internet account manager', False) then  {} 
    begin 
      AccountStr := Registry.ReadString('default mail account'); 
      Registry.CloseKey; 
      if (AccountStr <> '') then 
        if Registry.OpenKey('software\microsoft\internet account manager\accounts\' + 
          AccountStr, False) then  {} 
        begin 
          Edit_Server.Text  := Registry.ReadString('SMTP Server'); 
          Edit_Account.Text := Registry.ReadString('SMTP Email Address'); 
          Registry.CloseKey; 
        end; 
    end; 
  finally 
    Registry.Free; 
  end; 
end; 

Взято с сайта

Написание сервисов Windows NT на WinAPI

Написание сервисов Windows NT на WinAPI

Источник: delphi.xonix.ru
Причиной написания этой статьи, как не странно, стала необходимость написания своего сервиса. Но в Borland'е решили немного "порадовать" нас, пользователей Delphi 6 Personal, не добавив возможности создания сервисов (в остальных версиях Delphi 5 и 6 эта возможность имеется в виде класса TService). Решив, что еще не все потеряно, взял на проверку компоненты из одноименного раздела этого сайта. Первый оказался с многочисленными багами, а до пробы второго я не дошел, взглянув на исходник - модуль Forms в Uses это не только окошки, но и более 300 килобайт "веса" программы. Бессмысленного увеличения размера не хотелось и пришлось творить свое.
Так как сервис из воздуха не сотворишь, то мой исходник и эта статья очень сильно опираются на MSDN.

Итак, приступим к написанию своего сервиса...
Обычный Win32-сервис это обычная программа. Программу рекомендуется сделать консольной (DELPHI MENU | Project | Options.. | Linker [X]Generate Console Application) и крайне рекомендуется сделать ее без форм !!! и удалить модуль Forms из Uses. Рекомендуется потому, что, во-первых, это окошко показывать не стоит потому, что оно позволит любому юзеру, прибив ваше окошко прибить и сервис и, во-вторых, конечно же, размер файла (19Kb против 350 ). Поэтому удаляем форму (DELPHI MENU | Project | Remove from project... ). Удалив все формы, перейдем на главный модуль проекта, в котором удаляем текст между begin и end и Forms из Uses и добавляем Windows и WinSvc. В результате должно получиться что-то вроде этого

programProject1;

uses
 Windows,WinSvc;

{$R *.res}

begin

end.

На этом подготовительный этап закончен - начинаем писАть сервис.
Главная часть программы   
Как уже отмечалось - сервис это обычная программа. Программа в Pascal'е находится между begin и end. После запуска нашего сервиса (здесь и далее под запуском сервиса понимается именно запуск его из Менеджера сервисов, а не просто запуск exe'шника сервиса) менеджер сервисов ждет пока наш сервис вызовет функцию StartServiceCtrlDispatcher.Ждать он будет недолго - если в нашем exe'шнике несколько сервисов то секунд 30, если один - около секунды, поэтому помещаем вызов StartServiceCtrlDispatcher поближе к begin.

StartServiceCtrlDispatcher качестве аргумента требует _SERVICE_TABLE_ENTRYA, поэтому добавляем в var DispatchTable : array [0..кол-во сервисов] of _SERVICE_TABLE_ENTRYA; и заполняем этот массив (естественно перед вызовом StartServiceCtrlDispatcher).

Т.к. в нашем ехешнике будет 1 сервис, то заполняем его так :

 DispatchTable[0].lpServiceName:=ServiceName;
 DispatchTable[0].lpServiceProc:=@ServiceProc;

 DispatchTable[1].lpServiceName:=nil;
 DispatchTable[1].lpServiceProc:=nil;

Советую завести константы ServiceName - имя сервиса и ServiceDisplayName - отображаемое имя.
ServiceProc - основная функция сервиса(о ней ниже), а в функцию мы передаем ее адрес.
В DispatchTable[кол-во сервисов] все равно nil - это показывает функции, что предыдущее поле было последним. У меня получилось так :

begin
 DispatchTable[0].lpServiceName:=ServiceName;
 DispatchTable[0].lpServiceProc:=@ServiceProc;

 DispatchTable[1].lpServiceName:=nil;
 DispatchTable[1].lpServiceProc:=nil;

 if not StartServiceCtrlDispatcher(DispatchTable[0])
  then LogError('StartServiceCtrlDispatcher Error');
end.

StartServiceCtrlDispatcher выполнится только после того, как все сервисы будут остановлены.

Функция LogError протоколирует ошибки - напишите ее сами.
Функция ServiceMain   
ServiceMain - основная функция сервиса. Если в ехешнике несколько сервисов, но для каждого сервиса пишется своя ServiceMain функция. Имя функции может быть любым! и передается в DispatchTable.lpServiceProc:=@ServiceMain (см.предыдущущий абзац). У меня она называется ServiceProc и описывается так:
procedure ServiceProc(argc : DWORD;var argv : array of PChar);stdcall;
argc кол-во аргументов и их массив argv передаются менеджером сервисов из настроек сервиса. НЕ ЗАБЫВАЙТЕ STDCALL!!! Такая забывчивость - частая причина ошибки в программе.

В ServiceMain требуется выполнить подготовку к запуску сервиса и зарегистрировать обработчик сообщений от менеджера сервисов (Handler). Опять после запуска ServiceMain и до запуска RegisterServiceCtrlHandler должно пройти минимум времени. Если сервису надо делать что-нибудь очень долго и обязательно до вызова RegisterServiceCtrlHandler, то надо посылать сообщение SERVICE_START_PENDING функией SetServiceStatus.

Итак, в RegisterServiceCtrlHandler передаем название нашего сервиса и адрес функции Handler'а (см.далее). Далее выполняем подготовку к запуску и настройку сервиса. Остановимся на настройке поподробнее.
Эта самая настройка var ServiceStatus : SERVICE_STATUS;
(ServiceStatusHandle : SERVICE_STATUS_HANDLE и ServiceStatus надо сделать глобальными переменными и поместить их выше всех функций).

dwServiceType

- тип сервиса

SERVICE_WIN32_OWN_PROCESS
Одиночный сервис

SERVICE_WIN32_SHARE_PROCESS
Несколько сервисов в одном процессе

SERVICE_INTERACTIVE_PROCESS
интерактивный сервис (может взаимодействовать с пользователем).

Остальные константы - о драйверах. Если надо - смотрите их в MSDN.

dwControlsAccepted - принимаемые сообщения (какие сообщения мы будем обрабатывать)       
SERVICE_ACCEPT_PAUSE_CONTINUE   приостановка/перезапуск   
SERVICE_ACCEPT_STOP   остановка сервиса   
SERVICE_ACCEPT_SHUTDOWN   перезагрузка компьютера   
SERVICE_ACCEPT_PARAMCHANGE   изменение параметров сервиса без перезапуска (Win2000 и выше)   
Остальные сообщения смотрите опять же в MSDN (куда уж без него ;-)

dwWin32ExitCode и dwServiceSpecificExitCode - коды ошибок сервиса. Если все идет нормально, то они должны быть равны нулю, иначе коду ошибки.

dwCheckPoint - если сервис выполняет какое-нибудь долгое действие при остановке, запуске и т.д. то dwCheckPoint является индикатором прогресса (увеличивайте его, чтобы дать понять, что сервис не завис), иначе он должен быть равен нулю.

dwWaitHint - время, через которое сервис должен послать свой новый статус менеджеру сервисов при выполнении действия (запуска, остановки и т.д.). Если dwCurrentState и dwCheckPoint через это кол-во миллисекунд не изменится, то менеджер сервисов решит, что произошла ошибка.

dwCurrentState - см. где-то здесь Ставим его в SERVICE_RUNNING, если сервис запущен

После заполнения этой структуры посылаем наш новый статус функцией SetServiceStatus и мы работаем :).

После этого пишем код самого сервиса. Я вернусь к этому попозже.
Вот так выглядит моя ServiceMain :

procedure ServiceProc(argc : DWORD;var argv : array of PChar);stdcall;
var
 Status : DWORD;
 SpecificError : DWORD;
begin
  ServiceStatus.dwServiceType      := SERVICE_WIN32;
  ServiceStatus.dwCurrentState     := SERVICE_START_PENDING;
  ServiceStatus.dwControlsAccepted := SERVICE_ACCEPT_STOP 
    or SERVICE_ACCEPT_PAUSE_CONTINUE;
  ServiceStatus.dwWin32ExitCode           := 0;
  ServiceStatus.dwServiceSpecificExitCode := 0;
  ServiceStatus.dwCheckPoint              := 0;
  ServiceStatus.dwWaitHint                := 0;

  ServiceStatusHandle := 
           RegisterServiceCtrlHandler(ServiceName,@ServiceCtrlHandler);
  if ServiceStatusHandle = 0 then WriteLn('RegisterServiceCtrlHandler Error');

  Status :=ServiceInitialization(argc,argv,SpecificError);
  if Status <> NO_ERROR
   then begin
    ServiceStatus.dwCurrentState := SERVICE_STOPPED;
    ServiceStatus.dwCheckPoint   := 0;
    ServiceStatus.dwWaitHint     := 0;
    ServiceStatus.dwWin32ExitCode:=Status;
    ServiceStatus.dwServiceSpecificExitCode:=SpecificError;

    SetServiceStatus (ServiceStatusHandle, ServiceStatus);
   LogError('ServiceInitialization');
    exit;
   end;

   ServiceStatus.dwCurrentState :=SERVICE_RUNNING;
   ServiceStatus.dwCheckPoint   :=0;
   ServiceStatus.dwWaitHint     :=0;

   if not SetServiceStatus (ServiceStatusHandle,ServiceStatus)
    then begin
     Status:=GetLastError;
    LogError('SetServiceStatus');
     exit;
    end;
  // WORK HERE 
  //ЗДЕСЬ БУДЕТ ОСНОВНОЙ КОД ПРОГРАММЫ
end;

Функция Handler   
Функция Handler будет вызываться менеджером сервисов при передаче сообщений сервису. Опять же название функции - любое. Адрес функции передается с помощью функции RegisterServiceCtrlHandler (см. выше). Функция имеет один параметр типа DWORD (Cardinal) - сообщение сервису. Если в одном процессе несколько сервисов - для каждого из них должна быть своя функция.
procedure ServiceCtrlHandler(Opcode : Cardinal);stdcall;
Опять не забываем про stdcall.

Итак, функция получает код сообщения, который мы и проверяем. Начинаем вспоминать, что мы писали в ServiceStatus.dwControlsAccepted. У меня это SERVICE_ACCEPT_STOP и SERVICE_ACCEPT_PAUSE_CONTINUE, значит, мне надо проверять сообщения SERVICE_CONTROL_PAUSE, SERVICE_CONTROL_CONTINUE, SERVICE_CONTROL_STOP и выполнять соответствующие действия. Остальные сообщения:

ServiceStatus.dwControlsAccepted   Обрабатываемые сообщения   
SERVICE_ACCEPT_PAUSE_CONTINUE   SERVICE_CONTROL_PAUSE и SERVICE_CONTROL_CONTINUE    
SERVICE_ACCEPT_STOP   SERVICE_CONTROL_STOP   
SERVICE_ACCEPT_SHUTDOWN   SERVICE_CONTROL_SHUTDOWN   
SERVICE_ACCEPT_PARAMCHANGE   SERVICE_CONTROL_PARAMCHANGE   
Также надо обрабатывать SERVICE_CONTROL_INTERROGATE. Что это такое - непонятно, но обрабатывать надо :) Передаем новый статус сервиса менеджеру сервисов функцией SetServiceStatus.

Пример функции Handler:

procedure ServiceCtrlHandler(Opcode : Cardinal);stdcall;
var
 Status : Cardinal;
begin
 case Opcode of
  SERVICE_CONTROL_PAUSE    :
   begin
    ServiceStatus.dwCurrentState := SERVICE_PAUSED;
    end;
  SERVICE_CONTROL_CONTINUE :
   begin
    ServiceStatus.dwCurrentState := SERVICE_RUNNING;
   end;
  SERVICE_CONTROL_STOP     :
   begin
    ServiceStatus.dwWin32ExitCode:=0;
    ServiceStatus.dwCurrentState := SERVICE_STOPPED;
    ServiceStatus.dwCheckPoint   :=0;
    ServiceStatus.dwWaitHint     :=0;

    if not SetServiceStatus (ServiceStatusHandle,ServiceStatus)
     then begin
      Status:=GetLastError;
     LogError('SetServiceStatus');
      Exit;
     end;
     exit;
   end;

  SERVICE_CONTROL_INTERROGATE : ;
 end;

 if not SetServiceStatus (ServiceStatusHandle, ServiceStatus)
  then begin
   Status := GetLastError;
   LogError('SetServiceStatus');
   Exit;
  end;
end;

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

repeat
 Что-нибудь делаем пока сервис не завершится.
until ServiceStatus.dwCurrentState = SERVICE_STOPPED;
Но это пройдет если сервис не обрабатывает сообщения приостановки/перезапуска, иначе сервис никак не прореагирует. Другой вариант :
repeat 
 if ServiceStatus.dwCurrentState <> SERVICE_PAUSED
  then чего-то делаем
until ServiceStatus.dwCurrentState = SERVICE_STOPPED; 
И третий, имхо, самый правильный вариант = использование потока :
Пишем функцию 
function MainServiceThread(p:Pointer):DWORD;stdcall;
begin
 что-то делаем
end;  
и в ServiceMain создаем поток 
var
 ThID : Cardinal;
  
hThread:=CreateThread(nil,0,@MainServiceThread,nil,0,ThID);
и ждем его завершения
WaitForSingleObject(hThread,INFINITE);
закрывая после этого его дескриптор
CloseHandle(hThread);
При этом hThread делаем глобальной переменной.
Теперь при приостановке сервиса (в Handler) делаем так 
  SERVICE_CONTROL_PAUSE    :
   begin
    ServiceStatus.dwCurrentState := SERVICE_PAUSED;
    SuspendThread(hThread); // приостанавливаем поток
   end;
и при возобновлении работы сервиса 
  SERVICE_CONTROL_CONTINUE :
   begin
    ServiceStatus.dwCurrentState := SERVICE_RUNNING;
    ResumeThread(hThread); // возобновляем поток
   end;

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

Настройка BDE, Database Desktop

Настройка BDE, Database Desktop

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








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

Настройка монитора

Настройка монитора

Иногда требуется, чтобы программа работала при чётко заданных параметрах монитора: разрешение, глубина цвета, частота обновления… Определить текущее разрешение просто, достаточно обратиться к объекту TScreen и посмотреть значения его полей Width и Height. А вот чтобы установить свои значения требуется обратиться к функции Api: ChangeDisplaySettings. Если мы хотим вернуть текущие настройки по завершении работы программы, то перед вызовом изменений надо запомнить эти настройки например таким образом:



usesShellApi;
var
  DefWidth, DefHeight, BPP: word;
...

procedure SaveSettings;
var
  DC: hDC;
begin
  DefWidth := Screen.Width;
  DefHeight := Screen.Height;
  DC := CreateDC('DISPLAY', nil, nil, nil);
  BPP := GetDeviceCaps(DC, BITSPIXEL);
end;




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



procedure SetScreen(BPP:byte;width,height,FR:integer);
var
  D: TDevMode;
  h: HWND;
begin
  h:=0;
  D.dmDeviceName:='DISPLAY';
  D.dmBitsPerPel:=BPP;
  D.dmDisplayFrequency:=FR;
  D.dmPelsWidth:=Width;
  D.dmPelsHeight:=Height;
  D.dmFields:=DM_BITSPERPEL+DM_PELSWIDTH+DM_PELSHEIGHT+DM_DISPLAYFREQUENCY;
  D.dmSize:=SizeOf(D);
  if ChangeDisplaySettings(D,CDS_TEST)=DISP_CHANGE_SUCCESSFUL then
    ChangeDisplaySettings(D,CDS_UPDATEREGISTRY)
  else
    MessageBox(h,'This mode is not supported by your video.',
    'Failed to change mode', MB_ICONWarning);
end;




Вызывается так: SetScreen(глубина цвета, разрешение по горизонтали, разрешение по вертикали, частота в герцах); Например:



SetScreen(16,800,600,80); {16 бит цвет, 800х600, 80Гц.}




При завершении программы для восстановления старых параметров вызываем эту процедуру с сохранёнными ранее значениями:



SetScreen(BPP,DefWidth,DefHeight,80); 




Я не стал здесь беспокоиться о сохранении/возвращении частоты обновления, а сразу установил 80Гц, но если кто желает, может сохранить и этот параметр при запуске



DefFR:=GetDeviceCaps(DC, VREFRESH);




и восстановить при закрытии программы:



SetScreen(BPP,DefWidth,DefHeight,DefFR);




Пример применения этой возможности можно посмотреть в моей программе SDisplay, которая вешается в трей и позволяет быстро изменить параметры экрана.

Взято с

Настройки принтера

Настройки принтера

Ниже приведены некоторые участки кода, позволяющие изменять настройки принтера.Тот код, который позволяет менять установки, позволяет также вам узнать принцип управления настройками.Смотри документацию по структурам ExtDeviceMode, TDEVMODE и escape функциям принтера GETSETPAPERBINS и GetDeviceCaps().

Один из путей изменения установок принтера перед печатью документа - изменение devicemode(режим устройства)принтера.

var
Device: array[0..255] of char;
  Driver: array[0..255] of char;
  Port: array[0..255] of char;
  hDMode: THandle;
  PDMode: PDEVMODE;
begin

  Printer.PrinterIndex := Printer.PrinterIndex;
  Printer.GetPrinter(Device, Driver, Port, hDMode);
  if hDMode <> 0 then
    begin
      pDMode := GlobalLock(hDMode);
      if pDMode <> nil then
        begin
          pDMode^.dmFields := pDMode^.dmFields or DM_COPIES;
          pDMode^.dmCopies := 5;
          GlobalUnlock(hDMode);
        end;
      GlobalFree(hDMode);
    end;
  Printer.PrinterIndex := Printer.PrinterIndex;
  Printer.BeginDoc;
  Printer.Canvas.TextOut(100, 100, 'Тест 1');
  Printer.EndDoc;

Другой путь - изменение TPrinter.Это позволит изменять установки во время работы.Вы можете изменять настройки МЕЖДУ страницами.

Чтобы сделать это:

Прежде чем поступит команда startpage()(см.модуль printers.pas в каталоге Source\VCL), вы можете передать принтеру следующий код:

    DevMode.dmPaperSize := DMPAPER_LEGAL
{сброс настроек}

  Windows.ResetDc(dc, Devmode^);

Это также сбросит настройки, связанные с размером бумаги.Вы можете обратиться к описанию DEVMODE, чтобы узнать все доступные размеры бумаги.

Но это решение потребует перекомпиляции исходного кода vcl с добавлением пути к новому модулю(tools..options..library...libaray).Если вы все - таки на это решились, не забудьте после этого перезагрузить Delphi и помните, что после этого ваш исходный код становится несовместимым со стандартной версией Delphi.

Маленькое замечание...

При замене исходного принтера на другой помните, что размеры шрифтов не всегда могут правильно масштабироваться.Чтобы гарантировать соответствующий масштаб, устанавите свойство шрифта PixelsPerInch.

  uses Printers;

var

  MyFile: TextFile;
begin

  AssignPrn(MyFile);
  Rewrite(MyFile);

  Printer.Canvas.Font.Name := 'Courier New';
  Printer.Canvas.Font.Style := [fsBold];
  Printer.Canvas.Font.PixelsPerInch :=
    GetDeviceCaps(Printer.Canvas.Handle, LOGPIXELSY);

  Writeln(MyFile, 'Печатаем этот текст');

  System.CloseFile(MyFile);
end;

- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
uses Printers;

begin

  Printer.BeginDoc;
  Printer.Canvas.Font.Name := 'Courier New';
  Printer.Canvas.Font.Style := [fsBold];

  Printer.Canvas.Font.PixelsPerInch :=
    GetDeviceCaps(Printer.Canvas.Handle, LOGPIXELSY);

  Printer.Canvas.Textout(10, 10, 'Печатаем этот текст');

  Printer.EndDoc;
end;

Взято из

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

Сборник Kuliba

Настройки принтера. Драйвер. Очередь печати

Настройки принтера. Драйвер. Очередь печати

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




















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

Назначение палитры Bitmap

Назначение палитры Bitmap

Если вы рисуете на TImage....

Во-первых, вам нужно использовать Image1.Picture.bitmap, а не Image.Canvas. Причина кроется в том, что Image1.Picture.Bitmap имеет палитру, в Timage нет. Затем палитру необходимо назначить. Вот пример:

//Устанавливаем Width и Height перед использованием
// Image1.Picture c Bitmap Canvasvar

Bitmap: TBitmap;
begin
  Bitmap:=TBitmap.Create;
  Bitmap.LoadfromFile({'Whatever.bmp'});

  With Image2.Picture.bitmap do
  Begin
    Width:=Bitmap.Width;
    height:=Bitmap.Height;
    Palette:=Bitmap.Palette;
    Canvas.draw(0,0,bitmap);
    Refresh;
  end;
end;

Если вы рисуете на канве формы...

Canvas.Draw(0,0,Bitmap);
SelectPalette(Form1.Canvas.handle,Bitmap.Palette,True);
RealizePalette(Form1.Canvas.Handle);

Взято из

Не читаются русские буквы в Database Desktop

Не читаются русские буквы в Database Desktop

Для DBD 7.0 нужно исправить реестр: ключ

HKCU\Software\Borland\DBD\7.0\Preferences\Properties\
SystemFont="Fixedsys"
Если такой ключ не существует, его следует создать.

или
[HKEY_LOCAL_MACHINE\SYSTEM\CurrentControlSet\Control\Nls\CodePage]
"1252"="c_1251.nls"

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


Подскажите пожалуйста, у меня вот какая проблема:
Загружаю Database Desktop, открываю таблицу имеющую в полях русский текст,
а отображается не русский текст а не понятно что.
О: MANka
Для DBD 5.0 в файл c:\windows\pdoxwin.ini вставить в секцию
[Properties]
SystemFont=Arial Cyr

Для DBD 7.0 нужно исправить реестр: ключ

HKCU\Software\Borland\DBD\7.0\Preferences\Properties\
SystemFont="Fixedsys"
Если такой ключ не существует, его следует создать. Впрочем, для просмотра таблиц
все равно можно порекомендовать rx Database Explorer -- у него это получается очень хорошо.
О: Sergey V. Baldin
Это - проблема русских .dbf и Desktop'а . Надо установить шрифт
по умолчанию не Arial Cyr , а Fixedsys или System. копать примерно так:
1.находишь производителя Desktop :
Например, если это Borland Desktop 7.0, то находишь строку в реестре
HKEY_CURRENT_USER\SOFTWARE\BORLAND\DBD\7.0\Preferences\Properties\SystemFont и
меняешь Arial Cyr на стандартные для Windows: Fixedsys или System
(писать название шрифта с большой буквы).
2. И в стандартном драйвере BDE ,например DBASE, ставишь русский драйвер dBASE RUS cp866.
Открываешь BDE configurator(administrator), ярлык на 32-BDE находится в панели управления.
И в строке Drivers->Native->DBASE->Langdriver->ставишь dBASE RUS cp866.
После этого все заиграе

Взято с сайта

Не могу подсоединиться к IB из под web-сервера IIS, Netscape, Baikonur и др.

Не могу подсоединиться к IB из под web-сервера IIS, Netscape, Baikonur и др.

Если вы обращаетесь к IB из IIS, Baikonur и т.п. Web-серверов, то нужно использовать строку коннекта как для удаленного сервера, т.к. локальное подсоединение работать не будет. Например, 'server:c:\dir\data.gdb' или '\\server\c:\data.gdb'.


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

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

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

В Database Desktop поставьте правильный Language Driver у таблицы, например, Pdox ANSI Cyrr.

Это простой вопрос в том случае, если база уже создана на диске. Если мы создаем базу динамически из программы, то как потом поставить русский язык без Database Desktop'а?

Оказывается это не так просто. Я перерыл весь инет и так и не нашел. В итоге пришлось потрудится и получилась следующая функция:

{ Устанавливает русский LANGDRIVER для таблицы BDE (Paradox или dBASE)}
{ Таблица должна уже существовать на диске
Если вы создаете таблицу динамически,
не забудьте вызвать Table.CreateTable }

procedure SetTableRussianLanguage(Table: TTable);
 var
   Props: CURProps;
   hDb: hDBIDb;
   TableDesc: CRTblDesc;
   OptDesc: FLDDesc;
   OptData: array [0..250] of Char;
   S: string;
 const   // Define propertly table type & codepage from list below
   LDName = 'ancyrr';   // Paradox ANSI Cyrillic 
   // LDName = 'cyrr';  // Paradox Cyrr 866
   // LDName = 'DB866ru0'; // dBASE RUS cp866 

 begin
 // Get handle (if table still not opened)
   Table.Open;
   // Get the table properties to determine table type...
   Check(DbiGetCursorProps(Table.Handle, Props));

   // Blank out the structure...
   FillChar(TableDesc, sizeof(TableDesc), 0);
   FillChar(OptDesc, SizeOf(OptDesc), #0);
   // Get the database handle from the table's cursor handle...

   Check( DbiGetObjFromObj(hDBIObj(Table.Handle), objDATABASE,
          hDBIObj(hDb)));

   { If table name contain cyrillic or other native character,
      convert name to OEM }

   SetLength(S, Length(Table.TableName));
   CharToOEM(PChar(Table.TableName), @S[1]);

   // Put the table name in the table descriptor...
   StrPCopy(TableDesc.szTblName, S{Table.TableName});
   // Put the table type in the table descriptor...
   StrPCopy(TableDesc.szTblType, Props.szTableType);
   // Set the Pack option in the table descriptor to TRUE...

   StrCopy(OptDesc.szName, 'LANGDRIVER');
   OptDesc.iLen:=Length(LDName)+1;
   TableDesc.iOptParams:=1;
   TableDesc.pfldOptParams:=@OptDesc;
   TableDesc.pOptData:=@OptData;
   StrPCopy(OptData, LDName);

   // Close the table so the restructure can complete...
   Table.Close;
   // Call DbiDoRestructure...
   Check(DbiDoRestructure(hDb, 1, @TableDesc, nil, nil, nil, False));
 end;

Взято из

---

---