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

السلام عليكم و رحمة الله و بركاته

برنامج بسيط يحتوي على :
1- فتح + كتابة الى المنفذ بواسطة ApiWin32
2- وصل كل Pin بمكون Shape لمتابعة التغيرات
-----------------------------------------------
[صورة: guiah.jpg]

أتمنى أن يفيدكم بإذن الله .... بالتوفيق ,,

tf6m بارك الله فيك، عمل رائع وبرنامج أروع
نشاطك في المنتدى وحرصك على نشر العلم يجعلانك في القمة.
بالتوفيق للمزيد.

أخي kachwahed بارك الله فيك
في إنتظار ك و بالتوفيق,,

هدا تحسين على الكود :

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. 

بالتوفيق ,,

اشكرك علي البرنامج و ليتك تدرج تقاصيل قليلة عن فكرة عمل البرنامج \ الخوارزمية

الله يعطيك العافية .في الحديث عن هذا الموضوع لدي مكتبة صغيرة للتحكم بهذه المنافذ إضافة لمنفذ ال lpt . الله يعطيك العافية مجدداً وشكراً لك

يمكن ايضا تحسين كود SendDataClick

PHP كود :
procedure TForm1.SendDataClick(Sender: TObject);
var
  ShapClr: string;
  n: Byte;
  b: Char;
  Shp: TShape;
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];
    Shp := TShape(FindComponent('shp' + '_' + IntToStr(n)));
    if Shp <> nil then
    case b of
      '1': Shp.Brush.Color :=  cllime;
      '0': Shp.Brush.Color :=  clwhite;
    end;
  end;
end; 

مع تغيير اسماء المكون shape الى Shp_2 Shp_1 ... معدى المكون shape5 تركه باسمه . Smile

جميل جدا ، شكرا جزيلا أخي الكريم.

بالتوفيق.

بارك الله فيكم على الردود الطيبة ....

1- الأخ hanipino الهدف من الموضوع طرح فكرة الإتصال الخارجي أو التحكم
لم أتطرق للعديد من الجوانب .... فقط لمحة :tong: (كإعداد المودم و بروتوكول النقل
و تصميم الواجهة Pc/Elec ..... الخ) في إنتظار تحسينات أخرى لأن طريقتك ما كنت أعرفها
تختصر الكثير جازاك الله كل خير .

2- الأخ nabilkeb بالتوفيق لك أيضا أخي العزيز .

3- أخي kml_hmd هناك سلسلة Pdf راجعها :

http://www.delphi4arab.net/forum/showthread.php?tid=796

بالتوفيق للجميع ,,