function sonrakinibul
//** belirtilen datasetin belirtilen fieldinde str stringini arar. her aramada bir sonraki str değeri aranır.
//**Bulunamazsa false döndürür
//** sonrakinibul(table1, 'adi', 'ahmet');
function sonrakinibul(table :TDataset ; field : string ; str : string) : boolean;
var
bulundu : boolean;
i : integer;
begin
bulundu := false;
for i := 0 to table.RecordCount do
begin
if not table.Eof then
begin
table.next;
end
else
table.first;
if (table.fieldbyname(field).asstring = str) then
begin
result := true;
exit;
end;
end;
if bulundu = true then
result := true
else
result := false;
end;
Delphi - .....................................
Aligrid
unit Aligrid;
interface
uses
SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
Forms, Dialogs, Grids;
type TMyAlign = ( alRight, alLeft, alCenter);
type
TStringAlignGrid = class(TStringGrid)
private
FAlign : TMyAlign;
function GetAlign:TMyAlign;
procedure SetAlign(const Value: TMyAlign);
procedure Initialize;
protected
procedure DrawCell(ACol, ARow: Longint; ARect: TRect;
AState: TGridDrawState); override;
public
constructor Create(AOwner: TComponent); override;
published
property Alignment: TMyAlign read GetAlign write SetAlign default alLeft;
end;
procedure Register;
implementation
constructor TStringAlignGrid.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
Initialize;
end;
procedure TStringAlignGrid.Initialize;
begin
FAlign := alLeft;
end;
function TStringAlignGrid.GetAlign: TMyAlign;
begin
Result := FAlign;
end;
procedure TStringAlignGrid.SetAlign(const Value: TMyAlign);
begin
FAlign := Value;
Invalidate;
end;
procedure TStringAlignGrid.DrawCell(ACol, ARow: Longint; ARect: TRect;
AState: TGridDrawState);
procedure DrawCellText;
var
Text: array[0..255] of Char;
l : Integer;
Temp : TRect;
Alignment : TMyAlign;
begin
StrPCopy(Text, Cells[ACol, ARow]);
l:=Canvas.TextWidth(Cells[ACol, ARow]);
Temp := ARect;
Alignment := FAlign;
if Alignment in [alCenter] then
if l < (Temp.Right-Temp.Left) then begin
l := ((Temp.Right-Temp.Left) - l ) div 2;
Temp.Left := Temp.Left + l - 1;
Temp.Right := Temp.Right - l + 1 ;
end;
if Alignment in [alRight] then begin
Temp.Left := Temp.Right -l - 4 ;
if temp.left < ARect.Left then
temp.left := ARect.Left;
end;
ExtTextOut(Canvas.Handle, Temp.Left+2, Temp.Top + 2, ETO_CLIPPED or
ETO_OPAQUE, @Temp, Text, StrLen(Text), nil);
end;
begin
if DefaultDrawing then DrawCellText;
{inherited DrawCell(ACol, ARow, ARect, AState);}
end;
procedure Register;
begin
RegisterComponents('Beispiele', [TStringAlignGrid]);
end;
end.
Delphi - .....................................
Form Upload
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Classes, HTTPApp, AS_FormUpload;
type
TWeb = class(TWebModule)
procedure WebItemUploadAction(Sender: TObject; Request: TWebRequest;
Response: TWebResponse; var Handled: Boolean);
procedure WebItemDownloadAction(Sender: TObject; Request: TWebRequest;
Response: TWebResponse; var Handled: Boolean);
private
FStoredContentData: string;
FStoredContentType: string;
public
{ Public declarations }
end;
var
Web: TWeb;
implementation
{$R *.DFM}
procedure TWeb.WebItemUploadAction(Sender: TObject; Request: TWebRequest;
Response: TWebResponse; var Handled: Boolean);
var
FormUpload: TAS_FormUpload;
begin
FormUpload := TAS_FormUpload.Create(Request.ContentType, Request.Content);
try
FStoredContentData := FormUpload.ContentData;
FStoredContentType := FormUpload.ContentType;
Response.Content := Format('File: %s has been uploaded.', [FormUpload.FileName]);
finally
FormUpload.Free;
end;
end;
procedure TWeb.WebItemDownloadAction(Sender: TObject; Request: TWebRequest;
Response: TWebResponse; var Handled: Boolean);
var
ContentStream: TStringStream;
begin
Response.ContentType := FStoredContentType;
ContentStream := TStringStream.Create(FStoredContentData);
ContentStream.Position := 0;
Response.ContentStream := ContentStream;
{ ^ note: do not free the stream because the response object
will handle that task }
end;
end.
---
*)
unit AS_FormUpload;
{$I AS_Ver.inc}
interface
uses
Classes, SysUtils;
type
TAS_FormUpload = class(TObject)
FFileName: string;
FContentType: string;
FContentData: string;
public
constructor Create(const ContentType, Content: string); virtual;
property FileName: string read FFileName;
property ContentType: string read FContentType;
property ContentData: string read FContentData;
end;
implementation
{ TAS_FormUpload }
function FindSubString(Strings: TStrings; SubStr: PChar; var Index: Integer): Boolean;
{ ^ note: copied from AS_VCLUtils }
var
I: Integer;
begin
Result := False;
for I := Index to Pred(Strings.Count) do
if AnsiPos(SubStr, PChar(Strings[I])) > 0 then
begin
Index := I;
Result := True;
Exit;
end;
end;
constructor TAS_FormUpload.Create(const ContentType, Content: string);
const
SBoundary = 'boundary=';
SFileName = 'filename=';
var
StringList: TStringList;
S: string;
I: Integer;
Boundary: string;
begin
inherited Create;
//if Pos('multipart/form-data', ContentType) = 0 then
// raise Exception.Create('ContentType header must be "multipart/form-data"');
I := Pos(SBoundary, ContentType) + Length(SBoundary);
Boundary := Copy(ContentType, I, Length(ContentType) - Pred(I));
//if Boundary = '' or Length(Content) = 0 then
// raise Exception.Create('Invalid information about upload');
I := Pos(#13#10#13#10, Content) + 4;
Boundary := #13#10 + '--' + Boundary + '--';
FContentData := Copy(Content, I, Pos(Boundary, Content) - I);
StringList := TStringList.Create;
try
StringList.Text := Copy(Content, 1, I);;
{ note: set FileName }
I := 1;
if FindSubString(StringList, 'Content-Disposition:', I) then
begin
S := StringList[I];
I := Pos(SFileName, S);
if I > 0 then
begin
Inc(I, Length(SFileName) + 1);
while S[I] <> '"' do
begin
FFileName := FFileName + S[I];
Inc(I);
end;
end;
end;
{ note: set ContentType }
I := 1;
if FindSubString(StringList, 'Content-Type:', I) then
begin
S := StringList[I];
I := Pos(' ', S);
Delete(S, 1, I);
FContentType := S;
end;
finally
StringList.Free;
end;
end;
end.
Delphi - .....................................
Atdbedit
unit Atdbedit;
interface
uses WinTypes, WinProcs, Messages, SysUtils, Classes, Controls,
Forms, Graphics, Dbctrls;
type
TAtdbedit = class(TDbEdit)
private
FInColor : TColor;
FOutColor : TColor;
{ Private methods of TAtdbedit }
procedure AutoInitialize;
function GetInColor : TColor;
procedure SetInColor(Value : TColor);
function GetOutColor : TColor;
procedure SetOutColor(Value : TColor);
protected
{ Protected fields of TAtdbedit }
procedure Change; override;
procedure Click; override;
procedure DoEnter; override;
procedure KeyPress(var Key : Char); override;
procedure Loaded; override;
procedure MouseEnter (var Msg: TMessage);
message cm_MouseEnter;
procedure MouseLeave (var Msg: TMessage);
message cm_MouseLeave;
public
{ Public methods of TAtdbedit }
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
published
{ Published properties of TAtdbedit }
property OnChange;
property OnClick;
property OnDblClick;
property OnDragDrop;
property OnExit;
property OnKeyDown;
property OnKeyPress;
property OnKeyUp;
property OnMouseDown;
property OnMouseMove;
property OnMouseUp;
property InColor : TColor
read GetInColor write SetInColor
default clAqua;
property OutColor : TColor
read GetOutColor write SetOutColor
default clWhite;
end;
procedure Register;
implementation
procedure Register;
begin
RegisterComponents('Data Controls', [TAtdbedit]);
end;
{ Method to set variable and property values and create objects }
procedure TAtdbedit.AutoInitialize;
begin
FInColor := clAqua;
FOutColor := clWhite;
end;
{ Read method for property InColor }
function TAtdbedit.GetInColor : TColor;
begin
Result := FInColor;
end;
{ Write method for property InColor }
procedure TAtdbedit.SetInColor(Value : TColor);
begin
FInColor := Value;
end;
{ Read method for property OutColor }
function TAtdbedit.GetOutColor : TColor;
begin
Result := FOutColor;
end;
{ Write method for property OutColor }
procedure TAtdbedit.SetOutColor(Value : TColor);
begin
FOutColor := Value;
end;
{ Override OnChange handler from TDbEdit }
procedure TAtdbedit.Change;
begin
inherited Change;
end;
{ Override OnClick handler from TDbEdit }
procedure TAtdbedit.Click;
begin
inherited Click;
end;
{ Override OnEnter handler from TDbEdit }
procedure TAtdbedit.DoEnter;
begin
inherited DoEnter;
end;
{ Override OnKeyPress handler from TDbEdit }
procedure TAtdbedit.KeyPress(var Key : Char);
const
TabKey = Char(VK_TAB);
EnterKey = Char(VK_RETURN);
begin
inherited KeyPress(Key);
end;
constructor TAtdbedit.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
AutoInitialize;
end;
destructor TAtdbedit.Destroy;
begin
inherited Destroy;
end;
procedure TAtdbedit.Loaded;
begin
inherited Loaded;
end;
procedure TAtdbedit.MouseEnter;
begin
color := FInColor;
font.Style := font.style + [fsBold];
cursor := crUpArrow;
showHint:=true;
hint := DataField;
end;
procedure TAtdbedit.MouseLeave;
begin
color := FOutColor;
font.Style := font.style - [fsBold];
cursor := crDefault;
showHint:=false;
end;
end.
Delphi - .....................................
AutoInc
unit AutoInc;
INTERFACE
uses SysUtils;
procedure DemoRestructure(const DatabaseName:TFileName;
const TableName:TFileName);
IMPLEMENTATION
uses BDE,DB;
procedure AddPrimaryIndex(hDatabase:hDbiDb; const TableName,KeyViolName:TFileName);
var
hTableCursor: hDbiCur;
Properties: CURProps;
TableDesc: CRTblDesc; // see bde32.hlp/bde.int regarding these types
IndexOp: CROpType;
IndexDesc: IDXDesc;
szKeyViol: DbiName;
begin
// Open the table, returning its cursor handle.
Check(DbiOpenTable(hDatabase,
PChar(TableName),
szParadox,
nil,nil,0, // no result index required
dbiReadOnly,dbiOpenShared,
xltField, // use logical field types (normal)
False,nil,
hTableCursor)); // result
// Use this handle to get property information about the table.
Check(DbiGetCursorProps(hTableCursor,Properties)); // see CURProps in bde32.hlp
// Fill out a blank table descriptor specifying the required index change.
FillChar(TableDesc,sizeof(CRTblDesc),#0);
with TableDesc do
begin
StrCopy(szTblName,Properties.szName); // source table name
StrCopy(szTblType,szParadox); // I've found this is reqd
// Write a TableDesc which adds a primary index...
FillChar(IndexDesc,sizeof(IDXDesc),#0);
iIdxCount := 1; // adding one index
IndexOp := crADD;
pecrIdxOp := @IndexOp;
with IndexDesc do
begin
StrPCopy(szName,'NameNo');
bPrimary := True;
bUnique := True;
bMaintained := True;
iFldsInKey := 1; // primary idx has one field (not composite)
aiKeyFld[0] := 1; // and it's the first field
end;
TableDesc.pIdxDesc := @IndexDesc;
end;
Check(DbiCloseCursor(hTableCursor)); // must close prior to restructure
// Now we're ready.
Check(DbiDoRestructure(hDatabase,
1, // number of TableDesc records
// (BDE currently supports only one)
@TableDesc,
nil, // SaveAs destination
StrPCopy(szKeyViol,KeyViolName), // nil if not reqd
nil, // problem table (see DbiRegisterCallback)
False));
// Note: Even if an exception occurs the hTableCursor resource isn't leaked
// because DbiCloseDatabase releases associated table cursors.
end;
//-----------------------------------------------------------------------
// For an alternative field addressing scheme see Delphi example in bde32.hlp
// for DbiGetFieldDescs function.
type
FLDDescs = array [1..100] of FLDDesc;
PFLDDescs = ^FLDDescs;
CROpTypes = array [1..100] of CROpType;
PCROpTypes = ^CROpTypes;
procedure ReviseFields(hDatabase:hDbiDb; TableName:TFileName);
var
hTableCursor: hDbiCur;
Properties: CURProps;
FieldDescs: PFLDDescs;
FieldOps: PCROpTypes;
TableDesc: CRTblDesc;
NewFieldCount: integer;
i: integer;
ValidityDesc: VCHKDesc;
ValidityOp: CROpType;
DefaultServes: Word;
begin
Check(DbiOpenTable(hDatabase,PChar(TableName),szParadox,
nil,nil,0,dbiReadOnly,dbiOpenShared,xltField,False,nil,
hTableCursor));
Check(DbiGetCursorProps(hTableCursor,Properties));
// To fetch the field information we must first have somewhere to put it.
NewFieldCount := Properties.iFields + 3; // we're adding 3 extra fields
GetMem(FieldDescs,NewFieldCount*sizeof(FLDDesc)); // descriptors
GetMem(FieldOps,NewFieldCount*sizeof(CROpType)); // operators
try
// Fetch the existing field definitions.
Check(DbiGetFieldDescs(hTableCursor,@FieldDescs[1]));
// Modify the first field definition to be autoincrement.
FieldOps^[1] := crMODIFY; // the first is modified
with FieldDescs^[1] do
begin
iFldType := fldINT32;
iSubType := fldstAUTOINC;
// Had we nominated xltNone (physical) field types then we would
// probably replace the above with: iFldType := fldPDXAUTOINC;
end;
// Field #2 is unchanged.
FieldOps^[2] := crNOOP;
// Fields #3..#N are pushed right to occupy positions #6..#N+3.
Move(FieldDescs^[3],FieldDescs^[6],(Properties.iFields-2)*sizeof(FLDDesc));
for i := 6 to NewFieldCount do
begin
FieldOps^[i] := crCOPY; // These destination fields are copies
FieldDescs^[i].iFldNum := i-3; // of the nominated source fields
end;
// In between are the new fields.
for i := 3 to 5 do
begin
FieldOps^[i] := crADD; // this field is new
FillChar(FieldDescs^[i],sizeof(FLDDesc),#0);
with FieldDescs^[i] do
begin
iFldNum := i;
case i of
3: begin
StrCopy(szName,'Dish');
iFldType := fldZSTRING;
iUnits1 := 60; // number of characters
end;
4: begin
StrCopy(szName,'Serves');
iFldType := fldINT16;
// For fldFLOAT, iUnits1 := ... (precision?)
// iUnits2 := ... (decimal places?)
end;
5: begin
StrCopy(szName,'Recipe');
iFldType := fldBLOB;
iSubType := fldstMEMO;
iUnits1 := 1; // size, 1..240
// Memo text beyond the above will be stored in *.MB
// Use small value if many have empty memos.
// Larger value is more efficient if text can generally
// fit within the size nominated, as lookup is avoided.
end;
end;
end;
end;
// That's all for the field modifications (FieldOps & FieldDescs).
// Default field values are (strangely) given in the validity check
// structures. We provide one of those to implement a Serves default.
FillChar(ValidityDesc,sizeof(VCHKDesc),#0);
ValidityOp := crADD; // adding a new "validity check" descriptor
with ValidityDesc do
begin
iFldNum := 4; // destination field number
// bRequired := True; (this is how you'd make a field required)
bHasDefVal := True;
// Validity check properties are all of generic DBIVCHK type,
// which you can't cast to. Instead you must carefully Move,
// ensuring source size matches size of field's logical iFldType.
DefaultServes := 6;
Move(DefaultServes,aDefVal,sizeof(Word));
end;
// Fill out a table descriptor, referring to the structures we've made.
FillChar(TableDesc,sizeof(CRTblDesc),#0);
with TableDesc do
begin
StrCopy(szTblName,Properties.szName);
StrCopy(szTblType,szParadox);
// bPack := True; (you can pack it when finished if you like)
// field structure...
iFldCount := NewFieldCount;
pecrFldOp := @FieldOps^[1];
pfldDesc := @FieldDescs^[1];
// validity check (default value)...
iValChkCount := 1;
pecrValChkOp := @ValidityOp;
pvchkDesc := @ValidityDesc;
end;
Check(DbiCloseCursor(hTableCursor));
// If you didn't want the default value to apply to existing data
// you'd probably have to use DbiRegisterCallback. (I guess.)
Check(DbiDoRestructure(hDatabase,1,@TableDesc,nil,nil,
nil, // << add Problem table here if required
False));
finally
FreeMem(FieldOps);
FreeMem(FieldDescs);
end;
end;
//-----------------------------------------------------------------------
procedure DemoRestructure(const DatabaseName:TFileName;
const TableName:TFileName);
var
hDatabase: hDbiDb;
WorkingDir: DbiPath;
KeyViolName: TFileName;
begin
// Open a database session with exclusive read/write access.
Check(DbiOpenDatabase(PChar(DatabaseName), // alias
nil, // database type (Standard)
dbiReadWrite, // open mode (versus read-only)
dbiOpenExcl, // exclusive (versus shared)
nil, // database login password
0,nil,nil,
hDatabase));
try
Check(DbiGetDirectory(hDatabase,False,WorkingDir));
KeyViolName := StrPas(WorkingDir)+'V'+ExtractFileName(TableName); // etc
//ShowMessage(KeyViolName); (uses Dialogs)
// ftInteger->ftAutoinc restructure is only supported on keyed tables.
// We have to introduce the primary key first, as a separate step.
AddPrimaryIndex(hDatabase,TableName,KeyViolName);
// Then convert the first field to ftAutoinc and add extra fields,
// assigning a default value to one of them.
ReviseFields(hDatabase,TableName);
finally
Check(DbiCloseDatabase(hDatabase)); // closes associated cursors too
end;
end;
end.
Delphi - .....................................
BEncode
unit BEncode;
interface
uses
Classes, Contnrs, SysUtils;
type
TBEncodedFormat = (befEmpty, befString, befInteger, befList, befDictionary);
TBEncodedData = class(TObject)
public
Header: string;
Data: TObject; // actually TBEncoded
destructor Destroy; override;
published
constructor Create(Data: TObject);
end;
TBEncodedDataList = class(TObjectList)
protected
function GetItems(Index: Integer): TBEncodedData;
procedure SetItems(Index: Integer; AClass: TBEncodedData);
public
function FindElement(Header: string): TObject;
function Add(AClass: TBEncodedData): Integer;
function Extract(Item: TBEncodedData): TBEncodedData;
function Remove(AClass: TBEncodedData): Integer;
function IndexOf(AClass: TBEncodedData): Integer;
function First: TBEncodedData;
function Last: TBEncodedData;
procedure Insert(Index: Integer; AClass: TBEncodedData);
property Items[Index: Integer]: TBEncodedData read GetItems write SetItems;
default;
end;
TBEncoded = class(TObject)
private
FFormat: TBEncodedFormat;
procedure SetFormat(Format: TBEncodedFormat);
public
StringData: string;
IntegerData: int64;
ListData: TBEncodedDataList;
property Format: TBEncodedFormat read FFormat write SetFormat;
class procedure Encode(Encoded: TObject; var Output: string);
destructor Destroy; override;
published
constructor Create(Stream: TStream);
end;
implementation
destructor TBEncodedData.Destroy;
begin
Data.Free;
inherited Destroy;
end;
constructor TBEncodedData.Create(Data: TObject);
begin
inherited Create;
Self.Data := Data;
end;
destructor TBEncoded.Destroy;
begin
if ListData <> nil then
ListData.Free;
inherited Destroy;
end;
constructor TBEncoded.Create(Stream: TStream);
function GetString(Buffer: string): string;
var
X: char;
begin
// loop until we come across it
repeat
if Stream.Read(X, 1) <> 1 then
raise Exception.Create('');
if not ((X in ['0'..'9']) or (x = ':')) then
raise Exception.Create('');
if X = ':' then
begin
if Buffer = '' then
raise Exception.Create('');
if Length(Buffer) > 6 then
raise Exception.Create('');
SetLength(Result, StrToInt(Buffer));
if Stream.Read(Result[1], Length(Result)) <> Length(Result) then
raise Exception.Create('');
Break;
end
else
Buffer := Buffer + X;
until False;
end;
var
X: char;
Buffer: string;
Data: TBEncodedData;
Encoded: TBEncoded;
begin
inherited Create;
// get first character to determine the format of the proceeding data
if Stream.Read(X, 1) <> 1 then
raise Exception.Create('');
// is it an integer?
if X = 'i' then
begin
// yes it is, let's read until we come across e
Buffer := '';
repeat
if Stream.Read(X, 1) <> 1 then
raise Exception.Create('');
if not ((X in ['0'..'9']) or (X = 'e')) then
raise Exception.Create('');
if X = 'e' then
begin
if Buffer = '' then
raise Exception.Create('')
else
begin
Format := befInteger;
IntegerData := StrToInt64(Buffer);
Break;
end;
end
else
Buffer := Buffer + X;
until False;
end
// is it a list?
else if X = 'l' then
begin
// its a list
Format := befList;
// loop until we come across e
repeat
// have a peek around and see if theres an e
if Stream.Read(X, 1) <> 1 then
raise Exception.Create('');
// is it an e?
if X = 'e' then
Break;
// otherwise move the cursor back
Stream.Seek(-1, soFromCurrent);
// create the element
Encoded := TBEncoded.Create(Stream);
// add it to the list
ListData.Add(TBEncodedData.Create(Encoded));
until False;
end
// is it a dictionary?
else if X = 'd' then
begin
// its a dictionary :>
Format := befDictionary;
// loop until we come across e
repeat
// have a peek around and see if theres an e
if Stream.Read(X, 1) <> 1 then
raise Exception.Create('');
// is it an e?
if X = 'e' then
Break;
// if it isnt an e it has to be numerical!
if not (X in ['0'..'9']) then
raise Exception.Create('');
// now read the string data
Buffer := GetString(string(X));
// create the element
Encoded := TBEncoded.Create(Stream);
// create the data element
Data := TBEncodedData.Create(Encoded);
Data.Header := Buffer;
// add it to the list
ListData.Add(Data);
until False;
end
// is it a string?
else if X in ['0'..'9'] then
begin
StringData := GetString(string(X));
Format := befString;
end
else
raise Exception.Create('');
end;
class procedure TBEncoded.Encode(Encoded: TObject; var Output: string);
var
i: integer;
begin
with TBEncoded(Encoded) do
begin
// what type of member is it?
case Format of
befString: Output := Output + IntToStr(Length(StringData)) + ':' +
StringData;
befInteger: Output := Output + 'i' + IntToStr(IntegerData) + 'e';
befList:
begin
Output := Output + 'l';
for i := 0 to ListData.Count - 1 do
Encode(TBEncoded(ListData[i].Data), Output);
Output := Output + 'e';
end;
befDictionary:
begin
Output := Output + 'd';
for i := 0 to ListData.Count - 1 do
begin
Output := Output + IntToStr(Length(ListData[i].Header)) + ':' +
ListData[i].Header;
Encode(TBEncoded(ListData[i].Data), Output);
end;
Output := Output + 'e';
end;
end;
end;
end;
procedure TBEncoded.SetFormat(Format: TBEncodedFormat);
begin
if Format in [befList, befDictionary] then
ListData := TBEncodedDataList.Create;
FFormat := Format;
end;
function TBEncodedDataList.FindElement(Header: string): TObject;
var
i: integer;
begin
Header := LowerCase(Header);
for i := 0 to Count - 1 do
if LowerCase(Items[i].Header) = Header then
begin
Result := Items[i].Data;
Exit;
end;
Result := nil;
end;
function TBEncodedDataList.Add(AClass: TBEncodedData): Integer;
begin
Result := inherited Add(AClass);
end;
function TBEncodedDataList.Extract(Item: TBEncodedData): TBEncodedData;
begin
Result := TBEncodedData(inherited Extract(Item));
end;
function TBEncodedDataList.First: TBEncodedData;
begin
Result := TBEncodedData(inherited First);
end;
function TBEncodedDataList.GetItems(Index: Integer): TBEncodedData;
begin
Result := TBEncodedData(inherited Items[Index]);
end;
function TBEncodedDataList.IndexOf(AClass: TBEncodedData): Integer;
begin
Result := inherited IndexOf(AClass);
end;
procedure TBEncodedDataList.Insert(Index: Integer; AClass: TBEncodedData);
begin
inherited Insert(Index, AClass);
end;
function TBEncodedDataList.Last: TBEncodedData;
begin
Result := TBEncodedData(inherited First);
end;
function TBEncodedDataList.Remove(AClass: TBEncodedData): Integer;
begin
Result := inherited Remove(AClass);
end;
procedure TBEncodedDataList.SetItems(Index: Integer; AClass: TBEncodedData);
begin
inherited Items[Index] := AClass;
end;
end.
Delphi - .....................................
Barcode
unit unitBarcode;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls;
type
TBarcode = class(TGraphicControl)
private
fBarcode: String;
fTransparent: Boolean;
fFillColor: TColor;
fBorderColor: TColor;
fLineColor: TColor;
fBorderWidth: Integer;
fLineWidth: Integer;
fTopSpace: Integer;
fLeftSpace: Integer;
fLineHeight: Integer;
fExtLineHeight: Integer;
fISBN: String;
fUseISBN: Boolean;
fDisplayISBN: Boolean;
fTable:Array[0..9] of Byte;
protected
procedure DrawLines(StartIndex: integer; Value: string);
procedure ISBNToBarcode;
procedure OneBack;
procedure ThreeForward;
procedure SetBarcode(Value: string);
procedure SetISBN(Value: String);
procedure SetUseISBN(Value: Boolean);
procedure SetLineWidth(Value: Integer);
public
constructor Create(AOwner: TComponent); override;
procedure Paint;override;
procedure SetLineHeight(Value: Integer);
procedure SetDisplayISBN(Value: Boolean);
published
property Barcode: String read fBarcode write SetBarcode;
property ISBN: String read fISBN write SetISBN;
property UseISBN: Boolean read fUseISBN write SetUseISBN;
property DisplayISBN: Boolean read fDisplayISBN write SetDisplayISBN;
property LineWidth: Integer read fLineWidth write SetLineWidth;
property LineHeight: Integer read fLineHeight write SetLineHeight;
end;
implementation
const
ListA : array[0..9] of string =
('1110010','1100110','1101100','1000010','1011100',
'1001110','1010000','1000100','1001000','1110100');
ListE : array[0..9] of string =
('0100111','0110011','0011011','0100001','0011101',
'0111001','0111001','0010001','0001001','0010111');
ListU : array[0..9] of string =
('0001101','0011001','0010011','0111101','0100011',
'0110001','0101111','0111011','0110111','0001011');
ListEU : array[0..9] of string =
('UUUUUU','UUEUEE','UUEEUE','UUEEEU','UEUUEE',
'UEEUUE','UEEEUU','UEUEUE','UEUEEU','UEEUEU');
ListBasSon : string = '101';
ListOrta : string = '01010';
ListISBN:array[0..9] of byte=
(3,0,7,4,1,8,5,2,9,6);
procedure TBarcode.DrawLines(StartIndex: integer; Value: string);
var
i: integer;
Index: integer;
nExtLineHeight: integer;
begin
if Length(Value) = 0 then Exit;
Canvas.Pen.Width := fLineWidth;
if Length(Value) = 7 then
Canvas.Pen.Color := fLineColor
else
Canvas.Pen.Color := clRed;
if Length(Value) = 7 then
nExtLineHeight := 0
else
nExtLineHeight := fExtLineHeight;
Index := 0;
for i := StartIndex + 1 to StartIndex + Length(Value) do
begin
Inc(Index);
if Copy(Value, Index, 1) = '0' then Continue;
Canvas.MoveTo(fLeftSpace + i * fLineWidth, fTopSpace);
Canvas.LineTo(fLeftSpace + i * fLineWidth, fTopSpace + fLineHeight + nExtLineHeight);
end;
end;
constructor TBarcode.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
Parent := (AOwner as TWinControl);
Top := 100;
Left := 100;
Width := 210;
Height := 120;
fBarcode := '8690565035306';
fTransparent := False;
fFillColor := clWhite;
fBorderColor := clBlack;
fLineColor := clBlack;
fBorderWidth := 1;
fLineWidth:= 2;
fTopSpace:= 10;
fLeftSpace:= 10;
fLineHeight:= 70;
fExtLineHeight := 10;
end;
procedure TBarcode.Paint;
var
Index: integer;
FirstItem: integer;
Item: integer;
i: integer;
begin
inherited Paint;
if not fTransparent then
begin
Canvas.Pen.Width := fBorderWidth;
Canvas.Pen.Color := fBorderColor;
Canvas.Brush.Style := bsSolid;
Canvas.Brush.Color := fFillColor;
Canvas.Rectangle(1,1,Width,Height);
end;
// ************* Check First Code ******************
Index := 0;
DrawLines(Index, ListBasSon);
Index := Index + 3;
// ************* First Code ************************
for i := 1 to 6 do
begin
FirstItem := StrToInt(fBarcode[1]); // Birinci rakkam
Item := StrToInt(fBarcode[i + 1]);
if ListEU[FirstItem][i] = 'E' then
DrawLines(Index, ListE[Item]);
if ListEU[FirstItem][i] = 'U' then
DrawLines(Index, ListU[Item]);
Index := Index + 7;
end;
// ************* Center Code ***********************
DrawLines(Index, ListOrta);
Index := Index + 5;
// ************* Last Code *************************
for i := 7 to 12 do
begin
DrawLines(Index, ListA[StrToInt(fBarcode[i + 1])]);
Index := Index + 7;
end;
// ************* Check Last Code *******************
DrawLines(Index, ListBasSon);
if fTransparent then
Canvas.Brush.Style := bsClear;
Canvas.Font.Size := fLineWidth * 6;
Canvas.TextOut(fLeftSpace, fTopSpace + fLineHeight + fExtLineHeight + 5, fBarcode);
if fDisplayISBN then
Canvas.TextOut(fLeftSpace, 5, 'ISBN ' + fISBN);
end;
procedure TBarcode.OneBack;
var
nTable: array[0..9] of byte;
sayi: integer;
sayac: integer;
begin
sayi := 9;
for sayac := 0 to 9 do
begin
nTable[sayi] := fTable[sayac];
sayi := sayi + 1;
if sayi>9 then sayi:=0;
end;
for sayac := 0 to 9 do
fTable[sayac] := nTable[sayac];
end;
procedure TBarcode.ThreeForward;
var
nTable : array[0..9] of byte;
sayi: integer;
sayac: integer;
begin
sayi := 3;
for sayac := 0 to 9 do
begin
nTable[sayi] := fTable[sayac];
sayi := sayi + 1;
if sayi>9 then sayi:=0;
end;
for sayac := 0 to 9 do
fTable[sayac] := nTable[sayac];
end;
procedure TBarcode.ISBNToBarcode;
var
sayac: integer;
index: integer;
begin
if fISBN='' then exit;
for sayac := 0 to 9 do
fTable[sayac] := ListISBN[sayac];
try
index := strtoint(fISBN[9]);
if StrToInt(fISBN[8]) > 0 then
for sayac:=1 to StrToInt(fISBN[8]) do ThreeForward;
if StrToInt(fISBN[7]) > 0 then
for sayac:=1 to StrToInt(fISBN[7]) do OneBack;
if StrToInt(fISBN[6]) > 0 then
for sayac:=1 to StrToInt(fISBN[6]) do ThreeForward;
if StrToInt(fISBN[5]) > 0 then
for sayac:=1 to StrToInt(fISBN[5]) do OneBack;
if StrToInt(fISBN[4]) > 0 then
for sayac:=1 to StrToInt(fISBN[4]) do ThreeForward;
fBarcode := '978'+ Copy(fISBN,1,9) + IntToStr(fTable[index]);
except
ShowMessage('Hatalı kod yazılmış...');
end;
end;
procedure TBarcode.SetBarcode(Value: string);
begin
if not fUseISBN then
begin
fBarcode := Copy(Value + '0000000000000',1,13);
DisplayISBN := False;
end;
end;
procedure TBarcode.SetISBN(Value: String);
begin
fISBN := Copy(Value + '0000000000',1,10);
Paint;
end;
procedure TBarcode.SetUseISBN(Value: Boolean);
begin
fUseISBN := Value;
if Value then
ISBNToBarcode;
Paint;
end;
procedure TBarcode.SetDisplayISBN(Value: Boolean);
begin
fTopSpace:= 10;
if (Value) and (fUseISBN) then
fDisplayISBN := True
else
fDisplayISBN := False;
if fDisplayISBN then
fTopSpace:= Canvas.TextHeight(fISBN) + 10;
Paint;
end;
procedure TBarcode.SetLineWidth(Value: Integer);
begin
if Value < 1 then Value := 1;
fLineWidth := Value;
Paint;
end;
procedure TBarcode.SetLineHeight(Value: Integer);
begin
if Value < 1 then Value := 1;
fLineHeight := Value;
Paint;
end;
end.
Delphi - .....................................
AutoTable
unit AutoTable;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
Db, DBTables, mdmailslot;
const
MAX_MAILSLOT = 10;
type
TAutoTable = class(TTable)
private
{ Déclarations privées }
FMailSlot : TmdSecureMail;
FBackAutoRefresh : boolean;
FAutoRefresh : boolean;
FServer : string;
protected
{ Déclarations protégées }
procedure MsgAvail(Sender: TObject; Msg: String);
procedure DoAfterOpen; override;
procedure DoAfterClose; override;
procedure InternalPost; override;
procedure InternalEdit; override;
procedure InternalCancel; override;
procedure InternalDelete; override;
public
{ Déclarations publiques }
constructor Create(Aowner : TComponent); override;
published
{ Déclarations publiées }
property AutoRefresh : boolean read FAutoRefresh write FAutoRefresh;
property Server : string read FServer write FServer;
end;
procedure Register;
implementation
constructor TAutoTable.Create(Aowner : TComponent);
begin
inherited Create(AOwner);
FAutoRefresh:=true;
FBackAutoRefresh:=FAutoRefresh;
FServer:='.';
end;
procedure TAutoTable.InternalEdit;
begin
FBackAutoRefresh:=FAutoRefresh;
FAutoRefresh:=false;
inherited;
end;
procedure TAutoTable.InternalCancel;
begin
FBackAutoRefresh:=FAutoRefresh;
FAutoRefresh:=false;
inherited;
end;
procedure TAutoTable.InternalDelete;
var mt, t : string;
i : integer;
begin
FAutoRefresh:=FBackAutoRefresh;
inherited;
mt:=ExtractFileName(TableName);
if length(mt)>5 then mt:=copy(mt,1,5);
for i:=0 to MAX_MAILSLOT do begin
t:=mt+inttostr(i);
if t<>FMailSlot.slot then SendSecureMail(FServer,t,'Refresh');
end;
end;
procedure TAutoTable.InternalPost;
var mt, t : string;
i : integer;
begin
FAutoRefresh:=FBackAutoRefresh;
inherited;
mt:=ExtractFileName(TableName);
if length(mt)>5 then mt:=copy(mt,1,5);
for i:=0 to MAX_MAILSLOT do begin
t:=mt+inttostr(i);
if t<>FMailSlot.slot then SendSecureMail(FServer,t,'Refresh');
end;
end;
procedure TAutoTable.DoAfterOpen;
var
ok : boolean;
mt, t : string;
i : integer;
begin
inherited;
FMailSlot:=TmdSecureMail.create(self);
with FMailSlot do begin
ok:=false;
mt:=ExtractFileName(self.TableName);
if length(mt)>5 then mt:=copy(mt,1,5);
i:=0;
while not ok do begin
try
t:=mt+inttostr(i);
Slot:=t;
open;
ok:=true;
except
on e:emdmailslot do begin
inc(i);
if i>MAX_MAILSLOT then begin
raise Exception.Create('Trop de mailslots sur la table '+tablename);
end;
end;
end;
end;
OnMessageAvail:=MsgAvail;
end;
end;
procedure TAutoTable.DoAfterClose;
begin
inherited;
FMailSlot.destroy;
end;
procedure TAutoTable.MsgAvail(Sender: TObject; Msg: String);
begin
if not FAutoRefresh then exit;
if msg='Refresh' then begin
Refresh;
end;
end;
procedure Register;
begin
RegisterComponents('Steff', [TAutoTable]);
end;
end.
Delphi - .....................................
