Компонент для последовательного устройства (TRS232)
Компонент для последовательного устройства (TRS232)
Компонент, который представлен здесь, выполняет функции синхронного чтения и записи в последовательный интерфейс RS232.
В цикле выполняется Application.ProcessMessages, чтобы все сообщения от основной программы обрабатывались.
// ----------------------------------------------------------------------
// | RS232 - Basic Driver for the RS232 port 1.0 |
// ----------------------------------------------------------------------
// | © 1997 by Marco Cocco |
// | © 1998 by enhanced by Angerer Bernhard |
// ----------------------------------------------------------------------
unit uRS232;
interface
uses
Windows, Messages, SysUtils, Classes, Forms,
ExtCtrls; // TTimer
////////////////////////////////////////////////////////////////////////////////
type
TReceiveDataEvent = procedure(Sender: TObject; Msg, lParam, wParam:longint) of object;
// COM Port Baud Rates
TComPortBaudRate = ( br110, br300, br600, br1200, br2400, br4800,
br9600, br14400, br19200, br38400, br56000,
br57600, br115200 );
// COM Port Numbers
TComPortNumber = ( pnCOM1, pnCOM2, pnCOM3, pnCOM4 );
// COM Port Data bits
TComPortDataBits = ( db5BITS, db6BITS, db7BITS, db8BITS );
// COM Port Stop bits
TComPortStopBits = ( sb1BITS, sb1HALFBITS, sb2BITS );
// COM Port Parity
TComPortParity = ( ptNONE, ptODD, ptEVEN, ptMARK, ptSPACE );
// COM Port Hardware Handshaking
TComPortHwHandshaking = ( hhNONE, hhRTSCTS );
// COM Port Software Handshaing
TComPortSwHandshaking = ( shNONE, shXONXOFF );
TCommPortDriver = class(TComponent)
private
hTimer: TTimer;
FActive: boolean;
procedure SetActive(const Value: boolean);
protected
FComPortHandle : THANDLE; // COM Port Device Handle
FComPort : TComPortNumber; // COM Port to use (1..4)
FComPortBaudRate : TComPortBaudRate; // COM Port speed (brXXXX)
FComPortDataBits : TComPortDataBits; // Data bits size (5..8)
FComPortStopBits : TComPortStopBits; // How many stop bits to use
// (1,1.5,2)
FComPortParity : TComPortParity; // Type of parity to use
// (none,odd,even,mark,space)
FComPortHwHandshaking : TComPortHwHandshaking; // Type of hw
// handshaking to use
FComPortSwHandshaking : TComPortSwHandshaking; // Type of sw
// handshaking to use
FComPortInBufSize : word; // Size of the input buffer
FComPortOutBufSize : word; // Size of the output buffer
FComPortReceiveData : TReceiveDataEvent;
FComPortPollingDelay : word; // ms of delay between COM port pollings
FTimeOut : integer; // sec until timeout
FTempInBuffer : pointer;
procedure SetComPort( Value: TComPortNumber );
procedure SetComPortBaudRate( Value: TComPortBaudRate );
procedure SetComPortDataBits( Value: TComPortDataBits );
procedure SetComPortStopBits( Value: TComPortStopBits );
procedure SetComPortParity( Value: TComPortParity );
procedure SetComPortHwHandshaking( Value: TComPortHwHandshaking );
procedure SetComPortSwHandshaking( Value: TComPortSwHandshaking );
procedure SetComPortInBufSize( Value: word );
procedure SetComPortOutBufSize( Value: word );
procedure SetComPortPollingDelay( Value: word );
procedure ApplyCOMSettings;
procedure TimerEvent(Sender: TObject); virtual;
public
constructor Create( AOwner: TComponent ); override;
destructor Destroy; override;
function Connect: boolean; //override;
function Disconnect: boolean; //override;
function Connected: boolean;
function SendData( DataPtr: pointer; DataSize: integer ): boolean;
function SendString( aStr: string ): boolean;
// Event to raise when there is data available (input buffer has data)
property OnReceiveData: TReceiveDataEvent read FComPortReceiveData
write FComPortReceiveData;
published
// Which COM Port to use
property ComPort: TComPortNumber read FComPort write SetComPort
default pnCOM2;
// COM Port speed (bauds)
property ComPortSpeed: TComPortBaudRate read FComPortBaudRate
write SetComPortBaudRate default br9600;
// Data bits to used (5..8, for the 8250 the use of 5 data bits with 2 stop
// bits is an invalid combination, as is 6, 7, or 8 data bits with 1.5
// stop bits)
property ComPortDataBits: TComPortDataBits read FComPortDataBits
write SetComPortDataBits default db8BITS;
// Stop bits to use (1, 1.5, 2)
property ComPortStopBits: TComPortStopBits read FComPortStopBits
write SetComPortStopBits default sb1BITS;
// Parity Type to use (none,odd,even,mark,space)
property ComPortParity: TComPortParity read FComPortParity
write SetComPortParity default ptNONE;
// Hardware Handshaking Type to use:
// cdNONE no handshaking
// cdCTSRTS both cdCTS and cdRTS apply (This is the more common method)
property ComPortHwHandshaking: TComPortHwHandshaking
read FComPortHwHandshaking write SetComPortHwHandshaking default hhNONE;
// Software Handshaking Type to use:
// cdNONE no handshaking
// cdXONXOFF XON/XOFF handshaking
property ComPortSwHandshaking: TComPortSwHandshaking
read FComPortSwHandshaking write SetComPortSwHandshaking default shNONE;
// Input Buffer size
property ComPortInBufSize: word read FComPortInBufSize
write SetComPortInBufSize default 2048;
// Output Buffer size
property ComPortOutBufSize: word read FComPortOutBufSize
write SetComPortOutBufSize default 2048;
// ms of delay between COM port pollings
property ComPortPollingDelay: word read FComPortPollingDelay
write SetComPortPollingDelay default 100;
property TimeOut: integer read FTimeOut write FTimeOut default 30;
property Active: boolean read FActive write SetActive default false;
end;
TRS232 = class(TCommPortDriver)
protected
public
// new comm parameters are set
constructor Create( AOwner: TComponent ); override;
// ReadStrings reads direct from the comm-buffer and waits for
// more characters and handles the timeout
function ReadString(var aResStr: string; aCount: word ): boolean;
published
end;
procedure Register;
implementation
procedure Register;
begin
RegisterComponents('Additional', [TRS232]);
end;
constructor TCommPortDriver.Create( AOwner: TComponent );
begin
inherited Create( AOwner );
// Initialize to default values
FComPortHandle := 0; // Not connected
FComPort := pnCOM2; // COM 2
FComPortBaudRate := br9600; // 9600 bauds
FComPortDataBits := db8BITS; // 8 data bits
FComPortStopBits := sb1BITS; // 1 stop bit
FComPortParity := ptNONE; // no parity
FComPortHwHandshaking := hhNONE; // no hardware handshaking
FComPortSwHandshaking := shNONE; // no software handshaking
FComPortInBufSize := 2048; // input buffer of 512 bytes
FComPortOutBufSize := 2048; // output buffer of 512 bytes
FComPortReceiveData := nil; // no data handler
FTimeOut := 30; // sec until timeout
FComPortPollingDelay := 500;
GetMem( FTempInBuffer, FComPortInBufSize ); // Temporary buffer
// for received data
// Timer for teaching and messages
hTimer := TTimer.Create(Self);
hTimer.Enabled := false;
hTimer.Interval := 500;
hTimer.OnTimer := TimerEvent;
if ComponentState = [csDesigning] then
EXIT;
if FActive then
hTimer.Enabled := true; // start the timer only at application start
end;
destructor TCommPortDriver.Destroy;
begin
// Be sure to release the COM device
Disconnect;
// Free the temporary buffer
FreeMem( FTempInBuffer, FComPortInBufSize );
// Destroy the timer's window
inherited Destroy;
end;
procedure TCommPortDriver.SetComPort( Value: TComPortNumber );
begin
// Be sure we are not using any COM port
if Connected then
exit;
// Change COM port
FComPort := Value;
end;
procedure TCommPortDriver.SetComPortBaudRate( Value: TComPortBaudRate );
begin
// Set new COM speed
FComPortBaudRate := Value;
// Apply changes
if Connected then
ApplyCOMSettings;
end;
procedure TCommPortDriver.SetComPortDataBits( Value: TComPortDataBits );
begin
// Set new data bits
FComPortDataBits := Value;
// Apply changes
if Connected then
ApplyCOMSettings;
end;
procedure TCommPortDriver.SetComPortStopBits( Value: TComPortStopBits );
begin
// Set new stop bits
FComPortStopBits := Value;
// Apply changes
if Connected then
ApplyCOMSettings;
end;
procedure TCommPortDriver.SetComPortParity( Value: TComPortParity );
begin
// Set new parity
FComPortParity := Value;
// Apply changes
if Connected then
ApplyCOMSettings;
end;
procedure TCommPortDriver.SetComPortHwHandshaking(Value: TComPortHwHandshaking);
begin
// Set new hardware handshaking
FComPortHwHandshaking := Value;
// Apply changes
if Connected then
ApplyCOMSettings;
end;
procedure TCommPortDriver.SetComPortSwHandshaking(Value: TComPortSwHandshaking);
begin
// Set new software handshaking
FComPortSwHandshaking := Value;
// Apply changes
if Connected then
ApplyCOMSettings;
end;
procedure TCommPortDriver.SetComPortInBufSize( Value: word );
begin
// Free the temporary input buffer
FreeMem( FTempInBuffer, FComPortInBufSize );
// Set new input buffer size
FComPortInBufSize := Value;
// Allocate the temporary input buffer
GetMem( FTempInBuffer, FComPortInBufSize );
// Apply changes
if Connected then
ApplyCOMSettings;
end;
procedure TCommPortDriver.SetComPortOutBufSize( Value: word );
begin
// Set new output buffer size
FComPortOutBufSize := Value;
// Apply changes
if Connected then
ApplyCOMSettings;
end;
procedure TCommPortDriver.SetComPortPollingDelay( Value: word );
begin
FComPortPollingDelay := Value;
hTimer.Interval := Value;
end;
const
Win32BaudRates: array[br110..br115200] of DWORD =
( CBR_110, CBR_300, CBR_600, CBR_1200, CBR_2400, CBR_4800, CBR_9600,
CBR_14400, CBR_19200, CBR_38400, CBR_56000, CBR_57600, CBR_115200 );
const
dcb_Binary = $00000001;
dcb_ParityCheck = $00000002;
dcb_OutxCtsFlow = $00000004;
dcb_OutxDsrFlow = $00000008;
dcb_DtrControlMask = $00000030;
dcb_DtrControlDisable = $00000000;
dcb_DtrControlEnable = $00000010;
dcb_DtrControlHandshake = $00000020;
dcb_DsrSensivity = $00000040;
dcb_TXContinueOnXoff = $00000080;
dcb_OutX = $00000100;
dcb_InX = $00000200;
dcb_ErrorChar = $00000400;
dcb_NullStrip = $00000800;
dcb_RtsControlMask = $00003000;
dcb_RtsControlDisable = $00000000;
dcb_RtsControlEnable = $00001000;
dcb_RtsControlHandshake = $00002000;
dcb_RtsControlToggle = $00003000;
dcb_AbortOnError = $00004000;
dcb_Reserveds = $FFFF8000;
// Apply COM settings.
procedure TCommPortDriver.ApplyCOMSettings;
var dcb: TDCB;
begin
// Do nothing if not connected
if not Connected then
exit;
// Clear all
fillchar( dcb, sizeof(dcb), 0 );
// Setup dcb (Device Control Block) fields
dcb.DCBLength := sizeof(dcb); // dcb structure size
dcb.BaudRate := Win32BaudRates[ FComPortBaudRate ]; // baud rate to use
dcb.Flags := dcb_Binary or // Set fBinary: Win32 does not support non
// binary mode transfers
// (also disable EOF check)
dcb_RtsControlEnable; // Enables the RTS line when the device
// is opened and leaves it on
// dcb_DtrControlEnable; // Enables the DTR line when the device
// is opened and leaves it on
case FComPortHwHandshaking of // Type of hw handshaking to use
hhNONE:; // No hardware handshaking
hhRTSCTS: // RTS/CTS (request-to-send/clear-to-send) hardware handshaking
dcb.Flags := dcb.Flags or dcb_OutxCtsFlow or dcb_RtsControlHandshake;
end;
case FComPortSwHandshaking of // Type of sw handshaking to use
shNONE:; // No software handshaking
shXONXOFF: // XON/XOFF handshaking
dcb.Flags := dcb.Flags or dcb_OutX or dcb_InX;
end;
dcb.XONLim := FComPortInBufSize div 4; // Specifies the minimum number
// of bytes allowed
// in the input buffer before the
// XON character is sent
dcb.XOFFLim := 1; // Specifies the maximum number of bytes allowed in the
// input buffer before the XOFF character is sent.
// The maximum number of bytes allowed is calculated by
// subtracting this value from the size, in bytes,
// of the input buffer
dcb.ByteSize := 5 + ord(FComPortDataBits); // how many data bits to use
dcb.Parity := ord(FComPortParity); // type of parity to use
dcb.StopBits := ord(FComPortStopbits); // how many stop bits to use
dcb.XONChar := #17; // XON ASCII char
dcb.XOFFChar := #19; // XOFF ASCII char
SetCommState( FComPortHandle, dcb );
// Setup buffers size
SetupComm( FComPortHandle, FComPortInBufSize, FComPortOutBufSize );
end;
function TCommPortDriver.Connect: boolean;
var comName: array[0..4] of char;
tms: TCOMMTIMEOUTS;
begin
// Do nothing if already connected
Result := Connected;
if Result then exit;
// Open the COM port
StrPCopy( comName, 'COM' );
comName[3] := chr( ord('1') + ord(FComPort) );
comName[4] := #0;
FComPortHandle := CreateFile(
comName,
GENERIC_READ or GENERIC_WRITE,
0, // Not shared
nil, // No security attributes
OPEN_EXISTING,
FILE_ATTRIBUTE_NORMAL,
0 // No template
) ;
Result := Connected;
if not Result then exit;
// Apply settings
ApplyCOMSettings;
// Setup timeouts: we disable timeouts because we are polling the com port!
tms.ReadIntervalTimeout := 1; // Specifies the maximum time, in milliseconds,
// allowed to elapse between the arrival of two
// characters on the communications line
tms.ReadTotalTimeoutMultiplier := 0; // Specifies the multiplier, in
// milliseconds, used to calculate
// the total time-out period
// for read operations.
tms.ReadTotalTimeoutConstant := 1; // Specifies the constant, in milliseconds,
// used to calculate the total time-out
// period for read operations.
tms.WriteTotalTimeoutMultiplier := 0; // Specifies the multiplier, in
// milliseconds, used to calculate
// the total time-out period
// for write operations.
tms.WriteTotalTimeoutConstant := 0; // Specifies the constant, in
// milliseconds, used to calculate
// the total time-out period
// for write operations.
SetCommTimeOuts( FComPortHandle, tms );
Sleep(1000); // to avoid timing problems, wait until the Comm-Port is opened
end;
function TCommPortDriver.Disconnect: boolean;
begin
Result:=false;
if Connected then
begin
CloseHandle( FComPortHandle );
FComPortHandle := 0;
end;
Result := true;
end;
function TCommPortDriver.Connected: boolean;
begin
Result := FComPortHandle > 0;
end;
function TCommPortDriver.SendData(DataPtr: pointer; DataSize: integer): boolean;
var nsent: DWORD;
begin
Result := WriteFile( FComPortHandle, DataPtr^, DataSize, nsent, nil );
Result := Result and (nsent=DataSize);
end;
function TCommPortDriver.SendString( aStr: string ): boolean;
begin
if not Connected then
if not Connect then raise Exception.CreateHelp('RS232.SendString:'+
' Connect not possible !', 101);
Result:=SendData( pchar(aStr), length(aStr) );
if not Result then raise
Exception.CreateHelp('RS232.SendString: Send not possible !', 102);
end;
// Event for teaching and messages
procedure TCommPortDriver.TimerEvent(Sender: TObject);
var InQueue, OutQueue: integer;
// Test if data in inQueue(outQueue)
procedure DataInBuffer(Handle: THandle; var aInQueue, aOutQueue: integer);
var ComStat: TComStat;
e: cardinal;
begin
aInQueue := 0;
aOutQueue := 0;
if ClearCommError(Handle, e, @ComStat) then
begin
aInQueue := ComStat.cbInQue;
aOutQueue := ComStat.cbOutQue;
end;
end;
begin
if not Connected then
if not Connect then raise Exception.CreateHelp('RS232.TimerEvent:'+
' Connect not possible !', 101);
if Connected then
begin
DataInBuffer(FComPortHandle, InQueue, OutQueue);
// data in inQueue
if InQueue > 0 then
if Assigned(FComPortReceiveData) then FComPortReceiveData(Self , 0, 0, 0);
end;
end;
// RS232 implementation ////////////////////////////////////////////////////////
////////////////////////////////////////////////////////////////////////////////
constructor TRS232.Create( AOwner: TComponent );
begin
inherited Create( AOwner );
//OnReceiveData := ReceiveData;
FComPort := pnCOM1; // COM 1
FComPortBaudRate := br9600; // 9600 bauds
FComPortDataBits := db8BITS; // 8 data bits
FComPortStopBits := sb1BITS; // 1 stop bits
FComPortParity := ptEVEN; // even parity
FComPortHwHandshaking := hhNONE; // no hardware handshaking
FComPortSwHandshaking := shNONE; // no software handshaking
FComPortInBufSize := 2048; // input buffer of 512 ? bytes
FComPortOutBufSize := 2048; // output buffer of 512 ? bytes
FTimeOut := 30; // sec until timeout
end;
function TRS232.ReadString(VAR aResStr: string; aCount: word ): boolean;
var
nRead: dword;
Buffer: string;
Actual, Before: TDateTime;
TimeOutMin, TimeOutSec, lCount: word;
begin
Result := false;
if not Connected then
if not Connect then raise Exception.CreateHelp('RS232.ReadString:'+
' Connect not possible !', 101);
aResStr := '';
TimeOutMin:=TimeOut div 60;
TimeOutSec:=TimeOut mod 60;
if (not Connected) or (aCount <= 0) then EXIT;
nRead := 0; lCount := 0;
Before := Time;
while lCount<aCount do
begin
Application.ProcessMessages;
SetLength(Buffer,1);
if ReadFile( FComPortHandle, PChar(Buffer)^, 1, nRead, nil ) then
begin
if nRead > 0 then
begin
aResStr := aResStr + Buffer;
inc(lCount);
end;
Actual := Time;
if Actual-Before>EncodeTime(0, TimeOutMin, TimeOutSec, 0)
then raise Exception.CreateHelp('RS232.ReadString: TimeOut !', 103);
end
else begin
raise Exception.CreateHelp('RS232.ReadString: Read not possible !', 104);
end;
end; // while
Result:=true;
end;
{$A+,B-,C+,D-,E-,F-,G+,H+,I+,J+,K-,L-,M-,N+,O+,P+,Q-,R-,S-,T-,U-,V+,W-,X+,Y-,Z1}
{$MINSTACKSIZE $00004000}
{$MAXSTACKSIZE $00100000}
{$IMAGEBASE $51000000}
{$APPTYPE GUI}
unit ComportDriverThread;
interface
uses
//Include "ExtCtrl" for the TTimer component.
Windows, Messages, SysUtils, Classes, Forms, ExtCtrls;
type
TComPortNumber = (pnCOM1,pnCOM2,pnCOM3,pnCOM4);
TComPortBaudRate = (br110,br300,br600,br1200,br2400,br4800,br9600,
br14400,br19200,br38400,br56000,br57600,br115200);
TComPortDataBits = (db5BITS,db6BITS,db7BITS,db8BITS);
TComPortStopBits = (sb1BITS,sb1HALFBITS,sb2BITS);
TComPortParity = (ptNONE,ptODD,ptEVEN,ptMARK,ptSPACE);
TComportHwHandshaking = (hhNONE,hhRTSCTS);
TComPortSwHandshaking = (shNONE,shXONXOFF);
TTimerThread = class(TThread)
private
{ Private declarations }
FOnTimer : TThreadMethod;
FEnabled: Boolean;
protected
{ Protected declarations }
procedure Execute; override;
procedure SupRes;
public
{ Public declarations }
published
{ Published declarations }
property Enabled: Boolean read FEnabled write FEnabled;
end;
TComportDriverThread = class(TComponent)
private
{ Private declarations }
FTimer : TTimerThread;
FOnReceiveData : TNotifyEvent;
FReceiving : Boolean;
protected
{ Protected declarations }
FComPortActive : Boolean;
FComportHandle : THandle;
FComportNumber : TComPortNumber;
FComportBaudRate : TComPortBaudRate;
FComportDataBits : TComPortDataBits;
FComportStopBits : TComPortStopBits;
FComportParity : TComPortParity;
FComportHwHandshaking : TComportHwHandshaking;
FComportSwHandshaking : TComPortSwHandshaking;
FComportInputBufferSize : Word;
FComportOutputBufferSize : Word;
FComportPollingDelay : Word;
FTimeOut : Integer;
FTempInputBuffer : Pointer;
procedure SetComPortActive(Value: Boolean);
procedure SetComPortNumber(Value: TComPortNumber);
procedure SetComPortBaudRate(Value: TComPortBaudRate);
procedure SetComPortDataBits(Value: TComPortDataBits);
procedure SetComPortStopBits(Value: TComPortStopBits);
procedure SetComPortParity(Value: TComPortParity);
procedure SetComPortHwHandshaking(Value: TComportHwHandshaking);
procedure SetComPortSwHandshaking(Value: TComPortSwHandshaking);
procedure SetComPortInputBufferSize(Value: Word);
procedure SetComPortOutputBufferSize(Value: Word);
procedure SetComPortPollingDelay(Value: Word);
procedure ApplyComPortSettings;
procedure TimerEvent; virtual;
procedure doDataReceived; virtual;
public
{ Public declarations }
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
function Connect: Boolean;
function Disconnect: Boolean;
function Connected: Boolean;
function Disconnected: Boolean;
function SendData(DataPtr: Pointer; DataSize: Integer): Boolean;
function SendString(Input: String): Boolean;
function ReadString(var Str: string): Integer;
published
{ Published declarations }
property Active: Boolean read FComPortActive write SetComPortActive default False;
property ComPort: TComPortNumber read FComportNumber write SetComportNumber
default pnCOM1;
property ComPortSpeed: TComPortBaudRate read FComportBaudRate write
SetComportBaudRate default br9600;
property ComPortDataBits: TComPortDataBits read FComportDataBits write
SetComportDataBits default db8BITS;
property ComPortStopBits: TComPortStopBits read FComportStopBits write
SetComportStopBits default sb1BITS;
property ComPortParity: TComPortParity read FComportParity write
SetComportParity default ptNONE;
property ComPortHwHandshaking: TComportHwHandshaking read FComportHwHandshaking
write SetComportHwHandshaking default
hhNONE;
property ComPortSwHandshaking: TComPortSwHandshaking read FComportSwHandshaking
write SetComportSwHandshaking default
shNONE;
property ComPortInputBufferSize: Word read FComportInputBufferSize
write SetComportInputBufferSize default
2048;
property ComPortOutputBufferSize: Word read FComportOutputBufferSize
write SetComportOutputBufferSize default
2048;
property ComPortPollingDelay: Word read FComportPollingDelay write
SetComportPollingDelay default 100;
property OnReceiveData: TNotifyEvent read FOnReceiveData
write FOnReceiveData;
property TimeOut: Integer read FTimeOut write FTimeOut default 30;
end;
procedure Register;
implementation
procedure Register;
begin
RegisterComponents('Self-made Components', [TComportDriverThread]);
end;
{ TComportDriver }
constructor TComportDriverThread.Create(AOwner: TComponent);
begin
inherited;
FReceiving := False;
FComportHandle := 0;
FComportNumber := pnCOM1;
FComportBaudRate := br9600;
FComportDataBits := db8BITS;
FComportStopBits := sb1BITS;
FComportParity := ptNONE;
FComportHwHandshaking := hhNONE;
FComportSwHandshaking := shNONE;
FComportInputBufferSize := 2048;
FComportOutputBufferSize := 2048;
FOnReceiveData := nil;
FTimeOut := 30;
FComportPollingDelay := 500;
GetMem(FTempInputBuffer,FComportInputBufferSize);
if csDesigning in ComponentState then
Exit;
FTimer := TTimerThread.Create(False);
FTimer.FOnTimer := TimerEvent;
if FComPortActive then
FTimer.Enabled := True;
FTimer.SupRes;
end;
destructor TComportDriverThread.Destroy;
begin
Disconnect;
FreeMem(FTempInputBuffer,FComportInputBufferSize);
inherited Destroy;
end;
function TComportDriverThread.Connect: Boolean;
var
comName: array[0..4] of Char;
tms: TCommTimeouts;
begin
if Connected then
Exit;
StrPCopy(comName,'COM');
comName[3] := chr(ord('1') + ord(FComportNumber));
comName[4] := #0;
FComportHandle := CreateFile(comName,GENERIC_READ OR GENERIC_WRITE,0,nil,
OPEN_EXISTING,FILE_ATTRIBUTE_NORMAL,0);
if not Connected then
Exit;
ApplyComPortSettings;
tms.ReadIntervalTimeout := 1;
tms.ReadTotalTimeoutMultiplier := 0;
tms.ReadTotalTimeoutConstant := 1;
tms.WriteTotalTimeoutMultiplier := 0;
tms.WriteTotalTimeoutConstant := 0;
SetCommTimeouts(FComportHandle,tms);
Sleep(1000);
end;
function TComportDriverThread.Connected: Boolean;
begin
Result := FComportHandle > 0;
end;
function TComportDriverThread.Disconnect: Boolean;
begin
Result := False;
if Connected then
begin
CloseHandle(FComportHandle);
FComportHandle := 0;
end;
Result := True;
end;
function TComportDriverThread.Disconnected: Boolean;
begin
if (FComportHandle <> 0) then
Result := False
else
Result := True;
end;
const
Win32BaudRates: array[br110..br115200] of DWORD =
(CBR_110,CBR_300,CBR_600,CBR_1200,CBR_2400,CBR_4800,CBR_9600,CBR_14400,
CBR_19200,CBR_38400,CBR_56000,CBR_57600,CBR_115200);
const
dcb_Binary = $00000001;
dcb_ParityCheck = $00000002;
dcb_OutxCtsFlow = $00000004;
dcb_OutxDsrFlow = $00000008;
dcb_DtrControlMask = $00000030;
dcb_DtrControlDisable = $00000000;
dcb_DtrControlEnable = $00000010;
dcb_DtrControlHandshake = $00000020;
dcb_DsrSensitvity = $00000040;
dcb_TXContinueOnXoff = $00000080;
dcb_OutX = $00000100;
dcb_InX = $00000200;
dcb_ErrorChar = $00000400;
dcb_NullStrip = $00000800;
dcb_RtsControlMask = $00003000;
dcb_RtsControlDisable = $00000000;
dcb_RtsControlEnable = $00001000;
dcb_RtsControlHandshake = $00002000;
dcb_RtsControlToggle = $00003000;
dcb_AbortOnError = $00004000;
dcb_Reserveds = $FFFF8000;
procedure TComportDriverThread.ApplyComPortSettings;
var
//Device Control Block (= dcb)
dcb: TDCB;
begin
if not Connected then
Exit;
FillChar(dcb,sizeOf(dcb),0);
dcb.DCBlength := sizeOf(dcb);
dcb.Flags := dcb_Binary or dcb_RtsControlEnable;
dcb.BaudRate := Win32BaudRates[FComPortBaudRate];
case FComportHwHandshaking of
hhNONE : ;
hhRTSCTS:
dcb.Flags := dcb.Flags or dcb_OutxCtsFlow or dcb_RtsControlHandshake;
end;
case FComportSwHandshaking of
shNONE : ;
shXONXOFF:
dcb.Flags := dcb.Flags or dcb_OutX or dcb_Inx;
end;
dcb.XonLim := FComportInputBufferSize div 4;
dcb.XoffLim := 1;
dcb.ByteSize := 5 + ord(FComportDataBits);
dcb.Parity := ord(FComportParity);
dcb.StopBits := ord(FComportStopBits);
dcb.XonChar := #17;
dcb.XoffChar := #19;
SetCommState(FComportHandle,dcb);
SetupComm(FComportHandle,FComPortInputBufferSize,FComPortOutputBufferSize);
end;
function TComportDriverThread.ReadString(var Str: string): Integer;
var
BytesTrans, nRead: DWORD;
Buffer : String;
i : Integer;
temp : string;
begin
BytesTrans := 0;
Str := '';
SetLength(Buffer,1);
ReadFile(FComportHandle,PChar(Buffer)^, 1, nRead, nil);
while nRead > 0 do
begin
temp := temp + PChar(Buffer);
ReadFile(FComportHandle,PChar(Buffer)^, 1, nRead, nil);
end;
//Remove the end token.
BytesTrans := Length(temp);
SetLength(str,BytesTrans-2);
for i:=0 to BytesTrans-2 do
begin
str[i] := temp[i];
end;
Result := BytesTrans;
end;
function TComportDriverThread.SendData(DataPtr: Pointer;
DataSize: Integer): Boolean;
var
nsent : DWORD;
begin
Result := WriteFile(FComportHandle,DataPtr^,DataSize,nsent,nil);
Result := Result and (nsent = DataSize);
end;
function TComportDriverThread.SendString(Input: String): Boolean;
begin
if not Connected then
if not Connect then
raise Exception.CreateHelp('Could not connect to COM-port !',101);
Result := SendData(PChar(Input),Length(Input));
if not Result then
raise Exception.CreateHelp('Could not send to COM-port !',102);
end;
procedure TComportDriverThread.TimerEvent;
var
InQueue, OutQueue: Integer;
Buffer : String;
nRead : DWORD;
procedure DataInBuffer(Handle: THandle; var aInQueue, aOutQueue: Integer);
var
ComStat : TComStat;
e : Cardinal;
begin
aInQueue := 0;
aOutQueue := 0;
if ClearCommError(Handle,e,@ComStat) then
begin
aInQueue := ComStat.cbInQue;
aOutQueue := ComStat.cbOutQue;
end;
end;
begin
if csDesigning in ComponentState then
Exit;
if not Connected then
if not Connect then
raise Exception.CreateHelp('TimerEvent: Could not connect to COM-port !',101);
Application.ProcessMessages;
if Connected then
begin
DataInBuffer(FComportHandle,InQueue,OutQueue);
if InQueue > 0 then
begin
if (Assigned(FOnReceiveData) ) then
begin
FReceiving := True;
FOnReceiveData(Self);
end;
end;
end;
end;
procedure TComportDriverThread.SetComportBaudRate(Value: TComPortBaudRate);
begin
FComportBaudRate := Value;
if Connected then
ApplyComPortSettings;
end;
procedure TComportDriverThread.SetComportDataBits(Value: TComPortDataBits);
begin
FComportDataBits := Value;
if Connected then
ApplyComPortSettings;
end;
procedure TComportDriverThread.SetComportHwHandshaking(Value: TComportHwHandshaking);
begin
FComportHwHandshaking := Value;
if Connected then
ApplyComPortSettings;
end;
procedure TComportDriverThread.SetComportInputBufferSize(Value: Word);
begin
FreeMem(FTempInputBuffer,FComportInputBufferSize);
FComportInputBufferSize := Value;
GetMem(FTempInputBuffer,FComportInputBufferSize);
if Connected then
ApplyComPortSettings;
end;
procedure TComportDriverThread.SetComportNumber(Value: TComPortNumber);
begin
if Connected then
exit;
FComportNumber := Value;
end;
procedure TComportDriverThread.SetComportOutputBufferSize(Value: Word);
begin
FComportOutputBufferSize := Value;
if Connected then
ApplyComPortSettings;
end;
procedure TComportDriverThread.SetComportParity(Value: TComPortParity);
begin
FComportParity := Value;
if Connected then
ApplyComPortSettings;
end;
procedure TComportDriverThread.SetComportPollingDelay(Value: Word);
begin
FComportPollingDelay := Value;
end;
procedure TComportDriverThread.SetComportStopBits(Value: TComPortStopBits);
begin
FComportStopBits := Value;
if Connected then
ApplyComPortSettings;
end;
procedure TComportDriverThread.SetComportSwHandshaking(Value: TComPortSwHandshaking);
begin
FComportSwHandshaking := Value;
if Connected then
ApplyComPortSettings;
end;
procedure TComportDriverThread.DoDataReceived;
begin
if Assigned(FOnReceiveData) then FOnReceiveData(Self);
end;
procedure TComportDriverThread.SetComPortActive(Value: Boolean);
var
DumpString : String;
begin
FComPortActive := Value;
if csDesigning in ComponentState then
Exit;
if FComPortActive then
begin
//Just dump the contents of the input buffer of the com-port.
ReadString(DumpString);
FTimer.Enabled := True;
end
else
FTimer.Enabled := False;
FTimer.SupRes;
end;
{ TTimerThread }
procedure TTimerThread.Execute;
begin
Priority := tpNormal;
repeat
Sleep(500);
if Assigned(FOnTimer) then Synchronize(FOnTimer);
until Terminated;
end;
procedure TTimerThread.SupRes;
begin
if not Suspended then
Suspend;
if FEnabled then
Resume;
end;
end.
Взято с Исходников.ru
procedure TCommPortDriver.SetActive(const Value: boolean);
begin
FActive := Value;
end;
end.
Взято с Исходников.ru
Компонент для работы с PCX файлами
Компонент для работы с PCX файлами
Fully supports reading and writing of: 1, 8 and 24 bit PCX images.
///////////////////////////////////////////////////////////////////////
////
// TPCXImage //
// ========= //
// //
// Completed: The 10th of August 2001 //
// Author: M. de Haan //
// Email: M.deHaan@inn.nl //
// Tested: under W95 SP1, NT4 SP6, WIN2000 //
// Version: 1.0 //
//-------------------------------------------------------------------//
// Update: The 14th of August 2001 to version 1.1. //
// Reason: Added version check. //
// Added comment info on version. //
// Changed PCX header ID check. //
//-------------------------------------------------------------------//
// Update: The 19th of August 2001 to version 2.0. //
// Reason: Warning from Delphi about using abstract methods, //
// caused by not implementing ALL TGraphic methods. //
// (Thanks goes to R.P. Sterkenburg for his diagnostic.) //
// Added: SaveToClipboardFormat, LoadFromClipboardFormat, //
// GetEmpty. //
//-------------------------------------------------------------------//
// Update: The 13th of October 2001 to version 2.1. //
// Reason: strange errors, read errors, EExternalException, IDE //
// hanging, Delphi hanging, Debugger hanging, windows //
// hanging, keyboard locked, and so on. //
// Changed: Assign procedure. //
//-------------------------------------------------------------------//
// Update: The 5th of April 2002 to version 2.2. //
// Changed: RLE compressor routine. //
// Reason: Incompatibility problems with other programs caused //
// by the RLE compressor. //
// Other programs encode: $C0 as: $C1 $C0. //
// ($C0 means: repeat the following byte 0 times //
// $C1 means: repeat the following byte 1 time.) //
// Changed: File read routine. //
// Reason: Now detects unsupported PCX data formats. //
// Added: 'Unsupported data format' in exception handler. //
// Added: 1 bit PCX support in reading. //
// Added: Procedure Convert1BitPCXDataToImage. //
// Renamed: Procedure ConvertPCXDataToImage to //
// Convert24BitPCXDataToImage. //
//-------------------------------------------------------------------//
// Update: The 14th of April 2002 to version 2.3. //
// Now capable of reading and writing 1 and 24 bit PCX //
// images. //
// Added: 1 bit PCX support in writing. //
// Added: Procedure ConvertImageTo1bitPCXData. //
// Changed: Procedure CreatePCXHeader. //
// Changed: Procedure TPCXImage.SaveToFile. //
//-------------------------------------------------------------------//
// Update: The 19th of April 2002 to version 2.4. //
// Now capable of reading and writing: 1, 8 and 24 bit //
// PCX images. //
// Added: 8 bit PCX support in reading and writing. //
// Renamed: Procedure ConvertImageTo1And8bitPCXData. //
// Renamed: Procedure Convert1And8bitPCXDataToImage. //
// Changed: Procedure fSetPalette, fGetPalette. //
//-------------------------------------------------------------------//
// Update: The 7th of May 2002 to version 2.5. //
// Reason: The palette of 8-bit PCX images couldn't be read in //
// the calling program. //
// Changed: Procedures Assign, AssignTo, fSetPalette, fGetPalette. //
// Tested: All formats were tested with the following programs: //
// - import in Word 97, //
// * (Word ignores the palette of 1 bit PCX images!) //
// - import and export in MigroGrafX. //
// * (MicroGrafX also ignores the palette of 1 bit PCX //
// images.) //
// No problems were detected. //
// //
//===================================================================//
// //
// The PCX image file format is copyrighted by: //
// ZSoft, PC Paintbrush, PC Paintbrush plus //
// Trademarks: N/A //
// Royalty fees: NONE //
// //
//===================================================================//
// //
// The author can not be held responsable for using this software //
// in anyway. //
// //
// The features and restrictions of this component are: //
// ---------------------------------------------------- //
// //
// The reading and writing (import / export) of files / images: //
// - PCX version 5 definition, PC Paintbrush 3 and higher, //
// - RLE-compressed, //
// - 1 and 8 bit PCX images WITH palette and //
// - 24 bit PCX images without palette, //
// are supported by this component. //
// //
// Known issues //
// ------------ //
// //
// 1) GetEmpty is NOT tested. //
// //
// 2) SaveToClipboardFormat is NOT tested. //
// //
// 3) LoadFromClipboardFormat is NOT tested. //
// //
// 4) 4 bit PCX images (with palette) are NOT (yet) implemented. //
// (I have no 4-bit PCX images to test it on...) //
// //
///////////////////////////////////////////////////////////////////////
unit
PCXImage;
interface
uses
Windows,
SysUtils,
Classes,
Graphics;
const
WIDTH_OUT_OF_RANGE = 'Illegal width entry in PCX file header';
HEIGHT_OUT_OF_RANGE = 'Illegal height entry in PCX file header';
FILE_FORMAT_ERROR = 'Invalid file format';
VERSION_ERROR = 'Only PC Paintbrush (plus) V3.0 and ' +
'higher are supported';
FORMAT_ERROR = 'Illegal identification byte in PCX file' +
' header';
PALETTE_ERROR = 'Invalid palette signature found';
ASSIGN_ERROR = 'Can only Assign a TBitmap or a TPicture';
ASSIGNTO_ERROR = 'Can only AssignTo a TBitmap';
PCXIMAGE_EMPTY = 'The PCX image is empty';
BITMAP_EMPTY = 'The bitmap is empty';
INPUT_FILE_TOO_LARGE = 'The input file is too large to be read';
IMAGE_WIDTH_TOO_LARGE = 'Width of PCX image is too large to handle';
// added 19/08/2001
CLIPBOARD_LOAD_ERROR = 'Loading from clipboard failed';
// added 19/08/2001
CLIPBOARD_SAVE_ERROR = 'Saving to clipboard failed';
// added 14/10/2001
PCX_WIDTH_ERROR = 'Unexpected line length in PCX data';
PCX_HEIGHT_ERROR = 'More PCX data found than expected';
PCXIMAGE_TOO_LARGE = 'PCX image is too large';
// added 5/4/2002
ERROR_UNSUPPORTED = 'Unsupported PCX format';
const
sPCXImageFile = 'PCX V3.0+ image';
// added 19/08/2001
var
CF_PCX: WORD;
///////////////////////////////////////////////////////////////////////
// //
// PCXHeader //
// //
///////////////////////////////////////////////////////////////////////
type
QWORD = Cardinal; // Seems more logical to me...
type
fColorEntry = packed record
ceRed: BYTE;
ceGreen: BYTE;
ceBlue: BYTE;
end; // of packed record fColorEntry
type
TPCXImageHeader = packed record
fID: BYTE;
fVersion: BYTE;
fCompressed: BYTE;
fBitsPerPixel: BYTE;
fWindow: packed record
wLeft,
wTop,
wRight,
wBottom: WORD;
end; // of packed record fWindow
fHorzResolution: WORD;
fVertResolution: WORD;
fColorMap: array[0..15] of fColorEntry;
fReserved: BYTE;
fPlanes: BYTE;
fBytesPerLine: WORD;
fPaletteInfo: WORD;
fFiller: array[0..57] of BYTE;
end; // of packed record TPCXImageHeader
///////////////////////////////////////////////////////////////////////
// //
// PCXData //
// //
///////////////////////////////////////////////////////////////////////
type
TPCXData = object
fData: array of BYTE;
end; // of Type TPCXData
///////////////////////////////////////////////////////////////////////
// //
// ScanLine //
// //
///////////////////////////////////////////////////////////////////////
const
fMaxScanLineLength = $FFF; // Max image width: 4096 pixels
type
mByteArray = array[0..fMaxScanLineLength] of BYTE;
pmByteArray = ^mByteArray;
// The "standard" pByteArray from Delphi allocates 32768 bytes,
// which is a little bit overdone here, I think...
const
fMaxImageWidth = $FFF; // Max image width: 4096 pixels
type
xByteArray = array[0..fMaxImageWidth] of BYTE;
///////////////////////////////////////////////////////////////////////
// //
// PCXPalette //
// //
///////////////////////////////////////////////////////////////////////
type
TPCXPalette = packed record
fSignature: BYTE;
fPalette: array[0..255] of fColorEntry;
end; // of packed record TPCXPalette
///////////////////////////////////////////////////////////////////////
// //
// Classes //
// //
///////////////////////////////////////////////////////////////////////
type
TPCXImage = class;
TPCXFile = class;
///////////////////////////////////////////////////////////////////////
// //
// PCXFile //
// //
// File handler //
// //
///////////////////////////////////////////////////////////////////////
TPCXFile = class(TPersistent)
private
fHeight: Integer;
fWidth: Integer;
fPCXHeader: TPCXImageHeader;
fPCXData: TPCXData;
fPCXPalette: TPCXPalette;
fColorDepth: QWORD;
fPixelFormat: BYTE; // added 5/4/2002
fCurrentPos: QWORD;
fHasPalette: Boolean; // added 7/5/2002
protected
// Protected declarations
public
// Public declarations
constructor Create;
destructor Destroy; override;
procedure LoadFromFile(const Filename: string);
procedure LoadFromStream(Stream: TStream);
procedure SaveToFile(const Filename: string);
procedure SaveToStream(Stream: TStream);
published
// Published declarations
// The publishing is done in the TPCXImage section
end;
///////////////////////////////////////////////////////////////////////
// //
// TPCXImage //
// //
// Image handler //
// //
///////////////////////////////////////////////////////////////////////
TPCXImage = class(TGraphic)
private
// Private declarations
fBitmap: TBitmap;
fPCXFile: TPCXFile;
fRLine: xByteArray;
fGLine: xByteArray;
fBLine: xByteArray;
fP: pmByteArray;
fhPAL: HPALETTE;
procedure fConvert24BitPCXDataToImage;
procedure fConvert1And8BitPCXDataToImage;
procedure fConvertImageTo24BitPCXData;
procedure fConvertImageTo1And8BitPCXData(ImageWidthInBytes:
QWORD);
procedure fFillDataLines(const fLine: array of BYTE);
procedure fCreatePCXHeader(const byBitsPerPixel: BYTE;
const byPlanes: BYTE; const wBytesPerLine: DWORD);
procedure fSetPalette(const wNumColors: WORD);
procedure fGetPalette(const wNumColors: WORD);
function fGetPixelFormat: TPixelFormat; // Added 07/05/2002
function fGetBitmap: TBitmap; // Added 07/05/2002
protected
// Protected declarations
procedure Draw(ACanvas: TCanvas; const Rect: TRect); override;
function GetHeight: Integer; override;
function GetWidth: Integer; override;
procedure SetHeight(Value: Integer); override;
procedure SetWidth(Value: Integer); override;
function GetEmpty: Boolean; override;
public
// Public declarations
constructor Create; override;
destructor Destroy; override;
procedure Assign(Source: TPersistent); override;
procedure AssignTo(Dest: TPersistent); override;
procedure LoadFromFile(const Filename: string); override;
procedure LoadFromStream(Stream: TStream); override;
procedure SaveToFile(const Filename: string); override;
procedure SaveToStream(Stream: TStream); override;
procedure LoadFromClipboardFormat(AFormat: WORD;
AData: THandle; APalette: HPALETTE); override;
procedure SaveToClipboardFormat(var AFormat: WORD;
var AData: THandle; var APalette: HPALETTE); override;
published
// Published declarations
property Height: Integer
read GetHeight write SetHeight;
property Width: Integer
read GetWidth write SetWidth;
property PixelFormat: TPixelFormat
read fGetPixelFormat;
property Bitmap: TBitmap
read fGetBitmap; // Added 7/5/2002
end;
implementation
///////////////////////////////////////////////////////////////////////
// //
// TPCXImage //
// //
// Image handler //
// //
///////////////////////////////////////////////////////////////////////
constructor TPCXImage.Create;
begin
inherited Create;
// Init HPALETTE
fhPAL := 0;
// Create a private bitmap to hold the image
if not Assigned(fBitmap) then
fBitmap := TBitmap.Create;
// Create the PCXFile
if not Assigned(fPCXFile) then
fPCXFile := TPCXFile.Create;
end;
//---------------------------------------------------------------------
destructor TPCXImage.Destroy;
begin
// Reversed order of create
// Free fPCXFile
fPCXFile.Free;
// Free private bitmap
fBitmap.Free;
// Delete palette
if fhPAL <> 0 then
DeleteObject(fhPAL);
// Distroy all the other things
inherited Destroy;
end;
//---------------------------------------------------------------------
procedure TPCXImage.SetHeight(Value: Integer);
begin
if Value >= 0 then
fBitmap.Height := Value;
end;
//---------------------------------------------------------------------
procedure TPCXImage.SetWidth(Value: Integer);
begin
if Value >= 0 then
fBitmap.Width := Value;
end;
//---------------------------------------------------------------------
function TPCXImage.GetHeight: Integer;
begin
Result := fPCXFile.fHeight;
end;
//---------------------------------------------------------------------
function TPCXImage.GetWidth: Integer;
begin
Result := fPCXFile.fWidth;
end;
//---------------------------------------------------------------------
function TPCXImage.fGetBitmap: TBitmap;
begin
Result := fBitmap;
end;
//-------------------------------------------------------------------//
// The credits for this procedure go to his work of TGIFImage by //
// Reinier P. Sterkenburg //
// Added 19/08/2001 //
//-------------------------------------------------------------------//
// NOT TESTED!
procedure TPCXImage.LoadFromClipboardFormat(AFormat: WORD;
ADAta: THandle; APalette: HPALETTE);
var
Size: QWORD;
Buf: Pointer;
Stream: TMemoryStream;
BMP: TBitmap;
begin
if (AData = 0) then
AData := GetClipBoardData(AFormat);
if (AData <> 0) and (AFormat = CF_PCX) then
begin
Size := GlobalSize(AData);
Buf := GlobalLock(AData);
try
Stream := TMemoryStream.Create;
try
Stream.SetSize(Size);
Move(Buf^, Stream.Memory^, Size);
Self.LoadFromStream(Stream);
finally
Stream.Free;
end;
finally
GlobalUnlock(AData);
end;
end
else if (AData <> 0) and (AFormat = CF_BITMAP) then
begin
BMP := TBitmap.Create;
try
BMP.LoadFromClipboardFormat(AFormat, AData, APalette);
Self.Assign(BMP);
finally
BMP.Free;
end;
end
else
raise Exception.Create(CLIPBOARD_LOAD_ERROR);
end;
//-------------------------------------------------------------------//
// The credits for this procedure go to his work of TGIFImage by //
// Reinier P. Sterkenburg //
// Added 19/08/2001 //
//-------------------------------------------------------------------//
// NOT TESTED!
procedure TPCXImage.SaveToClipboardFormat(var AFormat: WORD;
var AData: THandle; var APalette: HPALETTE);
var
Stream: TMemoryStream;
Data: THandle;
Buf: Pointer;
begin
if Empty then
Exit;
// First store the bitmap to the clipboard
fBitmap.SaveToClipboardFormat(AFormat, AData, APalette);
// Then try to save the PCX
Stream := TMemoryStream.Create;
try
SaveToStream(Stream);
Stream.Position := 0;
Data := GlobalAlloc(HeapAllocFlags, Stream.Size);
try
if Data <> 0 then
begin
Buf := GlobalLock(Data);
try
Move(Stream.Memory^, Buf^, Stream.Size);
finally
GlobalUnlock(Data);
end;
if SetClipBoardData(CF_PCX, Data) = 0 then
raise Exception.Create(CLIPBOARD_SAVE_ERROR);
end;
except
GlobalFree(Data);
raise;
end;
finally
Stream.Free;
end;
end;
//-------------------------------------------------------------------//
// NOT TESTED!
function TPCXImage.GetEmpty: Boolean; // Added 19/08/2002
begin
if Assigned(fBitmap) then
Result := fBitmap.Empty
else
Result := (fPCXFile.fHeight = 0) or (fPCXFile.fWidth = 0);
end;
//---------------------------------------------------------------------
procedure TPCXImage.SaveToFile(const Filename: string);
var
fPCX: TFileStream;
W, WW: QWORD;
begin
if (fBitmap.Width = 0) or (fBitmap.Height = 0) then
raise Exception.Create(BITMAP_EMPTY);
W := fBitmap.Width;
WW := W div 8;
if (W mod 8) > 0 then
Inc(WW);
case fBitmap.PixelFormat of
pf1bit:
begin
// Fully supported by PCX and by this component
fCreatePCXHeader(1, 1, WW);
fConvertImageTo1And8BitPCXData(WW);
fGetPalette(2);
end;
pf4bit:
begin
// I don't have 4-bit PCX images to test with
// It will be treated as a 24 bit image
fCreatePCXHeader(8, 3, W);
fConvertImageTo24BitPCXData;
end;
pf8bit:
begin
// Fully supported by PCX and by this component
fCreatePCXHeader(8, 1, W);
fConvertImageTo1And8BitPCXData(W);
fGetPalette(256);
end;
pf15bit:
begin
// Is this supported in PCX?
// It will be treated as a 24 bit image
fCreatePCXHeader(8, 3, W);
fConvertImageTo24BitPCXData;
end;
pf16bit:
begin
// Is this supported in PCX?
// It will be treated as a 24 bit image
fCreatePCXHeader(8, 3, W);
fConvertImageTo24BitPCXData;
end;
pf24bit:
begin
// Fully supported by PCX and by this component
fCreatePCXHeader(8, 3, W);
fConvertImageTo24BitPCXData;
end;
pf32bit:
begin
// Not supported by PCX
fCreatePCXHeader(8, 3, W);
fConvertImageTo24BitPCXData;
end;
else
begin
fCreatePCXHeader(8, 3, W);
fConvertImageTo24BitPCXData;
end; // of else
end; // of Case
fPCX := TFileStream.Create(Filename, fmCreate);
try
fPCX.Position := 0;
SaveToStream(fPCX);
finally
fPCX.Free;
end; // of finally
SetLength(fPCXFile.fPCXData.fData, 0);
end; // of Procedure SaveToFile
//-------------------------------------------------------------------//
procedure TPCXImage.AssignTo(Dest: TPersistent);
var
bAssignToError: Boolean;
begin
bAssignToError := True;
if Dest is TBitmap then
begin
// The old AssignTo procedure was like this.
// But then the palette was couldn't be accessed in the calling
// program for some reason.
// --------------------------
// (Dest as TBitmap).Assign(fBitmap);
// If fBitmap.Palette <> 0 then
// (Dest as TBitmap).Palette := CopyPalette(fBitmap.Palette);
// --------------------------
// Do the assigning
(Dest as TBitmap).Assign(fBitmap);
if fPCXFile.fHasPalette then
(Dest as TBitmap).Palette := CopyPalette(fhPAL);
// Now the calling program can access the palette
// (if it has one)!
bAssignToError := False;
end;
if Dest is TPicture then
begin
(Dest as TPicture).Graphic.Assign(fBitmap);
bAssignToError := False;
end;
if bAssignToError then
raise Exception.Create(ASSIGNTO_ERROR);
// You can write other assignments here, if you want...
end;
//-------------------------------------------------------------------//
procedure TPCXImage.Assign(Source: TPersistent);
var
iX, iY: DWORD;
bAssignError: Boolean;
begin
bAssignError := True;
if (Source is TBitmap) then
begin
fBitmap.Assign(Source as TBitmap);
if (Source as TBitmap).Palette <> 0 then
begin
fhPAL := CopyPalette((Source as TBitmap).Palette);
fBitmap.Palette := fhPAL;
end;
bAssignError := False;
end;
if (Source is TPicture) then
begin
iX := (Source as TPicture).Width;
iY := (Source as TPicture).Height;
fBitmap.Width := iX;
fBitmap.Height := iY;
fBitmap.Canvas.Draw(0, 0, (Source as TPicture).Graphic);
bAssignError := False;
end;
// You can write other assignments here, if you want...
if bAssignError then
raise Exception.Create(ASSIGN_ERROR);
end;
//---------------------------------------------------------------------
procedure TPCXImage.Draw(ACanvas: TCanvas; const Rect: TRect);
begin
// Faster
// ACanvas.Draw(0,0,fBitmap);
// Slower
ACanvas.StretchDraw(Rect, fBitmap);
end;
//---------------------------------------------------------------------
procedure TPCXImage.LoadFromFile(const Filename: string);
begin
fPCXFile.LoadFromFile(Filename);
// added 5/4/2002
case fPCXFile.fPixelFormat of
1: fConvert1And8BitPCXDataToImage;
8: fConvert1And8BitPCXDataToImage;
24: fConvert24BitPCXDataToImage;
end;
end;
//---------------------------------------------------------------------
procedure TPCXImage.SaveToStream(Stream: TStream);
begin
fPCXFile.SaveToStream(Stream);
end;
//---------------------------------------------------------------------
procedure TPCXImage.LoadFromStream(Stream: TStream);
begin
fPCXFile.LoadFromStream(Stream);
end;
///////////////////////////////////////////////////////////////////////
// //
// Called by RLE compressor //
// //
///////////////////////////////////////////////////////////////////////
procedure TPCXImage.fFillDataLines(const fLine: array of BYTE);
var
By: BYTE;
Cnt: WORD;
I: QWORD;
W: QWORD;
begin
I := 0;
By := fLine[0];
Cnt := $C1;
W := fBitmap.Width;
repeat
Inc(I);
if By = fLine[I] then
begin
Inc(Cnt);
if Cnt = $100 then
begin
fPCXFile.fPCXData.fData[fPCXFile.fCurrentPos] :=
BYTE(Pred(Cnt));
Inc(fPCXFile.fCurrentPos);
fPCXFile.fPCXData.fData[fPCXFile.fCurrentPos] := By;
Inc(fPCXFile.fCurrentPos);
Cnt := $C1;
By := fLine[I];
end;
end;
if (By <> fLine[I]) then
begin
if (Cnt = $C1) then
begin
// If (By < $C1) then
if (By < $C0) then // changed 5/4/2002
begin
fPCXFile.fPCXData.fData[fPCXFile.fCurrentPos] := By;
Inc(fPCXFile.fCurrentPos);
end
else
begin
fPCXFile.fPCXData.fData[fPCXFile.fCurrentPos] := BYTE(Cnt);
Inc(fPCXFile.fCurrentPos);
fPCXFile.fPCXData.fData[fPCXFile.fCurrentPos] := By;
Inc(fPCXFile.fCurrentPos);
end;
end
else
begin
fPCXFile.fPCXData.fData[fPCXFile.fCurrentPos] := BYTE(Cnt);
Inc(fPCXFile.fCurrentPos);
fPCXFile.fPCXData.fData[fPCXFile.fCurrentPos] := By;
Inc(fPCXFile.fCurrentPos);
end;
Cnt := $C1;
By := fLine[I];
end;
until I = W - 1;
// Write the last byte(s)
if (Cnt > $C1) then
begin
fPCXFile.fPCXData.fData[fPCXFile.fCurrentPos] := BYTE(Cnt);
Inc(fPCXFile.fCurrentPos);
end;
if (Cnt = $C1) and (By > $C0) then
begin
fPCXFile.fPCXData.fData[fPCXFile.fCurrentPos] := BYTE(Cnt);
Inc(fPCXFile.fCurrentPos);
end;
fPCXFile.fPCXData.fData[fPCXFile.fCurrentPos] := By;
Inc(fPCXFile.fCurrentPos);
end;
//-------------------------------------------------------------------//
// RLE Compression algorithm //
//-------------------------------------------------------------------//
procedure TPCXImage.fConvertImageTo24BitPCXData; // Renamed 5/4/2002
var
H, W: QWORD;
X, Y: QWORD;
I: QWORD;
begin
H := fBitmap.Height;
W := fBitmap.Width;
fPCXFile.fCurrentPos := 0;
SetLength(fPCXFile.fPCXData.fData, 6 * H * W); // To be sure...
fBitmap.PixelFormat := pf24bit; // Always do this if you're using
// ScanLine!
for Y := 0 to H - 1 do
begin
fP := fBitmap.ScanLine[Y];
I := 0;
for X := 0 to W - 1 do
begin
fRLine[X] := fP[I];
Inc(I); // Extract a red line
fGLine[X] := fP[I];
Inc(I); // Extract a green line
fBLine[X] := fP[I];
Inc(I); // Extract a blue line
end;
fFillDataLines(fBLine); // Compress the blue line
fFillDataLines(fGLine); // Compress the green line
fFillDataLines(fRLine); // Compress the red line
end;
// Correct the length of fPCXData.fData
SetLength(fPCXFile.fPCXData.fData, fPCXFile.fCurrentPos);
end;
//-------------------------------------------------------------------//
procedure TPCXImage.fConvertImageTo1And8BitPCXData(ImageWidthInBytes:
QWORD);
var
H, W, X, Y: QWORD;
oldByte, newByte: BYTE;
Cnt: BYTE;
begin
H := fBitmap.Height;
W := ImageWidthInBytes;
fPCXFile.fCurrentPos := 0;
SetLength(fPCXFile.fPCXData.fData, 2 * H * W); // To be sure...
oldByte := 0; // Otherwise the compiler issues a warning about
// oldByte not being initialized...
Cnt := $C1;
for Y := 0 to H - 1 do
begin
fP := fBitmap.ScanLine[Y];
for X := 0 to W - 1 do
begin
newByte := fP[X];
if X > 0 then
begin
if (Cnt = $FF) then
begin
fPCXFile.fPCXData.fData[fPCXFile.fCurrentPos] := Cnt;
Inc(fPCXFile.fCurrentPos);
fPCXFile.fPCXData.fData[fPCXFile.fCurrentPos] := oldByte;
Inc(fPCXFile.fCurrentPos);
Cnt := $C1;
end
else if newByte = oldByte then
Inc(Cnt);
if newByte <> oldByte then
begin
if (Cnt > $C1) or (oldByte >= $C0) then
begin
fPCXFile.fPCXData.fData[fPCXFile.fCurrentPos] := Cnt;
Inc(fPCXFile.fCurrentPos);
Cnt := $C1;
end;
fPCXFile.fPCXData.fData[fPCXFile.fCurrentPos] := oldByte;
Inc(fPCXFile.fCurrentPos);
end;
end;
oldByte := newByte;
end;
// Write last byte of line
if (Cnt > $C1) or (oldByte >= $C0) then
begin
fPCXFile.fPCXData.fData[fPCXFile.fCurrentPos] := Cnt;
Inc(fPCXFile.fCurrentPos);
Cnt := $C1;
end;
fPCXFile.fPCXData.fData[fPCXFile.fCurrentPos] := oldByte;
Inc(fPCXFile.fCurrentPos);
end;
// Write last byte of image
if (Cnt > $C1) or (oldByte >= $C0) then
begin
fPCXFile.fPCXData.fData[fPCXFile.fCurrentPos] := Cnt;
Inc(fPCXFile.fCurrentPos);
// Cnt := 1;
end;
fPCXFile.fPCXData.fData[fPCXFile.fCurrentPos] := oldByte;
Inc(fPCXFile.fCurrentPos);
// Correct the length of fPCXData.fData
SetLength(fPCXFile.fPCXData.fData, fPCXFile.fCurrentPos);
end;
//-------------------------------------------------------------------//
// RLE Decompression algorithm //
//-------------------------------------------------------------------//
procedure TPCXImage.fConvert24BitPCXDataToImage; // Renamed 5/4/2002
var
I: QWORD;
By: BYTE;
Cnt: BYTE;
H, W: QWORD;
X, Y: QWORD;
K, L: QWORD;
begin
H := fPCXFile.fPCXHeader.fWindow.wBottom -
fPCXFile.fPCXHeader.fWindow.wTop + 1;
W := fPCXFile.fPCXHeader.fWindow.wRight -
fPCXFile.fPCXHeader.fWindow.wLeft + 1;
Y := 0; // First line of image
fBitmap.Width := W; // Set bitmap width
fBitmap.Height := H; // Set bitmap height
fBitmap.PixelFormat := pf24bit; // Always do this if you're using
// ScanLine!
I := 0; // Pointer to data byte of fPXCFile
repeat
// Process the red line
// ProcessLine(fRLine,W);
X := 0; // Pointer to position in Red / Green / Blue line
repeat
By := fPCXFile.fPCXData.fData[I];
Inc(I);
// one byte
if By < $C1 then
if X <= W then // added 5/4/2002
begin
fRLine[X] := By;
Inc(X);
end;
// multiple bytes (RLE)
if By > $C0 then
begin
Cnt := By and $3F;
By := fPCXFile.fPCXData.fData[I];
Inc(I);
//FillChar(fRLine[J],Cnt,By);
//Inc(J,Cnt);
for K := 1 to Cnt do
if X <= W then // added 5/4/2002
begin
fRLine[X] := By;
Inc(X);
end;
end;
until X >= W;
// Process the green line
// ProcessLine(fGLine,W);
X := 0;
repeat
By := fPCXFile.fPCXData.fData[I];
Inc(I);
// one byte
if By < $C1 then
if X <= W then // added 5/4/2002
begin
fGLine[X] := By;
Inc(X);
end;
// multiple bytes (RLE)
if By > $C0 then
begin
Cnt := By and $3F;
By := fPCXFile.fPCXData.fData[I];
Inc(I);
for K := 1 to Cnt do
if X <= W then // added 5/4/2002
begin
fGLine[X] := By;
Inc(X);
end;
end;
until X >= W;
// Process the blue line
// ProcessLine(fBLine,W);
X := 0;
repeat
By := fPCXFile.fPCXData.fData[I];
Inc(I);
// one byte
if By < $C1 then
if X <= W then // added 5/4/2002
begin
fBLine[X] := By;
Inc(X);
end;
// multiple bytes (RLE)
if By > $C0 then
begin
Cnt := By and $3F;
By := fPCXFile.fPCXData.fData[I];
Inc(I);
for K := 1 to Cnt do
if X <= W then // added 5/4/2002
begin
fBLine[X] := By;
Inc(X);
end;
end;
until X >= W;
// Write the just processed data RGB lines to the bitmap
fP := fBitmap.ScanLine[Y];
L := 0;
for X := 0 to W - 1 do
begin
fP[L] := fBLine[X];
Inc(L);
fP[L] := fGLine[X];
Inc(L);
fP[L] := fRLine[X];
Inc(L);
end;
Inc(Y); // Process the next RGB line
until Y >= H;
SetLength(fPCXFile.fPCXData.fData, 0);
end;
//-------------------------------------------------------------------//
procedure TPCXImage.fConvert1And8BitPCXDataToImage; // added 5/4/2002
var
I, J: QWORD;
By: BYTE;
Cnt: BYTE;
H, W, WW: QWORD;
X, Y: QWORD;
begin
H := fPCXFile.fPCXHeader.fWindow.wBottom -
fPCXFile.fPCXHeader.fWindow.wTop + 1;
W := fPCXFile.fPCXHeader.fWindow.wRight -
fPCXFile.fPCXHeader.fWindow.wLeft + 1;
fBitmap.Width := W; // Set bitmap width
fBitmap.Height := H; // Set bitmap height
WW := W;
// 1 bit PCX
if fPCXFile.fPixelFormat = 1 then
begin
// All 1 bit images have a palette
fBitmap.PixelFormat := pf1bit; // Always do this if you're using
// ScanLine!
WW := W div 8; // Correct width for pf1bit
if W mod 8 > 0 then
begin
Inc(WW);
fBitMap.Width := WW * 8;
end;
fSetPalette(2);
end;
// 8 bit PCX
if fPCXFile.fPixelFormat = 8 then
begin
// All 8 bit images have a palette!
// This is how to set the palette of a bitmap
// 1. First set the bitmap to pf8bit;
// 2. then set the palette of the bitmap;
// 3. then set the pixels with ScanLine or with Draw.
// If you do it with StretchDraw, it won't work. Don't ask me why.
// If you don't do it in this order, it won't work either! You'll
// get strange colors.
fBitmap.PixelFormat := pf8bit; // Always do this if you're using
// ScanLine!
fSetPalette(256);
end;
I := 0;
Y := 0;
repeat
fP := fBitmap.ScanLine[Y];
X := 0; // Pointer to position in line
repeat
By := fPCXFile.fPCXData.fData[I];
Inc(I);
// one byte
if By < $C1 then
if X <= WW then
begin
fP[X] := By;
Inc(X);
end;
// multiple bytes (RLE)
if By > $C0 then
begin
Cnt := By and $3F;
By := fPCXFile.fPCXData.fData[I];
Inc(I);
for J := 1 to Cnt do
if X <= WW then
begin
fP[X] := By;
Inc(X);
end;
end;
until X >= WW;
Inc(Y); // Next line
until Y >= H;
end;
//---------------------------------------------------------------------
procedure TPCXImage.fCreatePCXHeader(const byBitsPerPixel: BYTE;
const byPlanes: BYTE; const wBytesPerLine: DWORD);
var
H, W: WORD;
begin
W := fBitmap.Width;
H := fBitmap.Height;
// PCX header
fPCXFile.fPCXHeader.fID := BYTE($0A); // BYTE (1)
fPCXFile.fPCXHeader.fVersion := BYTE(5); // BYTE (2)
fPCXFile.fPCXHeader.fCompressed := BYTE(1); // BYTE (3)
// 0 = uncompressed, 1 = compressed
// Only RLE compressed files are supported by this component
fPCXFile.fPCXHeader.fBitsPerPixel := BYTE(byBitsPerPixel);
// BYTE (4)
fPCXFile.fPCXHeader.fWindow.wLeft := WORD(0); // WORD (5,6)
fPCXFile.fPCXHeader.fWindow.wTop := WORD(0); // WORD (7,8)
fPCXFile.fPCXHeader.fWindow.wRight := WORD(W - 1); // WORD (9,10)
fPCXFile.fPCXHeader.fWindow.wBottom := WORD(H - 1); // WORD (11,12)
fPCXFile.fPCXHeader.fHorzResolution := WORD(72); // WORD (13,14)
fPCXFile.fPCXHeader.fVertResolution := WORD(72); // WORD (15,16)
FillChar(fPCXFile.fPCXHeader.fColorMap, 48, 0); // Array of Byte
// (17..64)
fPCXFile.fPCXHeader.fReserved := BYTE(0); // BYTE (65)
fPCXFile.fPCXHeader.fPlanes := BYTE(byPlanes);
// BYTE (66)
fPCXFile.fPCXHeader.fBytesPerLine := WORD(wBytesPerLine);
// WORD (67,68)
// must be even
// rounded above
fPCXFile.fPCXHeader.fPaletteInfo := WORD(1); // WORD (69,70)
FillChar(fPCXFile.fPCXHeader.fFiller, 58, 0); // Array of Byte
// (71..128)
fPCXFile.fPixelFormat := fPCXFile.fPCXHeader.fPlanes *
fPCXFile.fPCXHeader.fBitsPerPixel;
fPCXFile.fColorDepth := 1 shl fPCXFile.fPixelFormat;
end;
//---------------------------------------------------------------------
(*
// From Delphi 5.0, graphics.pas
Function CopyPalette(Palette: HPALETTE): HPALETTE;
Var
PaletteSize : Integer;
LogPal : TMaxLogPalette;
Begin
Result := 0;
If Palette = 0 then
Exit;
PaletteSize := 0;
If GetObject(Palette,SizeOf(PaletteSize),@PaletteSize) = 0 then
Exit;
If PaletteSize = 0 then
Exit;
With LogPal do
Begin
palVersion := $0300;
palNumEntries := PaletteSize;
GetPaletteEntries(Palette,0,PaletteSize,palPalEntry);
End;
Result := CreatePalette(PLogPalette(@LogPal)^);
End;
*)
//---------------------------------------------------------------------
// From Delphi 5.0, graphics.pas
(*
Procedure TPCXImage.fSetPixelFormat(Value : TPixelFormat);
Const
BitCounts : Array [pf1Bit..pf32Bit] of BYTE = (1,4,8,16,16,24,32);
Var
DIB : TDIBSection;
Pal : HPALETTE;
DC : hDC;
KillPal : Boolean;
Begin
If Value = GetPixelFormat then
Exit;
Case Value of
pfDevice : Begin
HandleType := bmDDB;
Exit;
End;
pfCustom : InvalidGraphic(@SInvalidPixelFormat);
else
FillChar(DIB,sizeof(DIB), 0);
DIB.dsbm := FImage.FDIB.dsbm;
KillPal := False;
With DIB, dsbm,dsbmih do
Begin
bmBits := nil;
biSize := SizeOf(DIB.dsbmih);
biWidth := bmWidth;
biHeight := bmHeight;
biPlanes := 1;
biBitCount := BitCounts[Value];
Pal := FImage.FPalette;
Case Value of
pf4Bit : Pal := SystemPalette16;
pf8Bit : Begin
DC := GDICheck(GetDC(0));
Pal := CreateHalftonePalette(DC);
KillPal := True;
ReleaseDC(0, DC);
End;
pf16Bit : Begin
biCompression := BI_BITFIELDS;
dsBitFields[0] := $F800;
dsBitFields[1] := $07E0;
dsBitFields[2] := $001F;
End;
End; // of Case
Try
CopyImage(Handle, Pal, DIB);
PaletteModified := (Pal <> 0);
Finally
if KillPal then
DeleteObject(Pal);
End; // of Try
Changed(Self);
End; // of With
End; // of Case
End; // of Procedure
*)
//---------------------------------------------------------------------
procedure TPCXImage.fSetPalette(const wNumColors: WORD);
(* From Delphi 5.0, graphics.pas
Type
TPalEntry = packed record
peRed : BYTE;
peGreen : BYTE;
peBlue : BYTE;
End;
Type
tagLOGPALETTE = packed record
palVersion : WORD;
palNumEntries : WORD;
palPalEntry : Array[0..255] of TPalEntry
End;
Type
TMAXLogPalette = tagLOGPALETTE;
PMAXLogPalette = ^TMAXLogPalette;
Type
PRGBQuadArray = ^TRGBQuadArray;
TRGBQuadArray = Array[BYTE] of TRGBQuad;
Type
PRGBQuadArray = ^TRGBQuadArray;
TRGBQuadArray = Array[BYTE] of TRGBQuad;
*)
var
pal: TMaxLogPalette;
W: WORD;
begin
pal.palVersion := $300; // The "Magic" number
pal.palNumEntries := wNumColors;
for W := 0 to 255 do
begin
pal.palPalEntry[W].peRed :=
fPCXFile.fPCXPalette.fPalette[W].ceRed;
pal.palPalEntry[W].peGreen :=
fPCXFile.fPCXPalette.fPalette[W].ceGreen;
pal.palPalEntry[W].peBlue :=
fPCXFile.fPCXPalette.fPalette[W].ceBlue;
pal.palPalEntry[W].peFlags := 0;
end;
(* Must we delete the old palette first here? I dont know.
If fhPAL <> 0 then
DeleteObject(fhPAL);
*)
fhPAL := CreatePalette(PLogPalette(@pal)^);
if fhPAL <> 0 then
fBitmap.Palette := fhPAL;
end;
//---------------------------------------------------------------------
function TPCXImage.fGetPixelFormat: TPixelFormat;
// Only pf1bit, pf4bit and pf8bit images have a palette.
// pf15bit, pf16bit, pf24bit and pf32bit images have no palette.
// You can change the palette of pf1bit images in windows.
// The foreground color and the background color of pf1bit images
// do not have to be black and white. You can choose any tow colors.
// The palette of pf4bit images is fixed.
// The palette entries 0..9 and 240..255 of pf8bit images are reserved
// in windows.
begin
Result := pfDevice;
case fPCXFile.fPixelFormat of
01: Result := pf1bit; // Implemented WITH palette.
// 04 : Result := pf4bit; // Not yet implemented in this component,
// is however implemented in PCX format.
08: Result := pf8bit; // Implemented WITH palette.
// 15 : Result := pf15bit; // Not implemented in PCX format?
// 16 : Result := pf16bit; // Not implemented in PCX format?
24: Result := pf24bit; // Implemented, has no palette.
// 32 : Result := pf32bit; // Not implemented in PCX format.
end;
end;
//---------------------------------------------------------------------
procedure TPCXImage.fGetPalette(const wNumColors: WORD);
var
pal: TMaxLogPalette;
W: WORD;
begin
fPCXFile.fPCXPalette.fSignature := $0C;
pal.palVersion := $300; // The "Magic" number
pal.palNumEntries := wNumColors;
GetPaletteEntries(CopyPalette(fBitmap.Palette), 0, wNumColors,
pal.palPalEntry);
for W := 0 to 255 do
if W < wNumColors then
begin
fPCXFile.fPCXPalette.fPalette[W].ceRed :=
pal.palPalEntry[W].peRed;
fPCXFile.fPCXPalette.fPalette[W].ceGreen :=
pal.palPalEntry[W].peGreen;
fPCXFile.fPCXPalette.fPalette[W].ceBlue :=
pal.palPalEntry[W].peBlue;
end
else
begin
fPCXFile.fPCXPalette.fPalette[W].ceRed := 0;
fPCXFile.fPCXPalette.fPalette[W].ceGreen := 0;
fPCXFile.fPCXPalette.fPalette[W].ceBlue := 0;
end;
end;
//=====================================================================
///////////////////////////////////////////////////////////////////////
// //
// TPCXFile //
// //
///////////////////////////////////////////////////////////////////////
constructor TPCXFile.Create;
begin
inherited Create;
fHeight := 0;
fWidth := 0;
fCurrentPos := 0;
end;
//---------------------------------------------------------------------
destructor TPCXFile.Destroy;
begin
SetLength(fPCXData.fData, 0);
inherited Destroy;
end;
//---------------------------------------------------------------------
procedure TPCXFile.LoadFromFile(const Filename: string);
var
fPCXStream: TFileStream;
begin
fPCXStream := TFileStream.Create(Filename, fmOpenRead);
try
fPCXStream.Position := 0;
LoadFromStream(fPCXStream);
finally
fPCXStream.Free;
end;
end;
//---------------------------------------------------------------------
procedure TPCXFile.SaveToFile(const Filename: string);
var
fPCXStream: TFileStream;
begin
fPCXStream := TFileStream.Create(Filename, fmCreate);
try
fPCXStream.Position := 0;
SaveToStream(fPCXStream);
finally
fPCXStream.Free;
end;
end;
//---------------------------------------------------------------------
procedure TPCXFile.LoadFromStream(Stream: TStream);
var
fFileLength: Cardinal;
begin
// Read the PCX header
Stream.Read(fPCXHeader, SizeOf(fPCXHeader));
// Check the ID byte
if fPCXHeader.fID <> $0A then
raise Exception.Create(FORMAT_ERROR);
(*
Check PCX version byte
======================
Versionbyte = 0 => PC PaintBrush V2.5
Versionbyte = 2 => PC Paintbrush V2.8 with palette information
Versionbyte = 3 => PC Paintbrush V2.8 without palette information
Versionbyte = 4 => PC Paintbrush for Windows
Versionbyte = 5 => PC Paintbrush V3 and up, and PC Paintbrush Plus
with 24 bit image support
*)
// Check the PCX version
if fPCXHeader.fVersion <> 5 then
raise Exception.Create(VERSION_ERROR);
// Calculate width
fWidth := fPCXHeader.fWindow.wRight - fPCXHeader.fWindow.wLeft + 1;
if fWidth < 0 then
raise Exception.Create(WIDTH_OUT_OF_RANGE);
// Calculate height
fHeight := fPCXHeader.fWindow.wBottom - fPCXHeader.fWindow.wTop + 1;
if fHeight < 0 then
raise Exception.Create(HEIGHT_OUT_OF_RANGE);
// Is it too large?
if fWidth > fMaxImageWidth then
raise Exception.Create(IMAGE_WIDTH_TOO_LARGE);
// Calculate pixelformat
fPixelFormat := fPCXHeader.fPlanes * fPCXHeader.fBitsPerPixel;
// Calculate number of colors
fColorDepth := 1 shl fPixelFormat;
// Is this image supported?
if not (fPixelFormat in [1, 8, 24]) then
raise Exception.Create(ERROR_UNSUPPORTED);
// The lines following are NOT tested!!!
(*
If fColorDepth <= 16 then
For I := 0 to fColorDepth - 1 do
Begin
If fPCXHeader.fVersion = 3 then
Begin
fPCXPalette.fPalette[I].R := fPCXHeader.fColorMap[I].R shl 2;
fPCXPalette.fPalette[I].G := fPCXHeader.fColorMap[I].G shl 2;
fPCXPalette.fPalette[I].B := fPCXHeader.fColorMap[I].B shl 2;
End
else
Begin
fPCXPalette.fPalette[I].R := fPCXHeader.fColorMap[I].R;
fPCXPalette.fPalette[I].G := fPCXHeader.fColorMap[I].G;
fPCXPalette.fPalette[I].B := fPCXHeader.fColorMap[I].B;
End;
End;
*)
// Calculate number of data bytes
// If fFileLength > fMaxDataFileLength then
// Raise Exception.Create(INPUT_FILE_TOO_LARGE);
if fPixelFormat = 24 then
begin
fFileLength := Stream.Size - Stream.Position;
SetLength(fPCXData.fData, fFileLength);
// Read the data
Stream.Read(fPCXData.fData[0], fFileLength);
fHasPalette := False;
end;
if fPixelFormat in [1, 8] then
begin
fFileLength := Stream.Size - Stream.Position - 769;
SetLength(fPCXData.fData, fFileLength);
// Correct number of data bytes
Stream.Read(fPCXData.fData[0], fFilelength);
// Read the palette
Stream.Read(fPCXPalette, SizeOf(fPCXPalette));
fHasPalette := True;
// Check palette signature byte
if fPCXPalette.fSignature <> $0C then
raise Exception.Create(PALETTE_ERROR);
end;
end;
//---------------------------------------------------------------------
procedure TPCXFile.SaveToStream(Stream: TStream);
begin
fHasPalette := False;
Stream.Write(fPCXHeader, SizeOf(fPCXHeader));
Stream.Write(fPCXData.fData[0], fCurrentPos);
if fPixelFormat in [1, 8] then
begin
Stream.Write(fPCXPalette, SizeOf(fPCXPalette));
fHasPalette := True;
end;
end;
//---------------------------------------------------------------------
// Register PCX format
initialization
TPicture.RegisterFileFormat('PCX', sPCXImageFile, TPCXImage);
CF_PCX := RegisterClipBoardFormat('PCX Image');
TPicture.RegisterClipBoardFormat(CF_PCX, TPCXImage);
//---------------------------------------------------------------------
// Unregister PCX format
finalization
TPicture.UnRegisterGraphicClass(TPCXImage);
//---------------------------------------------------------------------
end.
//=====================================================================
Взято с
Delphi Knowledge BaseКомпонент FontListBox
Компонент FontListBox
Автор: Maarten de Haan
Надеюсь, что любители Delphi уже не один раз приукрашивали всякие ЛистБоксы и тому подобное. Автор исходника предлагает создать этот компонент своими силами. Впрочем, Вы сами можете увидеть как можно играться со шрифтами в ListBox.
{
==================================================================
Написан в Delphi V5.0.
Тестировался под: Windows 95, version A, servicepack 1
и Windows NT4.0, servicepack 5.
===================================================================
}
Unit FontListBox;
Interface
Uses
Windows, Messages, SysUtils, Classes, Graphics, Controls,
Forms, Dialogs, StdCtrls;
Type
TFontListBox = class(TCustomListbox)
Private
{ Private declarations }
fFontSample : Boolean; // Добавляемое свойство
fShowTrueType : Boolean; // Добавляемое свойство
fCanvas : TControlCanvas; // Необходимо
Procedure SetFontSample(B : Boolean); // внутренняя процедура
Procedure SetShowTrueType(B : Boolean); // внутренняя процедура
Protected
{ Protected declarations }
Procedure CreateWnd; override;
Public
{ Public declarations }
Constructor Create(AOwner : TComponent); override;
Destructor Destroy; override;
Procedure DrawItem(Index : Integer; R : TRect;
State : TOwnerDrawState); override;
Published
{ Published declarations }
{ Properties }
Property Fontsample : Boolean // Добавляемое свойство
Read fFontSample Write SetFontSample;
Property Align;
Property Anchors;
Property BiDiMode;
Property BorderStyle;
Property Color;
Property Columns;
Property Constraints;
Property Cursor;
Property DragCursor;
Property DragKind;
Property DragMode;
Property Enabled;
//Poperty ExtendedSelection; Не существует в базовом классе
Property Font;
Property Height;
Property HelpContext;
Property Hint;
Property ImeMode;
Property ImeName;
Property IntegralHeight;
Property Itemheight;
Property Items;
Property Left;
Property MultiSelect;
Property Name;
Property ParentBiDiMode;
Property ParentColor;
Property ParentFont;
Property ParentShowHint;
Property PopupMenu;
Property ShowTrueType : Boolean // Добавляемое свойство
Read fShowTrueType Write SetShowTrueType;
Property ShowHint;
Property Sorted;
Property Style;
Property TabOrder;
Property TabStop;
Property TabWidth;
Property Tag;
Property Top;
Property Visible;
Property Width;
{ Events }
Property OnClick;
Property OnContextPopup;
Property OnDblClick;
Property OnDragDrop;
Property OnDragOver;
Property OnDrawItem;
Property OnEndDock;
Property OnEnter;
Property OnExit;
Property OnKeyDown;
Property OnKeyPress;
Property OnKeyUp;
Property OnMeasureItem;
Property OnMouseDown;
Property OnMouseMove;
Property OnMouseUp;
Property OnStartDock;
Property OnStartDrag;
End;
Procedure Register;
Implementation
{--------------------------------------------------------------------}
Procedure Register; // Hello
Begin
RegisterComponents('Samples', [TFontListBox]);
End;
{--------------------------------------------------------------------}
Procedure TFontListBox.SetShowTrueType(B : Boolean);
Begin
If B <> fShowTrueType then
Begin
fShowTrueType := B;
Invalidate; // Заставляет апдейтится во время прорисовки
End;
End;
{--------------------------------------------------------------------}
Procedure TFontListBox.SetFontSample(B : Boolean);
Begin
If fFontSample <> B then
Begin
fFontSample := B;
Invalidate; // Заставляет апдейтится во время прорисовки
End;
End;
{--------------------------------------------------------------------}
Destructor TFontListBox.Destroy;
Begin
fCanvas.Free; // освобождает холст
Inherited Destroy;
End;
{-----------------------------------------------------------------------}
Constructor TFontListBox.Create(AOwner : TComponent);
Begin
Inherited Create(AOwner);
// Initialize properties
ParentFont := True;
Font.Size := 8;
Font.Style := [];
Sorted := True;
fFontSample := False;
Style := lbOwnerDrawFixed;
fCanvas := TControlCanvas.Create;
fCanvas.Control := Self;
ItemHeight := 16;
fShowTrueType := False;
End;
{--------------------------------------------------------------------}
procedure TFontListBox.CreateWnd;
Begin
inherited CreateWnd;
Items := Screen.Fonts; // Копируем все шрифты в ListBox.Items
ItemIndex := 0; // Выбираем первый фонт
End;
{--------------------------------------------------------------------}
procedure TFontListBox.DrawItem(Index : Integer; R : TRect;
State : TOwnerDrawState);
Var
Metrics : TTextMetric;
LogFnt : TLogFont;
oldFont,newFont : HFont;
IsTrueTypeFont : Boolean;
fFontStyle : TFontStyles;
fFontName : TFontName;
fFontColor : TColor;
Begin
LogFnt.lfHeight := 10;
LogFnt.lfWidth := 10;
LogFnt.lfEscapement := 0;
LogFnt.lfWeight := FW_REGULAR;
LogFnt.lfItalic := 0;
LogFnt.lfUnderline := 0;
LogFnt.lfStrikeOut := 0;
LogFnt.lfCharSet := DEFAULT_CHARSET;
LogFnt.lfOutPrecision := OUT_DEFAULT_PRECIS;
LogFnt.lfClipPrecision := CLIP_DEFAULT_PRECIS;
LogFnt.lfQuality := DEFAULT_QUALITY;
LogFnt.lfPitchAndFamily := DEFAULT_PITCH or FF_DONTCARE;
StrPCopy(LogFnt.lfFaceName,Items[Index]);
newFont := CreateFontIndirect(LogFnt);
oldFont := SelectObject(fCanvas.Handle,newFont);
GetTextMetrics(fCanvas.Handle,Metrics);
// Теперь вы можете проверить на TrueType-ность
IsTrueTypeFont := True;
If (Metrics.tmPitchAndFamily and TMPF_TRUETYPE) = 0 then
IsTrueTypeFont := False;
Canvas.FillRect(R);
If fShowTrueType and IsTrueTypeFont then
Begin
// Записываем параметры шрифтов
fFontName := Canvas.Font.Name;
fFontStyle := Canvas.Font.Style;
fFontColor := Canvas.Font.Color;
// Устанавливаем новые параметры шрифтов
Canvas.Font.Name := 'Times new roman';
Canvas.Font.Style := [fsBold];
//Canvas.Font.Color := clBlack;
Canvas.TextOut(R.Left + 2,R.Top,'T');
If fFontColor <> clHighLightText then
Canvas.Font.Color := clGray;
Canvas.TextOut(R.Left + 7,R.Top + 3,'T');
//Восстанавливаем параметры шрифтов
Canvas.Font.Style := fFontStyle;
Canvas.Font.Color := fFontColor;
Canvas.Font.Name := fFontName;
End;
If fFontSample then
// Шрифт будет прорисован фактически как шрифт
Canvas.Font.Name := Items[Index]
else
// Шрифт будет прорисован в свойстве "Font"
Canvas.Font.Name := Font.Name;
If fShowTrueType then
Canvas.TextOut(R.Left + 20,R.Top,Items[Index]) // Показывать TrueType
else
Canvas.TextOut(R.Left,R.Top,Items[Index]); // Не показывать TrueType
SelectObject(fCanvas.Handle,oldFont);
DeleteObject(newFont);
End;
{--------------------------------------------------------------------}
End.
{====================================================================}
Взято с Исходников.ru
Компонент PowerControl
Компонент PowerControl
Вопрос: А как реализовать в одном компоненте такие функции как выключение компьютера, перезагрузка, завершение сеанса работы пользователя, Eject CD, выключение питания монитора и т.д.? Ответ: предлагаем посмотреть следующий пример ...
procedure TForm1.Button1Click(Sender: TObject);
begin
PowerControl1.Action:=actCDEject;// Или... actLogOFF, actShutDown...
PowerControl1.Execute;
end;
=========================
Component Code:
unit PowerControl;
interface
uses WinTypes, WinProcs, Messages, SysUtils, Classes, Controls,
Forms, Graphics, MMSystem;
type
TAction = (actLogOFF,actShutDown,actReBoot,actForce,actPowerOFF,
actForceIfHung,actMonitorOFF,actMonitorON,actCDEject,actCDUnEject);
type
TPowerControl = class(TComponent)
private
FAction : TAction;
procedure SetAction(Value : TAction);
protected
public
function Execute : Boolean;
published
property Action : TAction read FAction write SetAction;
end;
procedure Register;
implementation
procedure Register;
begin
RegisterComponents('K2', [TPowerControl]);
end;
procedure TPowerControl.SetAction(Value : TAction);
begin
FAction := Value;
end;
function TPowerControl.Execute : Boolean;
begin
with (Owner as TForm) do
case FAction of
actLogOff: ExitWindowsEx(EWX_LOGOFF,1);
actShutDown: ExitWindowsEx(EWX_SHUTDOWN,1);
actReBoot: ExitWindowsEx(EWX_REBOOT,1);
actForce: ExitWindowsEx(EWX_FORCE,1);
actPowerOff: ExitWindowsEx(EWX_POWEROFF,1);
actForceIfHung: ExitWindowsEx(EWX_FORCEIFHUNG,1);
actMonitorOFF: SendMessage(Application.Handle,
WM_SYSCOMMAND, SC_MONITORPOWER, 0);
actMonitorON: SendMessage(Application.Handle, WM_SYSCOMMAND,
SC_MONITORPOWER, -1);
actCDEject: mciSendstring('SET CDAUDIO DOOR OPEN
WAIT',nil,0, Handle);
actCDUnEject: mciSendstring('SET CDAUDIO DOOR CLOSED
WAIT',nil,0, Handle);
end; {Case}
Result := True;
end;
end.
Взято с Исходников.ru
Компонент TStoredProc
компонент TStoredProc
Недавно я перешел на использование Oracle, но все мои попытки использовать компонент TStoredProc оказываются неудачными. Почему?
Причины неработоспособности компонента TStoredProc могут быть следующими.
Во-первых, при использовании ODBC-доступа может оказаться, что применяемый вами ODBC-драйвер не поддерживает хранимые процедуры (как известно, не все ODBC-драйверы их поддерживают).
Во-вторых, имеется известная проблема, описание которой содержится в разделе Developers Support корпоративного сайта Inprise (http://www.inprise.com). Дело в том, что число параметров хранимой процедуры, с которой взаимодействует компонент TStoredProc, не должно превышать 10. В случае, если реальное число параметров превышает 10, многие разработчики переписывают хранимые процедуры так, чтобы они использовали строковые параметры, содержащие по несколько реальных параметров.
--------------------------------------------------------------------------------
Взято из
Конфигурация и настройка
Конфигурация и настройка
Each function listed below returns information about the client application environment, such as the supported table, field and index types for the driver type, or the available driver types. Functions in this category can also perform tasks that affect the client application environment, such as loading a driver.
DbiAddAlias:
Adds an alias to the BDE configuration file (IDAPI.CFG).
DbiAddDriver:
Adds a driver to the BDE configuration file (IDAPI.CFG). NEW FUNCTION BDE 4.0
DbiAnsiToNative:
Multipurpose translate function.
DbiDebugLayerOptions:
Activates, deactivates, or sets options for the BDE debug layer. OBSOLETE FUNCTION BDE 4.0
DbiDeleteAlias:
Deletes an alias from the BDE configuration file (IDAPI.CFG).
DbiDeleteDriver:
Deletes a driver from the BDE configuration file (IDAPI.CFG). NEW FUNCTION BDE 4.0
DbiDllExit:
Prepares the BDE to be disconnected within a DLL. NEW FUNCTION BDE 4.0
DbiExit:
Disconnects the client application from BDE.
DbiGetClientInfo:
Retrieves system-level information about the client application environment.
DbiGetDriverDesc:
Retrieves a description of a driver.
DbiGetLdName:
Retrieves the name of the language driver associated with the specified object name (table name).
DbiGetLdObj:
Retrieves the language driver object associated with the given cursor.
DbiGetNetUserName:
Retrieves the user's network login name. User names should be available for all networks
supported by Microsoft Windows.
DbiGetProp:
Returns a property of an object.
DbiGetSysConfig:
Retrieves BDE system configuration information.
DbiGetSysInfo:
Retrieves system status and information.
DbiGetSysVersion:
Retrieves the system version information, including the BDE version number, date, and time,
and the client interface version number.
DbiInit:
Initializes the BDE environment.
DbiLoadDriver:
Load a given driver.
DbiNativeToAnsi:
Translates a string in the native language driver to an ANSI string.
DbiOpenCfgInfoList:
Returns a handle to an in-memory table listing all the nodes in the configuration file
accessible by the specified path.
DbiOpenDriverList:
Creates an in-memory table containing a list of driver names available to the client application.
DbiOpenFieldTypesList:
Creates an in-memory table containing a list of field types supported by the table type for
the driver type.
DbiOpenFunctionArgList:
Returns a list of arguments to a data source function.
DbiOpenFunctionList:
Returns a description of a data source function.
DbiOpenIndexTypesList:
Creates an in-memory table containing a list of all supported index types for the driver type.
DbiOpenLdList:
Creates an in-memory table containing a list of available language drivers.
DbiOpenTableList:
Creates an in-memory table with information about all the tables accessible to the client application.
DbiOpenTableTypesList:
Creates an in-memory table listing table type names for the given driver.
DbiOpenUserList:
Creates an in-memory table containing a list of users sharing the same network file.
DbiSetProp:
Sets the specified property of an object to a given value.
DbiUseIdleTime:
Allows BDE to accomplish background tasks during times when the client application is idle.
OBSOLETE FUNCTION BDE 4.0
Взято с
Delphi Knowledge BaseКонфигурация железа
Конфигурация железа
Cодержание раздела:
См. также статьи в других разделах:
Конфигурирование ODBC
Конфигурирование ODBC
Автор: Mark Nelson (Delphi Tech Support)
Представляю вашему вниманию инструкцию по конфигурированию ODBC и источника данных.
Для того, чтобы Borland Database Engine мог пользоваться драйверами ODBC, они должны быть сконфигурированы следующим образом:
Инсталлируйте драйвер и установите его в Панель Управления/ODBC administrator.
Если это файл базового драйвера типа dBase, Paradox, Excel, FoxPro и др., то вы должны указать каталог, содержащий ваши файлы.
Access и Local Btrieve файлы должны указывать на конкретный файл базы данных (Btreive на File.ddf, Access должен указывать на файл с расширением .MDB).
Если это линк (connection) к базе данных, например Oracle, Sybase, Interbase, и др., вы должны указать на этот линк. Обычно транспорт посредством TCPIP, SPX/IPX, NetBEUI и т.п. предусматривается поставщиком программного обеспечения. Каждый драйвер работает с транспортным протоколом по-своему.
Запустите Database Engine Configuration Utility. (BDECFG.EXE)
Выберите New ODBC Driver.
Задайте имя вашему драйверу (к имени автоматически добавится "ODBC_".)
Выберите ваш ODBC Driver из списка Default ODBC Driver List.
Выберите имя источника данных по умолчанию.
Создайте псевдоним (alias), указывающий на установленный вами драйвер.
Установите ссылку с именем псевдонима на ваш драйвер.
Примечание относительно баз данных Access 2.0: вам необходимо иметь самые последние драйверы от Microsoft. Имеющиеся драйверы позволяют работать только с базами данных Access 1.0, не выше.
Стоимость нового набора драйверов у самой Microsoft составляет $10, что эквивалентно цене носителя и пересылки.
Для работы с Access 2.0 вам необходимо использовать источник данных с именем "Microsoft Access Driver" или "Microsoft Access 2.0 Databases".
Имейте в виду, что "Access Data" и "Access Files" по умолчанию являются источниками данных только для Access 1.0. Поэтому для получения доступа к MDB-файлам Access 1.0 пользуйтесь "Access Data".
Btrieve также создает источник данных по умолчанию "Btrieve Data" и "Btrieve Files". Используйте "Btrieve Data" как ваш источник данных по умолчанию. Драйверы Btrieve позволяют использовать данные btrieve вплоть до версии 5.0. Для работы с Btrive данными более новой версии, необходим новый набор драйверов Microsoft или Intersolve Q+E.
Взято с
Конфигурирование ODBC и псевдонима
Конфигурирование ODBC и псевдонима
Настройка ODBC в Панели Управления
При инсталляции, Delphi устанавливает в Панель Управления апплет "ODBC" (далее - "настройка ODBC"). "Настройка ODBC" содержит доступные источники данных (драйвера), установленных для использования ODBC. Как вы можете видеть на главной странице "Data Sources", ODBC содержит внушительный набор форматов, которые могут использоваться в Delphi. Дополнительные форматы поддерживаются установленными драйверами и могут быть добавлены с помощью кнопки "Add...".
Для добавления нового или удаления существующего драйвера:
В окне "Data Sources" нажмите кнопку "Drivers...". В появившемся диалоговом окне "Drivers" нажмите кнопку "Add..." и укажите путь к новому драйверу ODBC.
Возвратитесь в окно "Data Sources" и добавьте доступные с новым драйвером источники данных с помощью кнопки "Add...".
Для настройки конкретного источника данных используйте кнопку "Setup...". Функция кнопки "Setup..." меняется с каждым форматом данных. Частенько настройки типа рабочей директории для драйвера настраиваются как раз в этом месте.
Разделы электронной справки доступны для каждой страницы и диалогового окна "Настроки ODBC".
BDE CONFIGURATION UTILITY
После установки драйвера ODBC, запустите BDE Configuration utility для конфигурации BDE для работы с новым драйвером.
На странице драйверов нажмите на кнопку "New ODBC driver".
Появится диалог с заголовком "Add ODBC driver". Опция "SQL link driver" позволяет выяснить, с какими типами баз данных можно работать с помощью данного драйвера ODBC.
Затем выбирайте default ODBC driver (драйвер ODBC по-умолчанию). Выпадающий список содержит список типов файлов, поддерживаемых установленными в системе драйверами ODBC.
Выберите для ODBC-драйвера источник данных по-умолчанию (default data source). Имея уже установленный на шаге 3 драйвер ODBC, список этого combobox'а будет содержать имена источников данных, подходящих для использования с выбранным драйвером.
Нажмите Ok.
Возвратитесь на страницу драйверов, выберите File/Save из главного меню и сохраните данную конфигурацию.
Создание псевдонима в DATABASE DESKTOP
Хотя создать псевдоним ODBC можно и из BDE Configuration utility, Database Desktop предоставляет более комфортное решение.
В меню "File" выберите пункт "Aliases..".
В появившемся диалоге "Alias Manager" нажмите кнопку "New".
Введите имя вашего нового псевдонима в поле редактирования, помеченной как "Database Alias".
Используя выпадающий список "Driver Type" (типы драйверов), выберите драйвер, подходящий для данного псевдонима. Таблицы Paradox и dBase считаются STANDARD. Если в BDE Configuration utility драйвер ODBC был правильно сконфигурирован, то его имя появится в списке.
Дополнительные опции опции могут появляться в зависимости от выбранного типа драйвера.
После завершения всех описанных действий сохраните новый псевдоним, выбрав "Keep New". Затем нажмите "Ok". Появится подсказка, спрашивающая о необходимости сохранения псевдонима в IDAPI.CFG. Выберите "Ok".
Теперь псевдоним будет работать и в Database Desktop, и в Delphi.
Взято с
Коннект к серверу и загрузка файла (используя wininet.dll)
Коннект к серверу и загрузка файла (используя wininet.dll)
uses
WinInet, ComCtrls;
function FtpDownloadFile(strHost, strUser, strPwd: string;
Port: Integer; ftpDir, ftpFile, TargetFile: string; ProgressBar: TProgressBar):
Boolean;
function FmtFileSize(Size: Integer): string;
begin
if Size >= $F4240 then
Result := Format('%.2f', [Size / $F4240]) + ' Mb'
else if Size < 1000 then
Result := IntToStr(Size) + ' bytes'
else
Result := Format('%.2f', [Size / 1000]) + ' Kb';
end;
const
READ_BUFFERSIZE = 4096; // or 256, 512, ...
var
hNet, hFTP, hFile: HINTERNET;
buffer: array[0..READ_BUFFERSIZE - 1] of Char;
bufsize, dwBytesRead, fileSize: DWORD;
sRec: TWin32FindData;
strStatus: string;
LocalFile: file;
bSuccess: Boolean;
begin
Result := False;
{ Open an internet session }
hNet := InternetOpen('Program_Name', // Agent
INTERNET_OPEN_TYPE_PRECONFIG, // AccessType
nil, // ProxyName
nil, // ProxyBypass
0); // or INTERNET_FLAG_ASYNC / INTERNET_FLAG_OFFLINE
{
Agent contains the name of the application or
entity calling the Internet functions
}
{ See if connection handle is valid }
if hNet = nil then
begin
ShowMessage('Unable to get access to WinInet.Dll');
Exit;
end;
{ Connect to the FTP Server }
hFTP := InternetConnect(hNet, // Handle from InternetOpen
PChar(strHost), // FTP server
port, // (INTERNET_DEFAULT_FTP_PORT),
PChar(StrUser), // username
PChar(strPwd), // password
INTERNET_SERVICE_FTP, // FTP, HTTP, or Gopher?
0, // flag: 0 or INTERNET_FLAG_PASSIVE
0); // User defined number for callback
if hFTP = nil then
begin
InternetCloseHandle(hNet);
ShowMessage(Format('Host "%s" is not available', [strHost]));
Exit;
end;
{ Change directory }
bSuccess := FtpSetCurrentDirectory(hFTP, PChar(ftpDir));
if not bSuccess then
begin
InternetCloseHandle(hFTP);
InternetCloseHandle(hNet);
ShowMessage(Format('Cannot set directory to %s.', [ftpDir]));
Exit;
end;
{ Read size of file }
if FtpFindFirstFile(hFTP, PChar(ftpFile), sRec, 0, 0) <> nil then
begin
fileSize := sRec.nFileSizeLow;
// fileLastWritetime := sRec.lastWriteTime
end
else
begin
InternetCloseHandle(hFTP);
InternetCloseHandle(hNet);
ShowMessage(Format('Cannot find file ', [ftpFile]));
Exit;
end;
{ Open the file }
hFile := FtpOpenFile(hFTP, // Handle to the ftp session
PChar(ftpFile), // filename
GENERIC_READ, // dwAccess
FTP_TRANSFER_TYPE_BINARY, // dwFlags
0); // This is the context used for callbacks.
if hFile = nil then
begin
InternetCloseHandle(hFTP);
InternetCloseHandle(hNet);
Exit;
end;
{ Create a new local file }
AssignFile(LocalFile, TargetFile);
{$I-}
Rewrite(LocalFile, 1);
{$I+}
if IOResult <> 0 then
begin
InternetCloseHandle(hFile);
InternetCloseHandle(hFTP);
InternetCloseHandle(hNet);
Exit;
end;
dwBytesRead := 0;
bufsize := READ_BUFFERSIZE;
while (bufsize > 0) do
begin
Application.ProcessMessages;
if not InternetReadFile(hFile,
@buffer, // address of a buffer that receives the data
READ_BUFFERSIZE, // number of bytes to read from the file
bufsize) then
Break; // receives the actual number of bytes read
if (bufsize > 0) and (bufsize <= READ_BUFFERSIZE) then
BlockWrite(LocalFile, buffer, bufsize);
dwBytesRead := dwBytesRead + bufsize;
{ Show Progress }
ProgressBar.Position := Round(dwBytesRead * 100 / fileSize);
Form1.Label1.Caption := Format('%s of %s / %d %%', [FmtFileSize(dwBytesRead),
FmtFileSize(fileSize), ProgressBar.Position]);
end;
CloseFile(LocalFile);
InternetCloseHandle(hFile);
InternetCloseHandle(hFTP);
InternetCloseHandle(hNet);
Result := True;
end;
Взято с
Delphi Knowledge BaseКонсольные приложения
Консольные приложения
Cодержание раздела:
Контрольные суммы и шифрование, проверка контрольных сумм
Контрольные суммы и шифрование, проверка контрольных сумм
Cодержание раздела:
См. также статьи в других разделах:
Конвертация арабских цифр в римские
Конвертация арабских цифр в римские
functionIntToRoman(num: Cardinal): String; {returns num in capital roman digits}
const
Nvals = 13;
vals: array [1..Nvals] of word = (1, 4, 5, 9, 10, 40, 50, 90, 100, 400, 500, 900, 1000);
roms: array [1..Nvals] of string[2] = ('I', 'IV', 'V', 'IX', 'X', 'XL', 'L', 'XC', 'C', 'CD', 'D', 'CM', 'M');
var
b: 1..Nvals;
begin
result := '';
b := Nvals;
while num > 0 do
begin
while vals[b] > num do
dec(b);
dec (num, vals[b]);
result := result + roms[b]
end;
end;
Взято из
Конвертация римских цифр в арабские
Конвертация римских цифр в арабские
functionRomanToDec(const Value: string): integer;
var
i, lastValue, curValue: integer;
begin
Result := 0;
lastValue := 0;
for i := Length(Value) downto 1 do
begin
case UpCase(Value[i]) of
'C':
curValue := 100;
'D':
curValue := 500;
'I':
curValue := 1;
'L':
curValue := 50;
'M':
curValue := 1000;
'V':
curValue := 5;
'X':
curValue := 10;
else
raise Exception.CreateFmt('Invalid character: %s', [Value[i]]);
end;
if curValue < lastValue then
Dec(Result, curValue)
else
Inc(Result, curValue);
lastValue := curValue;
end;
end;
Взято с
Delphi Knowledge BaseКонвертировать INI файл в XML
Конвертировать INI файл в XML
usesXMLIntf, XMLDoc, INIFiles;
procedure INI2XML(const pINIFileName: string; const pXML: IXMLNode;
const AsAttributes: Boolean = true);
var
lINIFile: TIniFile;
lSections, lItems: TStringList;
iSections, iItems: integer;
lNode: IXMLNode;
begin
lINIFile := TIniFile.Create(pINIFileName);
try
lSections := TStringList.Create;
try
lItems := TStringList.Create;
try
lINIFile.ReadSections(lSections);
for iSections := 0 to pred(lSections.Count) do
begin
lItems.Clear;
lINIFile.ReadSection(lSections[iSections], lItems);
lNode := pXML.AddChild(StringReplace(lSections[iSections], ' ', '',
[rfReplaceAll]));
for iItems := 0 to pred(lItems.Count) do
begin
if AsAttributes then
lNode.Attributes[lItems[iItems]] :=
lINIFile.ReadString(lSections[iSections], lItems[iItems], '')
else
lNode.AddChild(lItems[iItems]).Text :=
lINIFile.ReadString(lSections[iSections], lItems[iItems], '');
end;
lNode := nil;
end;
finally lItems.Free;
end;
finally lSections.Free;
end;
finally lINIFile.Free;
end;
end;
Взято с
Delphi Knowledge BaseКонвертировать результат запроса в XML и обратно
Конвертировать результат запроса в XML и обратно
unitADOXMLUnit;
interface
uses
Classes, ADOInt;
function RecordsetToXML(const Recordset: _Recordset): string;
function RecordsetFromXML(const XML: string): _Recordset;
implementation
uses
ComObj;
function RecordsetToXML(const Recordset: _Recordset): string;
var
RS: Variant;
Stream: TStringStream;
begin
Result := '';
if Recordset = nil then
Exit;
Stream := TStringStream.Create('');
try
RS := CreateOleObject('ADODB.Recordset');
RS := Recordset;
RS.Save(TStreamAdapter.Create(stream) as IUnknown, adPersistXML);
Stream.Position := 0;
Result := Stream.DataString;
finally
Stream.Free;
end;
end;
function RecordsetFromXML(const XML: string): _Recordset;
var
RS: Variant;
Stream: TStringStream;
begin
Result := nil;
if XML = '' then
Exit;
try
Stream := TStringStream.Create(XML);
Stream.Position := 0;
RS := CreateOleObject('ADODB.Recordset');
RS.Open(TStreamAdapter.Create(Stream) as IUnknown);
Result := IUnknown(RS) as _Recordset;
finally
Stream.Free;
end;
end;
end.
Взято с
Delphi Knowledge BaseКонвертировать таблицу в XML
Конвертировать таблицу в XML
{SMExport suite's free demo
Data export from dataset into XML-file
Copyright(C) 2000, written by Scalabium, Shkolnik Mike
E-Mail: smexport@scalabium.com
mshkolnik@yahoo.com
WEB: http://www.scalabium.com
http://www.geocities.com/mshkolnik
}
unit DS2XML;
interface
uses
Classes, DB;
procedure DatasetToXML(Dataset: TDataset; FileName: string);
implementation
uses
SysUtils;
var
SourceBuffer: PChar;
procedure WriteString(Stream: TFileStream; s: string);
begin
StrPCopy(SourceBuffer, s);
Stream.Write(SourceBuffer[0], StrLen(SourceBuffer));
end;
procedure WriteFileBegin(Stream: TFileStream; Dataset: TDataset);
function XMLFieldType(fld: TField): string;
begin
case fld.DataType of
ftString: Result := '"string" WIDTH="' + IntToStr(fld.Size) + '"';
ftSmallint: Result := '"i4"'; //??
ftInteger: Result := '"i4"';
ftWord: Result := '"i4"'; //??
ftBoolean: Result := '"boolean"';
ftAutoInc: Result := '"i4" SUBTYPE="Autoinc"';
ftFloat: Result := '"r8"';
ftCurrency: Result := '"r8" SUBTYPE="Money"';
ftBCD: Result := '"r8"'; //??
ftDate: Result := '"date"';
ftTime: Result := '"time"'; //??
ftDateTime: Result := '"datetime"';
else
end;
if fld.Required then
Result := Result + ' required="true"';
if fld.Readonly then
Result := Result + ' readonly="true"';
end;
var
i: Integer;
begin
WriteString(Stream,
'<?xml version="1.0" standalone="yes"?><!-- Generated by SMExport --> ' +
'<DATAPACKET Version="2.0">');
WriteString(Stream, '<METADATA><FIELDS>');
{write th metadata}
with Dataset do
for i := 0 to FieldCount - 1 do
begin
WriteString(Stream, '<FIELD attrname="' +
Fields[i].FieldName +
'" fieldtype=' +
XMLFieldType(Fields[i]) +
'/>');
end;
WriteString(Stream, '</FIELDS>');
WriteString(Stream, '<PARAMS DEFAULT_ORDER="1" PRIMARY_KEY="1" LCID="1033"/>');
WriteString(Stream, '</METADATA><ROWDATA>');
end;
procedure WriteFileEnd(Stream: TFileStream);
begin
WriteString(Stream, '</ROWDATA></DATAPACKET>');
end;
procedure WriteRowStart(Stream: TFileStream; IsAddedTitle: Boolean);
begin
if not IsAddedTitle then
WriteString(Stream, '<ROW');
end;
procedure WriteRowEnd(Stream: TFileStream; IsAddedTitle: Boolean);
begin
if not IsAddedTitle then
WriteString(Stream, '/>');
end;
procedure WriteData(Stream: TFileStream; fld: TField; AString: ShortString);
begin
if Assigned(fld) and (AString <> '') then
WriteString(Stream, ' ' + fld.FieldName + '="' + AString + '"');
end;
function GetFieldStr(Field: TField): string;
function GetDig(i, j: Word): string;
begin
Result := IntToStr(i);
while (Length(Result) < j) do
Result := '0' + Result;
end;
var
Hour, Min, Sec, MSec: Word;
begin
case Field.DataType of
ftBoolean: Result := UpperCase(Field.AsString);
ftDate: Result := FormatDateTime('yyyymmdd', Field.AsDateTime);
ftTime: Result := FormatDateTime('hhnnss', Field.AsDateTime);
ftDateTime:
begin
Result := FormatDateTime('yyyymmdd', Field.AsDateTime);
DecodeTime(Field.AsDateTime, Hour, Min, Sec, MSec);
if (Hour <> 0) or (Min <> 0) or (Sec <> 0) or (MSec <> 0) then
Result := Result + 'T' + GetDig(Hour, 2) + ':' + GetDig(Min, 2) + ':' +
GetDig(Sec, 2) + GetDig(MSec, 3);
end;
else
Result := Field.AsString;
end;
end;
procedure DatasetToXML(Dataset: TDataset; FileName: string);
var
Stream: TFileStream;
bkmark: TBookmark;
i: Integer;
begin
Stream := TFileStream.Create(FileName, fmCreate);
SourceBuffer := StrAlloc(1024);
WriteFileBegin(Stream, Dataset);
with DataSet do
begin
DisableControls;
bkmark := GetBookmark;
First;
{write a title row}
WriteRowStart(Stream, True);
for i := 0 to FieldCount - 1 do
WriteData(Stream, nil, Fields[i].DisplayLabel);
{write the end of row}
WriteRowEnd(Stream, True);
while (not EOF) do
begin
WriteRowStart(Stream, False);
for i := 0 to FieldCount - 1 do
WriteData(Stream, Fields[i], GetFieldStr(Fields[i]));
{write the end of row}
WriteRowEnd(Stream, False);
Next;
end;
GotoBookmark(bkmark);
EnableControls;
end;
WriteFileEnd(Stream);
Stream.Free;
StrDispose(SourceBuffer);
end;
end.
Взято с
Delphi Knowledge BaseКонвертируем Unix дату
Конвертируем Unix дату
The value is a Unix Time, defined as seconds since 1970-01-01T00:00:00,0Z. Important is the Letter Z, you live in Sweden, in consequence you must add 1 hour for StandardDate and 2 hours for DaylightDate to the date. The infos you can get with GetTimeZoneInformation. But you must determine, which Bias (Standard or Daylight) is valid for the date (in this case -60). You can convert the date value with the function below.
The Date for 977347109 is 2000-12-20T22:18:29+01:00.
const
UnixDateDelta = 25569; { 1970-01-01T00:00:00,0 }
SecPerMin = 60;
SecPerHour = SecPerMin * 60;
SecPerDay = SecPerHour * 24;
MinDayFraction = 1 / (24 * 60);
{Convert Unix time to TDatetime}
function UnixTimeToDateTime(AUnixTime: DWord; ABias: Integer): TDateTime;
begin
Result := UnixDateDelta + (AUnixTime div SecPerDay) { Days }
+ ((AUnixTime mod SecPerDay) / SecPerDay) { Seconds }
- ABias * MinDayFraction { Bias to UTC in minutes };
end;
{Convert Unix time to String with locale settings}
function UnixTimeToStr(AUnixTime: DWord; ABias: Integer): string;
begin
Result := FormatDateTime('ddddd hh:nn:ss', UnixTimeToDateTime(AUnixTime, ABias));
end;
{Convert TDateTime to Unix time}
function DateTimeToUnixTime(ADateTime: TDateTime; ABias: Integer): DWord;
begin
Result := Trunc((ADateTime - UnixDateDelta) * SecPerDay) + ABias * SecPerMin;
end;
procedure TForm1.Button4Click(Sender: TObject);
begin
Label1.Caption := UnixTimeToStr(977347109, -60);
end;
Взято с
Delphi Knowledge BaseКопирование файлов
Копирование файлов
Копирование методом Pascal
Type
TCallBack=procedure (Position,Size:Longint); {Для индикации процесса копирования}
procedure FastFileCopy(Const InfileName, OutFileName: String; CallBack: TCallBack);
Const BufSize = 3*4*4096; { 48Kbytes дает прекрасный результат }
Type
PBuffer = ^TBuffer;
TBuffer = array [1..BufSize] of Byte;
var
Size : integer;
Buffer : PBuffer;
infile, outfile : File;
SizeDone,SizeFile: Longint;
begin
if (InFileName <> OutFileName) then
begin
buffer := Nil;
AssignFile(infile, InFileName);
System.Reset(infile, 1);
try
SizeFile := FileSize(infile);
AssignFile(outfile, OutFileName);
System.Rewrite(outfile, 1);
try
SizeDone := 0; New(Buffer);
repeat
BlockRead(infile, Buffer^, BufSize, Size);
Inc(SizeDone, Size);
CallBack(SizeDone, SizeFile);
BlockWrite(outfile,Buffer^, Size)
until Size < BufSize;
FileSetDate(TFileRec(outfile).Handle,
FileGetDate(TFileRec(infile).Handle));
finally
if Buffer <> Nil then Dispose(Buffer);
System.close(outfile)
end;
finally
System.close(infile);
end;
end else
Raise EInOutError.Create('File cannot be copied into itself');
end;
Копирование методом потока
Procedure FileCopy(Const SourceFileName, TargetFileName: String);
Var
S,T : TFileStream;
Begin
S := TFileStream.Create(sourcefilename, fmOpenRead );
try
T := TFileStream.Create(targetfilename, fmOpenWrite or fmCreate);
try
T.CopyFrom(S, S.Size ) ;
FileSetDate(T.Handle, FileGetDate(S.Handle));
finally
T.Free;
end;
finally
S.Free;
end;
end;
Копирование методом LZExpand
uses LZExpand;
procedure CopyFile(FromFileName, ToFileName : string);
var
FromFile, ToFile: File;
begin
AssignFile(FromFile, FromFileName);
AssignFile(ToFile, ToFileName);
Reset(FromFile);
try
Rewrite(ToFile);
try
if LZCopy(TFileRec(FromFile).Handle, TFileRec(ToFile).Handle)<0 then
raise Exception.Create('Error using LZCopy')
finally
CloseFile(ToFile);
end;
finally
CloseFile(FromFile);
end;
end;
Копирование методами Windows
uses ShellApi; // !!! важно
function WindowsCopyFile(FromFile, ToDir : string) : boolean;
var F : TShFileOpStruct;
begin
F.Wnd := 0; F.wFunc := FO_COPY;
FromFile:=FromFile+#0; F.pFrom:=pchar(FromFile);
ToDir:=ToDir+#0; F.pTo:=pchar(ToDir);
F.fFlags := FOF_ALLOWUNDO or FOF_NOCONFIRMATION;
result:=ShFileOperation(F) = 0;
end;
// пример копирования
procedure TForm1.Button1Click(Sender: TObject);
begin
if not WindowsCopyFile('C:\UTIL\ARJ.EXE', GetCurrentDir) then
ShowMessage('Copy Failed');
end;
Источник:
Копирование экрана
Копирование экрана
unit ScrnCap;
interface
uses WinTypes, WinProcs, Forms, Classes, Graphics, Controls;
{ Копирует прямоугольную область экрана }
function CaptureScreenRect(ARect : TRect) : TBitmap;
{ Копирование всего экрана }
function CaptureScreen : TBitmap;
{ Копирование клиентской области формы или элемента }
function CaptureClientImage(Control : TControl) : TBitmap;
{ Копирование всей формы элемента }
function CaptureControlImage(Control : TControl) : TBitmap;
{===============================================================}
implementation
function GetSystemPalette : HPalette;
var
PaletteSize : integer;
LogSize : integer;
LogPalette : PLogPalette;
DC : HDC;
Focus : HWND;
begin
result:=0;
Focus:=GetFocus;
DC:=GetDC(Focus);
try
PaletteSize:=GetDeviceCaps(DC, SIZEPALETTE);
LogSize:=SizeOf(TLogPalette)+(PaletteSize-1)*SizeOf(TPaletteEntry);
GetMem(LogPalette, LogSize);
try
with LogPalette^ do
begin
palVersion:=$0300;
palNumEntries:=PaletteSize;
GetSystemPaletteEntries(DC, 0, PaletteSize, palPalEntry);
end;
result:=CreatePalette(LogPalette^);
finally
FreeMem(LogPalette, LogSize);
end;
finally
ReleaseDC(Focus, DC);
end;
end;
function CaptureScreenRect(ARect : TRect) : TBitmap;
var
ScreenDC : HDC;
begin
Result:=TBitmap.Create;
with result, ARect do begin
Width:=Right-Left;
Height:=Bottom-Top;
ScreenDC:=GetDC(0);
try
BitBlt(Canvas.Handle, 0,0,Width,Height,ScreenDC, Left, Top, SRCCOPY );
finally
ReleaseDC(0, ScreenDC);
end;
Palette:=GetSystemPalette;
end;
end;
function CaptureScreen : TBitmap;
begin
with Screen do
Result:=CaptureScreenRect(Rect(0,0,Width,Height));
end;
function CaptureClientImage(Control : TControl) : TBitmap;
begin
with Control, Control.ClientOrigin do
result:=CaptureScreenRect(Bounds(X,Y,ClientWidth,ClientHeight));
end;
function CaptureControlImage(Control : TControl) : TBitmap;
begin
with Control do
if Parent=Nil then
result:=CaptureScreenRect(Bounds(Left,Top,Width,Height))
else
with Parent.ClientToScreen(Point(Left, Top)) do
result:=CaptureScreenRect(Bounds(X,Y,Width,Height));
end;
end.
Зайцев О.В.
Владимиров А.М.
Взято с Исходников.ru
Копирование таблицы с помощью DBE
Копирование таблицы с помощью DBE
functionCopyTable(tbl: TTable; dest: string): boolean;
var
psrc, pdest: array[0..DBIMAXTBLNAMELEN] of char;
rslt: DBIResult;
begin
Result := False;
StrPCopy(pdest, dest);
with tbl do
begin
try
DisableControls;
StrPCopy(psrc, TableName);
rslt := DbiCopyTable(DBHandle, True, psrc, nil, pdest);
Result := (rslt = 0);
finally
Refresh;
EnableControls;
end;
end;
end;
Взято из
Когда копирую текст на русском
Копируем русский текст в буфер обмена в Windows2000
У меня Windows NT/2000. Когда копирую текст на русском языке, скажем, из TMemo в Ворд 97/2000, то получаю в результате каракули. Эти каракули исправляются, если перед копированием насильно переключить клавиатуру пользователя на русский язык. Но если у него нет этой клавиатуры, или если лучше не переключать ее, то как можно сообщить системе, что мы будем копировать РУССКИЙ текст. На форме создается невидимый TRichEdit (я обозвал его TRE в коде). Далее текст копируется в клипборд как обычно, после чего вызывается следующая процедура
procedureTMainForm.ConvertClipboard;
begin
TRE.SelectAll;
TRE.ClearSelection;
TRE.Lines.Add(Clipboard.AsText);
TRE.SelectAll;
TRE.Font.Name := 'Times New Roman'; //тут нужный шрифт
TRE.Font.Size := 12; // тут нужный размер
// или просто берите TRE.Font := MainMemo.Font;
TRE.SelAttributes.Charset := RUSSIAN_CHARSET;
TRE.CopyToClipboard;
end
Взято с
Корректная функция возведения в степень
Корректная функция возведения в степень
function power(Base, Exponent: Extended): Extended;
var ex: extended;
begin
power := 0;
if (exponent <> 0)
and (frac(trunc((1 / exponent) * 1000000) / 1000000) = 0)
and (base < 0) then
begin
if round(1 / exponent) mod 2 = 0 then exit;
ex := Exp(Exponent * Ln(-Base));
power := -ex;
end
else
begin
if Exponent = 0.0 then
power := 1.0
else if (Base = 0.0) and (Exponent > 0.0) then
power := 0.0
else if (Frac(Exponent) = 0.0) and (Abs(Exponent) <= MaxInt) then
power := IntPower(Base, Integer(Trunc(Exponent)))
else
power := Exp(Exponent * Ln(Base))
end;
end;
Теперь можем вычислить нечетный корень из отрицательного числа
Автор ответа: Mikel
Взято с Vingrad.ru
Краткая история Delphi
Краткая история Delphi
Delphi - это потомок Турбо Паскаля, который был выпущен для операционной системы CP/M в 1983 году. В феврале 1994 года Турбо Паскаль был перенесен на операционную систему MS-DOS.
На раннем этапе развития компьютеров IBM PC, Турбо Паскаль являлся одним из наиболее популярных языков разработки программного обеспечения - главным образом потому, что это было вполне серьезный компилятор, который, включая компилятор, редактор и все остальное, стоил всего $19.95 и работал на машине с 64 Kb оперативной памяти.
Под Windows - Турбо Паскаль был перенесен фирмой Borland в 1990 году. А самая последняя версия Borland Pascal 7.0 (имеющая теперь такое название), не считая Delphi, вышла в свет в 1992 году.
Разработка Delphi началась в 1993 году. После проведения beta-тестирования Delphi показали на "Software Development '95". И 14 февраля 1995 года официально объявили о ее продаже в США. В торговлю Delphi попала спустя 14 дней, 28 февраля 1995 года.
Источник:
Краткое описание Foxpro
Краткое описание Foxpro
Visual FoxPro последняя версия 8.0.
Производитель: Microsoft.
Домашняя страница: http://msdn.microsoft.com/vfoxpro/
После выпуска 7-ой версии Microsoft заявил о прекращении развития данного продукта, однако через год после этого была выпущена 8-ая версия.
Цена лицензионной 8-ой версии: полной версии по данным сайта производителя $649 US; для пользователей ранними версиями $349 US
В Москве 7-ая версия стоит ок. $600 US с доставкой по Москве.
Ограничения VFoxPro 7.0
Для людей имеющих представление, что такое БД привожу некоторые ограничения для 7-го Фокса (это лучше любых хар-тик), выводы сами напросятся. Для остальных распишу все позже.
Ограничения работы с базами
Максимум записей в файл таблицы...................................................1 миллиард
Максимальный размер файла таблицы.............................................2 гигабайта
Максимум символов в записи (MEMO).................................................65,500
Максимум символов в поле таблицы..................................................254
Максимальный размер числовых (и с плавающей точкой) полей....20
Максимум полей записей...................................................................255
Максимум таблиц открывается в одно время...................................255
(ограниченно памятью и доступными дескрипторами файла.)
Максимум байтов в индексном ключе в некомпактном индексе.....100
Максимум байтов в индексную ключе в компактном индексе.........240
Максимум открытых индексных файлов в таблице.........................неограниченно
Максимум открытых индексов во всех базах...............................неограниченно
Максимум отношений.......................................................................неограниченно
Максимальные поля, которые могут быть выбраны SQL SELECT........255
Ограничения языка
Минимальное значение целого числа............................-2,147,483,647
Максимальное значение целого числа............................2,147,483,647
Цифры точности в числовых вычислениях: VFoxPro может обрабатывать числа до 9007199254740992 (2^53) в точных вычислениях.
Значение по умолчанию переменных............................1,024
Максимум переменных.....................................................65,000
Максимум массивов...........................................................65,000
Максимум элементов в массив.........................................65,000
Максимум вложений DO...................................................128
Максимум вложенных структурированных команд программирования....384
Максимум транзакций......................................................5
Максимальная длина символьной переменой.................255
Максимум открытых окон.................................................неограниченно
Максимум открытых окон Browse....................................255
Максимум символов в макроподстановке........................8,192
Общие сведения.
FoxPro работает с таблицами формата *.dbf
Visual FoxPro 7.0 снабжено мощным набором мастеров, которые позволяют новичку достаточно быстро создать мощное работоспособное приложение, однако не могу рекомендовать использовать эту возможность людям, желающим, создать рациональное приложение, т.к. мастера используют навороченные библиотеки и не рационально используют память. Программы созданные с помощью мастеров очень грамозки.
FoxPro сильно интегрирован с SQL, позволяет вставлять блоки SQL-комманд непосредственно в тело основного кода и использовать в SQL-запросах собственные (фоксовские) функции. Что позволяет быстро и эффективно обробатывать большие базы, даже если таблицы не индексированы. Кроме того, FoxPro облодает собственными, очень мощными, и главное, удобными средствами работы с БД.
Наиболее крупные БД созданные на FoxPro (из мне известных):
База данных ГУВД г. Москвы.
База данных МГТС.
База данных Пенсионного фонда России.
Это основной язык написания программ Главного Научно-Вычеслительного Центра (ГНИВЦ) Министерства РФ по налогам и сборам
К достоинствам VFoxPro можно так же отнести: возможность создания составного индекса, работа с курсорами (виртуальными таблицами, не отличающимися от обычных, но исчезающих после завершения сеанса работа, т.е. не остаются ни в памяти ни на диске), возможность экспортировать\импортировать данные в\из XML, VFoxPro работает с другими базами по средствам драйвера ODBC, VFoxPro обладает высокой надежностью при работе с БД (в т.ч. и с индексами) и полность соответствует объявленным возможностям.
На VFoxPro можно создавать и клиент-серверные БД, однако в этой области VFoxPro значительно уступает большинству из известных серверов БД.
Резюме VFoxPro мощнейшее средство для работы с локальными базами данных, значительно превосходящее, по эффективности, все остальные системы БД.
Недостатки VFoxPro
Все вышесказанное относится к VFoxPro как средству разработки баз данных, однако на нем не представляется интересным создавать приложения не связанные с БД, хотя сам FoxPro является языком самодостаточным. Это связано с тем, что с VFoxPro поставляется очень убогий класс для работы с визуальными компонентами, а исходник этого класса закрыт. Поэтому разработчик ограничен в возможностях "украшать" свою программу. Следующее, в FoxPro не происходит объявления типа переменных, это лишает возможности контролировать правильность обращения к переменной и, главное, под переменную отводится максимальное кол-во памяти, поэтому программы написанные на VFoxPro очень ресурсоемкие. Большой недостаток VFoxPro - это крайне слабый конструктор отчетов, крайне осложняющий разработку приложения. Для работы программы, созданной на VFoxPro, необходимы библиотеки поддержки, что увеличивает размер поставляемой программы еще, примерно, на 4 Mb. Есть еще более мелкие недостатки.
Резюме Основными недостатками VFoxPro являются: большие требования к памяти, программами созданными на VFoxPro и слабые возможности по работе с визуальными компонентами.
Рекомендации для выбора Могу порекомендовать выбрать VFoxPro, тем кому требуется ввести и обрабатывать большие базы данных на локальных компьютерах или в небольших сетях. Т.к. VFoxPro позволяет создавать запросы, практически любой сложности. Разумеется не рекомендую использовать этот язык для составления больших серверных баз и для написания программ не связанных с ведением баз данных.
Обращаю внимание еще раз: FoxPro - это не только средство работы с базами данных, но это еще и язык программирования высокого уровня.
Типы данных Visual FoxPro
Тип данных Описание Размер Диапазон
Character Произвольный текст. 1 байт на символ; до 254 байтов Любые символы
Currency Денежная сумма. 8 байтов от -922337203685477.5808 до 922337203685477.5807
Date Хронологическая дата, состоящая из месяца, года и числа. 8 байтов от 01/01/100 до 12/31/9999
DateTime Хронологическая дата, состоящая из месяца, года, числа и времени. 8 байтов от 01/01/100 до 12/31/9999, плюс от 00:00:00 утра до 11:59:59 вечера
Logical Логическое значение истинности. 1 байт Истина (.T.) или Ложь (.F.)
Numeric Целое или с дробной частью число. 8 байтов в памяти;
от 1 до 20 байтов в таблице от
- .9999999999E+19
до
.9999999999E+20
Variant размер и диапазон принимает в соответствии с веденными данными
Типы данных полей таблиц Visual FoxPro
Тип поля Описание Размер Диапазон
Double Число с плавающей запятой двойной точности. 8 байтов от
+/-4.94065645841247E-324 до +/-1.79769313486232E308
Float Такое же, как Numeric. 8 байтов в памяти;
от 1 до 20 байтов в таблице от
- .9999999999E+19
до
.9999999999E+20
General Ссылка на OLE-объект. 4 байта в таблице. Ограничен только доступной памятью
Integer Целочисленные значения 4 байта от -2147483647 до 2147483646
Memo Ссылка на блок данных 4 байта в таблице Ограничен только доступной памятью
Character (Двоичный) Любые символьные данные, которые нужно сопровождать без изменения кодовых страниц 1 байт на символ до 254 байтов Любые символы
Memo (Двоичный) Любые memo-поля, которые нужно сопровождать без изменения кодовых страниц 4 байта в таблице Ограничен только доступной памятью
Вот пример работы с ADO
Зависимость от сервера не велика
conado=CREATEOBJECT(`adodb.connection`)
conado
TYPE(`conado`)
conado.open(`ora_ado`)
rd=CREATEOBJECT(`adodb.recordset`)
rd.Open(`select * from prof`,conado)
TYPE(`rd.Fields`)
rd.Fields(`pro`).Value
rd.MoveNext()
rd.Fields(1).Type
Пример работы через ODBC
con=sqlconnect('oradsn','scott','tiger')
if con>0 and sqlexec(con,'select * from scott.dept')>0
copy to dept
endif
если необходимо сделать параметризованный запрос:
m.depno=10
con=sqlconnect('oradsn','scott','tiger')
if con>0 and sqlexec(con,'select * from scott.dept where depno=? m.depno')>0
copy to dept
endif
Системные требования (для Visual FoxPro 7)
Процессор Pentium 133 или выше
Минимальный объем оперативной памяти - 64Mb, рекомендуется не менее 128Mb
Жесткий диск не менее 115Mb, до 200Mb, при полной установке.
Операционная система MS Windows98, ME, NT4, 2000, XP.
Видеорижим - SVGA.
Кроме того, необходимо, что бы на компьютере были установленны Internet Explorer 5.5 и Service Pack 1 (для Win2000).
Поддержка триггеров - да.
Поддержка хранимых процедур - да.
Поддержка транзакций - да.
Защита данных, шифрование - нет, шифрование данных осуществляется перед занесением данных в таблицу.
Возможность удалённого и Web администрирования - нет
Возможность импорта данных из
- MS Excell 2.0 - 97
- Lotus 1-3
- Paradox (до версии 4.0)
- Symphony
- FrameWork II
- MultiPlan 4.01
- RapidFile
Возможность экспорта данных в
- FoxBase+ (DBF)
- dBase IV (DBF)
- текстовый файл (txt)
- Lotus 1-2-3 1-A (WK1, WRK)
- Symphony (WR1, WRK)
- MultiPlan 4.01 (MOD)
System Data Format (SDF)
и некоторые другие, мало кому известные.
Наличие утилит для автоматизации операций для работы в командной строке, наличие собственных утилит для отладки запросов (выполнение SQL, построение плана выполнения кверей, профайлер и т.п.), утилиты для слежения за производительностью сервера. - Сам FoxPro
Автор Cashey (Vingrad.ru)
Краткое описание Paradox
Краткое описание Paradox
1) Краткое описание
- Парадокс - одна из самых старых локальных баз данных. Изначально развивалась фирмой Борланд (до 7й версии включительно), последние 3 версии: 8я, 9я и 10я выпущены фирмой Corel. В настоящее время судьба проекта не известна, но есть основания предполагать, что ни Борланд, ни Corel не имеют далекоидущих планов в отношении этой базы данных, а объёмы её продаж в чистом виде незначительны, впрочем она входит в поставку некоторых версий Corel Office.2) возможности
- количество баз данных на сервере - собственно база данных представляет собой каталог на диске который содержит файлы таблиц, индексов, view, форм и т.п. На одном компьютере может быть практически ничем не ограниченное количенство баз данных.
- количество таблиц в базе - неограниченно, но одновременно на одном компьютере не может быть открыто более 127 таблиц и 512 физических файлов
- размер таблиц - 255 полей, 2000000 записей в таблице (реально меньше, так как лимит блокировок исчерпывается быстрее, реальное количество записей где-то около полумиллиона),
10800 Bytes максимальный размер записи (без Memo/Blob полей), 127 вторичных индексов на таблицу,
256 Mb максимум в Blob поле
- количество пользователей и количество одновременных подключений - теоретический предел - 300 пользователей, но к этой информации надо относится с известной долей скептицизма, как и любая другая локальная база данных, парадокс в силу своей архитектуры очень плохо работает в многопользовательском режиме и реальное количество работающих одновременных подключений вряд ли может быть больше 10-20.
- наличие View - есть возможность создания View, которые представляют собой обычные текстовые файлы, отвечающие следующим требованиям:
- лежат в каталоге базы данных
- имеют расширение sql
- в качестве наполнения имеют обычное выражение SQL
Кроме того имеется другая разновидность View - файлы QBE (Query By Example) - очень древний, но довольно удобный способ работы с данными - альтернатива SQL, отличается гораздо большей гибкостью, чем SQL, но тем ни менее с развитием серверных баз данных отошедший в прошлое. Итак возможно создание текстового файла с расширением qbe и выражением qbe-запроса внутри, который можно использовать как View
- наличие SP, языка программирования - сам парадокс поддерживает хранимые процедуры на своём собственном языке, однако я не знаю, можно ли их использовать вне самого парадокса из других програм. Вот пример SP:
method pushButton (var eventInfo Event)
var
txt String
myNum Number
endVar
myNum = 123.321
txt = String(myNum)
msgInfo("myNum = ", txt)
endMethod
method pushButton (var eventInfo Event)
- наличие триггеров - нет
- репликация и синхронизация, перенос данных, средства backup - нет, однако, так как каждый объект базы данных является по сути отдельным файлом можно применять любые утилиты для Backup/Restore файлов.
- поддержка кластеров - нет
- поддержка XML, объектов, внешних процедур. - нет
- возможность взаимодействия между серверами, включая сервера других типов. - BDE имеет средства для взаимодействия между любыми базами данных, для которых есть BDE драйвера.
Вот пример SQL запроса к 2м базам данных:
Select T1.Field1, T2.Field2 From :Alias1:Table1 T1, :Alias2:Table2 T2
Where T1.Field3=T2.Field4
В данном случае не важно в какого типа базы данных под Alias1 и Alias2 - это могут быть базы данных любых разновидностей.
- поддерживаемые типы данных
Alpha - строка
Number - 15 знаков, плавающая запятая, плюс-минус 10 в 308 степени
Money - обычное поле с плавающей запятой, возможно прнименение различных форматов вывода
Short - целое от -32,767 до +32,767
Long Integer - oт -2147483648 дo 2147483647
BCD - плавающая запятая, повышенная точность, применяется для финансовых рассчётов
Date - для хранения даты
Time - для хранения времени
Timestamp - для хранения даты/времени
Memo
Formatted Memo
Graphic - вариант Blob поля
OLE - вариант Blob поля
Logical - True/False
Autoincrement
Binary - вариант Blob поля
Bytes - вариант Blob поля
- поддерживаемые конструкции SQL - поддерживаются все стандартные конструкции SQL: Select, Update, Insert, Create Table, Create Index, Alter Table, Alter Index, Join и т.д. Нет поддержки всторенных запросов типа: Select * From (Select * ...), нет поддержки использования переменных в запросах, нет возможности использования нескольких SQL statement в одном запросе.
- поддержка транзакций - есть
- системы репортинга, в том числе для Web - имеется встроенных не очень мощный репортинг, возможно использование других репортинговых систем: Crystal Report, Fast Report, Quick Report, Rave и д.р. Собственного репортинга ориентированного на Web нет.
- наличие собственного агента для выполнения заданий по расписанию - нет
3) Защита данных, шифрование - очень слабая защита паролем, шифрования нет, защита может предохранить только от неискушённого пользователя, так как присутствуют универсальные пароли, то профессионалом защита снимается за пару минут.
4) простота использования - в целом Парадокс достаточно дружелюбная среда. Администрирование и освоение трудностей не составляет.
- наличие встроенных средств администрирования с GUI интерфейсом - сам Парадокс - программа с довольно продуманным GUI интерфейсом, кроме того с BDE поставляется бесплатная программа Database Desktop, которая практически 90% дублирует функциональность самого Парадокса
- возможность удалённого и Web администрирования - нет
- сложность перевода проекта написанного под другую базу данных на рассматриваемую - Следует различать программы написанные именно при помощи самого Парадокса и программы на других языках программирования использующих таблицы формата парадокс.
а)Перевод програм с языка других баз данных на язык Парадокс достаточно трудоёмок и не стоит потраченных усилий.
б)Если же таблицы формата парадокс используются в третьесторонних программах то перевод с таблиц формата dbf на парадоксовский db обычно почти автоматический.
Перевод с формата db на dbf может быть связан с трудностями, так как db немного более "богатый" формат и могут быть нужны небольшие переделки в коде.
Перевод MS Access в Парадокс и наоборот будет связан с более значительными переделками.
Перевод с серверных баз данных на парадокс практически бессмысленен и подчас очень труден.
Перевод с парадокса на серверные базы данных обычно достаточно лёгок.
Итог: с Парадокса легко перейти на почти любые другие базы данных, обратное зачастую намного сложнее. Наибольшая совместимость с форматом dbf.
- сложность в установке и настройке - установка автоматическая, проблема может быть только одна - на больших винчестерах програма инсталляции может неправильно определять объём свободного места и не ставится (выход - временно занять свободное место оставив свободным только 1 гигабайт на время установки). Настройка не требуется. Практически не конфликтует с другим софтом
- насколько сложно администрирование сервера - администрирование практически не требуется
- наличие утилит для автоматизации операций для работы в командной строке - нет
- наличие собственных утилит для отладки запросов (выполнение SQL, построение плана выполнения кверей, профайлер и т.п.), утилиты для слежения за производительностью сервера. - Сам парадокс, Database Desktop
5) платформы
- на которых может работать сервер - MS DOS, MS Windows всех версий после Win 3.1
- на которых может работать клиент - MS DOS, MS Windows всех версий после Win 3.1
6) версии продуктов, краткая характеристика отличий
- наиболее широкораспространена версия 7 - под win32 платформу, последняя версия от Борланд. Последующие версии привносили практически лишь косметические изменения
7) способы доступа
- собственные API - есть DBI - API поставляемые с BDE
ODBC - поддержка только таблиц до 5й версии включительно, для более поздних версий - с ограничениями.
JDBC- есть
ADO (OLE DB) - фактически работает через драйвер ODBC
DAO - поддержка только таблиц до 5й версии включительно, для более поздних версий - с ограничениями.
BDE - "родной" и самый быстрый способ доступа
DBExpress - нет
Другие: - большое количество сторонних производителей компоеннтов, классов и библиотек для работы с форматами таблиц Парадокс.
оценка производительности - наиболее быстрый способ доступа - через BDE, на 1-2 порядка превосходит по скорости все остальные способы. Он же обеспечивает и максимальную функциональность.
- языки программирования - Парадокс является очень распространённым форматом для работы с базами данных самых различных языков программирования. Является "родным" для програмных сред от фирмы Борланд: Дельфи, СBuilder. Из этих сред работа с таблицами в формате Парадокса очень простая.
8) производительность
- монопольный доступ - очень высокая, особенно при локальном доступе. Например скорость выполнения Insert квери на локальной таблице при подключении BDE может достигать 2000-3000 кверей в минуту.
- для большого количества одновременных подключений - очень низкая, крайне желательен перевод на бузу данных с серверной архитектурой.
- для больших таблиц - при монопольном доступе весьма большая.
- для больших массивов данных при монопольном доступе - большая
9) цена - отдельно уже производителями не продаётся, вместе с Corel Office стоит порядка $100. Однако для написания програм которые работают с базами данных Парадокс сам Парадокс не требуется, достаточно иметь набор бесплатных утилит, таких как Database Desktop, тем более Парадокс не нужен для run-time среды таких програм.
10) явные недостатки и преимущества по сравнению с системами такого же класса - парадокс показывает практически такую-же или даже превосходящую производительность чем DBase/FoxPro, однако имеет значительно более слабую собственную среду программирования.
В сравнении с MS Access Парадокс показывает значительно более высокую производительность(примерно на порядок!), но проигрывает в мощности языка программирования и интегрированности с другими продуктами. Кроме того в отличие от MS Access развитие среды Парадокс практически прекращено.
11) предпочтительные проекты для использования
- с точки зрения количества данных - для проектов манипулирующих не более чем сотней тысяч записей.
- количества пользователей - 1-3 пользователя (одновременных подключений)
- уровня защищённости - не требующие защиты информации
- цены - для продуктов, которые не должны требовать дополнительных вложений в базы данных
распространённости - годится для распространяемых приложений, как весьма компактная и лёгкая в распространении бизнес-модель
Итог: - оптимально использование баз данных Парадокс для небольших проектов персонального пользования написанных на Дельфи или CБилдере
12) проекты в которых не рекомендуется использовать - для многопользовательских проектов, там где требуется высокий уровень защитыы данных и большие массивы информации.
13) Известные глюки и проблемы - система очень старая, что характеризует не только значительно устаревший интерфейс и отсутствие новомодных наворотов, но и очень низкое количество глюков. 2 основных глюка:
1. При многопользовательском доступе довольно частое возникновение corrupted table особенно если есть BLOB/Memo поля
2. При принудительном прерывании транзакции не освобождение ресурсов и как следствие "разбухание" служебных файлов.
14) Краткий обзор основных прилагаемых утилит и средств для обслуживания сервера
- Database Desktop - полноценная среда для управления любыми базами данных через BDE
- DataPump - утилита переноса данных из одной базы данных в другую
- BDE Administrator - программа управления BDE
15) Краткий обзор наиболее примечательных продуктов третьесторонних производителей для работы с данной базой данных. - огромное количество софта для работы с Парадоксовскими таблицами, практически можно найти программы на любой вкус и для любых целей.
Кросс-таблица через pivot-таблицу
Кросс-таблица через pivot-таблицу
Мне нужна помощь по реализации запроса кросс-таблицы в Delphi. У кого-нибудь имеется соответствующий опыт?
Использовать pivot-таблицу должен все тот-же общий механизм (относительно к любой базе данных SQL).
Предположим, что у нас есть данные продаж в таблице с полями Store, Product, Month, Sales, и вам необходимо отображать данные по продуктам за каждый месяц. (Примем, что поле 'month' для простоты имеет значения 1..12.)
Оригинальные данные примера:
Store Product Month Sales
#1 Toys 1 100
#2 Toys 1 68
#1 Toys 2 150
#1 Books 1 75
...
Желаемый отчет должен выглядеть похожим на этот:
Product January February March .....
Toys 168 150
Books 75 .....
Установите pivot-таблицу с именем tblPivot и 12 строками:
pvtMonth pvtJan pvtFeb pvtMar pvtApr ....
1 1 0 0 0 ....
2 0 1 0 0
3 0 0 1 0
4 0 0 0 1
.....
Теперь запрос, выполненный в виде:
select Product, January=sum(Sales*pvtJan),
February=sum(Sales*pvtFeb),
March=sum(Sales*pvtMar),
April=sum(Sales*pvtApr),...
where Month = pvtMonth
group by Product
даст вам информацию, опубликованную выше.
Поскольку pivot-таблица имеет только 12 строк, большинство SQL-движков сохранят результат в кэшовой памяти, так что скорость выполнения запроса весьма велика.
Взято из
Куки (Cookies)
Куки (Cookies)
Куки (Cookies)
Введение
Давайте вспомним, каким образом мы можем передавать CGI-программе параметры. При использовании метода GET параметры передаются в строке URL.
При использовании метода POST параметры передаются отдельно и не видны пользователю.
(отметим также, что в Internet Explorer 3 есть ошибка, из-за которой он ТЕРЯЕТ параметры при нажатии кнопки "Обновить").
Таким образом, нам не хватает возможности хранить информацию о передаваемых параметрах.
Что такое Cookie ?
"Cookie" - это небольшая порция информации, которая сохраняется на компьютере пользователя и привязана к конкретному URL. Когда браузер обращается к данному URL, он передает на удаленный сервер этот блок информации. В результате на сервере будет сформирована строка окружения HTTP_COOKIE, в которой содержится список всех cookies, которые относятся к данному URL. Перменная окружения HTTP_COOKIE будет содержать пары имен/значений параметров, разделенных символом ";" в следующем виде:
имя1=значение1;имя2=значение
;...Таким образом мы можем задавать сразу несколько параметров в одном cookie для данного URL.
Как создать Cookies ?
Давайте разберемся, как это делается! Для создания куков достаточно использовать HTTP-заголовок. Вспомним, каким образом задается тип передаваемого документа в заголовке: Content-type: text/html
Точно таким же образом в заголовке задаются и cookie! Просто добавляем еще одну строку:
Content-type: text/html
Set-Cookie: Name=Value
Таким образом, к примеру, можно сохранить на компьютере пользователя его имя и пароль, необходимые для входа на защищенный сайт или защищенную страничку. Многие сайты запрашивают у пользователя имя и пароль, передают их по методу POST, и затем сохраняют на компьютере полдьзователя в виде cookie.
Пример использования Cookies
По просьбам читателей я сделал программу Cook, демонстрирующую, как использовать cookies для авторизации пользователя. В архиве COOK.ZIP находится самая последняя версия моего модуля CGI и модуль Base64.
Курсоры в ADO
Курсоры в ADO
( перевод одноимённой статьи с сайта delphi.about.com )
В Delphi компоненты ADOExpress довольно приятны в использовании. Однако программирование компонент ADOExpress весьма отличается от традиционного Delphi программирования в компонентах TTable и TQuery, основанных на BDE. Естевственно, что если Вы привыкли к компонентам BDE dataset, то сразу же заметите различие в количестве возможностей и свойств, а так же в стиле программирования BDE и ADO.
В основе ADO лежит объект Recordset (aka Dataset). Этот объект является результатом Query команды (например, выражение SELECT компонента TADOQuery). Когда ADO-приложение получает строки из базы данных, то объект ADO Recordset формирует необходимую информацию и операции, допустимые для получаемых данных. При этом ADO использует курсоры, чтобы хранить набор строк для обработанной записи. Так же курсор содержит в себе текущую позицию в записи (recordset). Обычно, при разработке приложения, курсоры используются при создании записей, а так же при перемещении по записям (вперёд или назад).
В ADO курсоры имеют три функции. Первая, это тип курсора, определющая допустимые перемещения в пределах курсора, а так же будут ли отражаться изменения пользователей в записи. Вторая, это местоположение курсора, определяющая место хранения записи, в то время, пока курсор остаётся открытым. Третья, это тип блокировки курсора, которая определяет как ADO datastore будет блокировать строки, если Вам потребуется внести изменения.
Каждый раз когда мы будем открывать определённую запись ADO, то мы будем открывать её с определённым типом курсора.
Класс TCustomADODataSet содержит набор свойств, событий и методов, для работы с данными, доступными через ADO datastore. Все классы-потомки от TCustomADODataSet (такие как TADODataSet, TADOTable, TADOQuery, и TADOStoredProc) совместно используют некоторые общие свойства. В каждом из этих классов присутствуют три свойства, соответствующие функциям курсоров, описанным выше: CursorType, CursorLocation, и LockType. Давайте рассмотрим эти свойства по-подробнее.
CursorType
ADO содержит четы опции для данного типа курсора: dynamic, keyset, forward-only и static. Так как каждый тип курсора ведёт себя работает по разному, то несомненно Вы извлечёте пользу из каждого из этих видов курсоров.
Свойство CursorType указывает на то, каким образом Вы будете перемещаться по записям а так же какие изменения будут видны в записях базы данных, после того как Вы получите из неё данные. В Delphi классах ADO типы курсоров задаются в TCursorType.
ctDynamic
Позволит Вам видеть добавления, изменения и удаления, сделанные другими пользователями, а также позволит делать все типы перемещения по записи (Recordset) не полагаясь на закладки. Однако закладки можно использовать, если они поддерживаются. Для этого существует метод Supports в ADODataset, который сигнализирует о поддержке определённых типов операций. Следующее выражение позволяет определить, поддерживаются закладки или нет:
if ADOTable1.Supports(coBookmark) then ...
Если несколько пользователей одновременно вставляют (insert), апдейтят (update), или удаляют (delete) строки в базе данных, то лучше всего выбрать курсор dynamic.
ctKeyset
Ведет себя подобно динамическому курсору, за исключением того, что Вы не сможете видеть записи, которые добавляют другие пользователи, а так же не сможете получить доступ к записям, которые удаляются другими пользователями. Изменение данных другими пользователями будет все еще видимо. Этот тип всегда поддерживает закладки и поэтому позволяет все типы перемещения по записям (Recordset).
ctStatic
Обеспечивает статическую копию набора записей, чтобы использовать её для поиска данных и генерации отчётов. Данный тип всегда разрешает закладки и поэтому позволяет все типы движения по записям. Добавления, изменения, или удаления другими пользователями не будут видимы. Статический курсор ведет себя подобно компоненту BDE Query со свойством RequestLive установленным в False.
ctForward-only
Ведет себя идентично динамическому курсору за исключением того, что позволяет Вам пролистывать по записям только вперед. Это увеличивает производительность в ситуациях, где Вы необходимо делать только один проход по набору записей (Recordset).
Обратите внимание: если свойство CursorLocation в компоненте ADO dataset установлено в clUseClient, то Вы сможете использовать только опцию ctStatic.
Так же обратите внимание: что если Вы запросите тип курсора неподдерживаемый базой данных, то она может вернуть другой тип курсора. То есть если Вы пробуете установить CursorLocation в clUseServer и CursorType в ctDynamic, в базе данных Access, то Delphi заменит CursorType на ctKeyset.
CursorLocation
Свойство CursorLocation определяет, где будет создан набор записей (recordset) когда он будет открыт ? у клиента или на сервере.
Данные в клиентском (client-side) курсоре не сязаны постоянно ("inherently disconnected") с базой данных. ADO получает результаты запроса (все строки) и копирует данные клиенту перед тем, как Вы начнёте использовать их (в курсоре ADO). После того, как Вы сделаете изменения в наборе записей (Recordset), ADO преобразует эти изменения в запрос и отправляет этот запрос в Вашу базу данных через OLE DB. Клиентский (client-side) курсор ведёт себя подобно локальному кэшу.
В большинстве случаев, клиентский (client-side) курсор предпочтителен, потому что перемещения и обновления быстрее и более эффективны. Но, соответственно, увеличивается сетевой трафик при возвращении данных клиенту.
Использование серверного (server-side) курсора означает получение только необходимых записей. Естевственно, что на сервер падает большая нагрузка. Серверные (Server-side) курсоры полезны при вставке, модификации, удалении записей. Данный тип курсоров иногда обеспечивает лучшую производительность чем клиентский курсор, особенно когда сеть перегружена.
При выборе типа курсора Вам необходимо продумать множество факторов, таких как: будет ли у Вас большое количество обновлений либо Вы будете производить только выборку из базы данных; будете ли Вы использовать ADO как настольное приложение или Ваше приложение будет Internet-ориентированным; размер получаемых данных и т.д. Так же есть некоторое ограничения: например, MS Access не поддерживает динамических курсоров; вместо этого он использует keyset. Некоторые средства доступа к данным автоматически мастабируют свойства CursorType и CursorLocation, в то время как другие генерируют ошибку при использовании неподдерживаемых CursorType или CursorLocation.
LockType
Свойство LockType сообщает провайдеру о блокировках, которые будут помещены в записи в процессе редактирования. Блокировка позволяет предотвратить чтение данных одним пользователем в то время как другой пользователь изменяет эти данные, а так же не дать пользователю изменить данные, если они были изменены другим пользователем.
Такой эффект наблюдается в базе данных Access, которая блокирует некоторые соседние записи. Дело в том, что Access использует так называемую стратегию фиксации страницы. Поэтому, если пользователь редактирует запись, то другой пользователь уже не сможет получить доступ к изменению данной записи и, даже не сможет модифицировать ближе стоящие записи (до или после неё).
В Delphi, для этой цели используется TADOLockType в которой указывается тип блокировки, которая будет использоваться. Вы можете управлять строкой и блокировкой страницы, устанавливая соответствующую опцию блокировки курсора. Чтобы использовать определенную схему блокировки, провайдер и тип базы данных должны поддержать эту схему.
ltOptimistic
Оптимистическая блокировка блокирует запись только в том случае, если она была физически изменена. Этот тип блокировки полезен, если существует очень маленький шанс того, что второй пользователь может модифицировать строку в интервале между тем, когда курсор открыт, и когда строка окончательно модифицирована. Текущие значения в строке сравниваются со значением полученным когда строка была последний раз выбрана.
ltPessimistic
Пессимистическая блокировка блокирует каждую запись, до тех пор пока она находится в процессе редактирования. Эта опция заставляет ADO устанавливать исключительную блокировку на строку, когда пользователь делает любое изменения в любом столбцу записи. Компоненты ADOExpress непосредственно не поддерживают пессимистическую блокировку записей, потому что сама ADO не имеет возможности произвольно блокировать данную запись и до сих пор поддерживает навигацию в другие записи.
ltReadOnly
Данная блокировка просто не позволяет редактировать данные. Полезна в тех случаях, когда Ваше приложение должно временно предотвратить изменение данных, при этом чтение данной записи разрешено. Самый идеальный способ использования данной блокировки для создания отчётов, если установить CursorType как ctForwardOnly.
ltBatchOptimistic
Блокировка BatchOptimistic используется в клиентских курсорах. Наборы записей с данным курсором апдейтятся локально и все изменения отправляются в базу данных пакетами.
Взято с Исходников.ru
Kylix
Kylix
Cодержание раздела:
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
См. также статьи в других разделах:
Kylix 3 encounters declaration syntax errors in TIME.H
Kylix 3 encounters declaration syntax errors in TIME.H
I am using Kylix 3, and get declaration syntax errors in TIME.H when attempting to compile any project. How can I solve this problem?
The TIME.H declaration syntax errors can be resolved by going into the Project Options and moving the reference to /usr/include up in the Include path. Preferably, /usr/include should be moved to the very first position in the ordered Include path.
The exact cause of this problem is not yet known, but it could be related to Kylix 3 finding a different version of TIME.H elsewhere on the system. For reference, Kylix 3 contains four instances of TIME.H, in the following locations:
/usr/include/linux
/usr/include/bits
/usr/include/sys
/usr/include
Kylix Tutorial. Часть 1. Установка
Kylix Tutorial. Часть 1. Установка
Итак, свершилось, проходя мимо ларька с CD я увидел компакт с этикеткой синего цвета и магической надписью Kylix. Вернее диска было два и оба были немедленно куплены.
Беглое изучение их показало, что один содержит непосредственно Kylix, а второй дополнительные компоненты и утилиты третьих фирм и Interbase 6. По хорошей традиции пиратами была слита самая "продвинутая" версия Kylix Server Developer.
Ставить Kylix я пробовал под RedHat Linux 7.0.
Для установки нам потребуется
а) Компьютер с установленной ОС Linux
б) В составе Linux должны быть установлены графические оболочки GNOME и / или KDE (возможно Kylix будет работать и с другими, но эти две наиболее распространенны и Borland гарантирует работу под ними). Лично я пользуюсь KDE, посему про нее и буду рассказывать.
в) Права пользователя root
Первым делом необходимо установить патч на библиотеку glibc, по каким-то причинам не устроившую фирму Borland. Для этого и необходимо иметь права root. Заплатки (patches) сложены в директории /patches CD-ROM. Для Redhat 7.0 необходимо перейти в директорию <путь к CD>/patches/glibc_redhat/7.0. Установка патчей выполняется командами
rpm -Uvh glibc-[2c]*
rpm -Fvh glibc-[dp]* nscd-*
Возможно также Вам придется установить пакет libjpeg либо из дистрибутива RedHat либо из папки <путь к CD>/patches/jpeg6.2.0
Далее установка может проводиться как под аккаунтом root, так и под простым пользователем. Для инсталляции необходимо запустить на выполнение скрипт setup.sh. из корня CD.Графическая оболочка установки сделана удобно и интуитивно понятна. По умолчанию установка предлагается в домашнюю директорию пользователя, однако, чтобы при наличии нескольких пользователей лучше устанавливать в /usr/kylix, чтобы Kylix был доступен всем.
После установки запуск IDE Kylix можно выполнить
1) из командной строки: <путь инсталляции>/bin/startkylix
2) из выпадающего меню KDE (аналог кнопки Пуск в Windows). Меню Borland Kylix/Kylix
3) из выпадающего меню KDE (аналог кнопки Пуск в Windows). Меню /RedHat/ Borland Kylix/Kylix
Далее обнаруживается следующая неприятная вещь: в среде разработки программы компилируются и работают, однако при запуске вне IDE возникают ошибки. Лечится это так
1. Прописать пути к библиотекам. В файле .bash_profile в строку PATH добавить путь к директории bin Kylix-а. Например, если он установлен в /usr/kylix - то добавить надо путь /usr/kylix/bin.
2. В файл /etc/ld.so.conf добавить строчку с путем к libqtintf.so (в нашем примере /usr/kylix/bin)
3. запустить ldconfig.
Автор: Mike Goblin
Взято из
с разрешения автора.
Kylix Tutorial. Часть 2. Работа с базами данных через dbExpress.
Kylix Tutorial. Часть 2. Работа с базами данных через dbExpress.
Фирма Borland в Kylix и Delphi 6 реализовала новый движок для работы с базой данных dbExpress. Данный движок предназначен для работы с серверными БД. На сегодняшний день поддерживаются MySQL, Oracle, Interbase, DB2. К сожалению, на момент выпуска Kylix он работал не со всеми версиями MySQL. В частности, он не заработал с MySQL 3.23.22-beta. За неимением Oracle и DB2 я пользовался Interbase 6, находившемся на втором диске дистрибутива.
Архитектура доступа к данным
В самом виде приложение для работы с базами данных может быть представлено в следующем виде:
Ничего принципиально нового здесь нет, по сравнению с Delphi. Но это только на первый взгляд. В dbExpress датасеты делятся на два вида:
1. Клиентский датасет (client dataset)
2. Однонаправленные датасеты (unidirectional dataset)
Клиентский датасет хранит выбранные записи в памяти. Это позволяет осуществлять навигацию в любом направлении, фильтровать записи, кешировать изменения итд. Именно данный вид используется для отображения данных пользователю.
Однонаправленные запросы не кешируют данные. Передвигаться по ним можно только в направлении указанном в конструкции ORDER BY SQL запроса, данные не могут быть изменены. Однако они предоставляют быстрый доступ к большим массивам записей.
Компоненты закладки dbExpress
Посмотрим, что приготовила нам фирма Borland по части компонентов на закладке dbExpress
СвойстваОписание SQLConnection Компонент для организации связи с сервером базы данных. Аналог Database в BDE. Позволяет управлять параметрами соединения с сервером БД, такие как путь к базе данных, имя и пароль пользователя итд. Connected:booleanПризнак установления соединения с БД. True - соединение активно. ConnectionName: stringИмя конфигурации, содержащей параметры соединения. Аналог AliasName в TDatabase для BDE DriverName: stringИмя драйвера для соединения. (DB2, Interbase,Oracle, MySQL). Устанавливается автоматически при установке св-ва ConnectionName KeepConnection: booleanПоддерживать соединение с сервером БД, если в приложении нет активизированных датасетов. LibraryName: stringИмя библиотеки, содержащей драйвер для связи с сервером БД LoadParamsOnConnect: booleanЗагружать ли параметры соединения, ассоциированные с именем соединения, перед установкой соединения в run time. Полезно в случае когда параметры соединения могут быть изменены вне приложения или меняются в design time LoginPrompt: BooleanЗапрашивать логин и пароль при соединении Name: TComponentName Имя компонента Params: TStringsПараметры соединения TableScope: TTableScopesПараметры видимости таблиц
TsSynonym - видеть синонимы
TsSysTable - видеть системные таблицы
TsTable - видеть таблицы
TsView - видеть просмотры VendorLib: stringИмя библиотеки с клиентской частью БД SQLDataSet Однонаправленный датасет общего назначения. Active: booleanАктивность датасета CommandText: stringТекст команды (запроса) на получение или манипуляции с данными CommandType: TSQLCommandTypeТип датасета
CtQuery - SQL запрос
CtTable - таблица, автоматически генерируется запрос на выборку всех записей по всем полям
CtStoredProc - хранимая процедура DataSource: TDataSourceИсточник данных для мастер датасета MaxBlobSize: integerМаксимальный размер BLOB полей ObjectView: BooleanВключить иерархическое представление для вложенных полей ParamCheck:BooleanОбновлять список параметров при изменении текста команды Params:TparamsСписок параметров команды SortFieldNames: stringСписок полей для сортировки датасета, поля разделяются точкой с запятой. Действует для CommandType ctTable SQLConnection: TSQLConnectionИмя компонента SQLConnection через который будет происходить работа с БД Tag: integerТэг SQLQuery Запрос к БД (однонаправленный) Active: booleanАктивность запроса DataSource: TDataSourceИсточник данных для мастер датасета MaxBlobSize: integerМаксимальный размер BLOB полей ObjectView: BooleanВключить иерархическое представление для вложенных полей ParamCheck:BooleanОбновлять список параметров при изменении текста запроса Params:TparamsСписок параметров запроса SQL:TStringsТекст запроса SQLConnection: TSQLConnectionИмя компонента SQLConnection через который будет происходить работа с БД Tag: integerТэг SQLStoredProc Хранимая процедура (в случае получения данных однонаправленная) Active: booleanАктивность хранимой процедуры MaxBlobSize: integerМаксимальный размер BLOB полей ObjectView: BooleanВключить иерархическое представление для вложенных полей ParamCheck:BooleanОбновлять список параметров при изменении процедуры Params:TparamsСписок параметров процедуры SQLConnection: TSQLConnectionИмя компонента SQLConnection через который будет происходить работа с БД Tag: integerТэг SQLTable Таблица базы данных (однонаправленный датасет) Active: booleanАктивность таблицы IndexFieldNames: stringСписок полей сортировки (через точку с запятой) IndexName: stringИмя индекса сортировки. Возможно использование либо IndexName или IndexFieldNames MasterSource: TdataSourceМастер источник данных для организации отношений главный-подчиненный (master-detail) MasterFields:stringПоля связи главный-подчиненный MaxBlobSize: integerМаксимальный размер BLOB полей ObjectView: BooleanВключить иерархическое представление для вложенных полей SQLConnection: TSQLConnectionИмя компонента SQLConnection через который будет происходить работа с БД TableName: stringИмя таблицы БД из которой будут выбраны данные Tag: integerТэг SQLMonitor Организация наблюдения за работой компонентов доступа к данным Active: booleanАктивность монитора AutoSave: BooleanАвтоматическое сохранения журнала событий в файл, указанный в FileName FileName: stringИмя файла для хранения журнала событий SQLConnection: TSQLConnectionИмя компонента SQLConnection через который будет происходить работа с БД Tag: integerТэг TraceList:TstringsЖурнал событий SQLClientDataSet Клиентский датасет общего назначения Active: booleanАктивность датасета Aggregates: TaggregatesСписок доступных агрегатов AggregatesActive: booleanВычисление агрегатов AutoCalcFields: booleanГенерировать событие OnCalcFields и обновлять Lookup поля True -
· при открытии датасета
· при переходе датасета в состояни dsEdit
· Передача фокуса ввода другому компоненту или другому столбцу (для сетки) при наличии изменений в текущей ячейке
False
· при открытии датасета
· при переходе датасета в состояни dsEdit
· Запись извлекается из БД CommandText: stringТекст команды для выполнения (SQL запрос). При установке св-ва FileName данное св-во игнорируется При сбросе флага poAllowCommandText в св-ве Options также текст команды игнорируется CommandType: TSQLCommandTypeТип датасета
CtQuery - SQL запрос
CtTable - таблица, автоматически генерируется запрос на выборку всех записей по всем полям
CtStoredProc - хранимая процедура ConnectionName: stringИмя конфигурации, содержащей параметры соединения. Аналог AliasName в TDatabase для BDE Constraints: TConstraintsОграничения на значения на уровне одной записи DBConnection: TSQLConnectionИмя компонента SQLConnection через который будет происходить работа с БД DisableStringTrim: booleanУдалять конечные пробелы в строковых полях при их вставке БД FetchOnDemand: booleanПолучать данные по мере необходимости FieldDefs: TFieldDefsОпределения полей FileName: stringИмя файла для сохранения кеша данных Filter: stringФильтр Filtered: BooleanВключение фильтрации FilterOptions: TFilterOptionsПараметры фильтрации IndexDefs: TindexDefsОпределения индексов IndexFieldNames: stringСписок полей сортировки (через точку с запятой) IndexName: stringИмя индекса сортировки. Возможно использование либо IndexName либо IndexFieldNames MasterSource: TdataSourceМастер источник данных для организации отношений главный-подчиненный (master-detail) MasterFields:stringПоля связи главный-подчиненный ObjectView: BooleanВключить иерархическое представление для вложенных полей Options: TProviderOptionsПараметры работы с данными PacketRecord: integerКоличество записей в одном пакете данных
-1 - все
>0 - количество
0 - включать в пакет только метаданные Params: TparamsЗначение параметров для выборки данных ReadOnly: BooleanДоступ только для чтения Tag: integerТэг UpdateMode: TUpdateModeСпособ поиска записи при записи изменений
UpWhereAll - использовать все поля
UpWhereChanged - ключевые поля+старые значения измененных полей
UpWhereKeyOnly - только ключевые поля
Попробуем написать простейшее приложение для просмотра данных из базы в /usr/ibdb (будем считать что папка уже создана). Для этого выполним следующие шаги:
1. Создадим базу данных в Interbase 6. У меня он проинсталировался в /opt/interbase .
1.1 Запустим сервер /opt/interbase/bin/ibguard &
1.2 Войдем в оболочку isql - /opt/interbase/bin/isql
1.3 Введем SQL запросы на создание БД и таблицы users:
createdatabase '/usr/ibdb/test.gdb';
create table users( ID integer not null primary key, NAME varchar(20));
commit;
quit;
Если все выполнено правильно - то в папке /usr/ibdb появится файл test.gdb.
2. Создадим новое приложение. Меню File/NewApplication в IDE Kylix
3. На главной форме приложения разместим с закладки dbExpress компоненты: SQLConnection и SQLDataSet. SQLConnection - это "соедиение" с базой данных, т.е с его помощью можно управлять параметрами соединения, такими как тип драйвера, имя пользователя и пароль. Двойной щелчок левой кнопкой мыши на SQLConnection1 вызовет окно работы с соединениями.
Name - test_connect. После добавления установим следующие параметры:
Database - /usr/ibdb/test.gdb
ServerCharSet - win1251
Кнопкой "ОК" закроем диалог. Свойство Connected установим в True. В диалоге запроса пароля введем пароль masterkey. Соединение установлено.
Компонент SQLClientDataSet1 будет извлекать данные из таблицы users. Почему мы используем его а не SQLQuery? Ответ очень прост - SQLQuery - однонаправленный датасет. Поэтому он не может обеспечить навигации в обе стороны и редактирование данных.
Свойство DBConnection компонента SQLClientDataSet1 установим равным SQLConnection1. Введем запрос на выборку данных из таблицы users - select * from users - в св-во CommandText, либо воспользуемся диалогом для данного св-ва. Активизируем запрос, установив св-во Active в True.
Далее с закладки Data Access на форму положим компонент TDataSource. Данный компонент делает данные из датасетов доступными для отображения в пользовательских элементах управления (сетках итд). Его св-во DataSet установим в ClientDataSet1.
Перейдем на закладку DataControls и с нее разместим на форме сетку данных DBGrid и DBNavigator. Для обоих компонентов св-во DataSource установим в DataSource1. При этом в DBGrid1 появится заголовок с наименованиями полей таблицы users.
Теперь можно запустить приложение на выполнение (F9 однака).
Автор: Mike Goblin
Взято из
с разрешения автора.
Kylix Tutorial. Часть 3. Работа с базами данных через dbExpress. Коннект - есть коннект.
Kylix Tutorial. Часть 3. Работа с базами данных через dbExpress. Коннект - есть коннект.
Как говорилось раньше, SQLConnection предназначен для
1. Подключения к базе данных с заданными параметрами
2. Управления параметрами соединения и драйвера БД.
3. Получения списка установленных драйверов баз данных и доступных соединений
4. Создания, удаления, редактирования соединений.
5. Управление транзакциями
6. Выполнение SQL операторов
7. Получение метаданных
Подключения к базе данных
Подключение к базе данных осуществляется установкой св-ва Connected в True, либо вызвом метода Open. Отключение - установка Connected в False или вызов метода Close. Перед подключением необходимо установить имя соединения (св-во ConnectionName).
Пример установления соединения в run-time:
SQLConnection1.Connected:=false;
SQLConnection1.ConnectionName:='test_connect';
SQLConnection1.Connected:=true;
Управления параметрами соединения и драйвера БД.
Значения параметров по умолчанию для соединений хранятся в файле <домашняя директория пользователя>/.borland/dbxconnections или при отсутствии файлов по указанному пути в /usr/local/etc/dbxconnections.conf. Он представляет собой текстовый файл формата ini файлов. То есть содержит набор секций, заключенных в квадратные скобки и параметров в формате Имя параметра=значение параметра. Вот кускок этого файла:
[DB2Connection]
DriverName=DB2
BlobSize=-1
Database=DBNAME
Для драйверов настройки по умолчанию хранятся по указанным выше путям в файле dbxdrivers
Для получения настроек, в принципе можно анализировать содержимое этих файлов, написав собственный код, однако гораздо удобнее пользоваться стандартными решениями. Свойство Params типа TStrings предоставляет нам доступ к параметрам соединения.
Пример - установка имени и пароля пользователя:
SQLConection1.Params.Values['User_Name']:='SYSDBA';
SQLConection1.Params.Values['Password']:='masterkey';
Свойство LoadParamsOnConnect типа Boolean позволяет управлять автоматической установкой св-в DriverName и Params в значения по умолчанию для данного соединения перед установкой соединения. Данное св-во полезно лишь во время выполнения приложения при смене имени соединения. Во время разработки загрузка установка св-в по умолчанию происходит автоматически.
Получения списка установленных драйверов баз данных и доступных соединений
Способ №1: анализировать содержимое файлов dbxconnections и dbxdrivers. Неудобно надо писать много собственного кода (который уже написан программистами Borland).
Способ №2. Использование функций из модуля SqlExpr
GetDriverNames(List: TStrings; DesignMode:Boolean = True) - получение списка доступных драйверов.
List - список для заполнения именами драйверов
DesignMode - в каком режиме разработки (true) или выполнения программы (false) вызывается функция.
Пример получение списка драйверов dbExpress:
procedure TForm1.Button2Click(Sender:TObject);
begin
// cb_drivers - это комбобокс для отображения списка драйверов
GetDriverNames(cb_drivers.Items, false);
end;
procedure GetConnectionNames(List: TStrings; Driver:string = ''; DesignMode:Boolean = True);
Получение списка доступных соединений.
List - список для заполнения именами драйверов
Driver - имя драйвера, к которому подключаются соединения
DesignMode - в каком режиме разработки (true) или выполнения программы (false) вызывается функция.
Пример получение списка соединений доступных для INTERBASE:
procedure TForm1.Button1Click(Sender:TObject);
begin
// cb_conn - это комбобокс для отображения списка драйверов
GetDriverNames(cb_conn.Items, 'INTERBASE', false);
end;
Использование данных функций удобно, но не дает полного контроля за соединениями. Сами эти функции в своей работе используют интерфейс IConnectionAdmin.
Способ №3 Использование интерфейса IConnectionAdmin (определен в модуле DBConnAdmin). Данный способ дает наиболее мощные возможности по работе с соединениями.
Пример получение списка драйверов:
Var
ConnAdm: IConnectionAdmin;
Begin
// Получаем ссылку на интрефейс
ConnAdm:=GetConnctionAdmin;
ConnAdm. GetConnectionNames(cb_drivers);
End;
Методы интерфейса IConnectionAdmin;
IConnectionAdmin = interface
// Получение имен драйверов доступа к серверам БД
function GetDriverNames(List: TStrings): Integer;
// Получение параметров драйвера по умолчанию
function GetDriverParams(const DriverName: string; Params: TStrings): Integer;
// Получение имен файлов библиотек
procedure GetDriverLibNames(const DriverName: string;
var LibraryName, VendorLibrary: string);
// Получание списка соединений, доступных для заданного типа драйвера
function GetConnectionNames(List: TStrings; DriverName: string): Integer;
// Получение параметров соединения по умолчанию
function GetConnectionParams(const ConnectionName: string; Params: TStrings): Integer;
// Получение значения параметра соединения
procedure GetConnectionParamValues(const ParamName: string; Values: TStrings);
// Добавление нового соединения
procedure AddConnection(const ConnectionName, DriverName: string);
// Удаление соединения
procedure DeleteConnection(const ConnectionName: string);
// Изменение параметров соединения по умолчанию
procedure ModifyConnection(const ConnectionName: string; Params: TStrings);
// Изменение имени соединения
procedure RenameConnection(const OldName, NewName: string);
// Изменение параметров драйвера по умолчанию
procedure ModifyDriverParams(const DriverName: string; Params: TStrings);
end;
Создания, удаления, редактирования соединений.
Наверно, Вы уже догадались, что данные операции выполняются методами интерфейса IconnectionAdmin. Можно также и руками поправить файлы с конфигурациями, а можно двойным щелчком мыши на компоненте SQLConnection открыть диалог редактирования - выбирайте, что Вам удобнее.
Управление транзакциями
Вообще говоря, можно подтверждать или откатывать транзакции, передавая SQL запросы commit или rollback. Однако в SQLConnection определены специальные методы для управления транзакциями.
Начать новую транзакцию можно вызовом процедуры
Procedure StartTransaction( TransDesc: TTransactionDesc);
В качестве параметра передается структура с описанием транзакции, поля структуры:
TransactionID: LongWord - уникальный (уникальность обеспечивает программист) идентификатор транзакции.
GlobalID:LongWord - как написано в доке, используется для транзакций в Oracle, зачем пока не ясно
IsolationLevel - уровень изоляции транзакции, значения
xilDIRTYREAD - "грязное" чтение, транзакция видит все изменения других транзакций, даже если они еще не подтверждены
xilREADCOMMITES - видны только результаты подтвержденных транзакций, но изменения, сделанные другими после старта транзакции (во время ее выполнения) не видны в транзакции.
xilREPEATABLEREAD - гарантируется состоятельность полученных данных, даже если другие транзакции подтверждаются после старта текущей транзакции.
XilCUSTOM - специфический для данного сервера БД уровень изоляции, значение уровня изоляции определяется членом структуры CustomIsolationLevel. На данный момент не поддерживается в dbExpress
CustomIsolationLevel:LongWord - см выше
Завершаться транзакции, как известно, могут либо подтверждением, либо откатом изменений.
Подтверждение
Procedure Commit (TransDesc: TTransactionDesc);
TransDesc - структура с описанием подтверждаемой транзакции
Откат
Procedure Rollback (TransDesc: TTransactionDesc);
TransDesc - структура с описанием откатываемой транзакции
Другие методы и свойства, связанные с управлением транзакциями
TransactionLevel: SmallInt - идентификатор текущей транзакции, совпадает с TransactionID в описании транзакции
TransactionSupported : LongBool - поддерживает ли БД транзакции
InTransaction: Boolean - открыта ли транзакция?
Выполнение SQL операторов
В SQLConnection определены два метода для выполнения запросов к БД.
Function Execute (const SQL: string; Params:TParams; ResultSet: Pointer = nil):integer;
Выполняет запрос определенный в параметре SQL c параметрами, переданными в Params. Если в результате запроса были получены записи, то в ResultSet возвращается указатель на TCustomSQLDataSet, содержащий полученные записи. Возвращает количество полученных записей.
Если запрос не содержит параметров и не возвращает записей проще использовать вызов
Function ExecuteDirect(const SQL: string):LongWord;
Возвращает 0 при успешном завершении и код ошибки в случае неудачи.
Получение метаданных
В SQLConnection определен ряд методов для получения метаданных.
Получение списка таблиц и списка полей в таблице
Procedure GetTableNames(List: TStrings; SystemTables: boolean = false);
Если установить SystemTables в True будут выбраны только системные таблицы, в обратном случае набор таблиц определяется установками св-ва TableScope.
ВНИМАНИЕ: я пробовал устанавливать в TableScope все элементы, но при этом не получал списка таблиц (должны выбираться и системные и обычные таблицы)- кривые руки? Скорее глюк. Может Вам повезет больше.
Список полей может быть получен вызвом метода GetFieldNames
В SQLConnection он определен как
Procedure GetFieldNames(const TableName: string; List: TStrings);
Получение списка процедур и их параметров
GetProcedureNames и GetProcedureParams
Получение списка индексов
GetIndexNames
Автор: Mike Goblin
Взято из
с разрешения автора.
Kylix Tutorial. Часть 4. Использование однонаправленных наборов данных
Kylix Tutorial. Часть 4. Использование однонаправленных наборов данных
Однонаправленные наборы данных предоставляют механизм доступа для чтения данных из таблиц сервера БД с помощью SQL команд. Они созданы для быстрого и "легковесного" доступа к информации сервера БД с минимальной загрузкой последнего. Однонаправленные наборы данных посылают команды серверу БД и в случае наличия набора записей, получают однонаправленный курсор для доступа к этим записям. Однонаправленные наборы данных не буферизируют полученные данные в памяти, что делает их более быстрыми и менее ресурсоемкими по сравнению с другими типами наборов данных. Однако, из-за отсутствия буфера записей, однонаправленные наборы данных менее гибки. Многие из возможностей, объявленных в TDataSet либо не реализованы, либо вызывают генерацию исключительных ситуаций. Например:
· Из методов навигации поддерживаются только First и Next. Большинство других методов вызывают исключения. Некоторые, такие как методы работы с закладками (Bookmarks), представляют собой просто заглушки.
· Нет встроенной поддержки для редактирования записей, поскольку для этого требуется буферизация.
· Свойство CanModify всегда равно False, и попытки перевода датасета в режим редактирования всегда приводят к неудаче. Редактирование данных, однако, может осуществляться с помощью SQL команды UPDATE или при помощи подключения клиентского набора данных.
· Отсутствует поддержка фильтров, поскольку это требует буферизации. При попытке фильтрации вызывается исключение. Все ограничения на диапазон выбираемых записей должны содержаться в SQL команде.
· Отсутствует поддержка lookup полей, т.к при этом необходимо буферизировать возможные значения такого поля.
Однако отсутствие буферизации делает однонаправленные наборы данных быстрыми, простыми в реализации и распространении. На закладке dbExpress палитры компонентов представлены четыре типа однонаправленных наборов данных: TSQLDataSet, TSQLQuery, TSQLTable и TSQLStoredProc.
TSQLDataSet наиболее общий из всех четырех. Может использоваться для выборки любых данных или выполнения SQL команд. Данный компонент рекомендуется использовать для работы через dbExpress.
TSQLQuery можно использовать так же как и TSQLDataSet. Главное отсутсвии поддержки хранимых процедур (хотя многие сервера позволяют вызывать хранимые процедуры из запросов, но каждый делает это по-своему, стандартный синтаксис отсутствует). Данный компонент присутствует, в основном, для обеспечения совместимости при переносе приложений из Windows.
TSQLTable компонент, дающий доступ ко всем записям и полям таблицы. Данный компонент присутствует, в основном, для обеспечения совместимости при переносе приложений из Windows.
TStoredProc компонент доступа к хранимым процедурам сервера. Данный компонент присутствует, в основном, для обеспечения совместимости при переносе приложений из Windows.
Подключение к базе и открытие. Управление транзакциями.
Так как TSQLDataSet рекомендован в качестве универсального датасета доступа к данным далее мы его и рассмотрим, хотя многие моменты, как Вы заметите, будут верны для всех однонаправленных датасетов. Для получения данных с SQL сервера необходимо подключить однонаправленный датасет к БД, задать комаду и активизировать (открыть) его.
Для подключения к БД необходимо установить свойство SQLConnection равным имени компонента TSQLConection, который обеспечивает подключение к базе. В инспекторе объектов на этапе разработки автоматически отображается выпадающий список доступных подключений.
Текст команды необходимо указать в свойстве CommandText, интерпретация текста команды зависит от типа команды, указанного в свойстве CommandType. TSQLDataSet поддерживает 3 типа команд:
· ctQuery - в свойстве CommandText должен присутсвовать SQL запрос;
· ctStoredProc - в свойстве CommandText указывается имя хранимой процедуры;
· ctTable - в свойстве CommandText указывается имя таблицы из которой будут выбраны записи.
Активизация датасета в случае выполнения команды, возвращающей набор данных, (запросы SELECT, выборка таблицы итд) производится установкой свойства Active в True, либо вызовом метода Open. В обратном случае, если набор данных при выполнении команды не формируется (не путайте с пустым набором данных), нужно использовать метод ExecSQL.
Управление транзакцией, в которой осуществляется работа с сервером БД, однонаправленный датасет реализует через public свойство TransactionLevel. При одновременном открытии нескольких транзакций в компоненте TSQLConnection, можно установить TransactionLevel в значение идентификатора желаемой транзакции (поле TransactionID в структуре описания транзакции TTransactionDesc) при этом выполнение команд будет происходить в заданной транзакции.
Примеры:
//Выполнение запроса возвращающего набора данных
begin
SQLDataSet1.CommandType:=ctQuery;
SQLDataSet1.CommandText:='select * from MyTable';
SQLDataSet1.ExecSQL;
end;
// Выполнение запроса не возвращающего набора данных
begin
SQLDataSet1.CommandType:=ctQuery;
SQLDataSet1.CommandText:='update MyTable set StrField1 = '''+Edit1.Text+''' where id = 5';
SQLDataSet1.ExecSQL;
end;
// Выполнение запроса возвращающего таблицу с SQL сервера.
begin
SQLDataSet1.CommandType:=ctTable;
SQLDataSet1.CommandText:='MyTable';
SQLDataSet1.ExecSQL;
end;
Навигация по записям. Свойства Eof и Bof. Количество записей, номер записи.
Если Вы работали с базами данных в Delphi, можете пропустить этот раздел.
Как уже говорилось ранее, поддерживаются всегод два метода навигации по набору данных First и Next. Метод First делает текущей первую запись, метод Next позволяет передвинуться на одну запись вперед.
Свойство Eof типа boolean определяет достигнут ли конец набора данных. Свойство Bof также типа boolean индицирует нахождение в начале набора данных. Приведем в качестве примера код процедуры перебора записей набора данных:
begin
with SQLDataSet1 do
begin
Open;
while not Eof do
begin
Next;
end;
end;
end;
Количество записей в наборе данных содержится в public свойстве RecordCount, а порядковый номер записи в свойстве RecNo. Однако нумерация записей поддерживается не всеми типами серверов БД. Чтобы узнать поддерживается ли возможность нумерации необходимо проанализировать возвращаемое значение функции IsSequenced, если значение равно True, то нумерация поддерживается, иначе для всех записей значение свойства RecNo равно -1.
Порядок сортировки.
Порядок сортировки записей для типа команд ctQuery при выборке данных определяется конструкцией SQL ORDER BY, заданной в тексте запроса ( св-во CommandText).
Для типа команды ctTable порядок сортировки по умолчанию определяет SQL сервер. Для изменения порядка сортировки в этом случае необходимо в свойстве SortFieldNames указать имена полей сортировки, разделив их точкой с запятой. При генерации запроса на выборку таблицы данные поля будут вставлены в запрос в конструкции ORDER BY. Данный способ пригоден и для команды ctQuery. При этом в тексте SQL команды не должно содержаться ORDER BY. Однако первый описанный способ сортировки для типа команд ctQuery более предпочтителен.
Для типа команды ctStoredProc порядок сортировки определяется в самой хранимой процедуре.
Использование параметров в запросах и хранимых процедурах,подготовка запросов
Если Вы работали с базами данных в Delphi, можете пропустить этот раздел.
Свойство Params позволяет работать с параметрами запроса или хранимой процедуры. Параметры - это переменные запроса, которые Вы можете менять в design и runtime без изменения текста запроса. Например, в данном запросе параметр P_ID используется для задания критерия отбора записей.
SELECT * FROM mytable where id < :P_ID
Параметр заменяет конкретное значение, которое подставляется на этапе выполнения запроса. Имена параметров начинаются со знака :. Перед выполнением запроса необходимо задать значения всех его параметров.
При изменении текста запроса параметры, указанные в тексте добавляются в свойсвтво Params автоматически, если необходимо отключить такое поведение сбросьте свойство ParamCheck в False.
Свойство Params является коллекцией объектов типа TParam. Класс TParam описывает параметр запроса или хранимой процедуры. Наиболее важные свойства этого класса:
· DataType:TFieldType - тип данных параметра
· ParamType:TParamType - тип параметра :
· ptUnknown - неопределенный тип, перед выполнением запроса или процедуры надо задать конкретный тип из следующих возможных
· ptInput - входной параметр (используется для передачи параметров),
· ptOutput - выходной (используется для возврата значений из хранимой процедуры),
· ptInputOutput - и входной и выходной,
· ptResult - результат работы процедуры может быть только один параметр данныого типа для одной процедуры.
· Value: Variant - значение параметра. Должно быть заполено перед выполнением запроса.
В режиме разработки данные свойства устанаваливаются с помощью Object Inspector. В режиме выполнения для установки свойств и значений параметров используются следующие методы:
· ParamByName - доступ к параметру по имени
Например:
SQLDataSet1.ParamByName('Country').AsString:='Russia';
· Params - доступ по индексу(номеру). Индексирование ведется с 0.
Например:
SQLDataSet1.Params[0].AsString:='Russia';
· ParamValues - установка значений нескольких параметров.
Например:
SQLDataSet1.ParamValues['Name;Country']:=VarArrayOf([Edit1.Text, Edit2.Text]);
Подготовка запроса подразумевает анализ и разбор текста запроса SQL сервером, подстановку параметров и подготовку к выполнению. После выполнения команды сервер освобождает задействованные ресурсы. Однако при частом исполнении одного и того же запроса (даже с разными значениями параметров) для повышения быстродействия имеет смысл хранить скомпилированный запрос на сервере. Для этого свойство Prepared необходимо установить в True.
Запросы главный-подчиненный.
Если Вы работали с базами данных в Delphi, можете пропустить этот раздел.
Наличие у TSQLDataSet свойства TDataSource позволяет связать два набора данных отношениями главный-подчиненный, т.е отображать в подчиненном наборе только те записи, которые связаны с текущей записью главного набора данных. Для этого необходимо связать главный набор данных с компонентом TDataSource, установив у последнего св-во DataSet равным имени компонента с главным набором данных. Затем у подчиненного набора данных установить свойство DataSource равным имени компонента TDataSource, связанного с главным набором. После описанных манипуляций в тексте команды подчиненного запроса можно использовать поля главного набора для связи, указывая их в качестве параметров.
Доступ к метаданным
Метаданные - это данные о структуре базы данных, такие как созданые таблицы, хранимые процедуры, поля таблиц и параметры процедур итд. Получение метаданных осуществляется вызовом метода SetSchemaInfo. Метод объявлен как:
procedure SetSchemaInfo(SchemaType: TSchemaType; SchemaObjectName, SchemaPattern: string);
Первый параметр определяет тип метаданных. Его возможные значения
stNoSchema - схема отсутствует - производится выборка результатов запроса
stTables - получение списка таблиц
stSysTables - получение информации о системных таблицах
stProcedures - получение информации о хранимых процедурах
stColumns - информация о полях таблицы
stProcedureParams - параметры хранимой процедуры
stIndexes - информация об индексах таблицы
Второй параметр - имя таблицы или хранимой процедуры, о полях или параметрах которой мы получаем информацию. Имеет смысл лишь при следующих значениях первого параметра
stColumns, stProcedureParams, stIndexes, иначе параметр игнорируется,
Третий параметр SchemaPattern - позволяет задать маску для фильтрации выбранной информации. При этом допустимо применение следующих подстановок
% - любые символы
_ - одиночный символ
Если же в маску должны входить вышеприведенные два символа, то они записываются как %% - знак процента, __ - подчеркивание.
При изменении свойства CommandText набор данных автоматически устанавливает значение свойства SchemaInfo равным stNoSchema.
Пример:
// Выборка информации о таблицах
SQLDataSet1.Close;
SQLDataSet1.SetSchemaInfo(stTables,'','%');
SQLDataSet1.Open;
Автор: Mike Goblin
Взято из
с разрешения автора.
Kylix Tutorial. Работа с DBExpress (статья)
Kylix Tutorial. Работа с DBExpress (статья)
Эта серия статей была любезно предоставлена автором Mike Goblin для нашего FAQ. Оригинал статьи находится на сайте
л
л
You may need to know at runtime what properties are available for a particular component at runtime. The list can be obtained by a call to GetPropList. The types, functions and procedures, including GetPropList, that allow access to this property information reside in the VCL source file TYPINFO.PAS.
GetPropList Parameters
functionGetPropList(TypeInfo: PTypeInfo; TypeKinds: TTypeKinds; PropList: PPropList): Integer;
The first parameter for GetPropList is of type PTypeInfo, and is part of the RTTI (Run Time Type Information) available for any object. The record structure defined:
PPTypeInfo = ^PTypeInfo;
PTypeInfo = ^TTypeInfo;
TTypeInfo = record
Kind: TTypeKind;
Name: ShortString;
{TypeData: TTypeData}
end;
The TTypeInfo record can be accessed through the objects ClassInfo property. For example, if you were getting the property list of a TButton, the call might look, so far, like this:
GetPropList(Button1.ClassInfo, ....
The second parameter, of type TTypeKinds, is a set type that acts as a filter for the kinds of properties to include in the list. There are a number of valid entries that could be included in the set (see TYPEINFO.PAS), but tkProperties covers the majority. Now our call to GetPropList would look like:
GetPropList(Button1.ClassInfo, tkProperties ....
The last parameter, PPropList is an array of PPropInfo and is defined in TYPEINFO.PAS:
PPropList = ^TPropList;
TPropList = array[0..16379] of PPropInfo;
Now the call might read:
procedure TForm1.FormCreate(Sender: TObject);
var
PropList: PPropList;
begin
PropList := AllocMem(SizeOf(PropList^));
GetPropList(TButton.ClassInfo, tkProperties + [tkMethod], PropList);
{...}
Getting Additional Information from the TTypeInfo Record:
The example at the end of this document lists not just the property name, but it's type. The name of the property type resides in an additional set of structures. Let's take a second look at the TPropInfo record. Notice that it contains a PPTypeInfo that points ultimately to a TTypeInfo record. TTypeInfo contains the class name of the property.
PPropInfo = ^TPropInfo;
TPropInfo = packed record
PropType: PPTypeInfo;
GetProc: Pointer;
SetProc: Pointer;
StoredProc: Pointer;
Index: Integer;
Default: Longint;
NameIndex: SmallInt;
Name: ShortString;
end;
PPTypeInfo = ^PTypeInfo;
PTypeInfo = ^TTypeInfo;
TTypeInfo = record
Kind: TTypeKind;
Name: ShortString;
{TypeData: TTypeData}
end;
The example below shows how to set up the call to GetPropList, and how to access the array elements. TForm will be referenced in this example instead of TButton, but you can substitute other values in the GetPropList call. The visible result will be to fill the list with the property name and type of the TForm properties.
This project requires a TListBox. Enter the code below in the forms OnCreate event handler.
uses
TypInfo;
procedure TForm1.FormCreate(Sender: TObject);
var
PropList: PPropList;
i: integer;
begin
PropList := AllocMem(SizeOf(PropList^));
i := 0;
try
GetPropList(TForm.ClassInfo, tkProperties + [tkMethod], PropList);
while (PropList^[i] <> Nil) and (i < High(PropList^)) do
begin
ListBox1.Items.Add(PropList^[i].Name + ': ' + PropList^[i].PropType^.Name);
Inc(i);
end;
finally
FreeMem(PropList);
end;
end;
Взято из
Левый SHIFT+ENTER/Правый SHIFT+ENTER
Левый SHIFT+ENTER/Правый SHIFT+ENTER
procedure TDecEditForm.Memo1KeyPress(Sender: TObject; var Key: Char);
VAR s:String; RL:Byte;
begin
IF key=CHR(VK_RETURN) Then
Begin
//WIN NT/2000
If (GetVersion() and $80000000)=0 then
BEGIN
IF ((Word(GetKeyState(VK_LSHIFT)) and $8000)<>0) Then
Begin
End;
IF ((Word(GetKeyState(VK_RSHIFT)) and $8000)<>0) Then
Begin
End;
End
ELSE
//WIN 9.x
Begin
asm
mov ah,2
int $16
mov RL,al
end;
if 1 = (RL and 1) then // ПРАВЫЙ SHIFT НАЖАТ+ENTER
Begin
End;
if 2 = (RL and 2) then // ЛЕВЫЙ SHIFT НАЖАТ+ENTER
Begin
End;
End;
//WIN 9.x
END;
End;
Автор ответа: CHERRY
Взято с Vingrad.ru
Limit reached for installs using Kylix serial number
Limit reached for installs using Kylix serial number
I am attempting to register Kylix, but cannot and get the following error:
--------------------
Error registering software. The limit has been reached for installs using this serial number, please contact customer service to increase the allowed install count.
--------------------
How do I get around this and register Kylix?
Borland has a registration server that keeps count of how many times a product has been registered. The default count is five registrations. This error indicates that your serial number has already been registered five times, and the registration currently being attempted exceeds the count.
You can get this count increased by calling Borland's registration hotline at (888) 588-2230. Explain to the representative who answers the phone what product you have, as well as the full error message, and he or she (after asking for your relevant information) will be able to increase the count to allow for additional registrations.
Липкие окошки
Липкие окошки
одноимённой статьи с сайта delphi.about.com
В статье рассматривается приём создания обработчиков сообщений, которые позволяют форме при перетаскивании "прилипать" к краям экранной области.
Конечно же в Win API такой возможности не предусмотрено, поэтому мы воспользуемся сообщениями Windows. Как нам извесно, Delphi обрабатывает сообщения через события, генерируя его в тот момент, когда Windows посылает сообщений приложению. Однако некоторые сообщения не доходят до нас. Например, при изменении размеров формы, генерируется событие OnResize, соотвествующее сообщению WM_SIZE, но при перетаскивании формы никакой реакции не происходит. Конечно же форма может получить это сообщение, но изначально никаких действий для данного сообщения не предусмотрено.
Итак, при перемещении, окну посылается сообщение WM_MOVING. Обрабатывая данной сообщение, приложение может отслеживать размер и расположение перетаскиваемого квадрата и, при необходимости, изменять их.
Так же существует сообщение WM_WINDOWPOSCHANGING, которое посылается окну, в случае, если его размер, расположение или место в Z порядке собираются измениться, как результат вызова функции SetWindowPos либо другой функции управления окном.
Чаще всего с сообщением передаются дополнительные параметры, которые сообщают нам необходимую информацию. Например, сообщение WM_MOVE, указывающее на то, что форма изменила своё местоположение, так же передаёт в параметре LPARAM новые координаты X и Y.
Сообщение WM_WINDOWPOSCHANGING передаёт нам ТОЛЬКО один параметр - указатель на структуру WindowPos, которая содержит информацию о новом размере и местоположении окна. Вот как выглядит структура WindowPos:
TWindowPos = packed record
hwnd: HWND; {Identifies the window.}
hwndInsertAfter: HWND; {Window above this one}
x: Integer; {Left edge of the window}
y: Integer; {Right edge of the window}
cx: Integer; {Window width}
cy: Integer; {Window height}
flags: UINT; {Window-positioning options.}
end;
Наша задача проста: нам необходима, чтобы форма прилипла к краю экрана, если она находится на определённом расстоянии от окна (допустим 20 пикселей).
Пример
К новой форме добавьте Label, один контрол Edit и четыре Check boxes. Измените имя контрола Edit на edStickAt. Измените имена чекбоксов на chkLeft, chkTop, и т.д... Для установки количества пикселей используем edStickAt, который будет использоваться для определения необходимого расстояния до края экрана достаточного для приклеивания формы.
Нас интересует только одно сообщение WM_WINDOWPOSCHANGING. Обработчик для данного сообщения будет объявлен в секции private. Ниже приведён полный код этого процедуры "прилипания" вместе с комментариями. Обратите внимание, что Вы можете предотвратить "прилипание" формы к определённому краю, путё снятия нужной галочки.
Для получения рабочей области декстопа (минус панель задач, панель Microsoft и т.д.), используем SystemParametersInfo, первый параметр которой SPI_GETWORKAREA.
...
private
procedure WMWINDOWPOSCHANGING
(Var Msg: TWMWINDOWPOSCHANGING);
message WM_WINDOWPOSCHANGING;
...
procedure TfrMain.WMWINDOWPOSCHANGING
(var Msg: TWMWINDOWPOSCHANGING);
const
Docked: Boolean = FALSE;
var
rWorkArea: TRect;
StickAt : Word;
begin
StickAt := StrToInt(edStickAt.Text);
SystemParametersInfo
(SPI_GETWORKAREA, 0, @rWorkArea, 0);
with Msg.WindowPos^ do begin
if chkLeft.Checked then
if x <= rWorkArea.Left + StickAt then begin
x := rWorkArea.Left;
Docked := TRUE;
end;
if chkRight.Checked then
if x + cx >= rWorkArea.Right - StickAt then begin
x := rWorkArea.Right - cx;
Docked := TRUE;
end;
if chkTop.Checked then
if y <= rWorkArea.Top + StickAt then begin
y := rWorkArea.Top;
Docked := TRUE;
end;
if chkBottom.Checked then
if y + cy >= rWorkArea.Bottom - StickAt then begin
y := rWorkArea.Bottom - cy;
Docked := TRUE;
end;
if Docked then begin
with rWorkArea do begin
// не должна вылезать за пределы экрана
if x < Left then x := Left;
if x + cx > Right then x := Right - cx;
if y < Top then y := Top;
if y + cy > Bottom then y := Bottom - cy;
end; {ширина rWorkArea}
end; {}
end; {с Msg.WindowPos^}
inherited;
end;
end.
Теперь достаточно запустить проект и перетащить форму к любому краю экрана.
А также можно взять готовый пример (~6Kb)
Вот собственно и всё.
Комментарии:
Автор: Nashev
а так короче... И, ИМХО, лучше:
procedure TCustomGlueForm.WMWindowPosChanging1(var Msg: TWMWindowPosChanging);
var
WorkArea: TRect;
StickAt : Word;
begin
StickAt := 10;
SystemParametersInfo(SPI_GETWORKAREA, 0, @WorkArea, 0);
with WorkArea, Msg.WindowPos^ do
begin
// Сдвигаем границы для сравнения с левой и верхней сторонами
Right:=Right-cx;
Bottom:=Bottom-cy;
if abs(Left - x) <= StickAt then x := Left;
if abs(Right - x) <= StickAt then x := Right;
if abs(Top - y) <= StickAt then y := Top;
if abs(Bottom - y) <= StickAt then y := Bottom;
end;
inherited;
end;
Скачать демонстрационный проект с исходниками - 167Kb
В проекте осталось 2 глюка:
1) Если у формы, к которой прицепили другую форму за правую/нижнюю границы попробовать переместить эти границы, прицепленная форма останется на месте но все равно будет прикрепленной.
2) Иногда 3 формы прикрепляются друг к другу, и иначе, как воспользовавшись 1-ым глюком, их не расцепить.
Состав проекта:
сам проект, uCustomGlueForm - форма с добавленной липкостью 3 формы - пустышки, наследники TCustomGlueForm
Для использования сделанного в своих проектах надо добавить в проект, и свои формы создавать, наследуя от него, например, через мастер "File/New..."
В принципе, если липкость нужна без прилипания (а это уже работает без глюков) можно выкинуть все методы, кроме
procedure WMWindowPosChanging(var Msg: TWMWindowPosChanging);message WM_WINDOWPOSCHANGING;
и все переменные, а в самом WMWindowPosChanging удалить все упоминания этих переменных.
Взято с Исходников.ru
ListBox, CheckListBox, DBLookUp, Другие списки
ListBox, CheckListBox, DBLookUp, Другие списки
Cодержание раздела:
См. также статьи в других разделах:
Local SQL и временная таблица
Local SQL и временная таблица
Local SQL не поддерживает вложенные запросы, но после того как я заработал клок седых волос, я нашел в высшей степени простое решение: использование временной таблицы.
Пример:
withGeneralQuery do
begin
SQL.Clear;
SQL.Add(.... внутренний SQL);
SQL.Open;
DbiMakePermanent(handle, 'temp.db',true);
SQL.Clear;
SQL.Add(SELECT ... FROM 'temp.db'....);
SQL.Open;
end;
Единственное: необходимо убедиться в том, что имя таблицы не вступает в конфликт с именами нескольких работающих копий таблицы. И, разумеется, данная технология не даст "живой" набор!
Взято из
Локальные операторы языка SQL (BDE)
Локальные операторы языка SQL (BDE)
Вывод нужных полей
SELECTLastName, FirstName, Salary FROM employee
Хотим вывести только имя, фамилию и оклад служащих
Вывод всех полей из таблицы
SELECT * FROM employee
* обозначает все поля
Задание псевдонима таблице
SELECT * FROM employee emp
where emp.salary>35000
Таблице employee в качестве псевдонима задано emp
Выводим всех служащих с окладом свыше 35000
Исключение дубликатов
SELECT DISTINCT Country FROM vendors
Хотим узнать из каких стран поставляют продукцию
Постановка условия
SELECT * FROM vendors
Where Country='Canada'
Выводим поставщиков из Канады
Использование логические операторов
SELECT * FROM vendors
Where Country='U.S.A.' and Preferred='True'
Выводим только предпочитаемых поставщиков из США.
Когда используем оператор AND должны удовлетворяться оба условия
SELECT * FROM animals
Where AREA='South America' or AREA='New Orleans'
Хотим видеть только тех животных, которые обитают в Южной Америке или Новом Орлеане Когда используем оператор OR должно удовлетворяться хотя бы одно условие
SELECT * FROM animals
Where AREA='South America' and not Weight<7
Выводим животных, обитающих в Южной Америке с весом не менее 7 кг
Когда используем оператор AND NOT должно удовлетворяться первое условие и не должно - второе
SELECT * FROM animals
Where Weight<5 or not Weight<10
Выводим животных, с весом менее 5 кг или более 10 кг
Когда используем оператор OR NOT должно либо удовлетворяться первое условие, либо не должно - второе
Упорядочивание записей по возрастанию/убыванию/по номеру столбца
SELECT * FROM animals order by Weight
Выводим животных в порядке увеличения веса: сначала самые лёгкие, в конце самые тяжелые
SELECT * FROM animals order by Weight desc
...наоборот - по убыванию
SELECT * FROM animals order by 3
Упорядочить по третьему столбцу (отсчёт начинается с 1 )
Объединение нескольких запросов
SELECT * FROM animals
Where Area='South America'
UNION
SELECT * FROM animals
Where Area='New Orleans'
Выводим тех животных, которые обитают в Южной Америке, а так же тех, которые обитают в Новом Орлеане Оператором UNION можем объединять несколько запросов
Максимальное/минимальное значение поля
SELECT MAX(Salary) FROM employee
Выводим максимальный оклад из таблицы служащих
SELECT MIN(Salary) FROM employee
Выводим минимальный оклад из таблицы служащих
Сумма всех значений/среднее значение
SELECT SUM(Salary) FROM employee
Так можем узнать сколько получают служащие некой фирмы вместе взятые
SELECT AVG(Salary) FROM employee
Так можем узнать среднестатистический оклад
Количество записей в таблице/в поле
SELECT COUNT(*) FROM employee
Находим количество записей в таблице - в данном случае количество служащих
SELECT COUNT(*) FROM clients
Where occupation='Programmer'
Посчитали сколько человек увлекаются программированием
Группировка записей
SELECT Continent, MAX(Area) FROM country group by Continent
С помощью конструкции "group by" можем узнать какая страна занимает самую большую площадь для каждого континента
Конструкция IN
select * from Customer
Where Country IN ('US','Canada','Columbia')
Выводим покупателей из США, Канады и Колумбии
select * from Customer
Where Country NOT IN ('US','Canada')
Выводим всех покупателей за исключением тех, кто проживает в США, Канаде
Вывод пустых/непустых значений
select * from Customer
Where State is NULL
Выводит те записи, где не введено значение в поле State
select * from Customer
Where State is NOT NULL
Выводит те записи, где введено значение в поле State
Вывод значений приблизительно соответствующих нужным
select * from employee
Where LastName like 'L%'
Выводим только тех служащих, у которых фамилия начинается на букву 'L'. Знак '%' - означает любые символы
select * from employee
Where LastName like 'Nels_n'
Например, мы не помним: как правильно пишется 'Nelson' или 'Nelsan', тогда нужно будет воспользоваться знаком подчёркивания, который означает любой символ
Диапазон значений
select * from employee
Where Salary BETWEEN 25000 AND 50000
Можем вывести только тех, кто получает от 25000 до 50000 включительно
ANY, SOME, ALL
SELECT * FROM orders.db
where custno= ANY (select custno from customer.db where city = 'Largo');
или
SELECT * FROM orders.db
where custno= SOME (select custno from customer.db where city = 'Largo');
или
SELECT * FROM orders.db
where custno IN (select custno from customer.db where city = 'Largo');
Выводим заказы покупателей из города 'Largo'
SELECT * FROM clients
where birth_date>All(select birth_date from clients where city='Los Altos')
Вывести тех клиентов, которые моложе всех из 'Los Altos'
EXISTS
SELECT * FROM orders.db
where custno= ANY (select custno from customer where city = 'Largo')
and Exists(SELECT * FROM customer WHERE City='Largo')
Выводим заказы покупателей из города 'Largo' если вообще есть покупатели с этого города
Использование параметров
SELECT * FROM clients
where Last_Name=:LastNameParam
Если мы хотим дать возможность пользователю самому указывать фамилию нужного ему клиента. мы вместо значения для поля фамилия указываем параметр. Параметры указываются после двоеточия. И получить доступ к ним можно по индексу из свойства Params компонента Query. Индексация начинается с нуля. Затем, например, по нажатию на кнопке напишем код:
Query1.Active:=false;
Query1.Params[0].AsString:=Edit1.Text;
Query1.Active:=true;
Вывод дополнительного текста[использование выражений]
SELECT LastName, Salary/100, '$' FROM employee
Если зарплата указана не в долларах, а какой-то другой валюте, курс которой равен 1 к 100, мы можем вывести данные в $, используя вышеуказанное выражение
Использование нескольких таблиц
SELECT o.orderno,o.AmountPaid, c.Company FROM orders o, customer c
where o.custno=c.custno and c.city='Largo'
Выводим номер и сумму заказа из таблицы заказов и компанию сделавшую заказ из таблицы покупателей
Вложенные подзапросы
SELECT * FROM employee
where Salary=(select MAX(Salary) from employee)
Мы научились выводить максимальное значение, например, можем узнать максимальный оклад у служащих, но куда полезнее было бы узнать кто тот счастливчик. Именно здесь используется механизм вложенных подзапросов
Взято с
Локальный общий доступ
Локальный общий доступ
...я так понимаю, что LocalShare относится к ситуации, когда другие не-IDAPI приложения могут одновременно иметь доступ к одним и тем же файлам...
Примерно на такие мысли наталкивает поставляемая документация... к сожалению это не так.
LOCALSHARE=False говорит BDE о том, что он должен сам решать при необходимости вопрос о блокировке таблицы/записи в типичных ситуациях, например, когда BDE 'думает' что таблица находится на локальном диске он выключает блокировку для увеличения скорости доступа. К сожалению, логические диски общего пользования в сетях 'p-t-p' программно идентифицируются как локальные с предсказуемо липовыми результатами. Установка LOCALSHARE=True заставляет блокирующий механизм 'включаться' для всех дисков и, следовательно, решает эту проблему.
- Eryk Bottomley
Взято из
Советов по Delphi от
Сборник Kuliba
Ловим баги или почему программы допускают недопустимые операции
Ловим баги или почему программы допускают недопустимые операции
Ошибки - неизбежное зло программирования. Видимо пока трудно даже представить средство с помощью которого можно избавится от них. Человеку, которые выдумает это чудодейственное лекарство, благодарные потомки-программисты, несомненно, воздвигнут памятник. Пока же остается лишь заниматься обычным делом: ловлей багов.
"Нарушение Доступа" - фраза, которую пользователи видят, когда приложение делает попытки обратиться к памяти, которая не обозначена для их использования - и как следствие происходит сбой в работе программы:
Accessviolation at address <HEX_value>
in module <Application.Exe>.
Read of address <HEX_value_2>
Ситуация при которой Windows давала бы полную свободу программам - записывай данные куда хочешь, скорее всего бы привела к разноголосице программ и полной потери управления над компьютером. Но этого не происходит - Windows стоит на страже "границ памяти" и отслеживает недопустимые операции. Если сама она справиться с ними не в силах - происходит запуск утилиты Dr. Watson, которая записывает данные о возникшей ошибки, а сама программа закрывается.
Известно что, при программирование, особенно крупных программных продуктов, уследить за всеми процессами в коде невозможно, да и нет необходимости. Использование сторонних компонентов и библиотек только усложняет дело. Именно поэтому программисты Delphi, порой и сталкиваются со "своенравными" программами, которые то и дело норовят "сбросить пользователя". Итак, давайте рассмотрим некоторые вопросы, связанные с корректной средой программирования, так и непосредственно проблем написания кода, которые ведут к возникновению ошибок типа "ошибка доступа" (AVS) и очертим наиболее известные пути их исправления.
Мы можем поделить AVS, с которыми сталкиваются при разработке в Delphi на два основных типах: ошибки при выполнения и некорректная разработка проекта, что вызывает ошибки при работе программы.
Ошибки возникают при старте и закрытии Delphi или формировании проекта. Причиной могут являться сбои в "железе" компьютера.
Эти ошибки могут быть вызваны различными источниками, включая систему BIOS, операционную систему или аппаратные подпрограммы драйверов. Некоторые видео-, звуковые или сетевые платы могут фактически вызывать подобного рода ошибки в Delphi. Для решения подобных аппаратных проблем можно предпринять последовательность неких "стандартных" ходов:
Проверить, что не имеется никаких конфликтов между установленными устройствами, устранить обнаруженные конфликты;
Попробовать слегка уменьшить "аппетиты" видеодрайвера - поставить меньшее разрешение;
В случае если у вас двухпроцесорная система обеспечить равное изменение шага для каждого процессора;
И в конце концов просто попытаться заменить драйвера на более свежие.
Но помимо чисто железных проблем - большую головную боль могут вызвать ошибки в работе программного обеспечения. Особенно это касается непосредственно операционной системы. Зачастую Windows терпит крах спонтанно. Вот рекомендации которые помогут вам создать более устойчивую среду программирования:
Хотя Windows 9X популярная система, разработку лучше проводить в Windows NT или Windows 2000 - это более устойчивые операционные системы. Естественно при переходе на них придется отказаться от некоторых благ семейства Windows 95/98/Me - в частности не все программы адоптированы для Windows NT/2000. Зато вы получите более надежную и стабильную систему.
Не забывайте о том, как важно всегда иметь под рукой свежие версии компонентов для Delphi и дополнительных библиотек. В отличие от Windows создатели данных пакетов стараются от версии к версии уменьшать количество ошибок.
Следите за тем, что бы устанавливаемые компоненты были предназначены непосредственно для вашей версии Delphi. Попробуйте деинсталлировать чужеродные компоненты один за другим (или пакет за пакетом) пока проблема не будет устранена.
Контролируйте все программные продукты установленные на вашей машине и деинсталлируйте те из них, которые сбоят. Фаворитами AV среди них являются шароварные утилиты и программы и бета версии программных продуктов.
Все вышеперечисленное в основном не касалось самого процесса программирования и в малой степени зависит от разработчика. Теперь же обратимся к теме, как не допустить при разработки программного продукта ситуации при которой, он сам будет являться причиной ошибки.
Вы могли бы рассмотреть компилирование вашего приложения с директивой {$D}, данная директива компилятора может создавать файлы карты (файлы с расширением map, которые можно найти в том же каталоге, что и файлы проекта), которые могут послужить большой справкой в локализации источника подобных ошибок. Для лучшего "контроля" за своим приложением, компилируйте его с директивой {$D}. Таким образом, вы заставите Delphi генерировать информацию для отладки, которая может послужить подспорьем при выявление возникающих ошибок.
Следующая позиция в Project Options - Linker & Compiler позволяет вам, определить все для последующей отладки. Лучше всего, если помимо самого выполняемого кода будет доступна и отладочная информация - это поможет при поиске ошибок. Отладочная информация увеличивает размер файла и занимает дополнительную память при компилировании программ, но непосредственно на размер или быстродействие выполняемой программы не влияет. Включение опций отладочной информации и файла карты дают детальную информацию только, если вы компилируете программу с директивой {$D+}.
Эта информация состоит из таблицы номеров строк для каждой процедуры, которая отображает адреса объектных кодов в номера строк исходного текста. Директива $D обычно используется совместно с другой директивой - $L, что позволяет или запрещает генерацию информации о локальных символах для отладки.
Таким образом вы без труда сможете найти точный адрес той подпрограммы, которая была ответственна за ошибку. Одна из наиболее общих причин ошибок выполнения - использование объекта, который еще не был создан. Если второй адрес при выдачи ошибки - FFFFFFF (или 0000000) Вы можете почти утверждать, что было обращение к объекту, который еще не был создан. Например, вызов метода формы, которая не была создана.
procedure TfrMain.OnCreate(Sender: TObject);
var
BadForm: TBadForm;
begin
BadForm.Refresh; // причина ошибки
end;
Попытаемся разобратся в этой ситуации. Предположим, что BadForm есть в списке "Available forms " в окне Project Options|Forms. В этом списке находятся формы, которые должны быть созданы и уничтожены вручную. В коде выше происходит вызов метода Refresh формы BadForm, что вызывает нарушение доступа, так как форма еще не была создана, т.е. для объекта формы не было выделено памяти.
Если вы установите "Stop on Delphi Exceptions " в Language Exceptions tab в окне Debugger Options, возможно возникновение сообщения об ошибке, которое покажет, что произошло ошибка типа EACCESSVIOLATION. EACCESSVIOLATION - класс исключение для недопустимых ошибок доступа к памяти. Вы будете видеть это сообщение при разработке вашего приложения, т.е. при работе приложения, которое было запущено из среды Delphi.
Следующее окно сообщения будет видеть пользователь - и программа будет закрыта при совершение недопустимой операции:
Access violation at address 0043F193
in module 'Project1.exe'
Read of address 000000.
Первое шестнадцатиричное число ('0043F193') - адрес ошибки во время выполнения программы. Выберите, опцию меню 'Search|Find Error', введите адрес, в котором произошла ошибка ('0043F193') в диалоге и нажмите OK. Теперь Delphi перетранслирует ваш проект и покажет вам, строку исходного текста, где произошла ошибка во время выполнения программы, то есть BadForm.Refresh.
Естественно, что списка наиболее общих причин ошибок, вызывающих аварийное завершение работы программы, написанной в Delphi в чистом виде нет. Есть несколько общих "узких мест" в коде и структуре программы, когда подобная ошибка может произойти. Перечислим наиболее распространенные.
Недопустимый параметр API
Если вы пытаетесь передать недопустимый параметр в процедуру Win API, может произойти ошибка. Необходимо отслеживать все нововведения в API при выходе новых версий операционных систем и их обновлений.
Уничтожение исключения
Никогда не уничтожайте временный объект исключения. Обработка исключения автоматически уничтожает объект исключения. Если вы уничтожите объект самостоятельно, то приложение попытается уничтожать объект снова, и произойдет ошибка.
Zero := 0;
try
dummy := 10 / Zero;
except
on E: EZeroDivide do
MessageDlg('Can not divide by zero!', mtError, [mbOK], 0);
E.free. // причина ошибки
end;
Индексация пустой строки
Пустая строка не имеет никаких достоверных данных. Следовательно, попытка индексировать пустую строку - подобно попытке обратиться к нулю, что приведет также к ошибке:
var
s: string;
begin
s := '';
s[1] := 'a'; // причина ошибки
end;
Обращение к динамической переменной
Вы должны строить обращение к динамической переменной корректно, иначе вы перемещаете адреса указателей и возможно разрушаете другие выделенные ячейки памяти.
procedure TForm1.Button1Click(Sender: TObject);
var
p1, p2: pointer;
begin
GetMem(p1, 128);
GetMem(p2, 128);
{эта строка может быть причиной ошибки}
Move(p1, p2, 128);
{данная строка корректна }
Move(p1^, p2^, 128);
FreeMem(p1, 128);
FreeMem(p2, 128);
end;
Перечисленные подходы позволят избежать наиболее частых недочетов в разработке, которые могут вызвать столь неприятное как для пользователя, так и для разработчика сообщение о том, что программа выполнила "недопустимую операцию".
Взято с
Манипуляции с текстом
Манипуляции с текстом
Cодержание раздела:
См. также статьи в других разделах:
Манипуляции с заголовком формы
Манипуляции с заголовком формы
Cодержание раздела:
См. также статьи в других разделах:
Масштабирование окон приложений, в зависимости от разрешения экрана
Масштабирование окон приложений, в зависимости от разрешения экрана
1.В ранней стадии создания приложения решите для себя хотите ли вы позволить форме масштабироваться. Преимущество немасштабируемой формы в том, что ничего не меняется во время выполнения. В этом же заключается и недостаток (ваша форма может бать слишком маленькой или слишком большой в некоторых случаях).
2.Если вы не собираетесь делать форму масштабируемой, установите св-во Scaled=False и дальше не читайте. В противном случае Scaled=True.
3.Установите AutoScroll=False. AutoScroll = True означает не менять размер окна формы при выполнении что не очень хорошо выглядит, когда содержимое формы размер меняет.
4.Установите фонты в форме на TrueType фонты, например Arial. Если такого фонта не окажется на пользовательском компьютере, то Windows выберет альтернативный фонт из того же семейства. Этот фонт может не совпадать по размеру, что вызовет проблемы.
5.Установите св-во Position в любое значение, отличное от poDesigned. poDesigned оставляет форму там, где она была во время дизайна, и, например, при разрешении 1280x1024 форма окажется в левом верхнем углу и совершенно за экраном при 640x480.
6.Оставляйте по-крайней мере 4 точки между компонентами, чтобы при смене положения границы на одну позицию компоненты не "наезжали" друг на друга. Для однострочных меток (TLabel) с выравниванием alLeft или alRight установите AutoSize=True. Иначе AutoSize=False.
7.Убедитесь, что достаточно пустого места у TLabel для изменения ширины фонта - 25\% пустого места многовато, зато безопасно. При AutoSize=False Убедитесь, что ширина метки правильная, при AutoSize=True убедитесь, что есть ссвободное место для роста метки.
8.Для многострочных меток (word-wrapped labels), оставьте хотя бы одну пустую строку снизу.
9.Будьте осторожны при открытии проекта в среде Delphi при разных разрешениях. Свойство PixelsPerInch меняется при открытии формы. Лучше тестировать приложения при разных разрешениях, запуская готовый скомпилированный проект, а редактировать его при одном разрешении. Иначе это вызовет проблемы с размерами.
10.Не изменяйте свойство PixelsPerInch !
11.В общем, нет необходимости тестировать приложение для каждого разрешения в отдельности, но стоит проверить его на 640x480 с маленькими и большими фонтами и на более высоком разрешении перед продажей.
12.Уделите пристальное внимание принципиально однострочным компонентам типа TDBLookupCombo. Многострочные компоненты всегда показывают только целые строки, а TEdit покажет урезанную снизу строку. Каждый компонент лучше сделать на несколько точек больше.
Автор Song
Масштабирование размера формы и размера шрифтов
Масштабирование размера формы и размера шрифтов
Когда мои программы работают на системах с установленными маленькими шрифтами, я получаю странный вид моей формы. К примеру, расположенные на форме компоненты Label становятся малы для размещения указанного теста, обрезая его в правой или нижней части. StringGrid не осуществляет положенного выравнивания и т.д.
Попробуй следующий код. Он масштабирует как размер формы, так и размер шрифтов. Вызывай его в Form.FormCreate. Надеюсь это поможет.
unitgeScale;
interface
uses Forms, Controls;
procedure geAutoScale(MForm: TForm);
implementation
type
TFooClass = class(TControl); { необходимо выяснить защищенность }
{ свойства Font }
procedure geAutoScale(MForm: TForm);
const
cScreenWidth: integer = 800;
cScreenHeight: integer = 600;
cPixelsPerInch: integer = 96;
cFontHeight: integer = -11; {В режиме проектирование значение из Font.Height}
var
i: integer;
begin
{
ВАЖНО!! : Установите в Инспекторе Объектов свойство Scaled TForm в FALSE.
Следующая программа масштабирует форму так, чтобы она выглядела одинаково
внезависимости от размера экрана и пикселей на дюйм. Расположенный ниже
участок кода проверяет, отличается ли размер экрана во время выполнения
от размера во время проектирования. Если да, Scaled устанавливается в True
и компоненты снова масштабируются так, чтобы они выводились в той же
позиции экрана, что и во время проектирования.
}
if (Screen.width &; lt > cScreenWidth) or (Screen.PixelsPerInch <>
cPixelsPerInch) then
begin
MForm.scaled := TRUE;
MForm.height := MForm.height * screen.Height div cScreenHeight;
MForm.width := MForm.width * screen.width div cScreenWidth;
MForm.ScaleBy(screen.width, cScreenWidth);
end;
{
Этот код проверяет, отличается ли размер шрифта во времы выполнения от
размера во время проектирования. Если во время выполнения pixelsperinch
формы отличается от pixelsperinch во время проектирования, шрифты снова
масштабируются так, чтобы форма не отличалась от той, которая была во
время разработки. Масштабирование производится исходя из коэффициента,
получаемого путем деления значения font.height во время проектирования
на font.height во время выполнения. Font.size в этом случае работать не
будет, так как это может дать результат больший, чем текущие размеры
компонентов, при этом текст может оказаться за границами области компонента.
Например, форма создана при размерах экрана 800x600 с установленными
маленькими шрифтами, имеющими размер font.size = 8. Когда вы запускаете
в системе с 800x600 и большими шрифтами, font.size также будет равен 8,
но текст будет бОльшим чем при работе в системе с маленькими шрифтами.
Данное масштабирование позволяет иметь один и тот же размер шрифтов
при различных установках системы.
}
if (Screen.PixelsPerInch <> cPixelsPerInch) then
begin
for i := MForm.ControlCount - 1 downto 0 do
TFooClass(MForm.Controls[i]).Font.Height :=
(MForm.Font.Height div cFontHeight) *
TFooClass(MForm.Controls[i]).Font.Height;
end;
end;
end.
Взято из
Массив без ограничения типа и размера
Массив без ограничения типа и размера
//кпримеру опишем свой тип
type
MyType = record
zap1: longword;
zap2: char;
zap3: string[10];
end;
//опишем НЕОГРАНИЧЕННЫЙ массив переменный типа MyType
//хотя, может использоваться абсолютно любой
var
m: array of MyType;
....
procedure TForm1.Button1Click(Sender: TObject);
var i: byte;
begin
for i := 0 to 9 do // нумерация элементов начинается с нуля!
begin
SetLength(m, Length(m) + 1); // увеличение длины массива на 1
m[i].zap1 := i; // присвоение
m[i].zap2 := chr(i); // полям
m[i].zap3 := inttostr(i); // значений
end;
end;
....
SetLength(m, 0); // освобождение памяти
end.
C Уважением,
Сергей Дьяченко, sd@arzamas.nnov.ru
Взято из
Советов по Delphi от
Сборник Kuliba
Массив в Delphi
Массив в Delphi
Вот несколько функций для операций с двухмерными массивами. Самый простой путь для создания собственной библиотеки. Процедуры SetV и GetV позволяют читать и сохранять элементы массива VArray (его Вы можете объявить как угодно). Например:
type
VArray: array[1..1] of double;
var
X: ^VArray;
NR, NC: Longint;
begin
NR := 10000;
NC := 100;
if AllocArray(pointer(X), N * Sizeof(VArray)) then exit;
SetV(X^, NC, 2000, 5, 3.27); { X[2000,5] := 3.27 }
end;
function AllocArray(var V: pointer; const N: longint): Boolean;
begin {распределяем память для массива V размера N}
try
GetMem(V, N);
except
ShowMessage('ОШИБКА выделения памяти. Размер:' + IntToStr(N));
Result := True;
exit;
end;
FillChar(V^, N, 0); {в случае включения длинных строк заполняем их нулями}
Result := False;
end;
procedure SetV(var X: Varray; const N, ir, ic: LongInt; const value:
double);
begin {заполняем элементами двухмерный массив X размером ? x N : X[ir,ic] := value}
X[N * (ir - 1) + ic] := value;
end;
function GetV(const X: Varray; const N, ir, ic: Longint): double;
begin {возвращаем величины X[ir,ic] для двухмерного массива шириной N столбцов}
Result := X[N * (ir - 1) + ic];
end;
Самый простой путь - создать массив динамически
Myarray := GetMem(rows * cols * sizeof(byte,word,single,double и пр.)
сделайте функцию fetch_num типа
function fetch_num(r,c:integer) : single;
result := pointer + row + col*rows
и затем вместо myarray[2,3] напишите
myarray.fetch_num(2,3)
поместите эти функции в ваш объект и работа с массивами станет пустячным делом. Я экспериментировал с многомерными (вплоть до 8) динамическими сложными массивами и эти функции показали отличный результат.
Вот способ создания одно- и двухмерных динамических массивов:
(*
--
-- модуль для создания двух очень простых классов обработки динамических массивов
-- TDynaArray : одномерный массив
-- TDynaMatrix : двумерный динамический массив
--
*)
unit DynArray;
interface
uses
SysUtils;
type
TDynArrayBaseType = double;
const
vMaxElements = (High(Cardinal) - $F) div sizeof(TDynArrayBaseType);
{= гарантирует максимально возможный массив =}
type
TDynArrayNDX = 1..vMaxElements;
TArrayElements = array[TDynArrayNDX] of TDynArrayBaseType;
{= самый большой массив TDynArrayBaseType, который мы может объявить =}
PArrayElements = ^TArrayElements;
{= указатель на массив =}
EDynArrayRangeError = class(ERangeError);
TDynArray = class
private
fDimension: TDynArrayNDX;
fMemAllocated: word;
function GetElement(N: TDynArrayNDX): TDynArrayBaseType;
procedure SetElement(N: TDynArrayNDX; const NewValue: TDynArrayBaseType);
protected
Elements: PArrayElements;
public
constructor Create(NumElements: TDynArrayNDX);
destructor Destroy; override;
procedure Resize(NewDimension: TDynArrayNDX); virtual;
property dimension: TDynArrayNDX
read fDimension;
property Element[N: TDynArrayNDX]: TDynArrayBaseType
read GetElement
write SetElement;
default;
end;
const
vMaxMatrixColumns = 65520 div sizeof(TDynArray);
{= построение матрицы класса с использованием массива объектов TDynArray =}
type
TMatrixNDX = 1..vMaxMatrixColumns;
TMatrixElements = array[TMatrixNDX] of TDynArray;
{= каждая колонка матрицы будет динамическим массивом =}
PMatrixElements = ^TMatrixElements;
{= указатель на массив указателей... =}
TDynaMatrix = class
private
fRows: TDynArrayNDX;
fColumns: TMatrixNDX;
fMemAllocated: longint;
function GetElement(row: TDynArrayNDX;
column: TMatrixNDX): TDynArrayBaseType;
procedure SetElement(row: TDynArrayNDX;
column: TMatrixNDX;
const NewValue: TDynArrayBaseType);
protected
mtxElements: PMatrixElements;
public
constructor Create(NumRows: TDynArrayNDX; NumColumns: TMatrixNDX);
destructor Destroy; override;
property rows: TDynArrayNDX
read fRows;
property columns: TMatrixNDX
read fColumns;
property Element[row: TDynArrayNDX; column: TMatrixNDX]: TDynArrayBaseType
read GetElement
write SetElement;
default;
end;
implementation
(*
--
-- методы TDynArray
--
*)
constructor TDynArray.Create(NumElements: TDynArrayNDX);
begin {==TDynArray.Create==}
inherited Create;
fDimension := NumElements;
GetMem(Elements, fDimension * sizeof(TDynArrayBaseType));
fMemAllocated := fDimension * sizeof(TDynArrayBaseType);
FillChar(Elements^, fMemAllocated, 0);
end; {==TDynArray.Create==}
destructor TDynArray.Destroy;
begin {==TDynArray.Destroy==}
FreeMem(Elements, fMemAllocated);
inherited Destroy;
end; {==TDynArray.Destroy==}
procedure TDynArray.Resize(NewDimension: TDynArrayNDX);
begin {TDynArray.Resize==}
if (NewDimension < 1) then
raise EDynArrayRangeError.CreateFMT('Индекс вышел за границы диапазона : %d', [NewDimension]);
Elements := ReAllocMem(Elements, fMemAllocated, NewDimension * sizeof(TDynArrayBaseType));
fDimension := NewDimension;
fMemAllocated := fDimension * sizeof(TDynArrayBaseType);
end; {TDynArray.Resize==}
function TDynArray.GetElement(N: TDynArrayNDX): TDynArrayBaseType;
begin {==TDynArray.GetElement==}
if (N < 1) or (N > fDimension) then
raise EDynArrayRangeError.CreateFMT('Индекс вышел за границы диапазона : %d', [N]);
result := Elements^[N];
end; {==TDynArray.GetElement==}
procedure TDynArray.SetElement(N: TDynArrayNDX; const NewValue: TDynArrayBaseType);
begin {==TDynArray.SetElement==}
if (N < 1) or (N > fDimension) then
raise EDynArrayRangeError.CreateFMT('Индекс вышел за границы диапазона : %d', [N]);
Elements^[N] := NewValue;
end; {==TDynArray.SetElement==}
(*
--
-- методы TDynaMatrix
--
*)
constructor TDynaMatrix.Create(NumRows: TDynArrayNDX; NumColumns: TMatrixNDX);
var col: TMatrixNDX;
begin {==TDynaMatrix.Create==}
inherited Create;
fRows := NumRows;
fColumns := NumColumns;
{= выделение памяти для массива указателей (т.е. для массива TDynArrays) =}
GetMem(mtxElements, fColumns * sizeof(TDynArray));
fMemAllocated := fColumns * sizeof(TDynArray);
{= теперь выделяем память для каждого столбца матрицы =}
for col := 1 to fColumns do
begin
mtxElements^[col] := TDynArray.Create(fRows);
inc(fMemAllocated, mtxElements^[col].fMemAllocated);
end;
end; {==TDynaMatrix.Create==}
destructor TDynaMatrix.Destroy;
var col: TMatrixNDX;
begin {==TDynaMatrix.Destroy;==}
for col := fColumns downto 1 do
begin
dec(fMemAllocated, mtxElements^[col].fMemAllocated);
mtxElements^[col].Free;
end;
FreeMem(mtxElements, fMemAllocated);
inherited Destroy;
end; {==TDynaMatrix.Destroy;==}
function TDynaMatrix.GetElement(row: TDynArrayNDX;
column: TMatrixNDX): TDynArrayBaseType;
begin {==TDynaMatrix.GetElement==}
if (row < 1) or (row > fRows) then
raise EDynArrayRangeError.CreateFMT('Индекс строки вышел за границы диапазона : %d', [row]);
if (column < 1) or (column > fColumns) then
raise EDynArrayRangeError.CreateFMT('Индекс столбца вышел за границы диапазона : %d', [column]);
result := mtxElements^[column].Elements^[row];
end; {==TDynaMatrix.GetElement==}
procedure TDynaMatrix.SetElement(row: TDynArrayNDX;
column: TMatrixNDX;
const NewValue: TDynArrayBaseType);
begin {==TDynaMatrix.SetElement==}
if (row < 1) or (row > fRows) then
raise EDynArrayRangeError.CreateFMT('Индекс строки вышел за границы диапазона : %d', [row]);
if (column < 1) or (column > fColumns) then
raise EDynArrayRangeError.CreateFMT('Индекс столбца вышел за границы диапазона : %d', [column]);
mtxElements^[column].Elements^[row] := NewValue;
end; {==TDynaMatrix.SetElement==}
end.
----Тестовая программа для модуля DynArray----
--------------------------------------------------------------------------------
uses DynArray, WinCRT;
const
NumRows: integer = 7;
NumCols: integer = 5;
var
M: TDynaMatrix;
row, col: integer;
begin
M := TDynaMatrix.Create(NumRows, NumCols);
for row := 1 to M.Rows do
for col := 1 to M.Columns do
M[row, col] := row + col / 10;
writeln('Матрица');
for row := 1 to M.Rows do
begin
for col := 1 to M.Columns do
write(M[row, col]: 5: 1);
writeln;
end;
writeln;
writeln('Перемещение');
for col := 1 to M.Columns do
begin
for row := 1 to M.Rows do
write(M[row, col]: 5: 1);
writeln;
end;
M.Free;
end.
Взято из
Советов по Delphi от
Сборник Kuliba
Математика, алгоритмы
Математика, алгоритмы
Cодержание раздела:
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
·
