Delphi - база знаний

         

Компонент для последовательного устройства (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одержание раздела:


·
·  
·  
·

 



·
·  
·  
·  
·  
·  
·  
·  
·  
·  
·  



·
·  
·  
·  
·  
·  
·  
·  
·  
·  
·  
·  



·
·  
·  
·  
·  
·  
·  
·  
·  
·  
·  
·  






·
·