Programlama yapalım ve Öğrenelim.

ColorButton

unit ColorButton;

interface

uses

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

type

TAlignment =

(alTopLeft, alTopCenter, alTopRight,

alMiddleLeft, alMiddleCenter, alMiddleRight,

alBottomLeft, alBottomCenter, alBottomRight);

TButtonBevel = (bbLowered, bbNone, bbRaised);

TButtonStyles = (bsAutoSize, bsCenter, bsStretch, bsShowFocus, bsShowKey);

TButtonStyle = set of TButtonStyles;

TButtonState = (bsUp, bsDown, bsDisabled);

TColorButton = class(TCustomControl)

private

FAlignment: TAlignment;

FBevelStyle: TButtonBevel;

FBevelSize: Integer;

FColor: TColor;

FPicture: TPicture;

FSpacing: Integer;

FStyle: TButtonStyle;

FFocused: Boolean;

FState: TButtonState;

procedure SetAlignment(Value: TAlignment);

procedure SetBevelStyle(Value: TButtonBevel);

procedure SetBevelSize(Value: Integer);

procedure SetCaption(var Message: TMessage); message CM_TEXTCHANGED;

procedure SetColor(Value: TColor);

procedure SetEnabled(var Message: TMessage); message CM_ENABLEDCHANGED;

procedure SetFocusOff(var Message: TMessage); message CM_LOSTFOCUS;

procedure SetFocusOn(var Message: TMessage); message CM_GOTFOCUS;

procedure SetFont(var Message: TMessage); message CM_FONTCHANGED;

procedure SetPicture(Value: TPicture);

procedure SetSpacing(Value: Integer);

procedure SetStyle(Value: TButtonStyle);

procedure DoEnter; override;

procedure DoExit; override;

procedure KeyDown(var Key: Word; Shift: TShiftState); override;

procedure KeyUp(var Key: Word; Shift: TShiftState); override;

procedure KeyAccel(var Message: TCMDialogChar); message CM_DIALOGCHAR;

procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;

procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;

public

constructor Create(AOwner: TComponent); override;

destructor Destroy; override;

procedure Loaded; override;

procedure Paint; override;

published

property Alignment: TAlignment read FAlignment write SetAlignment default alMiddleCenter;

property BevelStyle: TButtonBevel read FBevelStyle write SetBevelStyle default bbRaised;

property BevelSize: Integer read FBevelSize write SetBevelSize default 2;

property Caption;

property Color: TColor read FColor write SetColor default clBtnFace;

property Cursor;

property DragCursor;

property DragMode;

property Enabled;

property Font;

property Height;

property Left;

property Name;

property Picture: TPicture read FPicture write SetPicture;

property Spacing: Integer read FSpacing write SetSpacing default 2;

property Style: TButtonStyle read FStyle write SetStyle default [bsCenter, bsShowFocus];

property Tag;

property TabOrder;

property TabStop;

property Top;

property Width;

property OnClick;

property OnDblClick;

property OnDragDrop;

property OnDragOver;

property OnEndDrag;

property OnEnter;

property OnExit;

property OnKeyDown;

property OnKeyPress;

property OnKeyUp;

property OnMouseDown;

property OnMouseMove;

property OnMouseUp;

property OnStartDrag;

end;

procedure Register;

function Smallest(X, Y: Integer): Integer;

function Largest(X, Y: Integer): Integer;

function GetHighlightColor(BaseColor: TColor): TColor;

function GetShadowColor(BaseColor: TColor): TColor;

function GetSpeedKey(var Caption: String): Integer;

implementation

procedure Register;

begin

RegisterComponents('Additional', [TColorButton]);

end;

// Global procedures and functions

///////////////////////////////////////////////////////////////////////////////

function Smallest(X, Y: Integer): Integer;

begin

if X < Y then Result := X else Result := Y;

end;

function Largest(X, Y: Integer): Integer;

begin

if X > Y then Result := X else Result := Y;

end;

function GetHighlightColor(BaseColor: TColor): TColor;

begin

Result := RGB(

Smallest(GetRValue(ColorToRGB(BaseColor)) + 64, 255),

Smallest(GetGValue(ColorToRGB(BaseColor)) + 64, 255),

Smallest(GetBValue(ColorToRGB(BaseColor)) + 64, 255)

);

end;

function GetShadowColor(BaseColor: TColor): TColor;

begin

Result := RGB(

Largest(GetRValue(ColorToRGB(BaseColor)) - 64, 0),

Largest(GetGValue(ColorToRGB(BaseColor)) - 64, 0),

Largest(GetBValue(ColorToRGB(BaseColor)) - 64, 0)

);

end;

function GetSpeedKey(var Caption: String): Integer;

var

keyPos: Integer;

begin

// Find the speed key location

keyPos := Pos('&', Caption);

// Delete the '&' symbol

Delete(Caption, keyPos, 1);

// Return the location of the speed key

Result := keyPos;

end;

// ColorButton procedures and functions

///////////////////////////////////////////////////////////////////////////////

constructor TColorButton.Create(AOwner: TComponent);

begin

inherited Create(AOwner);

FAlignment := alMiddleCenter;

FBevelStyle := bbRaised;

FBevelSize := 2;

FColor := clBtnFace;

FPicture := TPicture.Create;

FSpacing := 2;

FStyle := [bsCenter, bsShowFocus, bsShowKey];

FFocused := False;

FState := bsUp;

Width := 75; Height := 25;

Enabled := True;

TabStop := True;

end;

destructor TColorButton.Destroy;

begin

FPicture.Free;

inherited Destroy;

end;

procedure TColorButton.Loaded;

begin

inherited Loaded;

if Enabled then FState := bsUp else FState := bsDisabled;

end;

procedure TColorButton.Paint;

procedure DrawCaption(Offset: Integer);

var

xLoc, yLoc, edgeSize, keyPos: Integer;

newCaption: String;

begin

edgeSize := (FBevelSize + FSpacing);

newCaption := Caption;

keyPos := GetSpeedKey(newCaption);

with inherited Canvas do

begin

// Work out text location

case FAlignment of

alTopLeft:

begin

xLoc := edgeSize + Offset; yLoc := edgeSize + Offset;

end;

alTopCenter:

begin

xLoc := edgeSize + Offset + ((Width - (edgeSize * 2)) - TextWidth(newCaption)) div 2; yLoc := edgeSize + Offset;

end;

alTopRight:

begin

xLoc := Width - edgeSize - TextWidth(newCaption) + Offset; yLoc := edgeSize + Offset;

end;

alMiddleLeft:

begin

xLoc := edgeSize + Offset; yLoc := edgeSize + Offset + ((Height - (edgeSize * 2)) - TextHeight(newCaption)) div 2;

end;

alMiddleCenter:

begin

xLoc := edgeSize + Offset + ((Width - (edgeSize * 2)) - TextWidth(newCaption)) div 2;

yLoc := edgeSize + Offset + ((Height - (edgeSize * 2)) - TextHeight(newCaption)) div 2;

end;

alMiddleRight:

begin

xLoc := Width - edgeSize - TextWidth(newCaption) + Offset;

yLoc := edgeSize + Offset + ((Height - (edgeSize * 2)) - TextHeight(newCaption)) div 2;

end;

alBottomLeft:

begin

xLoc := edgeSize + Offset; yLoc := Height - edgeSize - TextHeight(newCaption) + Offset;

end;

alBottomCenter:

begin

xLoc := edgeSize + Offset + ((Width - (edgeSize * 2)) - TextWidth(newCaption)) div 2;

yLoc := Height - edgeSize - TextHeight(newCaption) + Offset;

end;

alBottomRight:

begin

xLoc := Width - edgeSize - TextWidth(newCaption) + Offset;

yLoc := Height - edgeSize - TextHeight(newCaption) + Offset;

end;

else

// Just in-case...

xLoc := edgeSize + Offset + ((Width - (edgeSize * 2)) - TextWidth(newCaption)) div 2;

yLoc := edgeSize + Offset + ((Height - (edgeSize * 2)) - TextHeight(newCaption)) div 2;

end;

// Draw the text

TextOut(xLoc, yLoc, newCaption);

// Draw the speed key

if ((keyPos > 0) and (bsShowKey in FStyle)) then

begin

// Can't use underscore character - unlikely to be correct width

Pen.Color := Font.Color;

MoveTo(xLoc + (TextWidth(Copy(newCaption, 1, keyPos - 1))), yLoc + (TextHeight('ABC')));

LineTo(xLoc + (TextWidth(Copy(newCaption, 1, keyPos))), yLoc + (TextHeight('ABC')));

end;

var

Client, Picture: TRect;

clHigh, clLow: TColor;

begin

if not Enabled and not (csDesigning in ComponentState) then FState := bsDisabled

else if FState = bsDisabled then FState := bsUp;

if ((not (FPicture.Graphic = nil)) and (bsAutoSize in FStyle)) then

begin

Width := FPicture.Width + (FBevelSize * 2);

Height := FPicture.Height + (FBevelSize * 2);

end;

Client := Bounds(0, 0, Width, Height);

Canvas.Font.Assign(Font);

with inherited Canvas do

begin

// Clear the background

Brush.Color := FColor;

FillRect(Client);

// Draw the button bevel

if not (FBevelStyle = bbNone) then

begin

// Get the bevel colors

if ((FState = bsDown) xor (FBevelStyle = bbLowered)) then

begin

clHigh := GetShadowColor(FColor);

clLow := GetHighlightColor(FColor);

end

else

begin

clHigh := GetHighlightColor(FColor);

clLow := GetShadowColor(FColor);

end;

Frame3D(Canvas, Client, clHigh, clLow, FBevelSize);

end;

// Draw the focus

if (FFocused and (bsShowFocus in FStyle)) and Enabled then

DrawFocusRect(Rect(

Client.Left + FSpacing - 1, Client.Top + FSpacing - 1,

Client.Right - FSpacing + 1, Client.Bottom - FSpacing + 1

));

// Draw the picture

if (FPicture <> nil) then

begin

if (bsStretch in FStyle) then

Picture := Rect(

FBevelSize + FSpacing, FBevelSize + FSpacing, Width - (FBevelSize + FSpacing), Height - (FBevelSize + FSpacing))

else if (bsCenter in FStyle) then

Picture := Bounds(

(Width - FPicture.Width) div 2, (Height - FPicture.Height) div 2,

FPicture.Width, FPicture.Height

)

else

case FAlignment of

alTopLeft, alTopCenter, alTopRight:

Picture := Bounds(

(Width - FPicture.Width) div 2,

((Height - (FBevelSize + FSpacing)) - FPicture.Height),

FPicture.Width, FPicture.Height

);

alMiddleLeft:

Picture := Bounds(

((Width - (FBevelSize + FSpacing)) - FPicture.Width),

(Height - FPicture.Height) div 2,

FPicture.Width, FPicture.Height

);

alMiddleCenter:

Picture := Bounds(

(Width - FPicture.Width) div 2,

(Height - FPicture.Height) div 2,

FPicture.Width, FPicture.Height

);

alMiddleRight:

Picture := Bounds(

(FBevelSize + FSpacing),

(Height - FPicture.Height) div 2,

FPicture.Width, FPicture.Height

);

alBottomLeft, alBottomCenter, alBottomRight:

Picture := Bounds(

(Width - FPicture.Width) div 2,

(FBevelSize + FSpacing),

FPicture.Width, FPicture.Height

);

end;

StretchDraw(Picture, FPicture.Graphic);

end

else

begin

Brush.Color := FColor;

FillRect(Rect(FBevelSize, FBevelSize, Width - FBevelSize, Height - FBevelSize));

end;

// Draw the caption

if (Caption <> '') then

begin

Brush.Style := bsClear;

if ((not Enabled) and (not (csDesigning in ComponentState))) then

begin

Font.Color := GetHighlightColor(FColor); DrawCaption(1);

Font.Color := GetShadowColor(FColor); DrawCaption(0);

end else DrawCaption(0);

end;

procedure TColorButton.DoEnter;

begin

FFocused := True; Repaint;

inherited DoEnter;

end;

procedure TColorButton.DoExit;

begin

FFocused := False; Repaint;

inherited DoExit;

end;

procedure TColorButton.KeyDown(var Key: Word; Shift: TShiftState);

begin

inherited KeyDown(Key, Shift);

if Key = VK_SPACE then

if Enabled then

begin

FState := bsDown;

Repaint;

end;

procedure TColorButton.KeyUp(var Key: Word; Shift: TShiftState);

begin

inherited KeyUp(Key, Shift);

if Key = VK_SPACE then

if Enabled then

begin

FState := bsUp;

Click; Repaint;

end;

if Key = VK_RETURN then if not (FState = bsDisabled) then Click;

end;

procedure TColorButton.KeyAccel(var Message: TCMDialogChar);

begin

with Message do

begin

if IsAccel(CharCode, Caption) and Enabled then

begin

Click;

Result := 1;

end

else inherited;

end;

procedure TColorButton.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);

begin

inherited MouseDown(Button, Shift, X, Y);

if Enabled then

begin

FState := bsDown;

Repaint;

end;

procedure TColorButton.MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);

begin

inherited MouseUp(Button, Shift, X, Y);

if Enabled then

begin

FState := bsUp;

Repaint;

end;

procedure TColorButton.SetAlignment(Value: TAlignment);

begin

FAlignment := Value;

Repaint;

end;

procedure TColorButton.SetBevelStyle(Value: TButtonBevel);

begin

FBevelStyle := Value;

Repaint;

end;

procedure TColorButton.SetBevelSize(Value: Integer);

begin

if Value < 1 then Value := 1;

FBevelSize := Value;

Repaint;

end;

procedure TColorButton.SetCaption(var Message: TMessage);

begin

Repaint;

end;

procedure TColorButton.SetColor(Value: TColor);

begin

FColor := Value;

Repaint;

end;

procedure TColorButton.SetEnabled(var Message: TMessage);

begin

inherited;

if Enabled then FState := bsUp else FState := bsDisabled;

Repaint;

end;

procedure TColorButton.SetFocusOff(var Message: TMessage);

begin

inherited;

FFocused := False;

Repaint;

end;

procedure TColorButton.SetFocusOn(var Message: TMessage);

begin

inherited;

FFocused := True;

Repaint;

end;

procedure TColorButton.SetFont(var Message: TMessage);

begin

inherited;

Repaint;

end;

procedure TColorButton.SetPicture(Value: TPicture);

begin

if FPicture <> Value then

begin

FPicture.Assign(Value);

Repaint;

end;

procedure TColorButton.SetSpacing(Value: Integer);

begin

if Value < 0 then Value := 0;

if FSpacing <> Value then

begin

FSpacing := Value;

Repaint;

end;

procedure TColorButton.SetStyle(Value: TButtonStyle);

begin

if FStyle <> Value then

begin

FStyle := Value;

Repaint;

end;

end.

Delphi - .....................................

QueryProc

unit QueryProc;

interface

uses Windows, SysUtils, Graphics, Classes, Controls, Db, DBCommon, Bde, SMIntf,

StdVCL, DBTables, Dialogs;

type

TTpProc = (tpInsert, tpUpdate, tpDelete);

TQueryProc = class(TQuery)

private

{ Private declarations }

{ FTrue: Boolean;}

FOnUR: TUpdateRecordEvent;

FMapp: array[TTpProc] of TStrings;

FProcName: array[TTpProc] of string;

FOverLoad: array[TTpProc] of Word;

FParamErr: string;

FParamMsg: string;

FStoredProc: TStoredProc;

procedure UR(DataSet: TDataSet; UpdateKind: TUpdateKind; var UpdateAction: TUpdateAction);

function GetMappIndex(Index: Integer): TStrings;

procedure SetMapp(TpProc: TTpProc; Value: TStrings);

procedure SetMappIndex(Index: Integer; Value: TStrings);

function GetProcNameIndex(Index: Integer): string;

procedure SetProcName(TpProc: TTpProc; Value: string);

procedure SetProcNameIndex(Index: Integer; Value: string);

function GetOverLoadIndex(Index: Integer): Word;

procedure SetOverLoad(TpProc: TTpProc; Value: Word);

procedure SetOverLoadIndex(Index: Integer; Value: Word);

procedure ExecutaProcedure(Oper: Integer);

protected

{ Protected declarations }

function GetOverLoad(TpProc: TTpProc): Word;

function GetProcName(TpProc: TTpProc): string;

function GetMapp(TpProc: TTpProc): TStrings;

procedure DoBeforeDelete; override;

function CreateParamDesc(Index: Integer): TStrings;

public

{ Public declarations }

constructor Create(AOwner: TComponent); override;

destructor Destroy; override;

procedure Post; override;

published

{ Published declarations }

property InsertMapp: TStrings index 0 read GetMappIndex write SetMappIndex;

property UpdateMapp: TStrings index 1 read GetMappIndex write SetMappIndex;

property DeleteMapp: TStrings index 2 read GetMappIndex write SetMappIndex;

property InsertStProc: string index 0 read GetProcNameIndex write SetProcNameIndex;

property UpdateStProc: string index 1 read GetProcNameIndex write SetProcNameIndex;

property DeleteStProc: string index 2 read GetProcNameIndex write SetProcNameIndex;

property InsertOverload: Word index 0 read GetOverloadIndex write SetOverloadIndex default 0;

property UpdateOverload: Word index 1 read GetOverloadIndex write SetOverloadIndex default 0;

property DeleteOverload: Word index 2 read GetOverloadIndex write SetOverloadIndex default 0;

property ParamErr: string read FParamErr write FParamErr;

property ParamMsg: string read FParamMsg write FParamMsg;

property CachedUpdates stored False default True;

property RequestLive stored False default True;

property OnUpdateRecord: TUpdateRecordEvent read FOnUR;

end;

procedure Register;

implementation

procedure Register;

begin

RegisterComponents('Data Access', [TQueryProc]);

end;

// criação do objeto

constructor TQueryProc.Create(AOwner: TComponent);

var TpProc: TTpProc;

begin

inherited Create(AOwner);

{ FTrue := True;}

inherited CachedUpdates := True;

inherited RequestLive := True;

inherited OnUpdateRecord := UR;

// cria os mapas de atribuição da procedure

for TpProc := Low(TTpProc) to High(TTpProc) do

begin

FMapp[TpProc] := TStringList.Create;

end;

// cria o TStoredProc

FStoredProc := TStoredProc.Create(Self);

FStoredProc.DatabaseName := DatabaseName;

FStoredProc.ParamBindMode := pbByName;

end;

// destroy do objeto

destructor TQueryProc.Destroy;

var TpProc: TTpProc;

begin

for TpProc := Low(TTpProc) to High(TTpProc) do

FMapp[TpProc].Free;

FStoredProc.Free;

inherited Destroy;

end;

// evento OnUpdateRecord (sempre pula a atualização)

procedure TQueryProc.UR(DataSet: TDataSet;

UpdateKind: TUpdateKind; var UpdateAction: TUpdateAction);

begin

UpdateAction := uaSkip; // uaApplied

end;

{*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*}

// retorna o mapa correspondente

function TQueryProc.GetMapp(TpProc: TTpProc): TStrings;

begin

Result := FMapp[TpProc];

end;

function TQueryProc.GetMappIndex(Index: Integer): TStrings;

begin

// pega o mapa correspondente ou

Result := FMapp[TTpProc(Index)];

// cria um novo "default"

if (FProcName[TTpProc(Index)] <> '') and

(FMapp[TTpProc(Index)].Count = 0) and

(ComponentState = [csDesigning]) then

begin

Result := CreateParamDesc(Index);

end;

// grava o mapa

procedure TQueryProc.SetMapp(TpProc: TTpProc; Value: TStrings);

begin

FMapp[TpProc].Assign(Value);

end;

procedure TQueryProc.SetMappIndex(Index: Integer; Value: TStrings);

begin

SetMapp(TTpProc(Index), Value);

end;

// retorna o nome da proc

function TQueryProc.GetProcName(TpProc: TTpProc): string;

begin

Result := FProcName[TpProc];

end;

function TQueryProc.GetProcNameIndex(Index: Integer): string;

begin

Result := FProcName[TTpProc(Index)];

end;

// grava o nome de proc

procedure TQueryProc.SetProcName(TpProc: TTpProc; Value: string);

begin

FProcName[TpProc] := Value;

end;

procedure TQueryProc.SetProcNameIndex(Index: Integer; Value: string);

begin

SetProcName(TTpProc(Index), Value);

end;

// pega o "OverLoad" da Proc (Oracle)

function TQueryProc.GetOverLoad(TpProc: TTpProc): Word;

begin

Result := FOverLoad[TpProc];

end;

function TQueryProc.GetOverLoadIndex(Index: Integer): Word;

begin

Result := FOverLoad[TTpProc(Index)];

end;

// grava o "OverLoad" da Proc (Oracle)

procedure TQueryProc.SetOverLoad(TpProc: TTpProc; Value: Word);

begin

FOverLoad[TpProc] := Value;

end;

procedure TQueryProc.SetOverLoadIndex(Index: Integer; Value: Word);

begin

SetOverLoad(TTpProc(Index), Value);

end;

{*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*}

// monta o mapa de atribuição dos parâmetros da proc

function TQueryProc.CreateParamDesc(Index: Integer): TStrings;

var

Desc: SPParamDesc;

Cursor: HDBICur;

Buffer: array[0..DBIMAXSPNAMELEN] of Char;

Name: string;

Posicao, Comp, iCampo, i: integer;

Preparado: boolean;

begin

Result := TStringList.Create;

// prepara a query colher os Fields

Preparado := Prepared;

if not Prepared then

try

Prepare;

except

exit;

// Raise Exception.Create('Erro preparanto para criar parametros');

end;

try

// se estiver prepado e for Banco de dados

if Prepared and (DBLocale <> nil) then

begin

// pega a lista de parâmetros da proc

AnsiToNative(DBLocale, FProcName[TTpProc(Index)], Buffer, DBIMAXSPNAMELEN);

if DbiOpenSPParamList(DBHandle, Buffer, False, FOverLoad[TTpProc(Index)], Cursor) = 0 then

try

while DbiGetNextRecord(Cursor, dbiNOLOCK, @Desc, nil) = 0 do

begin

// pega no Nome do parâmetro

NativeToAnsi(DBLocale, Desc.szName, Name);

if (TParamType(Desc.eParamType) = ptResult) and (Name = '') then

Name := Desc.szName;

if Name <> '' then

begin

// tira a arroba ('@') do parâmetro (Sybase e SQL Server)

if copy(Name, 1, 1) = '@' then

Name := Copy(Name, 2, 255);

// se parâmetro for OLD campo tambem será (Ver 'ExecutaProcedure')

if pos('OLD_', Name) > 0 then

Name := Name + '=OLD_'

else

Name := Name + '=';

// procura o campo nome mais aproximado

iCampo := -1;

Comp := 0;

for i := 0 to FieldCount - 1 do

begin

posicao := Pos(uppercase(Fields[i].FieldName), uppercase(Name));

// pega o campo com o maior número de caracteres coincedentes

if (posicao > 0) and

(Comp < Length(Fields[i].FieldName)) then

begin

iCampo := i;

Comp := Length(Fields[i].FieldName);

end;

// se algum nome é igual mapeia a atribuição

if iCampo <> -1 then

Name := Name + Fields[iCampo].FieldName;

Result.Add(Name);

end;

finally

DbiCloseCursor(Cursor);

end;

finally

if not Preparado then

Unprepare;

end;

// captura e modifica o Post da query

procedure TQueryProc.Post;

begin

UpdateRecord;

if State = dsInsert then

ExecutaProcedure(0)

else

ExecutaProcedure(1);

inherited Post;

end;

// captura e modifica o Delete da query

procedure TQueryProc.DoBeforeDelete;

begin

inherited DoBeforeDelete;

ExecutaProcedure(2);

end;

// executa a procedure de acordo com a operação informada

procedure TQueryProc.ExecutaProcedure(Oper: Integer);

var P, Param, Campo, TpValor, ParErro, Driver: string;

VlFloat: Double;

VlInteger, i: integer;

Separador: Char;

MappTmp: TStrings;

Old, New: Boolean;

TmpValue: Variant;

TpPar: TParamType;

begin

// pega o mapa de atribuição

MappTmp := TStringList.Create;

MappTmp.Clear;

MappTmp := FMapp[TTpProc(Oper)];

separador:=#0;

// se tem mapa de atribuição

if MappTmp.Count > 0 then

begin

ParErro := FParamErr;

// pega o Driver do banco

if DataBase.AliasName = '' then

Driver := DataBase.DriverName

else

Driver := DataBase.Session.GetAliasDriverName(DataBase.AliasName);

// se for SQL ou Sybase coloca "@" no parâmetro

if (Driver = 'MSSQL') or (Driver = 'SYBASE') then

begin

P := '@';

if FParamErr <> 'Result' then

ParErro := '@' + ParErro

end;

// atribui as propriedades da proc

FStoredProc.DatabaseName := DatabaseName;

FStoredProc.StoredProcName := FProcName[TTpProc(Oper)];

FStoredProc.OverLoad := FOverLoad[TTpProc(Oper)];

FStoredProc.Params.Clear;

// cria os parâmetros da proc

for i := 0 to MappTmp.Count - 1 do

if trim(MappTmp[i]) <> '' then

begin

// pega nome o parâmetro e o campo do mapa

Param := copy(MappTmp[i], 1, pos('=', MappTmp[i]) - 1);

Campo := copy(MappTmp[i], pos('=', MappTmp[i]) + 1, 99);

// verifica se o "campo" na realidade não é um "valor"

VlInteger := StrToIntDef(Campo, -9999);

if VlInteger <> -9999 then

TpValor := 'I'

else

try

Separador := DecimalSeparator;

DecimalSeparator := '.';

if TextToFloat(PChar(Campo), VlFloat, fvExtended) then

TpValor := 'F'

else

TpValor := '';

finally

DecimalSeparator := Separador;

TpValor := '';

end;

// atribui o valor do "campo" ao parâmeto da proc

if Campo = '' then

FStoredProc.Params.CreateParam(ftString, P + Param, ptOutput)

else if TpValor = 'F' then

with FStoredProc.Params.CreateParam(ftFloat, P + Param, ptInput) do

AsFloat := VlFloat

else if TpValor = 'I' then

with FStoredProc.Params.CreateParam(ftInteger, P + Param, ptInput) do

AsInteger := VlInteger

else if pos('"', Campo) = 1 then

with FStoredProc.Params.CreateParam(ftString, P + Param, ptInput) do

AsString := copy(Campo, 2, length(Campo) - 2)

else

begin

// verifica se o campo é OLD ou NEW e limpa o nome

Old := Copy(Campo, 1, 4) = 'OLD_';

New := Copy(Campo, 1, 4) = 'NEW_';

if Old or New then

Campo := Copy(Campo, 5, 99);

// se o campo é OLD então pega o valor antigo

// isto serve para alteração de chave primária

if Old then

TmpValue := FieldByName(Campo).OldValue

else

TmpValue := FieldByName(Campo).Value;

// se o Campo for NEW então o parâmetro sera OUTPUT

// isto serve para atualizar campos alterados na procedure

if New then

TpPar := ptInputOutput

else

TpPar := ptInput;

// atribui o valor

with FStoredProc.Params.CreateParam(FieldByName(Campo).DataType, P + Param, TpPar) do

begin

if not VarIsNull(TmpValue) then

Value := TmpValue;

end

end;

// cria parâmetro result para Sybase e SQL

if P = '@' then

FStoredProc.Params.CreateParam(ftInteger, 'Result', ptResult);

// executa a procedure

FStoredProc.ExecProc;

// se holve erro

if (FParamErr <> '') and

(FStoredProc.ParamByName(ParErro).AsInteger <> 0) then

begin

// gera exception

if FParamMsg <> '' then

raise Exception.Create(FStoredProc.ParamByName(P + FParamMsg).AsString)

else

raise Exception.Create('Erro código ' + FStoredProc.ParamByName(ParErro).AsString);

end

else

for i := 0 to MappTmp.Count - 1 do

if trim(MappTmp[i]) <> '' then

begin

// atualiza os campo NEW com os valores retornados pela proc

Param := copy(MappTmp[i], 1, pos('=', MappTmp[i]) - 1);

Campo := copy(MappTmp[i], pos('=', MappTmp[i]) + 1, 99);

if Copy(Campo, 1, 4) = 'NEW_' then

begin

Campo := Copy(Campo, 5, 99);

FieldByName(Campo).Value := FStoredProc.ParamByName(P + Param).Value;

end;

end.

Delphi - .....................................

QRSDBEdit

unit QRSDBEdit;

interface

uses

Windows, Messages, SysUtils, Classes, QControls, QStdCtrls, QMask,

QDBCtrls;

type

TRSDBEdit = class(TDBEdit)

private

{ Private declarations }

protected

{ Protected declarations }

public

{ Public declarations }

published

property EchoMode;

{ Published declarations }

end;

procedure Register;

implementation

procedure Register;

begin

RegisterComponents('Data Controls', [TRSDBEdit]);

end;

end.

Delphi - .....................................