برنامج التحكم بالمنفذالتسلسلي "Com"

PHP كود :
{**************************************************************************}
                     //CoDed By TF6M 26-11-2009//
{**************************************************************************}
unit Unit1;
{$WARNINGS OFF}
{$HINTS OFF}
{$OPTIMIZATION ON}
interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  ExtCtrls, StdCtrls, Spin, XPman;

type
  TForm1 = class(TForm)
    OpenCom: TButton;
    SendData: TButton;
    PortList: TComboBox;
    DataV: TSpinEdit;
    Shape1: TShape;
    Shape2: TShape;
    Shape3: TShape;
    Shape4: TShape;
    Shape5: TShape;
    Shape6: TShape;
    Shape7: TShape;
    Shape8: TShape;
    Shape9: TShape;
    ActTimer: TButton;
    Timer: TTimer;
    Button1: TButton;
    Button2: TButton;
    Image1: TImage;
    Label1: TLabel;
    Label2: TLabel;
    Label3: TLabel;
    Label4: TLabel;
    Label5: TLabel;
    Label6: TLabel;
    Label7: TLabel;
    Label8: TLabel;
    Label9: TLabel;
    procedure OpenComClick(Sender: TObject);
    procedure SendDataClick(Sender: TObject);
    procedure ActTimerClick(Sender: TObject);
    procedure TimerTimer(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure Button1Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);
    procedure ResEtShape;
  end;

var
  Form1: TForm1;
  Hcom: Hwnd;

implementation

{$R *.dfm}

procedure TForm1.ResEtShape;
begin
  if Hcom >= 0 then
    CloseHandle(Hcom);
  shape9.Brush.Color := clwhite;
  shape8.Brush.Color := clwhite;
  shape7.Brush.Color := clwhite;
  shape6.Brush.Color := clwhite;
  shape4.Brush.Color := clwhite;
  shape3.Brush.Color := clwhite;
  shape2.Brush.Color := clwhite;
  shape1.Brush.Color := clwhite;
  DataV.Value := 0;
end;

function Int2Bin(x: Integer): string;
var
  s: string;
begin
  s := '';
  repeat
    case x mod 2 of
      0: s := '0' + s;
      1: s := '1' + s;
    end;
    x := x div 2;
  until x = 0;
  if Length(s) = 8 then
    Result := s else
    Result := StringOfChar('0', 8 - Length(s)) + s;
end;

function OpenComPort(ComName: string): Hwnd;
begin
  Result := 0;
  Hcom := CreateFile(Pchar(ComName), GENERIC_All, 0, nil
    , OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, 0);
  if Hcom <> Dword(-1) then
    Result := Hcom;
end;

function SendValue(Data: Byte): Boolean;
var
  nBw: Dword;
begin
  Result := False;
  WriteFile(Hcom, Data, SizeOf(Data), nBw, nil);
  if SizeOf(Data) = nBw then
    Result := True;
end;

procedure TForm1.OpenComClick(Sender: TObject);
begin
  if OpenCom.Caption = 'OpenCom' then
  begin
    if PortList.ItemIndex <> -1 then
      if OpenComPort(PortList.Items[PortList.ItemIndex]) <> 0 then
        MessageBox(0, 'Open Ok', nil, 0) else
        MessageBox(0, 'Open No', nil, 0);
    OpenCom.Caption := 'CloseCom';
    SendData.Enabled := True;
  end else
  begin
    OpenCom.Caption := 'OpenCom';
    SendData.Enabled := False;
    ResEtShape;
  end;
end;

procedure TForm1.SendDataClick(Sender: TObject);
var
  ShapClr: string;
  n: Byte; b: Char;
begin
  if (Hcom = Dword(-1)) or (Hcom <= 0) then Exit;
  if SendValue(DataV.Value) then
    ShapClr := Int2Bin(DataV.Value);
  for n := 1 to 8 do
  begin
    b := ShapClr[n];
    if (n = 1) and (b = '1') then shape9.Brush.Color := cllime else if (n = 1) and (b = '0') then shape9.Brush.Color := clwhite;
    if (n = 2) and (b = '1') then shape8.Brush.Color := cllime else if (n = 2) and (b = '0') then shape8.Brush.Color := clwhite;
    if (n = 3) and (b = '1') then shape7.Brush.Color := cllime else if (n = 3) and (b = '0') then shape7.Brush.Color := clwhite;
    if (n = 4) and (b = '1') then shape6.Brush.Color := cllime else if (n = 4) and (b = '0') then shape6.Brush.Color := clwhite;
    if (n = 5) and (b = '1') then shape4.Brush.Color := cllime else if (n = 5) and (b = '0') then shape4.Brush.Color := clwhite;
    if (n = 6) and (b = '1') then shape3.Brush.Color := cllime else if (n = 6) and (b = '0') then shape3.Brush.Color := clwhite;
    if (n = 7) and (b = '1') then shape2.Brush.Color := cllime else if (n = 7) and (b = '0') then shape2.Brush.Color := clwhite;
    if (n = 8) and (b = '1') then shape1.Brush.Color := cllime else if (n = 8) and (b = '0') then shape1.Brush.Color := clwhite;
  end;
end;

procedure TForm1.ActTimerClick(Sender: TObject);
begin
  if not Timer.Enabled then
    Timer.Enabled := True else
    Timer.Enabled := False;
end;

procedure TForm1.TimerTimer(Sender: TObject);
begin
  if SendData.Enabled then
    SendDataClick(Sender);
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
  PortList.ItemIndex := 0;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  ExitProcess(GetLastError);
end;

procedure TForm1.Button2Click(Sender: TObject);
begin
  MessageBox(0, 'CoDed By TF6M | 26-11-2009'
    , nil, $2000 + $40 + $00);
end;

end.