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

[TF6M]

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

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

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

[kachwahed]

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

[TF6M]

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

[TF6M]

هدا تحسين على الكود :
http://img522.imageshack.us/img522/5644/31459559.jpg

{************************************************* *************************}
//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.



بالتوفيق ,,

[kml_hmd]

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

[issamdnn]

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

[hanipino]

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


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 تركه باسمه . :)

[nabilkeb]

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

بالتوفيق.

[TF6M]

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

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

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

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

http://www.delphi4arab.com/forum/showthread.php?t=796

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