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 BaseMultiple records found, but only one was expected
Multiple records found, but only one was expected
При выполнении некоторых живых запросов, возвращающих единственную запись, BDE ругается
![](image/multiplerecordsfoundbuton_1.jpg)
Автор: 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. В результате должно получиться что-то вроде этого
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;