Как сделать калькулятор в Delphi?

Delphi - объектно-ориентированный язык программирования, разработанный компанией Borland в 1995 году. Он основан на языке программирования Pascal, но имеет более расширенные возможности и добавлены новые функции.

Как Delphi реализует многоплатформенную разработку?

Delphi является интегрированной средой разработки (IDE), которая позволяет разрабатывать программное обеспечение для различных платформ, включая Windows, macOS, Android и iOS. Delphi достигает многоплатформенности с помощью...

Быстрый доступ к ADO

Советы » ADO » Быстрый доступ к ADO

unit

ADO; {This unit provides a quick access into ADO It handles all it's own exceptions It assumes it is working with SQL Server, on a PLC Database If an exception is thrown with a [PLCErr] suffix: the suffix is removed, and ErrMsg is set to the remaining string otherwise the whole exception is reported in ErrMsg Either way, the function call fails. Globals: adocn - connection which all other ADO objects use adors - Recordset adocmd - Command Object adocmdprm - Command Object set aside for Parametric querying ConnectionString - Connection String used for connecting ErrMsg - Last Error Message ADOActive - Indicator as to whether ADO has been started yet Functions: General ADO ADOStart:Boolean; ADOReset:Boolean; ADOStop:Boolean; Recordsets RSOpen(SQL:string;adRSType,adLockType,adCmdType:integer;UseServer:Boolean):Boolean; RSClose:Boolean; Normal Command Procedures CMDExec(SQL:string;adCmdType:integer):Boolean; Parametric Procedures PRMClear:Boolean; PRMSetSP(StoredProcedure:string;WithClear:Boolean):Boolean; PRMAdd(ParamName:string;ParamType,ParamIO,ParamSize:integer;Val:variant):Boolean; PRMSetParamVal(ParamName:string;val:variant):Boolean; PRMGetParamVal(ParamName:string;var val:variant):Boolean; Field Operations function SQLStr(str:string;SQLStrType:TSQLStrType); function SentenceCase(str:string):string; --to convert from 'FIELD_NAME' -> 'Field Name' call SQLStr(SentenceCase(txt),ssFromSQL); } interface

uses

OLEAuto, sysutils; const

{Param Data Types} adInteger = 3; adSingle = 4; adDate = 7; adBoolean = 11; adTinyInt = 16; adUnsignedTinyInt = 17; adDateTime = 135; advarChar = 200; {Param Directions} adParamInput = 1; adParamOutput = 2; adParamReturnValue = 4; {Command Types} adCmdText = 1; adCmdTable = 2; adCmdStoredProc = 4; adCmdTableDirect = 512; adCmdFile = 256; {Cursor/RS Types} adOpenForwardOnly = 0; adOpenKeyset = 1; adOpenDynamic = 2; adOpenStatic = 3; {Lock Types} adLockReadOnly = 1; adLockOptimistic = 3; {Cursor Locations} adUseServer = 2; adUseClient = 3; function

ADOReset: Boolean; function

ADOStop: Boolean; function

RSOpen(SQL: string

; adRSType, adLockType, adCmdType: integer; UseServer: Boolean): Boolean; function

RSClose: Boolean; function

CMDExec(SQL: string

; adCmdType: integer): Boolean; function

PRMClear: Boolean; function

PRMSetSP(StoredProcedure: string

; WithClear: Boolean): Boolean; function

PRMAdd(ParamName: string

; ParamType, ParamIO, ParamSize: integer; Val: variant): Boolean; function

PRMSetParamVal(ParamName: string

; val: variant): Boolean; function

PRMGetParamVal(ParamName: string

; var

val: variant): Boolean; type

TSQLStrType = (ssToSQL, ssFromSQL); function

SQLStr(str: string

; SQLStrType: TSQLStrType): string

; function

SentenceCase(str: string

): string

; var

adocn, adors, adocmd, adocmdPrm: variant; ConnectionString, ErrMsg: string

; ADOActive: boolean = false

; implementation

var

UsingConnection: Boolean; function

ADOStart: Boolean; begin

//Get the Object References try

adocn := CreateOLEObject('ADODB.Connection'); adors := CreateOLEObject('ADODB.Recordset'); adocmd := CreateOLEObject('ADODB.Command'); adocmdprm := CreateOLEObject('ADODB.Command'); result := true

; except

on

E: Exception do

begin

ErrMsg := e.message

; Result := false

; end

; end

; ADOActive := result; end

; function

ADOReset: Boolean; begin

Result := false

; //Ensure a clean slate... if

not

(ADOStop) then

exit; //Restart all the ADO References if

not

(ADOStart) then

exit; //Wire up the Connections //If the ADOconnetion fails, all objects will use the connection string // directly - poorer performance, but it works!! try

adocn.ConnectionString := ConnectionString; adocn.open; adors.activeconnection := adocn; adocmd.activeconnection := adocn; adocmdprm.activeconnection := adocn; UsingConnection := true

; except

try

adocn := unassigned; UsingConnection := false

; adocmd.activeconnection := ConnectionString; adocmdprm.activeconnection := ConnectionString; except

on

e: exception do

begin

ErrMsg := e.message

; exit; end

; end

; end

; Result := true

; end

; function

ADOStop: Boolean; begin

try

if

not

(varisempty(adocn)) then

begin

adocn.close; adocn := unassigned; end

; adors := unassigned; adocmd := unassigned; adocmdprm := unassigned; result := true

; except

on

E: Exception do

begin

ErrMsg := e.message

; Result := false

; end

; end

; ADOActive := false

; end

; function

RSOpen(SQL: string

; adRSType, adLockType, adCmdType: integer; UseServer: Boolean): Boolean; begin

result := false

; //Have two attempts at getting the required Recordset if

UsingConnection then

begin

try

if

UseServer then

adors.CursorLocation := adUseServer else

adors.CursorLocation := adUseClient; adors.open(SQL, , adRSType, adLockType, adCmdType); except

if

not

(ADOReset) then

exit; try

if

UseServer then

adors.CursorLocation := adUseServer else

adors.CursorLocation := adUseClient; adors.open(SQL, , adRSType, adLockType, adCmdType); except

on

E: Exception do

begin

ErrMsg := e.message

; exit; end

; end

; end

; end

else

begin

//Use the Connetcion String to establish a link try

adors.open(SQL, ConnectionString, adRSType, adLockType, adCmdType); except

if

not

(ADOReset) then

exit; try

adors.open(SQL, ConnectionString, adRSType, adLockType, adCmdType); except

on

E: Exception do

begin

ErrMsg := e.message

; exit; end

; end

; end

; end

; Result := true

; end

; function

RSClose: Boolean; begin

try

adors.Close; result := true

; except

on

E: Exception do

begin

ErrMsg := e.message

; result := false

; end

; end

; end

; function

CMDExec(SQL: string

; adCmdType: integer): Boolean; begin

result := false

; //Have two attempts at the execution.. try

adocmd.commandtext := SQL; adocmd.commandtype := adCmdType; adocmd.execute; except

try

if

not

(ADOReset) then

exit; adocmd.commandtext := SQL; adocmd.commandtype := adCmdType; adocmd.execute; except

on

e: exception do

begin

ErrMsg := e.message

; exit; end

; end

; end

; result := true

; end

; function

PRMClear: Boolean; var

i: integer; begin

try

for

i := 0 to

(adocmdprm.parameters.count) - 1 do

begin

adocmdprm.parameters.delete(0); end

; result := true

; except

on

e: exception do

begin

ErrMsg := e.message

; result := false

; end

; end

; end

; function

PRMSetSP(StoredProcedure: string

; WithClear: Boolean): Boolean; begin

result := false

; //Have two attempts at setting the Stored Procedure... try

adocmdprm.commandtype := adcmdStoredProc; adocmdprm.commandtext := StoredProcedure; if

WithClear then

if

not

(PRMClear) then

exit; result := true

; except

try

if

not

(ADOReset) then

exit; adocmdprm.commandtype := adcmdStoredProc; adocmdprm.commandtext := StoredProcedure; //NB: No need to clear the parameters, as an ADOReset will have done this.. result := true

; except

on

e: exception do

begin

ErrMsg := e.message

; end

; end

; end

; end

; function

PRMAdd(ParamName: string

; ParamType, ParamIO, ParamSize: integer; Val: variant): Boolean; var

DerivedParamSize: integer; begin

//Only try once to add the parameter (a call to ADOReset would reset EVERYTHING!!) try

case

ParamType of

adInteger: DerivedParamSize := 4; adSingle: DerivedParamSize := 4; adDate: DerivedParamSize := 8; adBoolean: DerivedParamSize := 1; adTinyInt: DerivedParamSize := 1; adUnsignedTinyInt: DerivedParamSize := 1; adDateTime: DerivedParamSize := 8; advarChar: DerivedParamSize := ParamSize; end

; adocmdprm.parameters.append(adoCmdPrm.createparameter(ParamName, ParamType, ParamIO, DerivedParamSize, Val)); except

on

e: exception do

begin

ErrMsg := e.message

; end

; end

; end

; function

PRMSetParamVal(ParamName: string

; val: variant): Boolean; begin

//Only try once to set the parameter (a call to ADOReset would reset EVERYTHING!!) try

adocmdprm.Parameters[ParamName].Value := val; result := true

; except

on

e: exception do

begin

ErrMsg := e.message

; result := false

; end

; end

; end

; function

PRMGetParamVal(ParamName: string

; var

val: variant): Boolean; begin

//Only try once to read the parameter (a call to ADOReset would reset EVERYTHING!!) try

val := adocmdprm.Parameters[ParamName].Value; result := true

; except

on

e: exception do

begin

ErrMsg := e.message

; result := false

; end

; end

; end

; function

SQLStr(str: string

; SQLStrType: TSQLStrType): string

; var

FindChar, ReplaceChar: char; begin

{Convert ' '->'_' for ssToSQL (remove spaces) Convert '_'->' ' for ssFromSQL (remove underscores)} case

SQLStrType of

ssToSQL: begin

FindChar := ' '; ReplaceChar := '_'; end

; ssFromSQL: begin

FindChar := '_'; ReplaceChar := ' '; end

; end

; result := str; while

Pos(FindChar, result) > 0 do

Result[Pos(FindChar, result)] := ReplaceChar; end

; function

SentenceCase(str: string

): string

; var

tmp: char; i {,len}: integer; NewWord: boolean; begin

NewWord := true

; result := str; for

i := 1 to

Length(str) do

begin

if

(result[i] = ' ') or

(result[i] = '_') then

NewWord := true

else

begin

tmp := result[i]; if

NewWord then

begin

NewWord := false

; result[i] := chr(ord(result[i]) or

64); //Set bit 6 - makes uppercase end

else

result[i] := chr(ord(result[i]) and

191); //reset bit 6 - makes lowercase end

; end

; {This was the original way of doing it, but I wanted to look for spaces or '_'s, and it all seemed problematic - if I find a better way another day, I'll alter the above... if str<>'' then begin tmp:=LowerCase(str); len:=length(tmp); tmp:=Uppercase(copy(tmp,1,1))+copy(tmp,2,len); i:=pos('_',tmp); while i<>0 do begin tmp:=copy(tmp,1,i-1)+' '+Uppercase(copy(tmp,i+1,1))+copy(tmp,i+2,len-i); i:=pos('_',tmp); end; end; result:=tmp;} end

; end

.

Другое по теме:

Категории

Статьи

Советы

Copyright © 2024 - All Rights Reserved - www.delphirus.com