Monday, February 05, 2007
TAtCommands
Aquest component gestiona els SMS mitjançant les comandes AT del modem.
unit AtCommands;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs;
const
SIZEBUFFER_RX=1024;
SIZEBUFFER_TX=1024;
CR=$0D;
LF=$0A;
CTRLZ=26;
type TPortsAt = (COM1,COM2,COM3,COM4,COM5,COM6,COM7,COM8,COM9,COM10);
type TParity = (pNONE,pODD,pEVEN,pMARK,pSPACE);
type TStopBit = (sbONE,sbONE5,sbTWO);
type TPortConfig = class(TPersistent)
private
FBaudRate: integer;
FBitsNumber: integer;
FParity: TParity;
FParityN: integer;
FStopBit: TStopBit;
FStopBitN: integer;
procedure SetParity(AParity: TParity);
procedure SetStopBit(AStopBit: TStopBit);
public
constructor Create;
published
property BaudRate: integer read FBaudRate write FBaudRate;
property BitsNumber: integer read FBitsNumber write FBitsNumber;
property Parity: TParity read FParity write SetParity;
property StopBit: TStopBit read FStopBit write SetStopBit;
end;
type
TAtCommands = class(TComponent)
private
{ Private declarations }
FPortName: TPortsAt;
FPortNumber: integer;
HandlePort: Array[0..6] of THANDLE;
FConfiguration: TPortConfig;
FEnabled: boolean;
FPhoneNumber: string;
FDelayTime: DWORD;
procedure SetPortName(APort: TPortsAt);
protected
{ Protected declarations }
function ReadByteSerialChannel(var b: BYTE): Integer;
function WriteByteSerialChannel(b: BYTE): Integer;
public
{ Public declarations }
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
function OpenSerialChannel: Integer;
procedure CloseSerialChannel;
procedure ClearInBuffer;
procedure ClearOutBuffer;
procedure SendAtCommand(AtComm: string);
procedure ReadAnswer(var Ans: string);
procedure SendCRLF;
procedure SendCtrlZ;
procedure SendMessage(msgtxt: string; var msgerr: string);
procedure Delay(Ms: DWORD);
procedure ReadMessage(index: integer; var msgtxt: string; var msgerr: string);
procedure DeleteMessage(index: integer; var msgerr: string);
published
{ Published declarations }
property Configuration: TPortConfig read FConfiguration write FConfiguration;
property PortName: TPortsAt read FPortName write SetPortName;
property Enabled: boolean read FEnabled write FEnabled;
property PhoneNumber: string read FPhoneNumber write FPhoneNumber;
property DelayTime: DWORD read FDelayTime write FDelayTime;
end;
procedure Register;
implementation
var
cPortName: Array[0..10] of PChar=('COM1','COM2','COM3','COM4','COM5','COM6','COM7','COM8','COM9','COM10','');
constructor TPortConfig.Create;
begin
FBaudRate := 9600;
FBitsNumber := 8;
FParity := pEVEN;
FParityN := EVENPARITY;
FStopBit := sbONE;
FStopBitN := ONESTOPBIT;
end;
procedure TPortConfig.SetParity(AParity: TParity);
begin
FParity := AParity;
case FParity of
pNONE: FParityN := NOPARITY;
pODD: FParityN := ODDPARITY;
pEVEN: FParityN := EVENPARITY;
pMARK: FParityN := MARKPARITY;
pSPACE: FParityN := SPACEPARITY;
end;
end;
procedure TPortConfig.SetStopBit(AStopBit: TStopBit);
begin
FStopBit := AStopBit;
case FStopBit of
sbONE: FStopBitN := ONESTOPBIT;
sbONE5: FStopBitN := ONE5STOPBITS;
sbTWO: FStopBitN := TWOSTOPBITS;
end;
end;
constructor TAtCommands.Create(AOwner: TComponent);
begin
FConfiguration := TPortConfig.Create;
FEnabled := True;
inherited Create(AOwner);
end;
destructor TAtCommands.Destroy;
begin
FConfiguration.Free;
inherited Destroy;
end;
procedure TAtCommands.SetPortName(APort: TPortsAt);
begin
FPortName := APort;
case APort of
COM1: FPortNumber := 0;
COM2: FPortNumber := 1;
COM3: FPortNumber := 2;
COM4: FPortNumber := 3;
COM5: FPortNumber := 4;
COM6: FPortNumber := 5;
COM7: FPortNumber := 6;
COM8: FPortNumber := 7;
COM9: FPortNumber := 8;
COM10: FPortNumber := 9;
end;
end;
function TAtCommands.OpenSerialChannel: Integer;
var
dcb: TDCB;
cto: TCOMMTIMEOUTS;
label
error;
begin
//Apertura del canal de comunicaciones
HandlePort[FPortNumber]:=CreateFile(cPortName[FPortNumber],
GENERIC_READ or GENERIC_WRITE,
0,
NIL,
OPEN_EXISTING,
0,
0);
if HandlePort[FPortNumber]=INVALID_HANDLE_VALUE then begin
goto error;
end;
//Lectura de la configuración actual
if not GetCommState(HandlePort[FPortNumber],dcb) then begin
goto error;
end;
//Modificación de la configuración del canal
dcb.BaudRate:=Configuration.FBaudRate;
dcb.ByteSize:=Configuration.FBitsNumber;
dcb.Parity:=Configuration.FParityN;
dcb.StopBits:=Configuration.FStopBitN;
if not SetCommState(HandlePort[FPortNumber],dcb) then begin
goto error;
end;
//Asignación de buffers de entrada y salida
SetUpComm(HandlePort[FPortNumber],SIZEBUFFER_RX,SIZEBUFFER_TX);
//Assignación de timeouts
GetCommTimeouts(HandlePort[FPortNumber],cto);
cto.ReadIntervalTimeout:=0;
cto.ReadTotalTimeoutMultiplier:=0;
cto.ReadTotalTimeoutConstant:=300; //200
cto.WriteTotalTimeoutMultiplier:=0;
cto.WriteTotalTimeoutConstant:=0;
setCommTimeouts(handlePort[FPortNumber],cto);
//Borrado de buffers de entrada y salida
PurgeComm(handlePort[FPortNumber],PURGE_TXCLEAR or
PURGE_RXCLEAR or
PURGE_TXABORT or
PURGE_RXABORT);
Result:=0;
Exit;
error:
Result:=GetLastError();
CloseHandle(HandlePort[FPortNumber]);
end;
procedure TAtCommands.CloseSerialChannel;
begin
PurgeComm(HandlePort[FPortNumber],PURGE_TXCLEAR or
PURGE_RXCLEAR or
PURGE_TXABORT or
PURGE_RXABORT);
CloseHandle(HandlePort[FPortNumber]);
end;
procedure TAtCommands.ClearInBuffer;
begin
PurgeComm(handlePort[FPortNumber],PURGE_RXCLEAR or
PURGE_RXABORT);
end;
procedure TAtCommands.ClearOutBuffer;
begin
PurgeComm(handlePort[FPortNumber],PURGE_TXCLEAR or
PURGE_TXABORT);
end;
function TAtCommands.ReadByteSerialChannel(var b: BYTE): Integer;
var
rx: Array[0..1] of BYTE;
nBytes: DWORD;
dwError: DWORD;
comStat: TCOMSTAT;
label
error;
begin
nBytes:=0;
ClearCommError(HandlePort[FPortNumber],dwError,@comStat);
if dwError > 0 then begin
goto error;
end;
if ReadFile(handlePort[FPortNumber],rx,1,nBytes,NIL)=False then begin
goto error;
end;
if nBytes=0 then begin
Result:=-1;
Exit;
end;
b:=rx[0];
Result:=0;
Exit;
error:
Result:=GetLastError();
end;
function TAtCommands.WriteByteSerialChannel(b: BYTE): Integer;
var
tx: Array[0..1] of BYTE;
nB: DWORD;
nBytes: DWORD;
dwError: DWORD;
comStat: TCOMSTAT;
label
error;
begin
nB:=1;
tx[0]:=b;
tx[1]:=0;
nBytes:=0;
repeat
ClearCommError(HandlePort[FPortNumber],dwError,@comStat);
if dwError > 0 then begin
goto error;
end;
if (comStat.cbOutQue < nB) then begin
if WriteFile(handlePort[FPortNumber],tx,nb,nBytes,NIL)=False then begin
goto error;
end;
if nBytes=0 then begin
goto error;
end else begin
dec(nB);
end;
end else begin
goto error;
end;
until nb=0;
Result:=0;
Exit;
error:
Result:=GetLastError();
end;
procedure TAtCommands.SendAtCommand(AtComm: string);
var
i: integer;
begin
for i:=1 to Length(AtComm) do
begin
WriteByteSerialChannel(BYTE(AtComm[i]));
end;
end;
procedure TAtCommands.SendCtrlZ;
begin
WriteByteSerialChannel(CTRLZ);
end;
procedure TAtCommands.SendCRLF;
begin
WriteByteSerialChannel(CR);
end;
procedure TAtCommands.ReadAnswer(var Ans: string);
var
i: integer;
b: byte;
s: string;
begin
i := 1;
while ReadByteSerialChannel(b)=0 do
begin
s := s + char(b);
Inc(i);
end;
ans := s;
end;
procedure TAtCommands.Delay(Ms: DWORD);
var
StartTime: DWORD;
Time: DWORD;
begin
StartTime:=GetTickCount;
while 1=1 do begin
Time:=GetTickCount();
if Time-StartTime > Ms then Exit;
Application.ProcessMessages();
end;
end;
procedure TAtCommands.SendMessage(msgtxt: string; var msgerr: string);
var
r: integer;
s: string;
begin
if FEnabled then
begin
r := OpenSerialChannel;
if r=0 then
begin
SendAtCommand('AT+CMGF=1');
SendCRLF;
Delay(FDelayTime);
ReadAnswer(s);
SendAtCommand('AT+CMGS="+34'+FPhoneNumber+'"');
SendCRLF;
Delay(FDelayTime);
ReadAnswer(s);
SendAtCommand(msgtxt);
SendCtrlZ;
Delay(FDelayTime);
ReadAnswer(s);
CloseSerialChannel;
end
else
begin
msgerr := Format('Error %d obrir port',[r]);
end;
end
else
begin
msgerr := '';
end;
end;
procedure TAtCommands.ReadMessage(index: integer; var msgtxt: string; var msgerr: string);
var
r: integer;
s: string;
begin
if FEnabled then
begin
r := OpenSerialChannel;
if r=0 then
begin
SendAtCommand('AT+CMGF=1');
SendCRLF;
Delay(FDelayTime);
ReadAnswer(s);
SendAtCommand('AT+CMGR='+IntToStr(index));
SendCRLF;
Delay(FDelayTime);
ReadAnswer(msgtxt);
CloseSerialChannel;
end
else
begin
msgerr := Format('Error %d obrir port',[r]);
end;
end
else
begin
msgerr := '';
msgtxt := 'Simulació';
end;
end;
procedure TAtCommands.DeleteMessage(index: integer; var msgerr: string);
var
r: integer;
s: string;
begin
if FEnabled then
begin
r := OpenSerialChannel;
if r=0 then
begin
SendAtCommand('AT+CMGF=1');
SendCRLF;
Delay(FDelayTime);
ReadAnswer(s);
SendAtCommand('AT+CMGD='+IntToStr(index));
SendCRLF;
Delay(FDelayTime);
ReadAnswer(s);
CloseSerialChannel;
end
else
begin
msgerr := Format('Error %d obrir port',[r]);
end;
end
else
begin
msgerr := '';
end;
end;
procedure Register;
begin
RegisterComponents('Components Delphi', [TAtCommands]);
end;
end.
Entre les propietas que cal configurar hi ha PortName, que és el port que correspon al dispositiu que empleem. A Configuration en determinen els parámetres. PhoneNumber és la destinació del missatge. Escollim un DelayTime per control.lar el correcte funcionament, si fos necessari. A partir d'aquí enviem missatges amb SendMessage, els borrem amb DeleteMessage, i els llegim amb ReadMessage.
Tuesday, January 23, 2007
ColorButton i ColorSpeedButton
Aquests components són una modificació sobre els components Button i SpeedButton per poder canviar-los de color.
unit TtButton;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, DsgnIntf,
ShellAPI, StdCtrls, Buttons;
type
TColorButton = class(TCustomControl)
private
{ Private declarations }
FCaption: string;
FFont: TFont;
FColor: TColor;
FWidthTop,FWidthDown: integer;
FGlyph: TBitmap;
FParentColor: boolean;
FBitmap: TBitmap;
procedure SetCaption(Value: string);
procedure SetFont(Value: TFont);
procedure SetColor(Value: TColor);
procedure SetParentColor(AParentColor: boolean);
protected
{ Protected declarations }
procedure SetGlyph(Value: TBitmap);
procedure Paint; override;
procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
procedure KeyPress(var Key: Char); override;
procedure DoExit; override;
procedure DoEnter; override;
procedure Click; override;
public
{ Public declarations }
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
published
{ Published declarations }
property Caption: string read FCaption write SetCaption;
property Font: TFont read FFont write SetFont;
property Color: TColor read FColor write SetColor;
property Glyph: TBitmap read FGlyph write SetGlyph;
property Action;
property Anchors;
property BidiMode;
property Constraints;
property DragCursor;
property DragKind;
property DragMode;
property Enabled;
property ParentBiDiMode;
property ParentColor: boolean read FParentColor write SetParentColor;
property ParentFont;
property ParentShowHint;
property PopupMenu;
property ShowHint;
property TabOrder;
property TabStop;
property Visible;
property OnClick;
property OnEnter;
property OnExit;
property OnKeyDown;
property OnKeyUp;
property OnKeyPress;
property OnMouseDown;
property OnMouseMove;
property OnMouseUp;
end;
type
TColorSpeedButton = class(TGraphicControl)
private
{ Private declarations }
FCaption: string;
FFont: TFont;
FColor: TColor;
FTopColor,FBottomColor: integer;
FGlyph: TBitmap;
FParentColor: boolean;
FBitmap: TBitmap;
procedure SetCaption(Value: string);
procedure SetFont(Value: TFont);
procedure SetColor(Value: TColor);
procedure SetParentColor(AParentColor: boolean);
protected
{ Protected declarations }
procedure SetGlyph(Value: TBitmap);
procedure Paint; override;
procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
public
{ Public declarations }
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
published
{ Published declarations }
property Caption: string read FCaption write SetCaption;
property Font: TFont read FFont write SetFont;
property Color: TColor read FColor write SetColor;
property Glyph: TBitmap read FGlyph write SetGlyph;
property Action;
property Anchors;
property BidiMode;
property Constraints;
property DragCursor;
property DragKind;
property DragMode;
property Enabled;
property ParentBiDiMode;
property ParentColor: boolean read FParentColor write SetParentColor;
property ParentFont;
property ParentShowHint;
property PopupMenu;
property ShowHint;
property Visible;
property OnClick;
property OnDblClick;
property OnMouseDown;
property OnMouseMove;
property OnMouseUp;
end;
procedure Register;
implementation
constructor TColorButton.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
FColor := clSilver;
FFont := TFont.Create;
FFont.Assign(Canvas.Font);
TabStop := True;
FWidthTop := 2;
FWidthDown := 4;
Width := 75;
Height := 25;
FGlyph := TBitmap.Create;
FParentColor := False;
FBitmap := TBitmap.Create;
end;
destructor TColorButton.Destroy;
begin
FFont.Free;
FGlyph.Free;
FBitmap.Free;
inherited Destroy;
end;
procedure TColorButton.SetGlyph(Value: TBitmap);
begin
FGlyph.Assign(Value);
Invalidate;
end;
procedure TColorButton.SetParentColor(AParentColor: boolean);
begin
FParentColor := AParentColor;
Paint;
end;
const
BORDER_FOCUS = 4;
procedure TColorButton.Paint;
var
i: integer;
begin
FBitmap.Width:=Width;
FBitmap.Height:=Height;
with FBitmap.Canvas do
begin
Font.Assign(FFont);
if FParentColor=False then
Brush.Color := FColor
else
Brush.Color := Parent.Brush.Color;
FBitmap.Canvas.FillRect(ClientRect);
if Focused then
begin
//external border
Pen.Style := psSolid;
Pen.Color := clWhite;
Pen.Width := 1;
FBitmap.Canvas.MoveTo(1,1);
FBitmap.Canvas.LineTo(Width-3,1);
FBitmap.Canvas.MoveTo(1,1);
FBitmap.Canvas.LineTo(1,Height-1);
Pen.Style := psSolid;
Pen.Width := FWidthTop;
Pen.Color := clBlack;
FBitmap.Canvas.MoveTo(0,0);
FBitmap.Canvas.LineTo(Width,0);
FBitmap.Canvas.MoveTo(0,0);
FBitmap.Canvas.LineTo(0,Height);
Pen.Width := FWidthDown;
FBitmap.Canvas.MoveTo(0,Height);
FBitmap.Canvas.LineTo(Width,Height);
FBitmap.Canvas.MoveTo(Width,0);
FBitmap.Canvas.LineTo(Width,Height);
//internal line
Pen.Color := clBlack;
Pen.Width := 1;
Pen.Style := psSolid;
for i:=BORDER_FOCUS to Width-BORDER_FOCUS do
begin
FBitmap.Canvas.MoveTo(i,BORDER_FOCUS);
if (i mod 2)=0 then
FBitmap.Canvas.LineTo(i+1,BORDER_FOCUS);
end;
for i:=BORDER_FOCUS to Height-BORDER_FOCUS do
begin
FBitmap.Canvas.MoveTo(BORDER_FOCUS,i);
if (i mod 2)=0 then
FBitmap.Canvas.LineTo(BORDER_FOCUS,i+1);
end;
for i:=BORDER_FOCUS to Width-BORDER_FOCUS do
begin
FBitmap.Canvas.MoveTo(i,Height-BORDER_FOCUS);
if (i mod 2)=0 then
FBitmap.Canvas.LineTo(i+1,Height-BORDER_FOCUS);
end;
for i:=BORDER_FOCUS to Height-BORDER_FOCUS do
begin
FBitmap.Canvas.MoveTo(Width-BORDER_FOCUS,i);
if (i mod 2)=0 then
FBitmap.Canvas.LineTo(Width-BORDER_FOCUS,i+1);
end;
end
else
begin
Pen.Width := 2;
Pen.Color := clWhite;
FBitmap.Canvas.MoveTo(0,0);
FBitmap.Canvas.LineTo(Width,0);
FBitmap.Canvas.MoveTo(0,0);
FBitmap.Canvas.LineTo(0,Height);
Pen.Color := clBlack;
Pen.Width := 4;
FBitmap.Canvas.MoveTo(0,Height);
FBitmap.Canvas.LineTo(Width,Height);
FBitmap.Canvas.MoveTo(Width,0);
FBitmap.Canvas.LineTo(Width,Height);
end;
Brush.Style := bsClear;
FGlyph.Transparent := True;
if (FGlyph.Width<>0) and (FCaption<>'') then
begin
FBitmap.Canvas.TextOut((width - TextWidth(FCaption) - FGlyph.Width) div 2 + FGlyph.Width + 5, (height - TextHeight(FCaption)) div 2 , FCaption);
FBitmap.Canvas.Draw((width - TextWidth(FCaption) - FGlyph.Width) div 2, (height - FGlyph.Height) div 2,FGlyph);
end
else
if FGlyph.Width=0 then
begin
FBitmap.Canvas.TextOut((width - TextWidth(FCaption)) div 2, (height - TextHeight(FCaption)) div 2 , FCaption);
end
else
begin
FBitmap.Canvas.Draw((width - FGlyph.Width) div 2, (height - FGlyph.Height) div 2,FGlyph);
end;
end;
Canvas.Draw(0,0,FBitmap);
end;
procedure TColorButton.SetCaption(Value: string);
begin
FCaption := Value;
Paint;
end;
procedure TColorButton.SetFont(Value: TFont);
begin
FFont.Assign(Value);
Paint;
end;
procedure TColorButton.SetColor(Value: TColor);
begin
FColor := Value;
Paint;
end;
procedure TColorButton.DoExit;
begin
Paint;
end;
procedure TColorButton.DoEnter;
begin
Paint;
end;
procedure TColorButton.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
FWidthTop := 4;
FWidthDown := 2;
SetFocus;
Paint;
end;
procedure TColorButton.MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
FWidthTop := 2;
FWidthDown := 4;
Paint;
end;
procedure TColorButton.Click;
begin
inherited;
end;
procedure TColorButton.KeyPress(var Key: Char);
begin
FWidthTop := 4;
FWidthDown := 2;
Paint;
if (Key=#13) or (Key=' ') then
Click;
FWidthTop := 2;
FWidthDown := 4;
Paint;
end;
constructor TColorSpeedButton.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
FColor := clSilver;
FFont := TFont.Create;
FFont.Assign(Canvas.Font);
FTopColor := clWhite;
FBottomColor := clBlack;
Width := 22;
Height := 22;
FGlyph := TBitmap.Create;
ParentFont := True;
FCaption := '';
FParentColor := False;
FBitmap := TBitmap.Create;
end;
destructor TColorSpeedButton.Destroy;
begin
FFont.Free;
FGlyph.Free;
FBitmap.Free;
inherited Destroy;
end;
procedure TColorSpeedButton.SetGlyph(Value: TBitmap);
begin
FGlyph.Assign(Value);
Invalidate;
end;
procedure TColorSpeedButton.Paint;
begin
FBitmap.Width:=Width; {Ajustamos nuestro bitmap}
FBitmap.Height:=Height;
with FBitmap.Canvas do
begin
Font.Assign(FFont);
if FParentColor=False then
Brush.Color := FColor
else
Brush.Color := Parent.Brush.Color;
FBitmap.Canvas.FillRect(ClientRect);
Pen.Width := 2;
Pen.Color := FTopColor;
FBitmap.Canvas.MoveTo(0,0);
FBitmap.Canvas.LineTo(Width,0);
FBitmap.Canvas.MoveTo(0,0);
FBitmap.Canvas.LineTo(0,Height);
Pen.Color := FBottomColor;
Pen.Width := 4;
FBitmap.Canvas.MoveTo(0,Height);
FBitmap.Canvas.LineTo(Width,Height);
FBitmap.Canvas.MoveTo(Width,0);
FBitmap.Canvas.LineTo(Width,Height);
FGlyph.Transparent := True;
if (FGlyph.Width<>0) and (FCaption<>'') then
begin
FBitmap.Canvas.TextOut((width - TextWidth(FCaption) - FGlyph.Width) div 2 + FGlyph.Width + 5, (height - TextHeight(FCaption)) div 2 , FCaption);
FBitmap.Canvas.Draw((width - TextWidth(FCaption) - FGlyph.Width) div 2, (height - FGlyph.Height) div 2,FGlyph);
end
else
if FGlyph.Width=0 then
begin
FBitmap.Canvas.TextOut((width - TextWidth(FCaption)) div 2, (height - TextHeight(FCaption)) div 2 , FCaption);
end
else
begin
FBitmap.Canvas.Draw((width - FGlyph.Width) div 2, (height - FGlyph.Height) div 2,FGlyph);
end;
end;
Canvas.Draw(0,0,FBitmap);
end;
procedure TColorSpeedButton.SetCaption(Value: string);
begin
FCaption := Value;
Paint;
end;
procedure TColorSpeedButton.SetFont(Value: TFont);
begin
FFont.Assign(Value);
Paint;
end;
procedure TColorSpeedButton.SetColor(Value: TColor);
begin
FColor := Value;
Paint;
end;
procedure TColorSpeedButton.SetParentColor(AParentColor: boolean);
begin
FParentColor := AParentColor;
Paint;
end;
procedure TColorSpeedButton.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
FTopColor := clBlack;
FBottomColor := clWhite;
Paint;
end;
procedure TColorSpeedButton.MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
FTopColor := clWhite;
FBottomColor := clBlack;
Paint;
end;
procedure Register;
begin
RegisterComponents('Components Delphi', [TColorButton]);
RegisterComponents('Components Delphi', [TColorSpeedButton]);
end;
end.
La propietat Color fa que el botó canvïi de color.
Tuesday, January 16, 2007
WinLinks
Aquest component incorpora una sèrie de mètodes que ens permeten crear accesos directes a l'aplicació que el conté.
unit WinLinks;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
ShlObj, ActiveX, ComObj;
const
CSIDL_DESKTOP = 0;
CSIDL_PROGRAMS = 2;
CSIDL_STARTUP = 7;
CSIDL_STARTMENU = 11;
type
TWinLinks = class(TComponent)
private
{ Private declarations }
Path: string;
Handle: HWnd;
function CreateLink(appname: string; apppath: string): boolean;
protected
{ Protected declarations }
procedure CreateLinkType(linktype: integer);
public
{ Public declarations }
procedure CreateDesktopLink;
procedure CreateStartMenuLink;
procedure CreateStartUpLink;
procedure CreateProgramsLink;
published
{ Published declarations }
end;
procedure Register;
function SHGetSpecialFolderPath(Handle: HWND; Path: PChar; Folder: Integer; Create: Bool): HRESULT; StdCall;
implementation
function SHGetSpecialFolderPath; External 'Shell32.DLL' Name 'SHGetSpecialFolderPathA';
function TWinLinks.CreateLink(appname: string; apppath: string): boolean;
var
IShellLinkInterface: IShellLink;
IPersistFileInterface: IPersistFile;
ResultCode: HResult;
WidePath: Array[0..1024] Of WideChar;
begin
apppath := PChar(apppath);
IShellLinkInterface := IShellLink(CreateCOMObject(CLSID_ShellLink));
With IShellLinkInterface Do
begin
SetPath(pchar(appname));
SetDescription(PChar(ChangeFileExt(ExtractFileName(appname),'')));
end;
StringToWideChar(apppath+'\'+ChangeFileExt(ExtractFileName(appname),'.lnk'), WidePath, 1024);
ResultCode := IShellLinkInterface.QueryInterface(IPersistFile, IPersistFileInterface);
If ResultCode <> S_OK Then // Si no fue posible
begin
Result := False;
Exit;
end;
ResultCode := IPersistFileInterface.Save(WidePath, True);
end;
procedure TWinLinks.CreateLinkType(linktype: integer);
begin
SetLength(Path, MAX_PATH+1);
SHGetSpecialFolderPath(Handle, PChar(Path), linktype, False);
CreateLink(Application.ExeName,Path);
end;
procedure TWinLinks.CreateDesktopLink;
begin
CreateLinkType(CSIDL_DESKTOP);
end;
procedure TWinLinks.CreateStartMenuLink;
begin
CreateLinkType(CSIDL_STARTMENU);
end;
procedure TWinLinks.CreateStartUpLink;
begin
CreateLinkType(CSIDL_STARTUP);
end;
procedure TWinLinks.CreateProgramsLink;
begin
CreateLinkType(CSIDL_PROGRAMS);
end;
procedure Register;
begin
RegisterComponents('Components Delphi', [TWinLinks]);
end;
end.
Els mètodes són CreateDesktopLink, CreateStartMenuLink, CreateStartUpLink i CreateProgramsLink, que ens permeten crear respectivament un accés directe a l'escriptori, al menú Inici, al menú que fa que l'aplicació s'inicïi amb windows i a la secció programes del menú Inici.
Thursday, January 11, 2007
FloatEdit
Caixa d'edició que només permet l'entrada de números reals.
unit FloatEdit;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls, DsgnIntf, ShellAPI;
type TFloatEditEd = class(TDefaultEditor)
procedure ExecuteVerb(Index: integer); override;
function GetVerb(Index: integer): string; override;
function GetVerbCount: integer; override;
end;
type
TFloatEdit = class(TCustomEdit)
private
{ Private declarations }
FAlignment: TAlignment;
FValue: double;
lDelPressed: boolean;
FVersion: string;
FMaxIntValue: integer;
FPrecission: integer;
FSeparator: char;
procedure SetAlignment(AAlignment: TAlignment);
function GetValue: double;
procedure SetValue(iNewVal: double);
function GetAsFloat: double;
procedure SetAsFloat(lnVal: double);
function GetAsString: string;
procedure SetAsString(strVal: string);
procedure SetVersion(strVersion: string);
procedure CMEnter(var Message: TCMEnter); message CM_ENTER;
protected
{ Protected declarations }
procedure KeyPress(var Key: Char); override;
procedure KeyDown(var Key: Word; Shift: TShiftState); override;
procedure KeyUp(var Key: Word; Shift: TShiftState); override;
procedure CreateParams(var Params: TCreateParams); override;
public
{ Public declarations }
constructor Create(AOwner: TComponent); override;
property AsFloat: double read GetAsFloat write SetAsFloat;
property AsString: string read GetAsString write SetAsString;
published
{ Published declarations }
property MaxIntValue: integer read FMaxIntValue write FMaxIntValue;
property Precission: integer read FPrecission write FPrecission;
property Value: double read GetValue write SetValue;
property Alignment: TAlignment read FAlignment write SetAlignment default taRightJustify;
property Anchors;
property AutoSelect;
property AutoSize default True;
property BorderStyle;
property Color;
property Ctl3D;
property DragCursor;
property DragMode;
property Enabled;
property Font;
property HideSelection;
property ParentColor;
property ParentCtl3D;
property ParentFont;
property ParentShowHint;
property PopupMenu;
property ReadOnly;
property ShowHint;
property TabOrder;
property Visible;
(* General events properties *)
property OnChange;
property OnClick;
property OnDblClick;
property OnDragDrop;
property OnDragOver;
property OnEndDrag;
property OnEnter;
property OnExit;
property OnKeyDown;
property OnKeyPress;
property OnKeyUp;
property OnMouseDown;
property OnMouseMove;
property OnMouseUp;
property Version: string read FVersion write SetVersion;
end;
procedure Register;
implementation
procedure Register;
begin
RegisterComponents('Components Delphi', [TFloatEdit]);
end;
constructor TFloatEdit.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
FAlignment := taRightJustify;
FValue := 0;
Text := '0';
FSeparator := ',';
FMaxIntValue := 2147483647;
FPrecission := 2;
lDelPressed := False;
FVersion := '1.1';
end;
procedure TFloatEdit.SetAlignment(AAlignment: TAlignment);
begin
if FAlignment <> AAlignment then
begin
FAlignment := AAlignment;
if not (csDesigning in ComponentState) then
RecreateWnd;
if Focused then
SelectAll;
end;
end;
function TFloatEdit.GetValue: double;
begin
Result := FValue;
end;
procedure TFloatEdit.SetValue(iNewVal: double);
begin
Text := FloatToStr(iNewVal);
FValue := iNewVal;
if Focused then
begin
SelStart := Length(Text);
SelectAll;
end;
end;
procedure TFloatEdit.SetAsFloat(lnVal: double);
begin
Value := lnVal;
end;
function TFloatEdit.GetAsFloat: double;
begin
Result := Value;
end;
procedure TFloatEdit.SetAsString(strVal: string);
begin
Value := StrToFloat(strVal);
end;
function TFloatEdit.GetAsString: string;
begin
Result := FloatToStr(Value);
end;
procedure TFloatEdit.KeyPress(var Key: Char);
begin
if not (Key in [#27, '0'..'9', #8, ',']) then begin
Key := #0;
MessageBeep(0);
Exit;
end
else if (Key in ['0'..'9']) then
begin
if (Length(Copy(Text,Pos(',',Text)+1,Length(Text)-Pos(',',Text)+1))>FPrecission-1) and (Pos(',',Text)<>0) then
begin
Key := #0;
MessageBeep(0);
Exit;
end
else if Int(StrToFloat(Text+key))>FMaxIntValue then
begin
Key := #0;
MessageBeep(0);
Exit;
end;
end;
inherited;
end;
procedure TFloatEdit.KeyDown(var Key: Word; Shift: TShiftState);
begin
ClearSelection;
inherited KeyDown(Key,Shift);
end;
procedure TFloatEdit.KeyUp(var Key: Word; Shift: TShiftState);
begin
inherited KeyUp(Key,Shift);
if Text='' then
begin
Text := '0';
SelStart := Length(Text);
SelectAll;
end;
FValue := StrToFloat(Text);
end;
procedure TFloatEdit.CreateParams(var Params: TCreateParams);
var
{$ifdef VER120}
lnStyle: LongWord;
{$else}
lnStyle: LongInt;
{$endif}
begin
inherited CreateParams(Params);
case Alignment of
taLeftJustify:
lnStyle := ES_LEFT;
taRightJustify:
lnStyle := ES_RIGHT
else
lnStyle := ES_CENTER;
end (*case*);
with Params do
Style := Style or DWORD(lnStyle);
end;
procedure TFloatEdit.SetVersion(strVersion: string);
begin
end;
procedure TFloatEdit.CMEnter(var Message: TCMEnter);
begin
if AutoSelect and not ReadOnly then
SelectAll
else
if not ReadOnly then
begin
SelStart := Length(Text);
end (*if*);
Refresh;
inherited;
end;
end.
La propietat Value conté el número introduït. MaxIntValue conté el màxim valor enter que és possible introduïr. Amb Precission determinem el màxim número de decimals permesos. Alignment permet alinear el text a la dreta o a l'esquerra.
Wednesday, January 10, 2007
SytemInfo
Mostra algunes propietats de sistema operatiu.
unit SystemInfo;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs;
type
TSystemInfo = class(TComponent)
private
{ Private declarations }
FShortDate: string;
FLongDate: string;
FTime: string;
FComputerName: string;
FUserName: string;
FCDRomDrive: string;
function GetFirstCdRomDrive: string;
protected
{ Protected declarations }
public
{ Public declarations }
constructor Create(AOwner:TComponent); override;
published
{ Published declarations }
property ShortDate: string read FShortDate write FShortDate;
property LongDate: string read FLongDate write FLongDate;
property Time: string read FTime write FTime;
property ComputerName: string read FComputerName write FComputerName;
property UserName: string read FUserName write FUserName;
property CDRomDrive: string read FCDRomDrive write FCDRomDrive;
end;
procedure Register;
implementation
function TSystemInfo.GetFirstCdRomDrive: string;
var
r: LongWord;
Unidades: array[0..128] of char;
pUnidad: pchar;
begin
Result := '';
r := GetLogicalDriveStrings(sizeof(Unidades), Unidades);
if r = 0 then exit;
if r > sizeof(Unidades) then
raise Exception.Create(SysErrorMessage(ERROR_OUTOFMEMORY));
pUnidad := Unidades; // Apunta a la primera unidad
while pUnidad^ <> #0 do begin
if GetDriveType(pUnidad) = DRIVE_CDROM then begin
Result := pUnidad;
exit;
end;
inc(pUnidad, 4); // Apunta a la siguiente unidad
end;
end;
constructor TSystemInfo.Create(AOwner:TComponent);
var
Buf: array[0..99] of char;
size: dword;
begin
inherited;
GetLocaleInfo(LOCALE_USER_DEFAULT,LOCALE_SSHORTDATE,@Buf,100);
FShortDate := Buf;
GetLocaleInfo(LOCALE_USER_DEFAULT,LOCALE_SLONGDATE,@Buf,100);
FLongDate := Buf;
GetLocaleInfo(LOCALE_USER_DEFAULT,LOCALE_STIMEFORMAT,@Buf,100);
FTime := Buf;
size := 100;
GetComputerName(Buf, size);
FComputerName := Buf;
GetUserName(Buf, size);
FUserName := Buf;
FCDRomDrive := GetFirstCdRomDrive;
end;
procedure Register;
begin
RegisterComponents('Components Delphi', [TSystemInfo]);
end;
end.
La propietat CDRomDrive ens indica la unitat del CD. ComputerName ens dona el nom de la màquina. LongData i ShortDate els formats de data del sistam. Time el format de temps del sistema. Finalment, User, l'usuari actual del sistema operatiu. Lògicament es poden anar afegint tantes propietats com es vulgui per obtenir dades del sistema.
Tuesday, January 09, 2007
BlinkingLabel
Descendent del TLabel que canvia de color intermitentment
unit BlinkingLabel;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls, ExtCtrls;
type
TBlinkingLabel = class(TCustomLabel)
private
{ Private declarations }
Timer: TTimer;
FBlinkingEnabled: boolean;
FBlinkingInterval: integer;
FBlinkingFirstColor: TColor;
FBlinkingSecondColor: TColor;
procedure RefreshLabel;
protected
{ Protected declarations }
procedure SetBlinkingEnabled(ABlinkingEnabled: boolean);
procedure SetBlinkingInterval(ABlinkingInterval: integer);
procedure OnTimer(Sender: TObject); virtual;
public
{ Public declarations }
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
published
{ Published declarations }
property BlinkingEnabled: boolean read FBlinkingEnabled write SetBlinkingEnabled default True;
property BlinkingInterval: integer read FBlinkingInterval write SetBlinkingInterval default 500;
property BlinkingFirstColor: TColor read FBlinkingFirstColor write FBlinkingFirstColor;
property BlinkingSecondColor: TColor read FBlinkingSecondColor write FBlinkingSecondColor;
property Align;
property Alignment;
property Anchors;
property AutoSize;
property BiDiMode;
property Caption;
property Color;
property Constraints;
property DragCursor;
property DragKind;
property DragMode;
property Enabled;
property FocusControl;
property Font;
property ParentBiDiMode;
property ParentColor;
property ParentFont;
property ParentShowHint;
property PopupMenu;
property ShowAccelChar;
property ShowHint;
property Transparent;
property Layout;
property WordWrap;
property Visible;
property OnClick;
property OnDblClick;
property OnDragOver;
property OnDragDrop;
property OnEndDock;
property OnEndDrag;
property OnMouseDown;
property OnMouseUp;
property OnStartDock;
property OnStartDrag;
end;
procedure Register;
implementation
constructor TBlinkingLabel.Create(AOwner: TComponent);
begin
FBlinkingEnabled := False;
FBlinkingInterval := 500;
FBlinkingFirstColor := clBlue;
FBlinkingSecondColor := clRed;
Timer := TTimer.Create(Self);
Timer.Enabled := FBlinkingEnabled;
Timer.Interval := FBlinkingInterval;
Timer.OnTimer := OnTimer;
inherited;
RefreshLabel;
end;
destructor TBlinkingLabel.Destroy;
begin
Timer.Free;
inherited;
end;
procedure TBlinkingLabel.SetBlinkingEnabled(ABlinkingEnabled: boolean);
begin
FBlinkingEnabled := ABlinkingEnabled;
Timer.Enabled := ABlinkingEnabled;
end;
procedure TBlinkingLabel.SetBlinkingInterval(ABlinkingInterval: integer);
begin
FBlinkingInterval := ABlinkingInterval;
Timer.Interval := ABlinkingInterval;
end;
procedure TBlinkingLabel.OnTimer(Sender: TObject);
begin
RefreshLabel;
end;
procedure TBlinkingLabel.RefreshLabel;
begin
if Font.Color=FBlinkingFirstColor then
Font.Color := FBlinkingSecondColor
else
Font.Color := FBlinkingFirstColor;
end;
procedure Register;
begin
RegisterComponents('Components Delphi', [TBlinkingLabel]);
end;
end.
Les propietats BlinkingFirstColor i BlinkingSecondColor indiquen els dos colors entre els quals s'alterna. La propietat BlinkingInterval indica el període de canvi en milisegons. Amb la propietat BlinkingEnabled activem o desactivem el canvi.
Monday, January 08, 2007
FormMemoryReg
Guarda en el registre la posició i tamany del formulari, per recuperar-les al tornar-lo a crear.
unit FormMemoryReg;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
Registry, Menus;
type
//save dimensions by form name
TFormMemoryReg = class(TComponent)
private
{ Private declarations }
RegIniFile: TRegIniFile;
FOwner: TForm;
AN: string;
protected
{ Protected declarations }
public
{ Public declarations }
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
procedure Loaded; override;
published
{ Published declarations }
end;
procedure Register;
implementation
constructor TFormMemoryReg.Create(AOwner: TComponent);
var
filename: string;
fl: TStringList;
begin
inherited Create(AOwner);
FOwner := TForm(AOwner);
end;
procedure TFormMemoryReg.Loaded;
var
fl: TStringList;
begin
inherited Loaded;
AN := ExtractFileName(Application.ExeName);
AN := ChangeFileExt(AN,'');
if not (csDesigning in ComponentState) then
begin
RegIniFile := TRegIniFile.Create('');
RegIniFile.RootKey := HKey_Local_Machine;
if not RegIniFile.OpenKey('Software\CompDelphi\'+AN+'\FormsMem',False) then
begin
RegIniFile.CreateKey('Software\CompDelphi\'+AN+'\FormsMem');
end;
FOwner.Top := RegIniFile.ReadInteger('',FOwner.Name+'t',FOwner.Top);
FOwner.Left := RegIniFile.ReadInteger('',FOwner.Name+'l',FOwner.Left);
FOwner.Height := RegIniFile.ReadInteger('',FOwner.Name+'h',FOwner.Height);
FOwner.Width := RegIniFile.ReadInteger('',FOwner.Name+'w',FOwner.Width);
RegIniFile.Free;
end;
end;
destructor TFormMemoryReg.Destroy;
begin
if not (csDesigning in ComponentState) then
begin
if FOwner.WindowState=wsNormal then
begin
RegIniFile := TRegIniFile.Create('');
RegIniFile.RootKey := HKey_Local_Machine;
RegIniFile.OpenKey('Software\CompDelphi\'+AN+'\FormsMem',False);
RegIniFile.WriteInteger('',FOwner.Name+'t',FOwner.Top);
RegIniFile.WriteInteger('',FOwner.Name+'w',FOwner.Width);
RegIniFile.WriteInteger('',FOwner.Name+'l',FOwner.Left);
RegIniFile.WriteInteger('',FOwner.Name+'h',FOwner.Height) ;
end;
RegIniFile.Free;
end;
inherited;
end;
procedure Register;
begin
RegisterComponents('Components Delphi', [TFormMemoryReg]);
end;
end.
