Registry'den Okuma ve Binary Yazma
{Registry'e yazdırma ve okuma ile ilgili bir proje üzerinde çalışırken
Delphi 7.0 ile gelen Registry.pas Unit'inin yeterli olmadığını,bütün veri
türlerini desteklemediğini gördüm.(Desteklenenler REG_SZ (rdString),REG_EXPAND_SZ
(rdExpandString), REG_DWORD (rdInteger) ve kısmen REG_BINARY (rdBinary))
Maalesef Binary veri okutma üzerinde 2 gün uğraşmak zorunda kaldım.. Unit Registry
Nümerik kaydedilen değerleri okuyor, KodBank'taki diğer bütün örnekler ise tüm registry tiplerini okuyup yazdığını iddia edenler dahil, spesifik olarak ya Nümerik kaydedilen değerleri okuyor, ya String kaydedilen değerleri okuyor en akıllıca çözümleyenler ise Byte dizisi olarak okutuyor ama o verileri de işlemiyordu(İşlenemez değil tabii ki)...
Projeye devam edebilmek için mecburen aşağıdaki ---OkuReg--- fonksiyonunu ve ona bağlı olarak
---YazRegBinary--- fonksiyonunu yazdım, tam olarak yeterli olmadığının farkındayım, fonksiyon özellikle
REG_RESOURCE_LIST ve REG_FULL_RESOURCE_DESCRIPTOR türü verileri okumakta yetersiz ayrıca Byte
dizisi olarak kaydedilen Binary tip verileri okumak için de geliştirilmesi lazım (Çözüm belli ama yoruldum)...
Ancak yine de İhtiyacım olan Veri tipini tam olarak belirleme, veri uzunluğunu bulma
string ve Integer(REG_DWORD) kayıtları okuma, String ve nümerik kaydedilmiş Binary verileri
okuma işlemlerini tek bir fonksiyonda topladım...İlgilenenlere }
// Forma 2 Edit,1 Listbox,4 Button,2 stringgrid,1 checkbox koyun
//---Fonksiyonun kullanılışını göstermek için basit bir unit-------------------------------------
unit Unit1 ;
interface
uses
Windows , Messages , SysUtils , Variants , Classes , Graphics , Controls , Forms ,
Dialogs , StdCtrls , Grids , Registry ;
// Regdegerlerini tanıtmalıyız......
type
RegDegerleri = record
DataTip_Str : String ; //Verinin türünü String olarak verir Ör: 'REG_DWORD'
DataTip_Int : Integer ; //Verinin türünü Integer olarak verir 1:REG_SZ 2:REG_EXPAND_SZ vs. fonksiyondan anlaşılıyor
Veri_Int : Integer ; //Verinin integer olarak değerini verir, String olarak kaydedilen veriler için -1 olarak dönecektir.
Veri_Str : String ; //Verinin string olarak değerini verir, Nümerik kaydedilenler için IntToStr hali döner..
Uzunluk : Integer ; //Verinin Registry'deki uzunluğunun kaç byte olduğunu verir
end ;
type
TForm1 = class ( TForm )
Edit1 : TEdit ;
StringGrid1 : TStringGrid ;
Button1 : TButton ;
CheckBox1 : TCheckBox ;
Edit2 : TEdit ;
Button2 : TButton ;
Button3 : TButton ;
Button4 : TButton ;
ListBox1 : TListBox ;
procedure Button1Click ( Sender : TObject );
procedure FormCreate ( Sender : TObject );
procedure Button2Click ( Sender : TObject );
procedure Button3Click ( Sender : TObject );
procedure Button4Click ( Sender : TObject );
private
{ Private declarations }
public
{ Public declarations }
end ;
function OkuReg ( const xReg : TRegistry ; RegDegerAd : string ): RegDegerleri ;
function YazRegBinary ( const xReg : TRegistry ; RegDegerAd , Veri_Str : string ; StrVeyaInt : Byte ): Boolean ;
var
Form1 : TForm1 ;
Reg1 : TRegistry ;
implementation
{$R *.dfm}
procedure TForm1 . FormCreate ( Sender : TObject );
var i : byte ;
const
xstr : array [ 0 .. 5 ] of string =( 'Değer Ad' , 'Veri Türü' , 'Veri Str' , 'Veri Int' , 'Veri Türü Int' , 'Uzunluk' );
begin
Reg1 := TRegistry . Create ;
Reg1 . RootKey := HKEY_CURRENT_USER ;
Reg1 . OpenKey ( 'AnahtarDeneme' , True ); //İşiniz bittiğinde silerseniz iyi olur
for i := 0 to 5 do StringGrid1 . cells [ i + 1 , 0 ]:= xstr [ i ];
ListBox1 . Visible := False ;
Button4 . Caption := 'Reg Değerleri Goster' ;
end ;
//...........................................................................
procedure TForm1 . Button1Click ( Sender : TObject ); //Edit2'yi Binary yazdır
// Checkbox seçili ise nümerik değilse string olarak yazdır.....
begin
if CheckBox1 . Checked then
if not YazRegBinary ( reg1 , Edit1 . Text , edit2 . Text , 1 ) then ShowMessage ( 'Registere yazma işlemi başarısız...'
+ chr ( 10 )+ 'Girilen verininin nümerik bir değer olduğundan emin olun' )
else else if not YazRegBinary ( reg1 , Edit1 . Text , edit2 . Text , 0 ) then ShowMessage ( 'Registere yazma işlemi başarısız...' );
end ;
//...........................................................................
procedure TForm1 . Button2Click ( Sender : TObject ); //Edit2'yi REG_SZ olarak yazdır
begin
reg1 . WriteString ( edit1 . Text , Edit2 . Text );
end ;
//...........................................................................
procedure TForm1 . Button3Click ( Sender : TObject ); //Edit2'yi REG_DWORD (Dword yani 16'lık veya 10'luk yazdır)
begin
reg1 . WriteInteger ( edit1 . Text , strtoint ( Edit2 . Text ));
end ;
//...........................................................................
// DenemeAnahtari içindeki tüm verileri Stringgride atiyoruz;
procedure TForm1 . Button4Click ( Sender : TObject );
var i : Byte ;
RegDeg : RegDegerleri ;
begin
reg1 . GetValueNames ( ListBox1 . Items );
if listbox1 . Count > 0 then
for i := 0 to ListBox1 . Count - 1 do
begin
//Fonksiyonun kullanılışı
StringGrid1 . Cells [ 1 , i + 1 ]:= ListBox1 . Items [ i ];
StringGrid1 . Cells [ 2 , i + 1 ]:= OkuReg ( reg1 , ListBox1 . Items [ i ]). DataTip_Str ;
StringGrid1 . Cells [ 3 , i + 1 ]:= OkuReg ( reg1 , ListBox1 . Items [ i ]). Veri_Str ;
StringGrid1 . Cells [ 4 , i + 1 ]:= inttostr ( OkuReg ( reg1 , ListBox1 . Items [ i ]). Veri_Int );
StringGrid1 . Cells [ 5 , i + 1 ]:= inttostr ( OkuReg ( reg1 , ListBox1 . Items [ i ]). DataTip_Int );
StringGrid1 . Cells [ 6 , i + 1 ]:= inttostr ( OkuReg ( reg1 , ListBox1 . Items [ i ]). Uzunluk );
//veya
regdeg := OkuReg ( reg1 , ListBox1 . Items [ i ]);
StringGrid1 . Cells [ 2 , i + 1 ]:= regdeg . DataTip_Str ;
StringGrid1 . Cells [ 3 , i + 1 ]:= regdeg . Veri_Str ;
end ;
end ;
//--------------------------------------------------------------------
//--------------Veri Okuma Fonksiyonu---------------------------------
//--------------------------------------------------------------------
function OkuReg ( const xReg : TRegistry ; RegDegerAd : string ): RegDegerleri ;
//Code By S.KILIÇ
var
xRegDeger : RegDegerleri ;
TipI , Uz , VeriInt : Integer ;
xDword : Dword ;
TipS , Veri : String ;
xPoint : Pointer ;
begin
Veri := '' ;
if RegQueryValueEx ( xReg . CurrentKey , PChar ( RegDegerAd ), nil , @ TipI , nil ,@ Uz ) = ERROR_SUCCESS then
begin //if1
case TipI of //case 1
0 : TipS := 'REG_NONE' ;
1 : TipS := 'REG_SZ' ;
2 : TipS := 'REG_EXPAND_SZ' ;
3 : TipS := 'REG_BINARY' ;
4 : TipS := 'REG_DWORD' ;
5 : TipS := 'REG_DWORD_LITTLE_ENDIAN' ;
6 : TipS := 'REG_LINK' ;
7 : TipS := 'REG_MULTI_SZ' ;
8 : TipS := 'REG_RESOURCE_LIST' ;
9 : TipS := 'REG_FULL_RESOURCE_DESCRIPTOR' ;
10 : TipS := 'REG_RESOURCE_REQUIREMENTS_LIST' ;
end ; //case 1
case TipI of //case 2
1 , 2 , 7 : if Uz > 0 then
begin
VeriInt :=- 1 ;
SetString ( Veri , nil , Uz );
if RegQueryValueEx ( xReg . CurrentKey , PChar ( RegDegerAd ), nil , @ TipI , PByte ( Veri ),@ Uz )
= ERROR_SUCCESS then SetLength ( Veri , StrLen ( PChar ( Veri )));
end else Veri := '' ;
3 , 8 , 9 : Begin
//String Değerleri Okutma
GetMem ( xPoint , Uz );
if RegQueryValueEx ( reg1 . currentkey , pchar ( Regdegerad ), nil , @ TipI , xPoint ,@ Uz )
= ERROR_SUCCESS then
begin
SetLength ( Veri , Uz );
Move ( xPoint ^, Veri [ 1 ], Uz );
FreeMem ( xPoint );
end else FreeMem ( xPoint );
//Integer Değerleri Okutma
try
xDword := 0 ;
if RegQueryValueEx ( reg1 . CurrentKey , PChar ( Regdegerad ), nil , @ TipI , PByte (@ xDword ),@ uz )
= ERROR_SUCCESS then veriInt := xDword else veriInt :=- 1 ;
except
VeriInt :=- 1 ;
end ;
//Byte dizisini okutma, Geliştirilmeli
end ;
4 , 5 : Begin
VeriInt := xreg . ReadInteger ( RegDegerAd );
Veri := inttostr ( VeriInt );
end ;
end ; //case 2
end else //if1
begin
TipS := 'Bilinmeyen' ;
TipI :=- 1 ;
Uz :=- 1 ;
end ;
xRegDeger . Veri_Str := Veri ;
xRegDeger . Veri_Int := VeriInt ;
xRegDeger . DataTip_Str := TipS ;
xRegDeger . DataTip_Int := TipI ;
xRegDeger . Uzunluk := Uz ;
Result := xRegDeger ;
end ;
//-----------------------------------------------------------------------------------------------------
//---Binary Yazdırma fonksiyonu------ StrVeyaInt=0 ise String kaydet , StrVeyaInt=1 ise nümerik kaydet
//-----------------------------------------------------------------------------------------------------
function YazRegBinary ( const xReg : TRegistry ; RegDegerAd , Veri_Str : string ; StrVeyaInt : Byte ): Boolean ;
Var
xInt : Integer ;
Begin
Result := True ;
if StrVeyaInt = 1 then //Nümerik olarak kaydedilecekse
begin
try xInt := strtoint ( Veri_Str ); except Result := False ; Exit ; end ;
if RegSetValueEx ( xreg . CurrentKey , PChar ( RegDegerAd ), 0 , 3 , @ xInt , SizeOf ( xInt ))
<>ERROR_SUCCESS then Result := False ;
end else
if StrVeyaInt = 0 then //String olarak kaydedilecekse
if RegSetValueEx ( xReg . CurrentKey , PChar ( RegDegerAd ), 0 , 3 , PChar ( Veri_Str + #0 ), Length ( Veri_Str ))
<>ERROR_SUCCESS then Result := False else
else Result := False ;
End ;
end .
// Yorum ve soru için : swordtur@yahoo.com
// Unutmadan Derleyip exe halini çalıştırırsanız try except'lerden kurtulursunuz.....
Delphi - .....................................
Asansör Simülasyonu
//4 katlı bir binadaki tek asansör...
//www.delphiforfun.org da daha güzeli
//http://www.delphiforfun.org/Programs/elevator_sim1.htm
//thread ile yapılmış...
unit Unit3 ;
interface
uses
Windows , Messages , SysUtils , Variants , Classes , Graphics , Controls , Forms ,
Dialogs , ExtCtrls , Buttons , StdCtrls , Spin ;
type
TForm3 = class ( TForm )
Timer1 : TTimer ;
Bevel1 : TBevel ;
Bevel2 : TBevel ;
Bevel3 : TBevel ;
Bevel4 : TBevel ;
Bevel5 : TBevel ;
Panel1 : TPanel ;
Shape1 : TShape ;
SpeedButton1 : TSpeedButton ;
SpeedButton2 : TSpeedButton ;
SpeedButton3 : TSpeedButton ;
SpeedButton4 : TSpeedButton ;
StaticText1 : TStaticText ;
StaticText2 : TStaticText ;
StaticText3 : TStaticText ;
StaticText4 : TStaticText ;
Shape2 : TShape ;
SpeedButton5 : TSpeedButton ;
SpeedButton6 : TSpeedButton ;
SpeedButton7 : TSpeedButton ;
SpeedButton8 : TSpeedButton ;
SpeedButton9 : TSpeedButton ;
GroupBox1 : TGroupBox ;
StaticText7 : TStaticText ;
StaticText6 : TStaticText ;
StaticText8 : TStaticText ;
StaticText9 : TStaticText ;
StaticText10 : TStaticText ;
Button1 : TButton ;
SpinEdit1 : TSpinEdit ;
Label1 : TLabel ;
StaticText5 : TStaticText ;
StaticText11 : TStaticText ;
procedure SpinEdit1Change ( Sender : TObject );
procedure SpeedButton4Click ( Sender : TObject );
procedure SpeedButton3Click ( Sender : TObject );
procedure SpeedButton2Click ( Sender : TObject );
procedure SpeedButton1Click ( Sender : TObject );
procedure Shape2MouseUp ( Sender : TObject ; Button : TMouseButton ;
Shift : TShiftState ; X , Y : Integer );
procedure Button1Click ( Sender : TObject );
procedure SpeedButton9Click ( Sender : TObject );
procedure Timer1Timer ( Sender : TObject );
procedure FormCreate ( Sender : TObject );
private
{ Private declarations }
public
{ Public declarations }
end ;
var
Form3 : TForm3 ;
counter : byte = 1 ; //door counter
requestFloor : byte = 0 ; //where to lift
floor : byte = 1 ; //active floor
measure : integer ; //lifting value
state : byte = 1 ; //1- stopped,
//2- door open(1 time),
//3- door wait(3 times),
//4- door close(1 time),
//5- move
implementation
{$R *.dfm}
procedure TForm3 . FormCreate ( Sender : TObject );
begin
panel1 . DoubleBuffered := True ; //smooth graphics
state := 1 ; //stopped
floor := 1 ; //active floor
measure := 0 ;
end ;
procedure TForm3 . Timer1Timer ( Sender : TObject );
begin //Elevator Engine
if Form3 . panel1 . Top = 360 then StaticText5 . Caption := '1' else
if Form3 . panel1 . Top = 250 then StaticText5 . Caption := '2' else
if Form3 . panel1 . Top = 140 then StaticText5 . Caption := '3' else
if Form3 . panel1 . Top = 30 then StaticText5 . Caption := '4' ;
case state of
1 :
begin
counter := 0 ;
StaticText6 . Caption := 'Stopped' ;
StaticText7 . Caption := 'Ready' ;
end ;
2 :
begin
StaticText6 . Caption := 'Door Opening' ;
StaticText7 . Caption := 'Not Ready' ;
counter := counter + 1 ;
if counter = 12 then state := 3 ; //finished opening
shape2 . Width := shape2 . Width - 5 ;
end ;
3 :
begin
StaticText6 . Caption := 'Door Opened' ;
StaticText7 . Caption := 'Not Ready' ;
counter := counter + 1 ;
if counter = 36 then //12*3 more time waiting
begin
state := 4 ; //close it
counter := 0 ;
end ;
end ;
4 :
begin
StaticText6 . Caption := 'Door Closing' ;
StaticText7 . Caption := 'Not Ready' ;
counter := counter + 1 ;
if counter = 12 then state := 1 ; //finished closing
shape2 . Width := shape2 . Width + 5 ;
end ;
5 :
begin
counter := 0 ;
StaticText6 . Caption := 'Moving' ;
StaticText7 . Caption := 'Not Ready' ;
if ( requestFloor = floor ) or ( measure = 0 ) then
begin
state := 2 ;
floor := requestFloor ; //new floor
exit ; //cut the event!
end ; //same floor
if (( requestFloor - floor )> 0 ) and ( measure <> 0 ) then
begin
panel1 . Top := panel1 . Top - 5 ;
measure := measure - 5 ;
end ;
if (( requestFloor - floor )< 0 ) and ( measure <> 0 ) then
begin
panel1 . Top := panel1 . Top + 5 ;
measure := measure - 5 ;
end ;
end ;
end ;
end ;
procedure TForm3 . SpeedButton9Click ( Sender : TObject );
begin //Emergency stop...
timer1 . Enabled := not ( timer1 . Enabled );
end ;
procedure TForm3 . Button1Click ( Sender : TObject );
begin
close ; //end...
end ;
procedure TForm3 . Shape2MouseUp ( Sender : TObject ; Button : TMouseButton ;
Shift : TShiftState ; X , Y : Integer );
begin
if state = 1 then state := 2 ; //door open if not moving...
end ;
procedure TForm3 . SpeedButton1Click ( Sender : TObject );
begin //here we move!
if state = 1 then begin
requestFloor := 4 ; state := 5 ;
measure :=( requestFloor - floor )*( panel1 . height + 20 );
if measure < 0 then measure := measure *- 1 ;
SpeedButton5 . Down := true ;
end ;
end ;
procedure TForm3 . SpeedButton2Click ( Sender : TObject );
begin
if state = 1 then begin
requestFloor := 3 ; state := 5 ;
measure :=( requestFloor - floor )*( panel1 . height + 20 );
if measure < 0 then measure := measure *- 1 ;
SpeedButton6 . Down := true ;
end ;
end ;
procedure TForm3 . SpeedButton3Click ( Sender : TObject );
begin
if state = 1 then begin
requestFloor := 2 ; state := 5 ;
measure :=( requestFloor - floor )*( panel1 . height + 20 );
if measure < 0 then measure := measure *- 1 ;
SpeedButton7 . Down := true ;
end ;
end ;
procedure TForm3 . SpeedButton4Click ( Sender : TObject );
begin
if state = 1 then begin
requestFloor := 1 ; state := 5 ;
measure :=( requestFloor - floor )*( panel1 . height + 20 );
if measure < 0 then measure := measure *- 1 ;
SpeedButton8 . Down := true ;
end ;
end ;
procedure TForm3 . SpinEdit1Change ( Sender : TObject );
begin //timer speed
timer1 . Interval := SpinEdit1 . Value ;
end ;
end .
----------------------------------- NESNELER
object Form3 : TForm3
Left = 0
Top = 0
BorderStyle = bsDialog
Caption = 'Elevator 2005'
ClientHeight = 473
ClientWidth = 410
Color = 14286847
Font . Charset = DEFAULT_CHARSET
Font. Color = clNavy
Font. Height = - 11
Font . Name = 'Tahoma'
Font . Style = []
Icon . Data = {
0000010001002020100000000000E80200001600000028000000200000004000
0000010004000000000000020000000000000000000000000000000000000000
0000000080000080000000808000800000008000800080800000C0C0C0008080
80000000FF0000FF000000FFFF00FF000000FF00FF00FFFF0000FFFFFF000000
0000000000050000000000000000000000000000055550000000000000000000
0000000555777500000000000000000000000555777777500000000000000000
0005557777778885000000000000000005557777778508885000000000000000
5187777785555088850000000000000055877885555555088850000000000000
5587855555555550888500000000000051855D55555555550888500000000000
555DDDD5555055555088850000000000057DDDDD555505555508850000000000
0057DD5557775055555085000000000000055557777775055555050000000000
0055577777788850555550000000000055577777785088850555550000000005
1877777855550888505555000000000558778855555550888505000000000005
587855555555550888500000000000051855D555555555508885000000000005
55DDDD5555555555088850000000000057DDDDDD555555555088500000000000
057DDDDD5555555555085000000000000057DDDDDD5555555550500000000000
00057DDDDD5555555555000000000000000057DDDDD555555555500000000000
0000057DDDDD5555555550000000000000000057DDDD85555550000000000000
000000057DDDD55550000000000000000000000057DDD5500000000000000000
00000000057D500000000000000000000000000000500000000000000000FFFE
7FFFFFF83FFFFFE01FFFFF800FFFFE0007FFF80003FFF00001FFF00000FFF000
007FF000003FF000001FF800001FFC00003FFE00003FFC00003FF000001FE000
001FE000007FE00000FFE000007FE000003FF000003FF800007FFC00007FFE00
007FFF00003FFF80003FFFC000FFFFE003FFFFF00FFFFFF83FFFFFFCFFFF}
OldCreateOrder = False
Position = poDesktopCenter
OnCreate = FormCreate
PixelsPerInch = 96
TextHeight = 13
object Bevel1 : TBevel
Left = 7
Top = 4
Width = 162
Height = 459
Shape = bsFrame
Style = bsRaised
end
object Bevel4 : TBevel
Left = 14
Top = 15
Width = 150
Height = 106
Shape = bsTopLine
end
object Bevel2 : TBevel
Left = 14
Top = 235
Width = 150
Height = 107
Shape = bsTopLine
end
object Bevel3 : TBevel
Left = 14
Top = 127
Width = 150
Height = 107
Shape = bsTopLine
end
object Bevel5 : TBevel
Left = 14
Top = 350
Width = 150
Height = 104
Shape = bsTopLine
end
object SpeedButton1 : TSpeedButton
Left = 184
Top = 56
Width = 31
Height = 27
Glyph . Data = {
76060000424D7606000000000000360400002800000018000000180000000100
0800000000004002000000000000000000000001000000010000FF00FF00FE00
FE00FE00FE00FE00FE00FE00FE00FE00FE00FE00FE00FE00FE00FE00FE00FE00
FE00FE00FE00FE00FE00FB01FD00F004F800D90BEF00C810E700BA14E2009E1C
D5007628C5004537B0001B439E0011469A000C4798000C4798000C4798000C47
98000C4798000C4798000C4798000C4797000C4797000C4797000C4797000C47
97000C4797000C4797000C4797000C4797000C4797000B4897000B4893000A48
800007495D0004493B00024A1C00014A0E00004A0600004A0200004A0000004F
010001540300025C050004660900066F0C0007750E00087A1000098013000B87
16000D8C19000E911C000D8D1A000B88170009811300087B110007740E000460
070001500200004C0000004B0000004B0000004B0000004B0000004B0000004B
0000004A0000004B0000004B0000004B0000004B0000004B0000004B0000004B
0000004B0000004B0000004B0000004B0000004B0000014B0100014B0100024B
0200044B0400064C06000A4D0A000F4E0F00174F1700205220002F552F00415A
4100505E50005D615D0064646400656565006666660067676700686868006969
69006A6A6A006B6B6B006C6C6C006D6D6D006E6E6E006F6F6F00707070007171
7100727272007373730074747400757575007676760077777700787878007979
79007A7A7A007B7B7B007C7C7C007D7D7D007E7E7E007F7F7F00808080008181
8100828282008383830084848400858585008686860087878700888888008989
89008A8A8A008B8B8B008C8C8C008D8D8D008E8E8E008F8F8F00909090009191
9100929292009393930094949400959595009696960097979700989898009999
99009A9A9A009B9B9B009C9C9C009D9D9D009E9E9E009F9F9F00A0A0A000A1A1
A100A2A2A200A3A3A300A4A4A400A5A5A500A6A6A600A7A7A700A8A8A800A9A9
A900AAAAAA00ABABAB00ACACAC00ADADAD00AEAEAE00AFAFAF00B0B0B000B1B1
B100B2B2B200B3B3B300B4B4B400B5B5B500B6B6B600B7B7B700B8B8B800B9B9
B900BABABA00BBBBBB00BCBCBC00BDBDBD00BEBEBE00BFBFBF00C0C0C000C1C1
C100B9C0C500B2BFCA00ABBECE009FBCD4008DB9DC007BB4E4006CB0EA005EAD
F00052A9F40048A6F80040A3FB003CA2FC0039A1FD00369FFE00359EFE00339C
FE00329BFE00319AFE003099FE002E97FE002C93FC00298EF700288BF1002687
EC002789EF00278AF200288CF5002A90F8002E96FC00309AFE00329CFE00349F
FE0037A3FE003AA8FE003CAAFE003EADFE0041B0FE0043B2FE0045B5FE0045B6
FE0046B7FE0047B9FE0047B9FE0047B9FD0047B9FD0047BAF80046BDE50044C3
CA0041C7AE003ECA97003CCD7E003BCF72003AD16B0038CF670037CE630035CC
5F0034CA5D0032C95A0031C757002EC453002BC04D0029BE4A00000000000000
000000000000000000000000000000000000000000001C000000000000000000
000000000000000000000000001CD91C00000000000000000000000000000000
000000001CD9DCD91C0000000050505050505050505050505000001CD9D4D6DC
D91C00000050F6F6F6F7FBFEFFFF3B3B50001CD8E6E3E0D6D7D91C0000505050
505050505050505050001C1C1CE8E4E21C1C1C00000000000000000000000000
000000001CECEAE61C000000000000000000000000000000000000001CECECEC
1C000000005050505050505050505050505000001C1C1C1C1C0000000050F6F6
F6F7FBFEFFFF3B3B3B5000000000000000000000005050505050505050505050
5050000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000505050
5050505050505000000000001C1C1C1C1C0000000050F6F7FBFEFFFF3B3B5000
000000001CE2D4D61C000000005050505050505050505000000000001CE4E1D5
1C00000000000000000000000000000000001C1C1CE6E3D01C1C1C0000000000
000000000000000000001CECECEAE6E3E0D61C00005050505050505050505050
5050001CECECE9E5E21C00000050F6F6F6F7FAFDFFFF3B3B3B5000001CECECE7
1C00000000505050505050505050505050500000001CEC1C0000000000000000
00000000000000000000000000001C0000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000}
OnClick = SpeedButton1Click
end
object SpeedButton2 : TSpeedButton
Left = 184
Top = 168
Width = 31
Height = 27
Glyph . Data = {
76060000424D7606000000000000360400002800000018000000180000000100
0800000000004002000000000000000000000001000000010000FF00FF00FE00
FE00FE00FE00FE00FE00FE00FE00FE00FE00FE00FE00F705F800DE18E100AC40
B3008F569900766881004F805D00348E42001F9A2E00169A2500149922001296
200011911D000F8C19000C851400087A0D00036F060001680100006600000066
0000006600000065000000650000006500000065000000650000006500000065
0000006500000065000000650000006500000065000000650000006500000065
0000006500000065000000650000006500000065000000650000006500000164
0100026302000362030005600500095D09000E590E00145414001D4D1D002647
26002F412F00373D37003C3C3C003D3D3D003E3E3E003F3F3F00404040004141
4100424242004343430044444400454545004646460047474700484848004949
49004A4A4A004B4B4B004C4C4C004D4D4D004E4E4E004F4F4F00505050005151
510052525200535353005454540055555500535C5500526356004F7558004C84
59004A945C0046A55E0044AF5E0042B65E0041BB5E003EBE5D003CBF5A0039BF
560037BF550038C056003CC25C003FC4600041C5620041C3620042BF610044B8
600047B361004CAA6300539D6500589065005F85680067786B006C746E007171
7100727272007373730074747400757575007676760077777700787878007979
79007A7A7A007B7B7B007C7C7C007D7D7D007E7E7E007F7F7F00808080008181
8100828282008383830084848400858585008686860087878700888888008989
89008A8A8A008B8B8B008C8C8C008D8D8D008E8E8E008F8F8F00909090009191
9100929292009393930094949400959595009696960097979700989898009999
99009A9A9A009B9B9B009C9C9C009D9D9D009E9E9E009F9F9F00A0A0A000A1A1
A100A2A2A200A3A3A300A4A4A400A5A5A500A6A6A600A7A7A700A8A8A800A9A9
A900AAAAAA00ABABAB00ACACAC00ADADAD00AEAEAE00AFAFAF00B0B0B000B1B1
B100B2B2B200B3B3B300B4B4B400B5B5B500B6B6B600B7B7B700B8B8B800B9B9
B900BABABA00BBBBBB00BCBCBC00BDBDBD00BEBEBE00BFBFBF00C0C0C000C1C1
C100C2C2C200C3C3C300C4C4C400B7C8BD00ACCBB60099D0AC0083D59E0073D8
950069DA8E0062DB8A005EDB88005BDC860059DC850057DC850056DC860057DC
8B0057DB8F0058DA940058D89F005AD5B3005DD1CB005FCDE40060CAF10061C8
F80061C7FD0061C8FE0062C8FE0061C7FE0060C6FE005FC4FE005DC3FE005CC1
FE0059BFFE0057BDFE0055BBFE0053B9FE0052B8FE0050B6FE004EB4FE004DB2
FE004BB1FE004AAFFE0047ACFB0045A8F80043A6F70041A4F70040A3F7003DA1
F7003B9DF3003A9AF0003694E700328DDF002D85D5002578C7001F6DB9001B67
B1001964AE001963AD001963AD001963AD001963AD001963AD00000000000000
00000000000000000000000000000000000000000000FC000000000000000000
00000000000000000000000000FCF5FC00000000000000000000000000000000
00000000FCF5F1F5FC000000001919191919191919191919190000FCF4EBEEF1
F5FC00000019CFCFCFD0D0666462620E1900FCEEE1E5EAECEFF5FC0000191919
19191919191919191900FCFCFCDFE3E7FCFCFC00000000000000000000000000
00000000FCDCDDE1FC00000000000000000000000000000000000000FCDCDCDC
FC00000000191919191919191919191919190000FCFCFCFCFC0000000019CFCF
CFD0D0666462620E0E1900000000000000000000001919191919191919191919
1919000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000191919
191919191919190000000000FCFCFCFCFC0000000019CFD0D0666462620E1900
00000000FCE7EBEDFC00000000191919191919191919190000000000FCE3E7EC
FC0000000000000000000000000000000000FCFCFCE0E4E9FCFCFC0000000000
00000000000000000000FCDCDCDDE1E5EBEDFC00001919191919191919191919
191900FCDCDCDEE2E7FC00000019CFCFCFCFD0666562620E0E190000FCDCDCDF
FC0000000019191919191919191919191919000000FCDCFC0000000000000000
0000000000000000000000000000FC0000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000}
OnClick = SpeedButton2Click
end
object SpeedButton3 : TSpeedButton
Left = 184
Top = 288
Width = 31
Height = 27
Glyph . Data = {
76060000424D7606000000000000360400002800000018000000180000000100
0800000000004002000000000000000000000001000000010000FF00FF00FE00
FE00FE00FE00FE00FE00FE00FE00FE00FE00FE00FE00F705F800DE18E100AC40
B3008F569900766881004F805D00348E42001F9A2E00169A2500149922001296
200011911D000F8C19000C851400087A0D00036F060001680100006600000066
0000006600000065000000650000006500000065000000650000006500000065
0000006500000065000000650000006500000065000000650000006500000065
0000006500000065000000650000006500000065000000650000006500000164
0100026302000362030005600500095D09000E590E00145414001D4D1D002647
26002F412F00373D37003C3C3C003D3D3D003E3E3E003F3F3F00404040004141
4100424242004343430044444400454545004646460047474700484848004949
49004A4A4A004B4B4B004C4C4C004D4D4D004E4E4E004F4F4F00505050005151
510052525200535353005454540055555500535C5500526356004F7558004C84
59004A945C0046A55E0044AF5E0042B65E0041BB5E003EBE5D003CBF5A0039BF
560037BF550038C056003CC25C003FC4600041C5620041C3620042BF610044B8
600047B361004CAA6300539D6500589065005F85680067786B006C746E007171
7100727272007373730074747400757575007676760077777700787878007979
79007A7A7A007B7B7B007C7C7C007D7D7D007E7E7E007F7F7F00808080008181
8100828282008383830084848400858585008686860087878700888888008989
89008A8A8A008B8B8B008C8C8C008D8D8D008E8E8E008F8F8F00909090009191
9100929292009393930094949400959595009696960097979700989898009999
99009A9A9A009B9B9B009C9C9C009D9D9D009E9E9E009F9F9F00A0A0A000A1A1
A100A2A2A200A3A3A300A4A4A400A5A5A500A6A6A600A7A7A700A8A8A800A9A9
A900AAAAAA00ABABAB00ACACAC00ADADAD00AEAEAE00AFAFAF00B0B0B000B1B1
B100B2B2B200B3B3B300B4B4B400B5B5B500B6B6B600B7B7B700B8B8B800B9B9
B900BABABA00BBBBBB00BCBCBC00BDBDBD00BEBEBE00BFBFBF00C0C0C000C1C1
C100C2C2C200C3C3C300C4C4C400B7C8BD00ACCBB60099D0AC0083D59E0073D8
950069DA8E0062DB8A005EDB88005BDC860059DC850057DC850056DC860057DC
8B0057DB8F0058DA940058D89F005AD5B3005DD1CB005FCDE40060CAF10061C8
F80061C7FD0061C8FE0062C8FE0061C7FE0060C6FE005FC4FE005DC3FE005CC1
FE0059BFFE0057BDFE0055BBFE0053B9FE0052B8FE0050B6FE004EB4FE004DB2
FE004BB1FE004AAFFE0047ACFB0045A8F80043A6F70041A4F70040A3F7003DA1
F7003B9DF3003A9AF0003694E700328DDF002D85D5002578C7001F6DB9001B67
B1001964AE001963AD001963AD001963AD001963AD001963AD00000000000000
00000000000000000000000000000000000000000000FC000000000000000000
00000000000000000000000000FCF5FC00000000000000000000000000000000
00000000FCF5F1F5FC000000001919191919191919191919190000FCF4EBEEF1
F5FC00000019CFCFCFD0D0666462620E1900FCEEE1E5EAECEFF5FC0000191919
19191919191919191900FCFCFCDFE3E7FCFCFC00000000000000000000000000
00000000FCDCDDE1FC00000000000000000000000000000000000000FCDCDCDC
FC00000000191919191919191919191919190000FCFCFCFCFC0000000019CFCF
CFD0D0666462620E0E1900000000000000000000001919191919191919191919
1919000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000191919
191919191919190000000000FCFCFCFCFC0000000019CFD0D0666462620E1900
00000000FCE7EBEDFC00000000191919191919191919190000000000FCE3E7EC
FC0000000000000000000000000000000000FCFCFCE0E4E9FCFCFC0000000000
00000000000000000000FCDCDCDDE1E5EBEDFC00001919191919191919191919
191900FCDCDCDEE2E7FC00000019CFCFCFCFD0666562620E0E190000FCDCDCDF
FC0000000019191919191919191919191919000000FCDCFC0000000000000000
0000000000000000000000000000FC0000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000}
OnClick = SpeedButton3Click
end
object SpeedButton4 : TSpeedButton
Left = 184
Top = 398
Width = 31
Height = 27
Glyph . Data = {
76060000424D7606000000000000360400002800000018000000180000000100
0800000000004002000000000000000000000001000000010000FF00FF00FE00
FE00FE00FE00FE00FE00FE00FE00FE00FE00FE00FE00F705F800DE18E100AC40
B3008F569900766881004F805D00348E42001F9A2E00169A2500149922001296
200011911D000F8C19000C851400087A0D00036F060001680100006600000066
0000006600000065000000650000006500000065000000650000006500000065
0000006500000065000000650000006500000065000000650000006500000065
0000006500000065000000650000006500000065000000650000006500000164
0100026302000362030005600500095D09000E590E00145414001D4D1D002647
26002F412F00373D37003C3C3C003D3D3D003E3E3E003F3F3F00404040004141
4100424242004343430044444400454545004646460047474700484848004949
49004A4A4A004B4B4B004C4C4C004D4D4D004E4E4E004F4F4F00505050005151
510052525200535353005454540055555500535C5500526356004F7558004C84
59004A945C0046A55E0044AF5E0042B65E0041BB5E003EBE5D003CBF5A0039BF
560037BF550038C056003CC25C003FC4600041C5620041C3620042BF610044B8
600047B361004CAA6300539D6500589065005F85680067786B006C746E007171
7100727272007373730074747400757575007676760077777700787878007979
79007A7A7A007B7B7B007C7C7C007D7D7D007E7E7E007F7F7F00808080008181
8100828282008383830084848400858585008686860087878700888888008989
89008A8A8A008B8B8B008C8C8C008D8D8D008E8E8E008F8F8F00909090009191
9100929292009393930094949400959595009696960097979700989898009999
99009A9A9A009B9B9B009C9C9C009D9D9D009E9E9E009F9F9F00A0A0A000A1A1
A100A2A2A200A3A3A300A4A4A400A5A5A500A6A6A600A7A7A700A8A8A800A9A9
A900AAAAAA00ABABAB00ACACAC00ADADAD00AEAEAE00AFAFAF00B0B0B000B1B1
B100B2B2B200B3B3B300B4B4B400B5B5B500B6B6B600B7B7B700B8B8B800B9B9
B900BABABA00BBBBBB00BCBCBC00BDBDBD00BEBEBE00BFBFBF00C0C0C000C1C1
C100C2C2C200C3C3C300C4C4C400B7C8BD00ACCBB60099D0AC0083D59E0073D8
950069DA8E0062DB8A005EDB88005BDC860059DC850057DC850056DC860057DC
8B0057DB8F0058DA940058D89F005AD5B3005DD1CB005FCDE40060CAF10061C8
F80061C7FD0061C8FE0062C8FE0061C7FE0060C6FE005FC4FE005DC3FE005CC1
FE0059BFFE0057BDFE0055BBFE0053B9FE0052B8FE0050B6FE004EB4FE004DB2
FE004BB1FE004AAFFE0047ACFB0045A8F80043A6F70041A4F70040A3F7003DA1
F7003B9DF3003A9AF0003694E700328DDF002D85D5002578C7001F6DB9001B67
B1001964AE001963AD001963AD001963AD001963AD001963AD00000000000000
00000000000000000000000000000000000000000000FC000000000000000000
00000000000000000000000000FCF5FC00000000000000000000000000000000
00000000FCF5F1F5FC000000001919191919191919191919190000FCF4EBEEF1
F5FC00000019CFCFCFD0D0666462620E1900FCEEE1E5EAECEFF5FC0000191919
19191919191919191900FCFCFCDFE3E7FCFCFC00000000000000000000000000
00000000FCDCDDE1FC00000000000000000000000000000000000000FCDCDCDC
FC00000000191919191919191919191919190000FCFCFCFCFC0000000019CFCF
CFD0D0666462620E0E1900000000000000000000001919191919191919191919
1919000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000191919
191919191919190000000000FCFCFCFCFC0000000019CFD0D0666462620E1900
00000000FCE7EBEDFC00000000191919191919191919190000000000FCE3E7EC
FC0000000000000000000000000000000000FCFCFCE0E4E9FCFCFC0000000000
00000000000000000000FCDCDCDDE1E5EBEDFC00001919191919191919191919
191900FCDCDCDEE2E7FC00000019CFCFCFCFD0666562620E0E190000FCDCDCDF
FC0000000019191919191919191919191919000000FCDCFC0000000000000000
0000000000000000000000000000FC0000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000}
OnClick = SpeedButton4Click
end
object Label1 : TLabel
Left = 232
Top = 88
Width = 61
Height = 13
Caption = 'World Speed'
end
object Panel1 : TPanel
Left = 35
Top = 360
Width = 105
Height = 90
TabOrder = 0
object Shape1 : TShape
Left = 8
Top = 8
Width = 65
Height = 75
Brush . Color = clSilver
Pen. Style = psClear
Shape = stRoundRect
end
object Shape2 : TShape
Left = 8
Top = 8
Width = 65
Height = 75
Cursor = crHandPoint
Hint = 'Click to open the door'
Brush . Color = 14342874
ParentShowHint = False
Pen. Color = clGray
Pen. Style = psDot
Shape = stRoundRect
ShowHint = True
OnMouseUp = Shape2MouseUp
end
object SpeedButton5 : TSpeedButton
Left = 74
Top = 16
Width = 13
Height = 14
GroupIndex = 1
Caption = '4'
Font . Charset = DEFAULT_CHARSET
Font. Color = clWindowText
Font. Height = - 9
Font . Name = 'Tahoma'
Font . Style = []
ParentFont = False
OnClick = SpeedButton1Click
end
object SpeedButton6 : TSpeedButton
Left = 74
Top = 32
Width = 13
Height = 14
GroupIndex = 1
Caption = '3'
Font . Charset = DEFAULT_CHARSET
Font. Color = clWindowText
Font. Height = - 9
Font . Name = 'Tahoma'
Font . Style = []
ParentFont = False
OnClick = SpeedButton2Click
end
object SpeedButton7 : TSpeedButton
Left = 74
Top = 48
Width = 13
Height = 14
GroupIndex = 1
Caption = '2'
Font . Charset = DEFAULT_CHARSET
Font. Color = clWindowText
Font. Height = - 9
Font . Name = 'Tahoma'
Font . Style = []
ParentFont = False
OnClick = SpeedButton3Click
end
object SpeedButton8 : TSpeedButton
Left = 74
Top = 64
Width = 13
Height = 14
GroupIndex = 1
Down = True
Caption = '1'
Font . Charset = DEFAULT_CHARSET
Font. Color = clWindowText
Font. Height = - 9
Font . Name = 'Tahoma'
Font . Style = []
ParentFont = False
OnClick = SpeedButton4Click
end
object SpeedButton9 : TSpeedButton
Left = 90
Top = 64
Width = 13
Height = 14
Hint = 'Start/Stop the engine'
Caption = 'S'
Font . Charset = DEFAULT_CHARSET
Font. Color = clRed
Font. Height = - 11
Font . Name = 'Tahoma'
Font . Style = []
ParentFont = False
ParentShowHint = False
ShowHint = True
OnClick = SpeedButton9Click
end
object StaticText5 : TStaticText
Left = 87
Top = 5
Width = 14
Height = 12
Alignment = taCenter
AutoSize = False
BevelInner = bvSpace
BorderStyle = sbsSingle
Caption = '1'
Color = clBlack
Font. Charset = SYMBOL_CHARSET
Font. Color = clRed
Font. Height = - 11
Font . Name = 'WST_Swed'
Font . Style = [ fsBold ]
ParentColor = False
ParentFont = False
TabOrder = 0
end
end
object StaticText1 : TStaticText
Left = 177
Top = 24
Width = 40
Height = 17
Alignment = taCenter
AutoSize = False
BevelInner = bvSpace
Caption = 'Floor 4'
TabOrder = 1
end
object StaticText2 : TStaticText
Left = 177
Top = 136
Width = 40
Height = 17
Alignment = taCenter
AutoSize = False
BevelInner = bvSpace
Caption = 'Floor 3'
TabOrder = 2
end
object StaticText3 : TStaticText
Left = 177
Top = 248
Width = 40
Height = 17
Alignment = taCenter
AutoSize = False
BevelInner = bvSpace
Caption = 'Floor 2'
TabOrder = 3
end
object StaticText4 : TStaticText
Left = 177
Top = 358
Width = 40
Height = 17
Alignment = taCenter
AutoSize = False
BevelInner = bvSpace
Caption = 'Floor 1'
TabOrder = 4
end
object GroupBox1 : TGroupBox
Left = 232
Top = 8
Width = 166
Height = 73
Caption = '[Status]'
Ctl3D = False
ParentCtl3D = False
TabOrder = 5
object StaticText7 : TStaticText
Left = 12
Top = 48
Width = 35
Height = 17
Alignment = taCenter
BevelInner = bvSpace
Caption = 'Ready'
TabOrder = 0
end
object StaticText6 : TStaticText
Left = 12
Top = 24
Width = 44
Height = 17
Alignment = taCenter
BevelInner = bvSpace
Caption = 'Stopped'
TabOrder = 1
end
end
object StaticText8 : TStaticText
Left = 236
Top = 296
Width = 163
Height = 17
Alignment = taCenter
BevelInner = bvSpace
Caption = 'Example Project with Delphi 2005'
Font . Charset = DEFAULT_CHARSET
Font. Color = clTeal
Font. Height = - 11
Font . Name = 'Tahoma'
Font . Style = []
ParentFont = False
TabOrder = 6
end
object StaticText9 : TStaticText
Left = 236
Top = 312
Width = 91
Height = 17
Alignment = taCenter
BevelInner = bvSpace
Caption = 'Tarik BAGRIYANIK'
Font . Charset = DEFAULT_CHARSET
Font. Color = clTeal
Font. Height = - 11
Font . Name = 'Tahoma'
Font . Style = []
ParentFont = False
TabOrder = 7
end
object StaticText10 : TStaticText
Left = 236
Top = 336
Width = 80
Height = 17
Alignment = taCenter
BevelInner = bvSpace
Caption = 'November 2005'
Font . Charset = DEFAULT_CHARSET
Font. Color = clTeal
Font. Height = - 11
Font . Name = 'Tahoma'
Font . Style = []
ParentFont = False
TabOrder = 8
end
object Button1 : TButton
Left = 320
Top = 416
Width = 75
Height = 41
Caption = '&Close'
TabOrder = 9
OnClick = Button1Click
end
object SpinEdit1 : TSpinEdit
Left = 232
Top = 104
Width = 65
Height = 22
Increment = 10
MaxValue = 1000
MinValue = 10
TabOrder = 10
Value = 50
OnChange = SpinEdit1Change
end
object StaticText11 : TStaticText
Left = 236
Top = 352
Width = 92
Height = 17
Alignment = taCenter
BevelInner = bvSpace
Caption = '5 hours - 150 lines'
Font . Charset = DEFAULT_CHARSET
Font. Color = clTeal
Font. Height = - 11
Font . Name = 'Tahoma'
Font . Style = []
ParentFont = False
TabOrder = 11
end
object Timer1 : TTimer
Interval = 50
OnTimer = Timer1Timer
Left = 240
Top = 416
end
end
Delphi - .....................................
Asansör Simülasyonu
//4 katlı bir binadaki tek asansör...
//www.delphiforfun.org da daha güzeli
//http://www.delphiforfun.org/Programs/elevator_sim1.htm
//thread ile yapılmış...
unit Unit3 ;
interface
uses
Windows , Messages , SysUtils , Variants , Classes , Graphics , Controls , Forms ,
Dialogs , ExtCtrls , Buttons , StdCtrls , Spin ;
type
TForm3 = class ( TForm )
Timer1 : TTimer ;
Bevel1 : TBevel ;
Bevel2 : TBevel ;
Bevel3 : TBevel ;
Bevel4 : TBevel ;
Bevel5 : TBevel ;
Panel1 : TPanel ;
Shape1 : TShape ;
SpeedButton1 : TSpeedButton ;
SpeedButton2 : TSpeedButton ;
SpeedButton3 : TSpeedButton ;
SpeedButton4 : TSpeedButton ;
StaticText1 : TStaticText ;
StaticText2 : TStaticText ;
StaticText3 : TStaticText ;
StaticText4 : TStaticText ;
Shape2 : TShape ;
SpeedButton5 : TSpeedButton ;
SpeedButton6 : TSpeedButton ;
SpeedButton7 : TSpeedButton ;
SpeedButton8 : TSpeedButton ;
SpeedButton9 : TSpeedButton ;
GroupBox1 : TGroupBox ;
StaticText7 : TStaticText ;
StaticText6 : TStaticText ;
StaticText8 : TStaticText ;
StaticText9 : TStaticText ;
StaticText10 : TStaticText ;
Button1 : TButton ;
SpinEdit1 : TSpinEdit ;
Label1 : TLabel ;
StaticText5 : TStaticText ;
StaticText11 : TStaticText ;
procedure SpinEdit1Change ( Sender : TObject );
procedure SpeedButton4Click ( Sender : TObject );
procedure SpeedButton3Click ( Sender : TObject );
procedure SpeedButton2Click ( Sender : TObject );
procedure SpeedButton1Click ( Sender : TObject );
procedure Shape2MouseUp ( Sender : TObject ; Button : TMouseButton ;
Shift : TShiftState ; X , Y : Integer );
procedure Button1Click ( Sender : TObject );
procedure SpeedButton9Click ( Sender : TObject );
procedure Timer1Timer ( Sender : TObject );
procedure FormCreate ( Sender : TObject );
private
{ Private declarations }
public
{ Public declarations }
end ;
var
Form3 : TForm3 ;
counter : byte = 1 ; //door counter
requestFloor : byte = 0 ; //where to lift
floor : byte = 1 ; //active floor
measure : integer ; //lifting value
state : byte = 1 ; //1- stopped,
//2- door open(1 time),
//3- door wait(3 times),
//4- door close(1 time),
//5- move
implementation
{$R *.dfm}
procedure TForm3 . FormCreate ( Sender : TObject );
begin
panel1 . DoubleBuffered := True ; //smooth graphics
state := 1 ; //stopped
floor := 1 ; //active floor
measure := 0 ;
end ;
procedure TForm3 . Timer1Timer ( Sender : TObject );
begin //Elevator Engine
if Form3 . panel1 . Top = 360 then StaticText5 . Caption := '1' else
if Form3 . panel1 . Top = 250 then StaticText5 . Caption := '2' else
if Form3 . panel1 . Top = 140 then StaticText5 . Caption := '3' else
if Form3 . panel1 . Top = 30 then StaticText5 . Caption := '4' ;
case state of
1 :
begin
counter := 0 ;
StaticText6 . Caption := 'Stopped' ;
StaticText7 . Caption := 'Ready' ;
end ;
2 :
begin
StaticText6 . Caption := 'Door Opening' ;
StaticText7 . Caption := 'Not Ready' ;
counter := counter + 1 ;
if counter = 12 then state := 3 ; //finished opening
shape2 . Width := shape2 . Width - 5 ;
end ;
3 :
begin
StaticText6 . Caption := 'Door Opened' ;
StaticText7 . Caption := 'Not Ready' ;
counter := counter + 1 ;
if counter = 36 then //12*3 more time waiting
begin
state := 4 ; //close it
counter := 0 ;
end ;
end ;
4 :
begin
StaticText6 . Caption := 'Door Closing' ;
StaticText7 . Caption := 'Not Ready' ;
counter := counter + 1 ;
if counter = 12 then state := 1 ; //finished closing
shape2 . Width := shape2 . Width + 5 ;
end ;
5 :
begin
counter := 0 ;
StaticText6 . Caption := 'Moving' ;
StaticText7 . Caption := 'Not Ready' ;
if ( requestFloor = floor ) or ( measure = 0 ) then
begin
state := 2 ;
floor := requestFloor ; //new floor
exit ; //cut the event!
end ; //same floor
if (( requestFloor - floor )> 0 ) and ( measure <> 0 ) then
begin
panel1 . Top := panel1 . Top - 5 ;
measure := measure - 5 ;
end ;
if (( requestFloor - floor )< 0 ) and ( measure <> 0 ) then
begin
panel1 . Top := panel1 . Top + 5 ;
measure := measure - 5 ;
end ;
end ;
end ;
end ;
procedure TForm3 . SpeedButton9Click ( Sender : TObject );
begin //Emergency stop...
timer1 . Enabled := not ( timer1 . Enabled );
end ;
procedure TForm3 . Button1Click ( Sender : TObject );
begin
close ; //end...
end ;
procedure TForm3 . Shape2MouseUp ( Sender : TObject ; Button : TMouseButton ;
Shift : TShiftState ; X , Y : Integer );
begin
if state = 1 then state := 2 ; //door open if not moving...
end ;
procedure TForm3 . SpeedButton1Click ( Sender : TObject );
begin //here we move!
if state = 1 then begin
requestFloor := 4 ; state := 5 ;
measure :=( requestFloor - floor )*( panel1 . height + 20 );
if measure < 0 then measure := measure *- 1 ;
SpeedButton5 . Down := true ;
end ;
end ;
procedure TForm3 . SpeedButton2Click ( Sender : TObject );
begin
if state = 1 then begin
requestFloor := 3 ; state := 5 ;
measure :=( requestFloor - floor )*( panel1 . height + 20 );
if measure < 0 then measure := measure *- 1 ;
SpeedButton6 . Down := true ;
end ;
end ;
procedure TForm3 . SpeedButton3Click ( Sender : TObject );
begin
if state = 1 then begin
requestFloor := 2 ; state := 5 ;
measure :=( requestFloor - floor )*( panel1 . height + 20 );
if measure < 0 then measure := measure *- 1 ;
SpeedButton7 . Down := true ;
end ;
end ;
procedure TForm3 . SpeedButton4Click ( Sender : TObject );
begin
if state = 1 then begin
requestFloor := 1 ; state := 5 ;
measure :=( requestFloor - floor )*( panel1 . height + 20 );
if measure < 0 then measure := measure *- 1 ;
SpeedButton8 . Down := true ;
end ;
end ;
procedure TForm3 . SpinEdit1Change ( Sender : TObject );
begin //timer speed
timer1 . Interval := SpinEdit1 . Value ;
end ;
end .
----------------------------------- NESNELER
object Form3 : TForm3
Left = 0
Top = 0
BorderStyle = bsDialog
Caption = 'Elevator 2005'
ClientHeight = 473
ClientWidth = 410
Color = 14286847
Font . Charset = DEFAULT_CHARSET
Font. Color = clNavy
Font. Height = - 11
Font . Name = 'Tahoma'
Font . Style = []
Icon . Data = {
0000010001002020100000000000E80200001600000028000000200000004000
0000010004000000000000020000000000000000000000000000000000000000
0000000080000080000000808000800000008000800080800000C0C0C0008080
80000000FF0000FF000000FFFF00FF000000FF00FF00FFFF0000FFFFFF000000
0000000000050000000000000000000000000000055550000000000000000000
0000000555777500000000000000000000000555777777500000000000000000
0005557777778885000000000000000005557777778508885000000000000000
5187777785555088850000000000000055877885555555088850000000000000
5587855555555550888500000000000051855D55555555550888500000000000
555DDDD5555055555088850000000000057DDDDD555505555508850000000000
0057DD5557775055555085000000000000055557777775055555050000000000
0055577777788850555550000000000055577777785088850555550000000005
1877777855550888505555000000000558778855555550888505000000000005
587855555555550888500000000000051855D555555555508885000000000005
55DDDD5555555555088850000000000057DDDDDD555555555088500000000000
057DDDDD5555555555085000000000000057DDDDDD5555555550500000000000
00057DDDDD5555555555000000000000000057DDDDD555555555500000000000
0000057DDDDD5555555550000000000000000057DDDD85555550000000000000
000000057DDDD55550000000000000000000000057DDD5500000000000000000
00000000057D500000000000000000000000000000500000000000000000FFFE
7FFFFFF83FFFFFE01FFFFF800FFFFE0007FFF80003FFF00001FFF00000FFF000
007FF000003FF000001FF800001FFC00003FFE00003FFC00003FF000001FE000
001FE000007FE00000FFE000007FE000003FF000003FF800007FFC00007FFE00
007FFF00003FFF80003FFFC000FFFFE003FFFFF00FFFFFF83FFFFFFCFFFF}
OldCreateOrder = False
Position = poDesktopCenter
OnCreate = FormCreate
PixelsPerInch = 96
TextHeight = 13
object Bevel1 : TBevel
Left = 7
Top = 4
Width = 162
Height = 459
Shape = bsFrame
Style = bsRaised
end
object Bevel4 : TBevel
Left = 14
Top = 15
Width = 150
Height = 106
Shape = bsTopLine
end
object Bevel2 : TBevel
Left = 14
Top = 235
Width = 150
Height = 107
Shape = bsTopLine
end
object Bevel3 : TBevel
Left = 14
Top = 127
Width = 150
Height = 107
Shape = bsTopLine
end
object Bevel5 : TBevel
Left = 14
Top = 350
Width = 150
Height = 104
Shape = bsTopLine
end
object SpeedButton1 : TSpeedButton
Left = 184
Top = 56
Width = 31
Height = 27
Glyph . Data = {
76060000424D7606000000000000360400002800000018000000180000000100
0800000000004002000000000000000000000001000000010000FF00FF00FE00
FE00FE00FE00FE00FE00FE00FE00FE00FE00FE00FE00FE00FE00FE00FE00FE00
FE00FE00FE00FE00FE00FB01FD00F004F800D90BEF00C810E700BA14E2009E1C
D5007628C5004537B0001B439E0011469A000C4798000C4798000C4798000C47
98000C4798000C4798000C4798000C4797000C4797000C4797000C4797000C47
97000C4797000C4797000C4797000C4797000C4797000B4897000B4893000A48
800007495D0004493B00024A1C00014A0E00004A0600004A0200004A0000004F
010001540300025C050004660900066F0C0007750E00087A1000098013000B87
16000D8C19000E911C000D8D1A000B88170009811300087B110007740E000460
070001500200004C0000004B0000004B0000004B0000004B0000004B0000004B
0000004A0000004B0000004B0000004B0000004B0000004B0000004B0000004B
0000004B0000004B0000004B0000004B0000004B0000014B0100014B0100024B
0200044B0400064C06000A4D0A000F4E0F00174F1700205220002F552F00415A
4100505E50005D615D0064646400656565006666660067676700686868006969
69006A6A6A006B6B6B006C6C6C006D6D6D006E6E6E006F6F6F00707070007171
7100727272007373730074747400757575007676760077777700787878007979
79007A7A7A007B7B7B007C7C7C007D7D7D007E7E7E007F7F7F00808080008181
8100828282008383830084848400858585008686860087878700888888008989
89008A8A8A008B8B8B008C8C8C008D8D8D008E8E8E008F8F8F00909090009191
9100929292009393930094949400959595009696960097979700989898009999
99009A9A9A009B9B9B009C9C9C009D9D9D009E9E9E009F9F9F00A0A0A000A1A1
A100A2A2A200A3A3A300A4A4A400A5A5A500A6A6A600A7A7A700A8A8A800A9A9
A900AAAAAA00ABABAB00ACACAC00ADADAD00AEAEAE00AFAFAF00B0B0B000B1B1
B100B2B2B200B3B3B300B4B4B400B5B5B500B6B6B600B7B7B700B8B8B800B9B9
B900BABABA00BBBBBB00BCBCBC00BDBDBD00BEBEBE00BFBFBF00C0C0C000C1C1
C100B9C0C500B2BFCA00ABBECE009FBCD4008DB9DC007BB4E4006CB0EA005EAD
F00052A9F40048A6F80040A3FB003CA2FC0039A1FD00369FFE00359EFE00339C
FE00329BFE00319AFE003099FE002E97FE002C93FC00298EF700288BF1002687
EC002789EF00278AF200288CF5002A90F8002E96FC00309AFE00329CFE00349F
FE0037A3FE003AA8FE003CAAFE003EADFE0041B0FE0043B2FE0045B5FE0045B6
FE0046B7FE0047B9FE0047B9FE0047B9FD0047B9FD0047BAF80046BDE50044C3
CA0041C7AE003ECA97003CCD7E003BCF72003AD16B0038CF670037CE630035CC
5F0034CA5D0032C95A0031C757002EC453002BC04D0029BE4A00000000000000
000000000000000000000000000000000000000000001C000000000000000000
000000000000000000000000001CD91C00000000000000000000000000000000
000000001CD9DCD91C0000000050505050505050505050505000001CD9D4D6DC
D91C00000050F6F6F6F7FBFEFFFF3B3B50001CD8E6E3E0D6D7D91C0000505050
505050505050505050001C1C1CE8E4E21C1C1C00000000000000000000000000
000000001CECEAE61C000000000000000000000000000000000000001CECECEC
1C000000005050505050505050505050505000001C1C1C1C1C0000000050F6F6
F6F7FBFEFFFF3B3B3B5000000000000000000000005050505050505050505050
5050000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000505050
5050505050505000000000001C1C1C1C1C0000000050F6F7FBFEFFFF3B3B5000
000000001CE2D4D61C000000005050505050505050505000000000001CE4E1D5
1C00000000000000000000000000000000001C1C1CE6E3D01C1C1C0000000000
000000000000000000001CECECEAE6E3E0D61C00005050505050505050505050
5050001CECECE9E5E21C00000050F6F6F6F7FAFDFFFF3B3B3B5000001CECECE7
1C00000000505050505050505050505050500000001CEC1C0000000000000000
00000000000000000000000000001C0000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000}
OnClick = SpeedButton1Click
end
object SpeedButton2 : TSpeedButton
Left = 184
Top = 168
Width = 31
Height = 27
Glyph . Data = {
76060000424D7606000000000000360400002800000018000000180000000100
0800000000004002000000000000000000000001000000010000FF00FF00FE00
FE00FE00FE00FE00FE00FE00FE00FE00FE00FE00FE00F705F800DE18E100AC40
B3008F569900766881004F805D00348E42001F9A2E00169A2500149922001296
200011911D000F8C19000C851400087A0D00036F060001680100006600000066
0000006600000065000000650000006500000065000000650000006500000065
0000006500000065000000650000006500000065000000650000006500000065
0000006500000065000000650000006500000065000000650000006500000164
0100026302000362030005600500095D09000E590E00145414001D4D1D002647
26002F412F00373D37003C3C3C003D3D3D003E3E3E003F3F3F00404040004141
4100424242004343430044444400454545004646460047474700484848004949
49004A4A4A004B4B4B004C4C4C004D4D4D004E4E4E004F4F4F00505050005151
510052525200535353005454540055555500535C5500526356004F7558004C84
59004A945C0046A55E0044AF5E0042B65E0041BB5E003EBE5D003CBF5A0039BF
560037BF550038C056003CC25C003FC4600041C5620041C3620042BF610044B8
600047B361004CAA6300539D6500589065005F85680067786B006C746E007171
7100727272007373730074747400757575007676760077777700787878007979
79007A7A7A007B7B7B007C7C7C007D7D7D007E7E7E007F7F7F00808080008181
8100828282008383830084848400858585008686860087878700888888008989
89008A8A8A008B8B8B008C8C8C008D8D8D008E8E8E008F8F8F00909090009191
9100929292009393930094949400959595009696960097979700989898009999
99009A9A9A009B9B9B009C9C9C009D9D9D009E9E9E009F9F9F00A0A0A000A1A1
A100A2A2A200A3A3A300A4A4A400A5A5A500A6A6A600A7A7A700A8A8A800A9A9
A900AAAAAA00ABABAB00ACACAC00ADADAD00AEAEAE00AFAFAF00B0B0B000B1B1
B100B2B2B200B3B3B300B4B4B400B5B5B500B6B6B600B7B7B700B8B8B800B9B9
B900BABABA00BBBBBB00BCBCBC00BDBDBD00BEBEBE00BFBFBF00C0C0C000C1C1
C100C2C2C200C3C3C300C4C4C400B7C8BD00ACCBB60099D0AC0083D59E0073D8
950069DA8E0062DB8A005EDB88005BDC860059DC850057DC850056DC860057DC
8B0057DB8F0058DA940058D89F005AD5B3005DD1CB005FCDE40060CAF10061C8
F80061C7FD0061C8FE0062C8FE0061C7FE0060C6FE005FC4FE005DC3FE005CC1
FE0059BFFE0057BDFE0055BBFE0053B9FE0052B8FE0050B6FE004EB4FE004DB2
FE004BB1FE004AAFFE0047ACFB0045A8F80043A6F70041A4F70040A3F7003DA1
F7003B9DF3003A9AF0003694E700328DDF002D85D5002578C7001F6DB9001B67
B1001964AE001963AD001963AD001963AD001963AD001963AD00000000000000
00000000000000000000000000000000000000000000FC000000000000000000
00000000000000000000000000FCF5FC00000000000000000000000000000000
00000000FCF5F1F5FC000000001919191919191919191919190000FCF4EBEEF1
F5FC00000019CFCFCFD0D0666462620E1900FCEEE1E5EAECEFF5FC0000191919
19191919191919191900FCFCFCDFE3E7FCFCFC00000000000000000000000000
00000000FCDCDDE1FC00000000000000000000000000000000000000FCDCDCDC
FC00000000191919191919191919191919190000FCFCFCFCFC0000000019CFCF
CFD0D0666462620E0E1900000000000000000000001919191919191919191919
1919000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000191919
191919191919190000000000FCFCFCFCFC0000000019CFD0D0666462620E1900
00000000FCE7EBEDFC00000000191919191919191919190000000000FCE3E7EC
FC0000000000000000000000000000000000FCFCFCE0E4E9FCFCFC0000000000
00000000000000000000FCDCDCDDE1E5EBEDFC00001919191919191919191919
191900FCDCDCDEE2E7FC00000019CFCFCFCFD0666562620E0E190000FCDCDCDF
FC0000000019191919191919191919191919000000FCDCFC0000000000000000
0000000000000000000000000000FC0000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000}
OnClick = SpeedButton2Click
end
object SpeedButton3 : TSpeedButton
Left = 184
Top = 288
Width = 31
Height = 27
Glyph . Data = {
76060000424D7606000000000000360400002800000018000000180000000100
0800000000004002000000000000000000000001000000010000FF00FF00FE00
FE00FE00FE00FE00FE00FE00FE00FE00FE00FE00FE00F705F800DE18E100AC40
B3008F569900766881004F805D00348E42001F9A2E00169A2500149922001296
200011911D000F8C19000C851400087A0D00036F060001680100006600000066
0000006600000065000000650000006500000065000000650000006500000065
0000006500000065000000650000006500000065000000650000006500000065
0000006500000065000000650000006500000065000000650000006500000164
0100026302000362030005600500095D09000E590E00145414001D4D1D002647
26002F412F00373D37003C3C3C003D3D3D003E3E3E003F3F3F00404040004141
4100424242004343430044444400454545004646460047474700484848004949
49004A4A4A004B4B4B004C4C4C004D4D4D004E4E4E004F4F4F00505050005151
510052525200535353005454540055555500535C5500526356004F7558004C84
59004A945C0046A55E0044AF5E0042B65E0041BB5E003EBE5D003CBF5A0039BF
560037BF550038C056003CC25C003FC4600041C5620041C3620042BF610044B8
600047B361004CAA6300539D6500589065005F85680067786B006C746E007171
7100727272007373730074747400757575007676760077777700787878007979
79007A7A7A007B7B7B007C7C7C007D7D7D007E7E7E007F7F7F00808080008181
8100828282008383830084848400858585008686860087878700888888008989
89008A8A8A008B8B8B008C8C8C008D8D8D008E8E8E008F8F8F00909090009191
9100929292009393930094949400959595009696960097979700989898009999
99009A9A9A009B9B9B009C9C9C009D9D9D009E9E9E009F9F9F00A0A0A000A1A1
A100A2A2A200A3A3A300A4A4A400A5A5A500A6A6A600A7A7A700A8A8A800A9A9
A900AAAAAA00ABABAB00ACACAC00ADADAD00AEAEAE00AFAFAF00B0B0B000B1B1
B100B2B2B200B3B3B300B4B4B400B5B5B500B6B6B600B7B7B700B8B8B800B9B9
B900BABABA00BBBBBB00BCBCBC00BDBDBD00BEBEBE00BFBFBF00C0C0C000C1C1
C100C2C2C200C3C3C300C4C4C400B7C8BD00ACCBB60099D0AC0083D59E0073D8
950069DA8E0062DB8A005EDB88005BDC860059DC850057DC850056DC860057DC
8B0057DB8F0058DA940058D89F005AD5B3005DD1CB005FCDE40060CAF10061C8
F80061C7FD0061C8FE0062C8FE0061C7FE0060C6FE005FC4FE005DC3FE005CC1
FE0059BFFE0057BDFE0055BBFE0053B9FE0052B8FE0050B6FE004EB4FE004DB2
FE004BB1FE004AAFFE0047ACFB0045A8F80043A6F70041A4F70040A3F7003DA1
F7003B9DF3003A9AF0003694E700328DDF002D85D5002578C7001F6DB9001B67
B1001964AE001963AD001963AD001963AD001963AD001963AD00000000000000
00000000000000000000000000000000000000000000FC000000000000000000
00000000000000000000000000FCF5FC00000000000000000000000000000000
00000000FCF5F1F5FC000000001919191919191919191919190000FCF4EBEEF1
F5FC00000019CFCFCFD0D0666462620E1900FCEEE1E5EAECEFF5FC0000191919
19191919191919191900FCFCFCDFE3E7FCFCFC00000000000000000000000000
00000000FCDCDDE1FC00000000000000000000000000000000000000FCDCDCDC
FC00000000191919191919191919191919190000FCFCFCFCFC0000000019CFCF
CFD0D0666462620E0E1900000000000000000000001919191919191919191919
1919000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000191919
191919191919190000000000FCFCFCFCFC0000000019CFD0D0666462620E1900
00000000FCE7EBEDFC00000000191919191919191919190000000000FCE3E7EC
FC0000000000000000000000000000000000FCFCFCE0E4E9FCFCFC0000000000
00000000000000000000FCDCDCDDE1E5EBEDFC00001919191919191919191919
191900FCDCDCDEE2E7FC00000019CFCFCFCFD0666562620E0E190000FCDCDCDF
FC0000000019191919191919191919191919000000FCDCFC0000000000000000
0000000000000000000000000000FC0000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000}
OnClick = SpeedButton3Click
end
object SpeedButton4 : TSpeedButton
Left = 184
Top = 398
Width = 31
Height = 27
Glyph . Data = {
76060000424D7606000000000000360400002800000018000000180000000100
0800000000004002000000000000000000000001000000010000FF00FF00FE00
FE00FE00FE00FE00FE00FE00FE00FE00FE00FE00FE00F705F800DE18E100AC40
B3008F569900766881004F805D00348E42001F9A2E00169A2500149922001296
200011911D000F8C19000C851400087A0D00036F060001680100006600000066
0000006600000065000000650000006500000065000000650000006500000065
0000006500000065000000650000006500000065000000650000006500000065
0000006500000065000000650000006500000065000000650000006500000164
0100026302000362030005600500095D09000E590E00145414001D4D1D002647
26002F412F00373D37003C3C3C003D3D3D003E3E3E003F3F3F00404040004141
4100424242004343430044444400454545004646460047474700484848004949
49004A4A4A004B4B4B004C4C4C004D4D4D004E4E4E004F4F4F00505050005151
510052525200535353005454540055555500535C5500526356004F7558004C84
59004A945C0046A55E0044AF5E0042B65E0041BB5E003EBE5D003CBF5A0039BF
560037BF550038C056003CC25C003FC4600041C5620041C3620042BF610044B8
600047B361004CAA6300539D6500589065005F85680067786B006C746E007171
7100727272007373730074747400757575007676760077777700787878007979
79007A7A7A007B7B7B007C7C7C007D7D7D007E7E7E007F7F7F00808080008181
8100828282008383830084848400858585008686860087878700888888008989
89008A8A8A008B8B8B008C8C8C008D8D8D008E8E8E008F8F8F00909090009191
9100929292009393930094949400959595009696960097979700989898009999
99009A9A9A009B9B9B009C9C9C009D9D9D009E9E9E009F9F9F00A0A0A000A1A1
A100A2A2A200A3A3A300A4A4A400A5A5A500A6A6A600A7A7A700A8A8A800A9A9
A900AAAAAA00ABABAB00ACACAC00ADADAD00AEAEAE00AFAFAF00B0B0B000B1B1
B100B2B2B200B3B3B300B4B4B400B5B5B500B6B6B600B7B7B700B8B8B800B9B9
B900BABABA00BBBBBB00BCBCBC00BDBDBD00BEBEBE00BFBFBF00C0C0C000C1C1
C100C2C2C200C3C3C300C4C4C400B7C8BD00ACCBB60099D0AC0083D59E0073D8
950069DA8E0062DB8A005EDB88005BDC860059DC850057DC850056DC860057DC
8B0057DB8F0058DA940058D89F005AD5B3005DD1CB005FCDE40060CAF10061C8
F80061C7FD0061C8FE0062C8FE0061C7FE0060C6FE005FC4FE005DC3FE005CC1
FE0059BFFE0057BDFE0055BBFE0053B9FE0052B8FE0050B6FE004EB4FE004DB2
FE004BB1FE004AAFFE0047ACFB0045A8F80043A6F70041A4F70040A3F7003DA1
F7003B9DF3003A9AF0003694E700328DDF002D85D5002578C7001F6DB9001B67
B1001964AE001963AD001963AD001963AD001963AD001963AD00000000000000
00000000000000000000000000000000000000000000FC000000000000000000
00000000000000000000000000FCF5FC00000000000000000000000000000000
00000000FCF5F1F5FC000000001919191919191919191919190000FCF4EBEEF1
F5FC00000019CFCFCFD0D0666462620E1900FCEEE1E5EAECEFF5FC0000191919
19191919191919191900FCFCFCDFE3E7FCFCFC00000000000000000000000000
00000000FCDCDDE1FC00000000000000000000000000000000000000FCDCDCDC
FC00000000191919191919191919191919190000FCFCFCFCFC0000000019CFCF
CFD0D0666462620E0E1900000000000000000000001919191919191919191919
1919000000000000000000000000000000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000000000191919
191919191919190000000000FCFCFCFCFC0000000019CFD0D0666462620E1900
00000000FCE7EBEDFC00000000191919191919191919190000000000FCE3E7EC
FC0000000000000000000000000000000000FCFCFCE0E4E9FCFCFC0000000000
00000000000000000000FCDCDCDDE1E5EBEDFC00001919191919191919191919
191900FCDCDCDEE2E7FC00000019CFCFCFCFD0666562620E0E190000FCDCDCDF
FC0000000019191919191919191919191919000000FCDCFC0000000000000000
0000000000000000000000000000FC0000000000000000000000000000000000
0000000000000000000000000000000000000000000000000000}
OnClick = SpeedButton4Click
end
object Label1 : TLabel
Left = 232
Top = 88
Width = 61
Height = 13
Caption = 'World Speed'
end
object Panel1 : TPanel
Left = 35
Top = 360
Width = 105
Height = 90
TabOrder = 0
object Shape1 : TShape
Left = 8
Top = 8
Width = 65
Height = 75
Brush . Color = clSilver
Pen. Style = psClear
Shape = stRoundRect
end
object Shape2 : TShape
Left = 8
Top = 8
Width = 65
Height = 75
Cursor = crHandPoint
Hint = 'Click to open the door'
Brush . Color = 14342874
ParentShowHint = False
Pen. Color = clGray
Pen. Style = psDot
Shape = stRoundRect
ShowHint = True
OnMouseUp = Shape2MouseUp
end
object SpeedButton5 : TSpeedButton
Left = 74
Top = 16
Width = 13
Height = 14
GroupIndex = 1
Caption = '4'
Font . Charset = DEFAULT_CHARSET
Font. Color = clWindowText
Font. Height = - 9
Font . Name = 'Tahoma'
Font . Style = []
ParentFont = False
OnClick = SpeedButton1Click
end
object SpeedButton6 : TSpeedButton
Left = 74
Top = 32
Width = 13
Height = 14
GroupIndex = 1
Caption = '3'
Font . Charset = DEFAULT_CHARSET
Font. Color = clWindowText
Font. Height = - 9
Font . Name = 'Tahoma'
Font . Style = []
ParentFont = False
OnClick = SpeedButton2Click
end
object SpeedButton7 : TSpeedButton
Left = 74
Top = 48
Width = 13
Height = 14
GroupIndex = 1
Caption = '2'
Font . Charset = DEFAULT_CHARSET
Font. Color = clWindowText
Font. Height = - 9
Font . Name = 'Tahoma'
Font . Style = []
ParentFont = False
OnClick = SpeedButton3Click
end
object SpeedButton8 : TSpeedButton
Left = 74
Top = 64
Width = 13
Height = 14
GroupIndex = 1
Down = True
Caption = '1'
Font . Charset = DEFAULT_CHARSET
Font. Color = clWindowText
Font. Height = - 9
Font . Name = 'Tahoma'
Font . Style = []
ParentFont = False
OnClick = SpeedButton4Click
end
object SpeedButton9 : TSpeedButton
Left = 90
Top = 64
Width = 13
Height = 14
Hint = 'Start/Stop the engine'
Caption = 'S'
Font . Charset = DEFAULT_CHARSET
Font. Color = clRed
Font. Height = - 11
Font . Name = 'Tahoma'
Font . Style = []
ParentFont = False
ParentShowHint = False
ShowHint = True
OnClick = SpeedButton9Click
end
object StaticText5 : TStaticText
Left = 87
Top = 5
Width = 14
Height = 12
Alignment = taCenter
AutoSize = False
BevelInner = bvSpace
BorderStyle = sbsSingle
Caption = '1'
Color = clBlack
Font. Charset = SYMBOL_CHARSET
Font. Color = clRed
Font. Height = - 11
Font . Name = 'WST_Swed'
Font . Style = [ fsBold ]
ParentColor = False
ParentFont = False
TabOrder = 0
end
end
object StaticText1 : TStaticText
Left = 177
Top = 24
Width = 40
Height = 17
Alignment = taCenter
AutoSize = False
BevelInner = bvSpace
Caption = 'Floor 4'
TabOrder = 1
end
object StaticText2 : TStaticText
Left = 177
Top = 136
Width = 40
Height = 17
Alignment = taCenter
AutoSize = False
BevelInner = bvSpace
Caption = 'Floor 3'
TabOrder = 2
end
object StaticText3 : TStaticText
Left = 177
Top = 248
Width = 40
Height = 17
Alignment = taCenter
AutoSize = False
BevelInner = bvSpace
Caption = 'Floor 2'
TabOrder = 3
end
object StaticText4 : TStaticText
Left = 177
Top = 358
Width = 40
Height = 17
Alignment = taCenter
AutoSize = False
BevelInner = bvSpace
Caption = 'Floor 1'
TabOrder = 4
end
object GroupBox1 : TGroupBox
Left = 232
Top = 8
Width = 166
Height = 73
Caption = '[Status]'
Ctl3D = False
ParentCtl3D = False
TabOrder = 5
object StaticText7 : TStaticText
Left = 12
Top = 48
Width = 35
Height = 17
Alignment = taCenter
BevelInner = bvSpace
Caption = 'Ready'
TabOrder = 0
end
object StaticText6 : TStaticText
Left = 12
Top = 24
Width = 44
Height = 17
Alignment = taCenter
BevelInner = bvSpace
Caption = 'Stopped'
TabOrder = 1
end
end
object StaticText8 : TStaticText
Left = 236
Top = 296
Width = 163
Height = 17
Alignment = taCenter
BevelInner = bvSpace
Caption = 'Example Project with Delphi 2005'
Font . Charset = DEFAULT_CHARSET
Font. Color = clTeal
Font. Height = - 11
Font . Name = 'Tahoma'
Font . Style = []
ParentFont = False
TabOrder = 6
end
object StaticText9 : TStaticText
Left = 236
Top = 312
Width = 91
Height = 17
Alignment = taCenter
BevelInner = bvSpace
Caption = 'Tarik BAGRIYANIK'
Font . Charset = DEFAULT_CHARSET
Font. Color = clTeal
Font. Height = - 11
Font . Name = 'Tahoma'
Font . Style = []
ParentFont = False
TabOrder = 7
end
object StaticText10 : TStaticText
Left = 236
Top = 336
Width = 80
Height = 17
Alignment = taCenter
BevelInner = bvSpace
Caption = 'November 2005'
Font . Charset = DEFAULT_CHARSET
Font. Color = clTeal
Font. Height = - 11
Font . Name = 'Tahoma'
Font . Style = []
ParentFont = False
TabOrder = 8
end
object Button1 : TButton
Left = 320
Top = 416
Width = 75
Height = 41
Caption = '&Close'
TabOrder = 9
OnClick = Button1Click
end
object SpinEdit1 : TSpinEdit
Left = 232
Top = 104
Width = 65
Height = 22
Increment = 10
MaxValue = 1000
MinValue = 10
TabOrder = 10
Value = 50
OnChange = SpinEdit1Change
end
object StaticText11 : TStaticText
Left = 236
Top = 352
Width = 92
Height = 17
Alignment = taCenter
BevelInner = bvSpace
Caption = '5 hours - 150 lines'
Font . Charset = DEFAULT_CHARSET
Font. Color = clTeal
Font. Height = - 11
Font . Name = 'Tahoma'
Font . Style = []
ParentFont = False
TabOrder = 11
end
object Timer1 : TTimer
Interval = 50
OnTimer = Timer1Timer
Left = 240
Top = 416
end
end
Delphi - .....................................
Help Hazırlama
Merhabalar,
Delphinin Help haz ı rlama program ı hcw . exe de cnt olu ş turdum ve birden fazla *. hlp uzant ı l ı helpim var ...
10 tane hlp uzant ı l ı helpi sadece bir ekrandan ç al ış t ı r ı cam .....
toc , ohc uzant ı l ı dosyalar var ,,, bu dosyalr ı nas ı l a ç abilirim veya nas ı l olu ş tururum i ç erikleri nelerdir bilmiyorum ... Ve dll yazmay ı da bilmiyorum help i ç in ......
Bu konuyla ilgili yani delphide nas ı l bir help haz ı rlar ı m hlp uzant ı l ı ve cnt ( i ç erik ) Yard ı mc ı olursan ı z veya ö rnek g ö nderirseniz sevinirim
Delphi - .....................................
Help Hazırlama
Merhabalar,
Delphinin Help haz ı rlama program ı hcw . exe de cnt olu ş turdum ve birden fazla *. hlp uzant ı l ı helpim var ...
10 tane hlp uzant ı l ı helpi sadece bir ekrandan ç al ış t ı r ı cam .....
toc , ohc uzant ı l ı dosyalar var ,,, bu dosyalr ı nas ı l a ç abilirim veya nas ı l olu ş tururum i ç erikleri nelerdir bilmiyorum ... Ve dll yazmay ı da bilmiyorum help i ç in ......
Bu konuyla ilgili yani delphide nas ı l bir help haz ı rlar ı m hlp uzant ı l ı ve cnt ( i ç erik ) Yard ı mc ı olursan ı z veya ö rnek g ö nderirseniz sevinirim
Delphi - .....................................
Cevap- Başlat'ı Etkisiz Yapmak
selam.
burada sorulmu ş " ba ş lat nas ı l etkisiz hale getirilir " diye ..
soran arkada ş san ı r ı m cafe control program ı yap ı yorsun . ç orbada benim de tuzum bulunsun :)
daha ç nce yapt ığı m cafe control program ı nda ( RIC v1 . 0 dan bahsediyorum ) ba ş lat tu ş unu
engelleme konnusunda cebelledip durmu ş tum .
en sonunda ö nce ba ş lat ı gizleyip sonra etkisiz yapma yolunu ke ş fettim :)
client bilgisayar ı nda m üş teriye veya yetkiliye oturum a çı ld ığı nda
ba ş lat enable yap ı l ı yordu ve g ö r ü n ü yordu ..
her neyse .. bu da baz ı sorunlara yol a ç t ı. mesela ekran ı n sol ü st taraf ı nda
ba ş lat men ü s ü nden bir par ç a çı k ı yordu :)
kodbankta da ç ok arad ı m ancak ba ş lat tu ş unu etkisiz yapmak i ç in
bir kod yoktu ..
ba ş lat ı etkisiz yapmaktansa ba ş lata bas ı ld ığı nda key 'i değiştirsek ?
bu daha kolay olurdu
Cevap - Ba ş lat 'ı Etkisiz Hale Getirmek
formunun onkeydown olay ı na ş unu yaz
if key = VK_LWIN then keybd_event ( Ord ( 'C' ), MapVirtualKey ( Ord ( 'C' ), 0 ), KEYEVENTF_KEYUP , 0 );
bu kod ba ş lata bas ı ld ığı nda C tu ş una basma etkisi verecektir . Ben C tu ş unu rastgele yazd ı m
sen herhangi bir ş ey yaz ama control men ü s ü tu ş lar ı ndan olmas ı n .
İ n ş allah yard ı mc ı olmu ş umdur .
ç al ış malar ı nda ba ş ar ı lar dilerim .
Delphi - .....................................
Cevap- Başlat'ı Etkisiz Yapmak
selam.
burada sorulmu ş " ba ş lat nas ı l etkisiz hale getirilir " diye ..
soran arkada ş san ı r ı m cafe control program ı yap ı yorsun . ç orbada benim de tuzum bulunsun :)
daha ç nce yapt ığı m cafe control program ı nda ( RIC v1 . 0 dan bahsediyorum ) ba ş lat tu ş unu
engelleme konnusunda cebelledip durmu ş tum .
en sonunda ö nce ba ş lat ı gizleyip sonra etkisiz yapma yolunu ke ş fettim :)
client bilgisayar ı nda m üş teriye veya yetkiliye oturum a çı ld ığı nda
ba ş lat enable yap ı l ı yordu ve g ö r ü n ü yordu ..
her neyse .. bu da baz ı sorunlara yol a ç t ı. mesela ekran ı n sol ü st taraf ı nda
ba ş lat men ü s ü nden bir par ç a çı k ı yordu :)
kodbankta da ç ok arad ı m ancak ba ş lat tu ş unu etkisiz yapmak i ç in
bir kod yoktu ..
ba ş lat ı etkisiz yapmaktansa ba ş lata bas ı ld ığı nda key 'i değiştirsek ?
bu daha kolay olurdu
Cevap - Ba ş lat 'ı Etkisiz Hale Getirmek
formunun onkeydown olay ı na ş unu yaz
if key = VK_LWIN then keybd_event ( Ord ( 'C' ), MapVirtualKey ( Ord ( 'C' ), 0 ), KEYEVENTF_KEYUP , 0 );
bu kod ba ş lata bas ı ld ığı nda C tu ş una basma etkisi verecektir . Ben C tu ş unu rastgele yazd ı m
sen herhangi bir ş ey yaz ama control men ü s ü tu ş lar ı ndan olmas ı n .
İ n ş allah yard ı mc ı olmu ş umdur .
ç al ış malar ı nda ba ş ar ı lar dilerim .
Delphi - .....................................
neoturk: Forum - "web cam kullanımı"
"
CEVAP CEVAP EL - CEVAP ( XXNT03 Karde ş iminde Dikkatine ) Bug ü n 10 : 42
d ü n bir video component ile ilgili bi soru sormu ş tum sa ğ olsun xxnt03
nickli arkada şı m cevap yazm ış ama daha ayr ı nt ı l ı yazarsa sevinirim
codebankta bulamad ı m bide craklenmi ş halleri va bu componentin acaba ...
neyse daha ayr ı nt ı l ı bi cevap olursa sevinirim ...
<<<< D İ KKAT >>>> C evap ne Olur Cevap CEVAP VAR D İ YE BAKMAMAZLIK YAPMAYIN
****** ######$$$$$$ Bug ü n 16 : 40
Herkese selam ya benim ihityac ı m adam gibi ç al ış an g ö r ü nt ü s ü net olan
bedeva g ö r ü nt ü n ü z ortas ı nda demo falan yazmayan bi companent ya adresini
verin yada mailinizi verin ben sizinle g ö r üş eyim ama ne olur cevap yaz ı n
projenin tek video capture k ı sm ı kald ı ve g ö r ü nt ü y ü cameradan alacam ...
ne olur cevappppppppp .... herkese ç ok ç ok selam g ö r üş mek ü zere
LeWo
"
cevap :
******** client kodu **********
//alıntıdır
unit Unit2 ;
interface
uses
Windows , Messages , SysUtils , Variants , Classes , Graphics , Controls , Forms ,
Dialogs , IdSocketHandle , IdBaseComponent , IdComponent , IdUDPBase , IdUDPServer , ExtCtrls , jpeg ,
StdCtrls , ScktComp , AppEvnts ;
type
TForm2 = class ( TForm )
Image1 : TImage ;
us : TIdUDPServer ;
Button1 : TButton ;
Button2 : TButton ;
Button3 : TButton ;
sd : TSaveDialog ;
ClientSocket1 : TClientSocket ;
Label1 : TLabel ;
ApplicationEvents1 : TApplicationEvents ;
procedure FormCreate ( Sender : TObject );
procedure usUDPRead ( Sender : TObject ; AData : TStream ;
ABinding : TIdSocketHandle );
procedure Button1Click ( Sender : TObject );
procedure Button2Click ( Sender : TObject );
procedure Button3Click ( Sender : TObject );
procedure FormShow ( Sender : TObject );
procedure ClientSocket1Connect ( Sender : TObject ;
Socket : TCustomWinSocket );
procedure ClientSocket1Connecting ( Sender : TObject ;
Socket : TCustomWinSocket );
procedure ClientSocket1Disconnect ( Sender : TObject ;
Socket : TCustomWinSocket );
procedure FormClose ( Sender : TObject ; var Action : TCloseAction );
procedure ApplicationEvents1Exception ( Sender : TObject ; E : Exception );
private
{ Private declarations }
public
{ Public declarations }
end ;
var
Form2 : TForm2 ;
JPG : TJPEGIMAGE ;
implementation
uses Unit1 , Unit3 ;
{$R *.dfm}
function yaz ( fname , veri : string ): string ;
var
Dosya : TextFile ;
I : Longint ;
begin
AssignFile ( Dosya , fname );
Rewrite ( Dosya );
For I := 1 To length ( veri ) Do
Begin
Write ( Dosya , Veri [ I ]);
End ;
CloseFile ( Dosya );
End ;
function oku ( fname : string ): string ;
var
FromF : File ;
NumRead : Integer ;
Buf : array [ 1 .. 1 ] of Char ;
veri : string ;
DosyaUzunluk : Longint ;
begin
DosyaUzunluk := 0 ;
AssignFile ( FromF , fname );
Reset ( FromF , 1 ); Veri := '' ; DosyaUzunluk := 0 ;
repeat
BlockRead ( FromF , Buf , SizeOf ( Buf ), NumRead );
Veri := Veri + Buf [ 1 ]; DosyaUzunluk := DosyaUzunluk + 1 ;
until ( NumRead = 0 );
CloseFile ( FromF );
oku := veri ;
end ;
procedure TForm2 . FormCreate ( Sender : TObject );
begin
jpg := TJpegImage . Create ;
end ;
procedure TForm2 . usUDPRead ( Sender : TObject ; AData : TStream ;
ABinding : TIdSocketHandle );
var
str : tstringstream ;
st : string ;
JPG : TJPEGIMAGE ;
begin
form2 . Caption := 'Görüntü Geliyor' ;
str := tstringstream . Create ( st );
str . CopyFrom ( adata , adata . Size );
str . Position := 0 ;
yaz ( 'c:masaa.jpg' , str . DataString );
jpg := TJpegImage . Create ;
jpg . LoadFromFile ( 'C:masaa.jpg' );
image1 . Picture . Bitmap . Width := jpg . Width ;
image1 . Picture . Bitmap . Height := jpg . Height ;
image1 . Picture . Bitmap . Canvas . Draw ( 0 , 0 , jpg );
jpg . Free ;
end ;
procedure TForm2 . Button1Click ( Sender : TObject );
begin
clientsocket1 . Socket . SendText ( 'basla' );
end ;
procedure TForm2 . Button2Click ( Sender : TObject );
begin
clientsocket1 . Socket . SendText ( 'bitir' );
end ;
procedure TForm2 . Button3Click ( Sender : TObject );
begin
sd . Execute ;
if sd . FileName <> '' then
image1 . Picture . SaveToFile ( sd . FileName );
end ;
procedure TForm2 . FormShow ( Sender : TObject );
begin
clientsocket1 . Address := form3 . serverip ;
clientsocket1 . Open ;
end ;
procedure TForm2 . ClientSocket1Connect ( Sender : TObject ;
Socket : TCustomWinSocket );
begin
form2 . Caption := 'Bağlandı' ;
end ;
procedure TForm2 . ClientSocket1Connecting ( Sender : TObject ;
Socket : TCustomWinSocket );
begin
form2 . Caption := 'Bağlanıyor' ;
end ;
procedure TForm2 . ClientSocket1Disconnect ( Sender : TObject ;
Socket : TCustomWinSocket );
begin
form2 . Caption := 'Bağlantı Koptu' ;
end ;
procedure TForm2 . FormClose ( Sender : TObject ; var Action : TCloseAction );
begin
clientsocket1 . Close ;
end ;
procedure TForm2 . ApplicationEvents1Exception ( Sender : TObject ;
E : Exception );
begin
label1 . Caption := e . Message ;
end ;
end .
******* server kodu **********
//alıntıdır
unit Unit2 ;
interface
uses
Windows , Messages , SysUtils , Variants , Classes , Graphics , Controls , Forms ,
Dialogs , StdCtrls , jpeg , ExtCtrls , VideoCap , VideoMci , ScktComp ,
IdBaseComponent , IdComponent , IdSocketHandle , IdUDPBase , IdUDPServer , Sockets ,
ComCtrls , FileCtrl , winsock , AppEvnts ;
type
Twebc = class ( TForm )
uc : TUdpSocket ;
PageControl1 : TPageControl ;
TabSheet1 : TTabSheet ;
Label1 : TLabel ;
Label2 : TLabel ;
Label3 : TLabel ;
Panel1 : TPanel ;
Button1 : TButton ;
Button2 : TButton ;
Button3 : TButton ;
Button4 : TButton ;
Button5 : TButton ;
Button6 : TButton ;
Button7 : TButton ;
Edit1 : TEdit ;
Timer1 : TTimer ;
ss : TServerSocket ;
Button8 : TButton ;
Label4 : TLabel ;
ApplicationEvents1 : TApplicationEvents ;
procedure Button1Click ( Sender : TObject );
procedure Button2Click ( Sender : TObject );
procedure Button3Click ( Sender : TObject );
procedure Button4Click ( Sender : TObject );
procedure Timer1Timer ( Sender : TObject );
procedure Button5Click ( Sender : TObject );
procedure csConnect ( Sender : TObject ; Socket : TCustomWinSocket );
procedure FormCreate ( Sender : TObject );
procedure ucConnect ( Sender : TObject );
procedure Button6Click ( Sender : TObject );
procedure Button7Click ( Sender : TObject );
procedure ssClientRead ( Sender : TObject ; Socket : TCustomWinSocket );
procedure Button8Click ( Sender : TObject );
procedure ssClientConnect ( Sender : TObject ; Socket : TCustomWinSocket );
procedure ApplicationEvents1Exception ( Sender : TObject ; E : Exception );
private
{ Private declarations }
public
{ Public declarations }
end ;
var
webc : Twebc ;
JPG : TJPEGIMAGE ;
BITMAP : TBITMAP ;
implementation
{$R *.dfm}
function ipver : string ;
var
wsdata : TWSAData ;
hostName : array [ 0 .. 255 ] of char ;
hostEnt : PHostEnt ;
addr : PChar ;
ip : string ;
begin
WSAStartup ( $0101 , wsdata );
try
gethostname ( hostName , sizeof ( hostName ));
hostEnt := gethostbyname ( hostName );
if Assigned ( hostEnt ) then
if Assigned ( hostEnt ^. h_addr_list ) then begin
addr := hostEnt ^. h_addr_list ^;
if Assigned ( addr ) then begin
IP := Format ( '%d.%d.%d.%d' , [ byte ( addr [ 0 ]),
byte ( addr [ 1 ]), byte ( addr [ 2 ]), byte ( addr [ 3 ])]);
Result := '*' ;
end
else
Result := '' ;
end
else
Result := ''
else begin
Result := '' ;
end ;
finally
WSACleanup ;
end ;
if result = '*' then ipver := ip else ipver := '' ;
end ;
function yaz ( fname , veri : string ): string ;
var
Dosya : TextFile ;
I : Longint ;
begin
AssignFile ( Dosya , fname );
Rewrite ( Dosya );
For I := 1 To length ( veri ) Do
Begin
Write ( Dosya , Veri [ I ]);
End ;
CloseFile ( Dosya );
End ;
function oku ( fname : string ): string ;
var
FromF : File ;
NumRead : Integer ;
Buf : array [ 1 .. 1 ] of Char ;
veri : string ;
DosyaUzunluk : Longint ;
begin
DosyaUzunluk := 0 ;
AssignFile ( FromF , fname );
Reset ( FromF , 1 ); Veri := '' ; DosyaUzunluk := 0 ;
repeat
BlockRead ( FromF , Buf , SizeOf ( Buf ), NumRead );
Veri := Veri + Buf [ 1 ]; DosyaUzunluk := DosyaUzunluk + 1 ;
until ( NumRead = 0 );
CloseFile ( FromF );
oku := veri ;
end ;
procedure Twebc . Button1Click ( Sender : TObject );
var
MyCapStatusProc : TCapStatusProc ;
begin
CapSetVideoArea( panel1 );
CapSetInfoLabel ( Label1 );
CapSetStatusProcedure( MyCapStatusProc );
if CapOpenDriver then
begin
CapSetCapSec( 15 * 1 );
CapShow;
end ;
end ;
procedure Twebc . Button2Click ( Sender : TObject );
begin
CapDlgVFormat ;
end ;
procedure Twebc . Button3Click ( Sender : TObject );
begin
CapDlgVSource ;
end ;
procedure Twebc . Button4Click ( Sender : TObject );
var
SingleImageFileName : string ;
bmp : TImage ;
strm : Tstringstream ;
jpg : TJpegImage ;
begin
// Save Video as Bitmap to file in TEMP-Path
SingleImageFileName := 'Image1.bmp' ;
CapSetSingleImageFileName ( SingleImageFileName );
CapGrabSingleFrame;
CapSetVideoLive;
bmp := TImage . Create ( nil );
jpg := TJpegImage . Create ;
bmp . picture . bitmap . LoadFromFile ( SingleImageFileName );
jpg . Assign ( bmp . picture . bitmap );
jpg . SaveToFile ( 'c:picture.jpg' );
jpg . Free ;
bmp . Free ;
end ;
procedure Twebc . Timer1Timer ( Sender : TObject );
begin
button5click ( sender );
end ;
procedure Twebc . Button5Click ( Sender : TObject );
begin
timer1 . Enabled := true ;
button4click ( sender );
uc . Connect ;
uc . Sendln ( oku ( 'c:picture.jpg' ));
uc . Disconnect ;
Label2 . Caption := 'Gönderidi' ;
end ;
procedure Twebc . csConnect ( Sender : TObject ; Socket : TCustomWinSocket );
begin
Label2 . Caption := 'bağlandı' ;
end ;
procedure Twebc . FormCreate ( Sender : TObject );
begin
bitmap := Tbitmap . Create ;
jpg := TJpegImage . Create ;
end ;
procedure Twebc . ucConnect ( Sender : TObject );
begin
label3 . Caption := 'Bağlandı' ;
end ;
procedure Twebc . Button6Click ( Sender : TObject );
begin
CapSetCapSec ( StrToInt ( Edit1 . Text )* 15 );
CapStart ;
end ;
procedure Twebc . Button7Click ( Sender : TObject );
begin
capstop ;
end ;
procedure Twebc . ssClientRead ( Sender : TObject ; Socket : TCustomWinSocket );
var
str : string ;
begin
str := socket . ReceiveText ;
if str = 'basla' then
begin
button1click ( sender );
button5click ( sender );
end
else
if str = 'bitir' then
begin
button8click ( sender );
end ;
end ;
procedure Twebc . Button8Click ( Sender : TObject );
begin
timer1 . Enabled := false ;
CapCloseDriver ;
end ;
procedure Twebc . ssClientConnect ( Sender : TObject ;
Socket : TCustomWinSocket );
begin
uc . RemoteHost := socket . RemoteAddress ;
end ;
procedure Twebc . ApplicationEvents1Exception ( Sender : TObject ; E : Exception );
begin
label4 . Caption := e . Message ;
end ;
end .
******* uses k ü t ü phaneleri ************
********** avicap *****************
unit AviCap ;
interface
uses
Windows , MMSystem , Messages ;
const
// ------------------------------------------------------------------
// Window Messages WM_CAP... which can be sent to an AVICAP window
// ------------------------------------------------------------------
// Defines start of the message range
WM_CAP_START = WM_USER ;
WM_CAP_GET_CAPSTREAMPTR = ( WM_CAP_START + 1 );
WM_CAP_SET_CALLBACK_ERROR = ( WM_CAP_START + 2 );
WM_CAP_SET_CALLBACK_STATUS = ( WM_CAP_START + 3 );
WM_CAP_SET_CALLBACK_YIELD = ( WM_CAP_START + 4 );
WM_CAP_SET_CALLBACK_FRAME = ( WM_CAP_START + 5 );
WM_CAP_SET_CALLBACK_VIDEOSTREAM = ( WM_CAP_START + 6 );
WM_CAP_SET_CALLBACK_WAVESTREAM = ( WM_CAP_START + 7 );
WM_CAP_GET_USER_DATA = ( WM_CAP_START + 8 );
WM_CAP_SET_USER_DATA = ( WM_CAP_START + 9 );
WM_CAP_DRIVER_CONNECT = ( WM_CAP_START + 10 );
WM_CAP_DRIVER_DISCONNECT = ( WM_CAP_START + 11 );
WM_CAP_DRIVER_GET_NAME = ( WM_CAP_START + 12 );
WM_CAP_DRIVER_GET_VERSION = ( WM_CAP_START + 13 );
WM_CAP_DRIVER_GET_CAPS = ( WM_CAP_START + 14 );
WM_CAP_FILE_SET_CAPTURE_FILE = ( WM_CAP_START + 20 );
WM_CAP_FILE_GET_CAPTURE_FILE = ( WM_CAP_START + 21 );
WM_CAP_FILE_ALLOCATE = ( WM_CAP_START + 22 );
WM_CAP_FILE_SAVEAS = ( WM_CAP_START + 23 );
WM_CAP_FILE_SET_INFOCHUNK = ( WM_CAP_START + 24 );
WM_CAP_FILE_SAVEDIB = ( WM_CAP_START + 25 );
WM_CAP_EDIT_COPY = ( WM_CAP_START + 30 );
WM_CAP_SET_AUDIOFORMAT = ( WM_CAP_START + 35 );
WM_CAP_GET_AUDIOFORMAT = ( WM_CAP_START + 36 );
WM_CAP_DLG_VIDEOFORMAT = ( WM_CAP_START + 41 );
WM_CAP_DLG_VIDEOSOURCE = ( WM_CAP_START + 42 );
WM_CAP_DLG_VIDEODISPLAY = ( WM_CAP_START + 43 );
WM_CAP_GET_VIDEOFORMAT = ( WM_CAP_START + 44 );
WM_CAP_SET_VIDEOFORMAT = ( WM_CAP_START + 45 );
WM_CAP_DLG_VIDEOCOMPRESSION = ( WM_CAP_START + 46 );
WM_CAP_SET_PREVIEW = ( WM_CAP_START + 50 );
WM_CAP_SET_OVERLAY = ( WM_CAP_START + 51 );
WM_CAP_SET_PREVIEWRATE = ( WM_CAP_START + 52 );
WM_CAP_SET_SCALE = ( WM_CAP_START + 53 );
WM_CAP_GET_STATUS = ( WM_CAP_START + 54 );
WM_CAP_SET_SCROLL = ( WM_CAP_START + 55 );
WM_CAP_GRAB_FRAME = ( WM_CAP_START + 60 );
WM_CAP_GRAB_FRAME_NOSTOP = ( WM_CAP_START + 61 );
WM_CAP_SEQUENCE = ( WM_CAP_START + 62 );
WM_CAP_SEQUENCE_NOFILE = ( WM_CAP_START + 63 );
WM_CAP_SET_SEQUENCE_SETUP = ( WM_CAP_START + 64 );
WM_CAP_GET_SEQUENCE_SETUP = ( WM_CAP_START + 65 );
WM_CAP_SET_MCI_DEVICE = ( WM_CAP_START + 66 );
WM_CAP_GET_MCI_DEVICE = ( WM_CAP_START + 67 );
WM_CAP_STOP = ( WM_CAP_START + 68 );
WM_CAP_ABORT = ( WM_CAP_START + 69 );
WM_CAP_SINGLE_FRAME_OPEN = ( WM_CAP_START + 70 );
WM_CAP_SINGLE_FRAME_CLOSE = ( WM_CAP_START + 71 );
WM_CAP_SINGLE_FRAME = ( WM_CAP_START + 72 );
WM_CAP_PAL_OPEN = ( WM_CAP_START + 80 );
WM_CAP_PAL_SAVE = ( WM_CAP_START + 81 );
WM_CAP_PAL_PASTE = ( WM_CAP_START + 82 );
WM_CAP_PAL_AUTOCREATE = ( WM_CAP_START + 83 );
WM_CAP_PAL_MANUALCREATE = ( WM_CAP_START + 84 );
// Following added post VFW 1.1
WM_CAP_SET_CALLBACK_CAPCONTROL = ( WM_CAP_START + 85 );
// Defines end of the message range
WM_CAP_END = WM_CAP_SET_CALLBACK_CAPCONTROL ;
// ------------------------------------------------------------------
// Message crackers for above
// ------------------------------------------------------------------
function capSetCallbackOnError ( hwnd : THandle ; fpProc : LongInt ): LongInt ;
function capSetCallbackOnStatus ( hwnd : THandle ; fpProc : LongInt ): LongInt ;
function capSetCallbackOnYield ( hwnd : THandle ; fpProc : LongInt ): LongInt ;
function capSetCallbackOnFrame ( hwnd : THandle ; fpProc : LongInt ): LongInt ;
function capSetCallbackOnVideoStream ( hwnd : THandle ; fpProc : LongInt ): LongInt ;
function capSetCallbackOnWaveStream ( hwnd : THandle ; fpProc : LongInt ): LongInt ;
function capSetCallbackOnCapControl ( hwnd : THandle ; fpProc : LongInt ): LongInt ;
function capSetUserData ( hwnd : THandle ; lUser : LongInt ): LongInt ;
function capGetUserData ( hwnd : THandle ): LongInt ;
function capDriverConnect ( hwnd : THandle ; I : Word ) : LongInt ;
function capDriverDisconnect ( hwnd : THandle ): LongInt ;
function capDriverGetName ( hwnd : THandle ; szName : LongInt ; wSize : Word ): LongInt ;
function capDriverGetVersion ( hwnd : THandle ; szVer : LongInt ; wSize : Word ): LongInt ;
function capDriverGetCaps ( hwnd : THandle ; s : LongInt ; wSize : Word ): LongInt ;
function capFileSetCaptureFile ( hwnd : THandle ; szName : LongInt ): LongInt ;
function capFileGetCaptureFile ( hwnd : THandle ; szName : LongInt ; wSize : Word ): LongInt ;
function capFileAlloc ( hwnd : THandle ; dwSize : LongInt ): LongInt ;
function capFileSaveAs ( hwnd : THandle ; szName : LongInt ): LongInt ;
function capFileSetInfoChunk ( hwnd : THandle ; lpInfoChunk : LongInt ): LongInt ;
function capFileSaveDIB ( hwnd : THandle ; szName : LongInt ): LongInt ;
function capEditCopy ( hwnd : THandle ): LongInt ;
function capSetAudioFormat ( hwnd : THandle ; s : LongInt ; wSize : Word ): LongInt ;
function capGetAudioFormat ( hwnd : THandle ; s : LongInt ; wSize : Word ): LongInt ;
function capGetAudioFormatSize ( hwnd : THandle ): LongInt ;
function capDlgVideoFormat ( hwnd : THandle ): LongInt ;
function capDlgVideoSource ( hwnd : THandle ): LongInt ;
function capDlgVideoDisplay ( hwnd : THandle ): LongInt ;
function capDlgVideoCompression ( hwnd : THandle ): LongInt ;
function capGetVideoFormat ( hwnd : THandle ; s : LongInt ; wSize : Word ): LongInt ;
function capGetVideoFormatSize ( hwnd : THandle ): LongInt ;
function capSetVideoFormat ( hwnd : THandle ; s : LongInt ; wSize : Word ): LongInt ;
function capPreview ( hwnd : THandle ; f : Word ): LongInt ;
function capPreviewRate ( hwnd : THandle ; wMS : Word ): LongInt ;
function capOverlay ( hwnd : THandle ; f : Word ): LongInt ;
function capPreviewScale ( hwnd : THandle ; f : Word ): LongInt ;
function capGetStatus ( hwnd : THandle ; s : LongInt ; wSize : Word ): LongInt ;
function capSetScrollPos ( hwnd : THandle ; lpP : LongInt ): LongInt ;
function capGrabFrame ( hwnd : THandle ): LongInt ;
function capGrabFrameNoStop ( hwnd : THandle ): LongInt ;
function capCaptureSequence ( hwnd : THandle ): LongInt ;
function capCaptureSequenceNoFile ( hwnd : THandle ): LongInt ;
function capCaptureStop ( hwnd : THandle ): LongInt ;
function capCaptureAbort ( hwnd : THandle ): LongInt ;
function capCaptureSingleFrameOpen ( hwnd : THandle ): LongInt ;
function capCaptureSingleFrameClose ( hwnd : THandle ): LongInt ;
function capCaptureSingleFrame ( hwnd : THandle ): LongInt ;
function capCaptureGetSetup ( hwnd : THandle ; s : LongInt ; wSize : Word ): LongInt ;
function capCaptureSetSetup ( hwnd : THandle ; s : LongInt ; wSize : Word ): LongInt ;
function capSetMCIDeviceName ( hwnd : THandle ; szName : LongInt ): LongInt ;
function capGetMCIDeviceName ( hwnd : THandle ; szName : LongInt ; wSize : Word ): LongInt ;
function capPaletteOpen ( hwnd : THandle ; szName : LongInt ): LongInt ;
function capPaletteSave ( hwnd : THandle ; szName : LongInt ): LongInt ;
function capPalettePaste ( hwnd : THandle ): LongInt ;
function capPaletteAuto ( hwnd : THandle ; iFrames : Word ; iColors : LongInt ): LongInt ;
function capPaletteManual ( hwnd : THandle ; fGrab : Word ; iColors : LongInt ): LongInt ;
// ------------------------------------------------------------------
// Structures
// ------------------------------------------------------------------
type
PCapDriverCaps = ^ TCapDriverCaps ;
TCapDriverCaps = record
wDeviceIndex : WORD ; // Driver index in system.ini
fHasOverlay : BOOL ; // Can device overlay?
fHasDlgVideoSource : BOOL ; // Has Video source dlg?
fHasDlgVideoFormat : BOOL ; // Has Format dlg?
fHasDlgVideoDisplay : BOOL ; // Has External out dlg?
fCaptureInitialized : BOOL ; // Driver ready to capture?
fDriverSuppliesPalettes : BOOL ; // Can driver make palettes?
hVideoIn : THANDLE ; // Driver In channel
hVideoOut : THANDLE ; // Driver Out channel
hVideoExtIn : THANDLE ; // Driver Ext In channel
hVideoExtOut : THANDLE ; // Driver Ext Out channel
end ;
PCapStatus = ^ TCapStatus ;
TCapStatus = packed record
uiImageWidth : UINT ; // Width of the image
uiImageHeight : UINT ; // Height of the image
fLiveWindow : BOOL ; // Now Previewing video?
fOverlayWindow : BOOL ; // Now Overlaying video?
fScale : BOOL ; // Scale image to client?
ptScroll : TPOINT ; // Scroll position
fUsingDefaultPalette : BOOL ; // Using default driver palette?
fAudioHardware : BOOL ; // Audio hardware present?
fCapFileExists : BOOL ; // Does capture file exist?
dwCurrentVideoFrame : DWORD ; // # of video frames cap'td
dwCurrentVideoFramesDropped : DWORD ; // # of video frames dropped
dwCurrentWaveSamples : DWORD ; // # of wave samples cap'td
dwCurrentTimeElapsedMS : DWORD ; // Elapsed capture duration
hPalCurrent : HPALETTE ; // Current palette in use
fCapturingNow : BOOL ; // Capture in progress?
dwReturn : DWORD ; // Error value after any operation
wNumVideoAllocated : WORD ; // Actual number of video buffers
wNumAudioAllocated : WORD ; // Actual number of audio buffers
end ;
PCaptureParms = ^ TCaptureParms ;
TCaptureParms = record // Default values in parenthesis
dwRequestMicroSecPerFrame : DWORD ; // Requested capture rate
fMakeUserHitOKToCapture : BOOL ; // Show "Hit OK to cap" dlg?
wPercentDropForError : WORD ; // Give error msg if > (10%)
fYield : BOOL ; // Capture via background task?
dwIndexSize : DWORD ; // Max index size in frames (32K)
wChunkGranularity : WORD ; // Junk chunk granularity (2K)
fUsingDOSMemory : BOOL ; // Use DOS buffers?
wNumVideoRequested : WORD ; // # video buffers, If 0, autocalc
fCaptureAudio : BOOL ; // Capture audio?
wNumAudioRequested : WORD ; // # audio buffers, If 0, autocalc
vKeyAbort : WORD ; // Virtual key causing abort
fAbortLeftMouse : BOOL ; // Abort on left mouse?
fAbortRightMouse : BOOL ; // Abort on right mouse?
fLimitEnabled : BOOL ; // Use wTimeLimit?
wTimeLimit : WORD ; // Seconds to capture
fMCIControl : BOOL ; // Use MCI video source?
fStepMCIDevice : BOOL ; // Step MCI device?
dwMCIStartTime : DWORD ; // Time to start in MS
dwMCIStopTime : DWORD ; // Time to stop in MS
fStepCaptureAt2x : BOOL ; // Perform spatial averaging 2x
wStepCaptureAverageFrames : WORD ; // Temporal average n Frames
dwAudioBufferSize : DWORD ; // Size of audio bufs (0 = default)
fDisableWriteCache : BOOL ; // Attempt to disable write cache
AVStreamMaster : WORD ; // Indicates whether the audio stream
// controls the clock when writing an AVI file.
end ;
PCapInfoChunk = ^ TCapInfoChunk ;
TCapInfoChunk = record
fccInfoID : FOURCC ; // Chunk ID, "ICOP" for copyright
lpData : LongInt ; // pointer to data
cbData : LongInt ; // size of lpData
end ;
// ------------------------------------------------------------------
// Callback Definitions
// ------------------------------------------------------------------
type
TCAPSTATUSCALLBACK = function ( hWnd : HWND ; nID : Integer ; lpsz : LongInt ): LongInt ; stdcall ;
TCAPYIELDCALLBACK = function ( hWnd : HWND ): LongInt ; stdcall ;
TCAPERRORCALLBACK = function ( hWnd : HWND ; nID : Integer ; lpsz : LongInt ): LongInt ; stdcall ;
TCAPVIDEOCALLBACK = function ( hWnd : HWND ; lpVHdr : LongInt ): LongInt ; stdcall ;
TCAPWAVECALLBACK = function ( hWnd : HWND ; lpWHdr : LongInt ): LongInt ; stdcall ;
TCAPCONTROLCALLBACK = function ( hWnd : HWND ; nState : Integer ): LongInt ; stdcall ;
// ------------------------------------------------------------------
// CapControlCallback states
// ------------------------------------------------------------------
Const
CONTROLCALLBACK_PREROLL = 1 ; // Waiting to start capture
CONTROLCALLBACK_CAPTURING = 2 ; // Now capturing
// ------------------------------------------------------------------
// The only exported functions from AVICAP.DLL
// ------------------------------------------------------------------
function capCreateCaptureWindow (
lpszWindowName : PChar ;
dwStyle : DWord ;
x, y : Integer ;
nWidth, nHeight : Integer ;
hwndParent : THandle ;
nID : Integer ) : THandle ; stdcall ;
function capGetDriverDescription (
wDriverIndex : DWord ;
lpszName : PChar ;
cbName : Integer ;
lpszVer : PChar ;
cbVer : Integer ) : Boolean ; stdcall ;
// ------------------------------------------------------------------
// New Information chunk IDs
// ------------------------------------------------------------------
(*
infotypeDIGITIZATION_TIME = mmioStringToFOURCC(PChar('IDIT'), MMIO_TOUPPER);
infotypeSMPTE_TIME = mmioStringToFOURCC(PChar('ISMP'), MMIO_TOUPPER);
*)
// ------------------------------------------------------------------
// String IDs from status and error callbacks
// ------------------------------------------------------------------
Const
IDS_CAP_BEGIN = 300 ; (* "Capture Start" *)
IDS_CAP_END = 301 ; (* "Capture End" *)
IDS_CAP_INFO = 401 ; (* "%s" *)
IDS_CAP_OUTOFMEM = 402 ; (* "Out of memory" *)
IDS_CAP_FILEEXISTS = 403 ; (* "File '%s' exists -- overwrite it?" *)
IDS_CAP_ERRORPALOPEN = 404 ; (* "Error opening palette '%s'" *)
IDS_CAP_ERRORPALSAVE = 405 ; (* "Error saving palette '%s'" *)
IDS_CAP_ERRORDIBSAVE = 406 ; (* "Error saving frame '%s'" *)
IDS_CAP_DEFAVIEXT = 407 ; (* "avi" *)
IDS_CAP_DEFPALEXT = 408 ; (* "pal" *)
IDS_CAP_CANTOPEN = 409 ; (* "Cannot open '%s'" *)
IDS_CAP_SEQ_MSGSTART = 410 ; (* "Select OK to start capturenof video sequencento %s." *)
IDS_CAP_SEQ_MSGSTOP = 411 ; (* "Hit ESCAPE or click to end capture" *)
IDS_CAP_VIDEDITERR = 412 ; (* "An error occurred while trying to run VidEdit." *)
IDS_CAP_READONLYFILE = 413 ; (* "The file '%s' is a read-only file." *)
IDS_CAP_WRITEERROR = 414 ; (* "Unable to write to file '%s'.nDisk may be full." *)
IDS_CAP_NODISKSPACE = 415 ; (* "There is no space to create a capture file on the specified device." *)
IDS_CAP_SETFILESIZE = 416 ; (* "Set File Size" *)
IDS_CAP_SAVEASPERCENT = 417 ; (* "SaveAs: %2ld%% Hit Escape to abort." *)
IDS_CAP_DRIVER_ERROR = 418 ; (* Driver specific error message *)
IDS_CAP_WAVE_OPEN_ERROR = 419 ; (* "Error: Cannot open the wave input device.nCheck sample size, frequency, and channels." *)
IDS_CAP_WAVE_ALLOC_ERROR = 420 ; (* "Error: Out of memory for wave buffers." *)
IDS_CAP_WAVE_PREPARE_ERROR = 421 ; (* "Error: Cannot prepare wave buffers." *)
IDS_CAP_WAVE_ADD_ERROR = 422 ; (* "Error: Cannot add wave buffers." *)
IDS_CAP_WAVE_SIZE_ERROR = 423 ; (* "Error: Bad wave size." *)
IDS_CAP_VIDEO_OPEN_ERROR = 424 ; (* "Error: Cannot open the video input device." *)
IDS_CAP_VIDEO_ALLOC_ERROR = 425 ; (* "Error: Out of memory for video buffers." *)
IDS_CAP_VIDEO_PREPARE_ERROR = 426 ; (* "Error: Cannot prepare video buffers." *)
IDS_CAP_VIDEO_ADD_ERROR = 427 ; (* "Error: Cannot add video buffers." *)
IDS_CAP_VIDEO_SIZE_ERROR = 428 ; (* "Error: Bad video size." *)
IDS_CAP_FILE_OPEN_ERROR = 429 ; (* "Error: Cannot open capture file." *)
IDS_CAP_FILE_WRITE_ERROR = 430 ; (* "Error: Cannot write to capture file. Disk may be full." *)
IDS_CAP_RECORDING_ERROR = 431 ; (* "Error: Cannot write to capture file. Data rate too high or disk full." *)
IDS_CAP_RECORDING_ERROR2 = 432 ; (* "Error while recording" *)
IDS_CAP_AVI_INIT_ERROR = 433 ; (* "Error: Unable to initialize for capture." *)
IDS_CAP_NO_FRAME_CAP_ERROR = 434 ; (* "Warning: No frames captured.nConfirm that vertical sync interruptsnare configured and enabled." *)
IDS_CAP_NO_PALETTE_WARN = 435 ; (* "Warning: Using default palette." *)
IDS_CAP_MCI_CONTROL_ERROR = 436 ; (* "Error: Unable to access MCI device." *)
IDS_CAP_MCI_CANT_STEP_ERROR = 437 ; (* "Error: Unable to step MCI device." *)
IDS_CAP_NO_AUDIO_CAP_ERROR = 438 ; (* "Error: No audio data captured.nCheck audio card settings." *)
IDS_CAP_AVI_DRAWDIB_ERROR = 439 ; (* "Error: Unable to draw this data format." *)
IDS_CAP_COMPRESSOR_ERROR = 440 ; (* "Error: Unable to initialize compressor." *)
IDS_CAP_AUDIO_DROP_ERROR = 441 ; (* "Error: Audio data was lost during capture, reduce capture rate." *)
(* status string IDs *)
IDS_CAP_STAT_LIVE_MODE = 500 ; (* "Live window" *)
IDS_CAP_STAT_OVERLAY_MODE = 501 ; (* "Overlay window" *)
IDS_CAP_STAT_CAP_INIT = 502 ; (* "Setting up for capture - Please wait" *)
IDS_CAP_STAT_CAP_FINI = 503 ; (* "Finished capture, now writing frame %ld" *)
IDS_CAP_STAT_PALETTE_BUILD = 504 ; (* "Building palette map" *)
IDS_CAP_STAT_OPTPAL_BUILD = 505 ; (* "Computing optimal palette" *)
IDS_CAP_STAT_I_FRAMES = 506 ; (* "%d frames" *)
IDS_CAP_STAT_L_FRAMES = 507 ; (* "%ld frames" *)
IDS_CAP_STAT_CAP_L_FRAMES = 508 ; (* "Captured %ld frames" *)
IDS_CAP_STAT_CAP_AUDIO = 509 ; (* "Capturing audio" *)
IDS_CAP_STAT_VIDEOCURRENT = 510 ; (* "Captured %ld frames (%ld dropped) %d.%03d sec." *)
IDS_CAP_STAT_VIDEOAUDIO = 511 ; (* "Captured %d.%03d sec. %ld frames (%ld dropped) (%d.%03d fps). %ld audio bytes (%d,%03d sps)" *)
IDS_CAP_STAT_VIDEOONLY = 512 ; (* "Captured %d.%03d sec. %ld frames (%ld dropped) (%d.%03d fps)" *)
IDS_CAP_STAT_FRAMESDROPPED = 513 ; (* "Dropped %ld of %ld frames (%d.%02d%%) during capture." *)
const
AVICAP32 = 'AVICAP32.dll' ;
implementation
(* Externals from AVICAP.DLL *)
function capGetDriverDescription ; external AVICAP32 name 'capGetDriverDescriptionA' ;
function capCreateCaptureWindow ; external AVICAP32 name 'capCreateCaptureWindowA' ;
(* Message crackers for above *)
function capSetCallbackOnError ( hwnd : THandle ; fpProc : LongInt ) : LongInt ;
begin
Result := SendMessage ( hwnd , WM_CAP_SET_CALLBACK_ERROR , 0 , fpProc );
end ;
function capSetCallbackOnStatus ( hwnd : THandle ; fpProc : LongInt ): LongInt ;
begin
Result := SendMessage ( hwnd , WM_CAP_SET_CALLBACK_STATUS , 0 , fpProc );
end ;
function capSetCallbackOnYield ( hwnd : THandle ; fpProc : LongInt ): LongInt ;
begin
Result := SendMessage ( hwnd , WM_CAP_SET_CALLBACK_YIELD , 0 , fpProc );
end ;
function capSetCallbackOnFrame ( hwnd : THandle ; fpProc : LongInt ): LongInt ;
begin
Result := SendMessage ( hwnd , WM_CAP_SET_CALLBACK_FRAME , 0 , fpProc );
end ;
function capSetCallbackOnVideoStream ( hwnd : THandle ; fpProc : LongInt ): LongInt ;
begin
Result := SendMessage ( hwnd , WM_CAP_SET_CALLBACK_VIDEOSTREAM , 0 , fpProc );
end ;
function capSetCallbackOnWaveStream ( hwnd : THandle ; fpProc : LongInt ): LongInt ;
begin
Result := SendMessage ( hwnd , WM_CAP_SET_CALLBACK_WAVESTREAM , 0 , fpProc );
end ;
function capSetCallbackOnCapControl ( hwnd : THandle ; fpProc : LongInt ): LongInt ;
begin
Result := SendMessage ( hwnd , WM_CAP_SET_CALLBACK_CAPCONTROL , 0 , fpProc );
end ;
function capSetUserData ( hwnd : THandle ; lUser : LongInt ): LongInt ;
begin
Result := SendMessage ( hwnd , WM_CAP_SET_USER_DATA , 0 , lUser );
end ;
function capGetUserData ( hwnd : THandle ): LongInt ;
begin
Result := SendMessage ( hwnd , WM_CAP_GET_USER_DATA , 0 , 0 );
end ;
function capDriverConnect ( hwnd : THandle ; I : Word ) : LongInt ;
begin
Result := SendMessage ( hwnd , WM_CAP_DRIVER_CONNECT , I , 0 );
end ;
function capDriverDisconnect ( hwnd : THandle ): LongInt ;
begin
Result := SendMessage ( hwnd , WM_CAP_DRIVER_DISCONNECT , 0 , 0 );
end ;
function capDriverGetName ( hwnd : THandle ; szName : LongInt ; wSize : Word ): LongInt ;
begin
Result := SendMessage ( hwnd , WM_CAP_DRIVER_GET_NAME , wSize , szName );
end ;
function capDriverGetVersion ( hwnd : THandle ; szVer : LongInt ; wSize : Word ): LongInt ;
begin
Result := SendMessage ( hwnd , WM_CAP_DRIVER_GET_VERSION , wSize , szVer );
end ;
function capDriverGetCaps ( hwnd : THandle ; s : LongInt ; wSize : Word ): LongInt ;
begin
Result := SendMessage ( hwnd , WM_CAP_DRIVER_GET_CAPS , wSize , s );
end ;
function capFileSetCaptureFile ( hwnd : THandle ; szName : LongInt ): LongInt ;
begin
Result := SendMessage ( hwnd , WM_CAP_FILE_SET_CAPTURE_FILE , 0 , szName );
end ;
function capFileGetCaptureFile ( hwnd : THandle ; szName : LongInt ; wSize : Word ): LongInt ;
begin
Result := SendMessage ( hwnd , WM_CAP_FILE_GET_CAPTURE_FILE , wSize , szName );
end ;
function capFileAlloc ( hwnd : THandle ; dwSize : LongInt ): LongInt ;
begin
Result := SendMessage ( hwnd , WM_CAP_FILE_ALLOCATE , 0 , dwSize );
end ;
function capFileSaveAs ( hwnd : THandle ; szName : LongInt ): LongInt ;
begin
Result := SendMessage ( hwnd , WM_CAP_FILE_SAVEAS , 0 , szName );
end ;
function capFileSetInfoChunk ( hwnd : THandle ; lpInfoChunk : LongInt ): LongInt ;
begin
Result := SendMessage ( hwnd , WM_CAP_FILE_SET_INFOCHUNK , 0 , lpInfoChunk );
end ;
function capFileSaveDIB ( hwnd : THandle ; szName : LongInt ): LongInt ;
begin
Result := SendMessage ( hwnd , WM_CAP_FILE_SAVEDIB , 0 , szName );
end ;
function capEditCopy ( hwnd : THandle ): LongInt ;
begin
Result := SendMessage ( hwnd , WM_CAP_EDIT_COPY , 0 , 0 );
end ;
function capSetAudioFormat ( hwnd : THandle ; s : LongInt ; wSize : Word ): LongInt ;
begin
Result := SendMessage ( hwnd , WM_CAP_SET_AUDIOFORMAT , wSize , s );
end ;
function capGetAudioFormat ( hwnd : THandle ; s : LongInt ; wSize : Word ): LongInt ;
begin
Result := SendMessage ( hwnd , WM_CAP_GET_AUDIOFORMAT , wSize , s );
end ;
function capGetAudioFormatSize ( hwnd : THandle ): LongInt ;
begin
Result := SendMessage ( hwnd , WM_CAP_GET_AUDIOFORMAT , 0 , 0 );
end ;
function capDlgVideoFormat ( hwnd : THandle ): LongInt ;
begin
Result := SendMessage ( hwnd , WM_CAP_DLG_VIDEOFORMAT , 0 , 0 );
end ;
function capDlgVideoSource ( hwnd : THandle ): LongInt ;
begin
Result := SendMessage ( hwnd , WM_CAP_DLG_VIDEOSOURCE , 0 , 0 );
end ;
function capDlgVideoDisplay ( hwnd : THandle ): LongInt ;
begin
Result := SendMessage ( hwnd , WM_CAP_DLG_VIDEODISPLAY , 0 , 0 );
end ;
function capDlgVideoCompression ( hwnd : THandle ): LongInt ;
begin
Result := SendMessage ( hwnd , WM_CAP_DLG_VIDEOCOMPRESSION , 0 , 0 );
end ;
function capGetVideoFormat ( hwnd : THandle ; s : LongInt ; wSize : Word ): LongInt ;
begin
Result := SendMessage ( hwnd , WM_CAP_GET_VIDEOFORMAT , wSize , s );
end ;
function capGetVideoFormatSize ( hwnd : THandle ): LongInt ;
begin
Result := SendMessage ( hwnd , WM_CAP_GET_VIDEOFORMAT , 0 , 0 );
end ;
function capSetVideoFormat ( hwnd : THandle ; s : LongInt ; wSize : Word ): LongInt ;
begin
Result := SendMessage ( hwnd , WM_CAP_SET_VIDEOFORMAT , wSize , s );
end ;
function capPreview ( hwnd : THandle ; f : Word ): LongInt ;
begin
Result := SendMessage ( hwnd , WM_CAP_SET_PREVIEW , f , 0 );
end ;
function capPreviewRate ( hwnd : THandle ; wMS : Word ): LongInt ;
begin
Result := SendMessage ( hwnd , WM_CAP_SET_PREVIEWRATE , wMS , 0 );
end ;
function capOverlay ( hwnd : THandle ; f : Word ): LongInt ;
begin
Result := SendMessage ( hwnd , WM_CAP_SET_OVERLAY , f , 0 );
end ;
function capPreviewScale ( hwnd : THandle ; f : Word ): LongInt ;
begin
Result := SendMessage ( hwnd , WM_CAP_SET_SCALE , f , 0 );
end ;
function capGetStatus ( hwnd : THandle ; s : LongInt ; wSize : Word ): LongInt ;
begin
Result := SendMessage ( hwnd , WM_CAP_GET_STATUS , wSize , s );
end ;
function capSetScrollPos ( hwnd : THandle ; lpP : LongInt ): LongInt ;
begin
Result := SendMessage ( hwnd , WM_CAP_SET_SCROLL , 0 , lpP );
end ;
function capGrabFrame ( hwnd : THandle ): LongInt ;
begin
Result := SendMessage ( hwnd , WM_CAP_GRAB_FRAME , 0 , 0 );
end ;
function capGrabFrameNoStop ( hwnd : THandle ): LongInt ;
begin
Result := SendMessage ( hwnd , WM_CAP_GRAB_FRAME_NOSTOP , 0 , 0 );
end ;
function capCaptureSequence ( hwnd : THandle ): LongInt ;
begin
Result := SendMessage ( hwnd , WM_CAP_SEQUENCE , 0 , 0 );
end ;
function capCaptureSequenceNoFile ( hwnd : THandle ): LongInt ;
begin
Result := SendMessage ( hwnd , WM_CAP_SEQUENCE_NOFILE , 0 , 0 );
end ;
function capCaptureStop ( hwnd : THandle ): LongInt ;
begin
Result := SendMessage ( hwnd , WM_CAP_STOP , 0 , 0 );
end ;
function capCaptureAbort ( hwnd : THandle ): LongInt ;
begin
Result := SendMessage ( hwnd , WM_CAP_ABORT , 0 , 0 );
end ;
function capCaptureSingleFrameOpen ( hwnd : THandle ): LongInt ;
begin
Result := SendMessage ( hwnd , WM_CAP_SINGLE_FRAME_OPEN , 0 , 0 );
end ;
function capCaptureSingleFrameClose ( hwnd : THandle ): LongInt ;
begin
Result := SendMessage ( hwnd , WM_CAP_SINGLE_FRAME_CLOSE , 0 , 0 );
end ;
function capCaptureSingleFrame ( hwnd : THandle ): LongInt ;
begin
Result := SendMessage ( hwnd , WM_CAP_SINGLE_FRAME , 0 , 0 );
end ;
function capCaptureGetSetup ( hwnd : THandle ; s : LongInt ; wSize : Word ): LongInt ;
begin
Result := SendMessage ( hwnd , WM_CAP_GET_SEQUENCE_SETUP , wSize , s );
end ;
function capCaptureSetSetup ( hwnd : THandle ; s : LongInt ; wSize : Word ): LongInt ;
begin
Result := SendMessage ( hwnd , WM_CAP_SET_SEQUENCE_SETUP , wSize , s );
end ;
function capSetMCIDeviceName ( hwnd : THandle ; szName : LongInt ): LongInt ;
begin
Result := SendMessage ( hwnd , WM_CAP_SET_MCI_DEVICE , 0 , szName );
end ;
function capGetMCIDeviceName ( hwnd : THandle ; szName : LongInt ; wSize : Word ): LongInt ;
begin
Result := SendMessage ( hwnd , WM_CAP_GET_MCI_DEVICE , wSize , szName );
end ;
function capPaletteOpen ( hwnd : THandle ; szName : LongInt ): LongInt ;
begin
Result := SendMessage ( hwnd , WM_CAP_PAL_OPEN , 0 , szName );
end ;
function capPaletteSave ( hwnd : THandle ; szName : LongInt ): LongInt ;
begin
Result := SendMessage ( hwnd , WM_CAP_PAL_SAVE , 0 , szName );
end ;
function capPalettePaste ( hwnd : THandle ): LongInt ;
begin
Result := SendMessage ( hwnd , WM_CAP_PAL_PASTE , 0 , 0 );
end ;
function capPaletteAuto ( hwnd : THandle ; iFrames : Word ; iColors : LongInt ): LongInt ;
begin
Result := SendMessage ( hwnd , WM_CAP_PAL_AUTOCREATE , iFrames , iColors );
end ;
function capPaletteManual ( hwnd : THandle ; fGrab : Word ; iColors : LongInt ): LongInt ;
begin
Result := SendMessage ( hwnd , WM_CAP_PAL_MANUALCREATE , fGrab , iColors );
end ;
end .
******** videocap ************
unit VideoCap ;
interface
uses Windows , Dialogs , Controls , SysUtils , StdCtrls , MMSystem , AviCap ;
const
MAXVIDDRIVERS = 10 ;
MS_FOR_15FPS = 66 ;
MS_FOR_20FPS = 50 ;
MS_FOR_30FPS = 33 ;
MS_FOR_25FPS = 40 ; // rate in msec
type
TCapStatusProc = procedure ( Sender : TObject ) of object ;
var
ghCapWnd : THandle ;
gCapVideoArea : TWinControl ;
gCapVideoDriverName : string ;
gdwCapNofMaxVideoFrame : DWord ;
gCapVideoFileName : string ;
gCapSingleImageFileName : string ;
gCapVideoInfoLabel : TLabel ;
gCapStatusProcedure : TCapStatusProc ;
procedure CapSetVideoArea ( Container : TWinControl );
procedure CapSetVideoFileName ( FileName : string );
procedure CapSetSingleImageFileName ( FileName : string );
procedure CapSetInfoLabel ( InfoLabel : TLabel );
procedure CapSetStatusProcedure ( StatusProc : TCapStatusProc );
function CapOpenDriver : Boolean ;
function CapInitDriver ( Index : Integer ): Boolean ;
procedure CapCloseDriver ;
procedure CapShow ;
procedure CapSetCapSec ( NofMaxVideoFrame : Integer );
procedure CapStart ;
procedure CapStop ;
function CapHasDlgVFormat : Boolean ;
function CapHasDlgVDisplay : Boolean ;
function CapHasDlgVSource : Boolean ;
procedure CapDlgVFormat ;
procedure CapDlgVDisplay ;
procedure CapDlgVSource ;
procedure CapSetVideoOverlay ;
procedure CapSetVideoLive ;
procedure CapGrabSingleFrame ;
implementation
(*---------------------------------------------------------------*)
(*--- C A P - V I D E O D R I V E R ---*)
(*---------------------------------------------------------------*)
(*---------------------------------------------------------------*)
procedure CapSetVideoArea ( Container : TWinControl );
begin
gCapVideoArea := Container ;
end ;
(*---------------------------------------------------------------*)
procedure CapSetVideoFileName ( FileName : string );
begin
gCapVideoFileName := FileName ;
end ;
(*---------------------------------------------------------------*)
procedure CapSetSingleImageFileName ( FileName : string );
begin
gCapSingleImageFileName := FileName ;
end ;
(*---------------------------------------------------------------*)
procedure CapSetInfoLabel ( InfoLabel : TLabel );
begin
gCapVideoInfoLabel := InfoLabel ;
end ;
(*---------------------------------------------------------------*)
procedure CapSetStatusProcedure ( StatusProc : TCapStatusProc );
begin
gCapStatusProcedure := StatusProc ;
end ;
(*---------------------------------------------------------------*)
(* -- Video For Windows Status Callback Function --- *)
(*---------------------------------------------------------------*)
function StatusCallbackProc ( hWnd : HWND ; nID : Integer ; lpsz : LongInt ): LongInt ; stdcall ;
var
TmpStr : string ;
dwVideoNum : Integer ;
begin
// hWnd: Application main window handle
// nID: Status code for the current status
// lpStatusText: Status text string for the current status
TmpStr := StrPas ( PChar ( lpsz ));
gCapVideoInfoLabel. Caption := TmpStr ;
gCapVideoInfoLabel. Refresh ;
if nID = IDS_CAP_STAT_VIDEOCURRENT then
begin
dwVideoNum := StrToInt ( Copy ( TmpStr , 0 , Pos ( ' ' , TmpStr )- 1 ));
if dwVideoNum >= gdwCapNofMaxVideoFrame then
begin
capCaptureAbort( ghCapWnd );
if @ gCapStatusProcedure <> nil then gCapStatusProcedure ( nil );
end ;
end ;
Result := 1 ;
end ;
(*---------------------------------------------------------------*)
function CapOpenDriver : Boolean ;
var
Retc : LongInt ;
DriverIndex : Integer ;
DriverStarted : boolean ;
achDeviceName : array [ 0 .. 80 ] of Char ;
achDeviceVersion : array [ 0 .. 100 ] of Char ;
achFileName : array [ 0 .. 255 ] of Char ;
begin
Result := FALSE ;
if gCapVideoArea = nil then exit ;
Result := TRUE ;
// Create the Video Capture Window
ghCapWnd := capCreateCaptureWindow ( PChar ( 'KruwoSoft' ),
WS_CHILD or WS_VISIBLE , 0 , 0 ,
gCapVideoArea . Width , gCapVideoArea . Height ,
gCapVideoArea . Handle , 0 );
if ghCapWnd <> 0 then
begin
// Install Status-Callback-Function
retc := capSetCallbackOnStatus ( ghCapWnd , LongInt ( 0 ));
if retc <> 0 then
begin
retc := capSetCallbackOnStatus ( ghCapWnd , LongInt (@ StatusCallbackProc ));
if retc <> 0 then
begin
// Open Installed Video Driver
DriverIndex := 0 ;
repeat
DriverStarted := CapInitDriver ( DriverIndex );
if NOT DriverStarted then DriverIndex := DriverIndex + 1 ;
until ( DriverStarted = TRUE ) OR ( DriverIndex >= MAXVIDDRIVERS );
// Keep Name of Video Driver
if capGetDriverDescription ( DriverIndex ,
achDeviceName , 80 ,
achDeviceVersion, 100 ) then
begin
gCapVideoDriverName := string ( achDeviceName );
end ;
// Set Capture FileName
StrPCopy( achFileName , gCapVideoFileName );
retc := capFileSetCaptureFile ( ghCapWnd , LongInt (@ achFileName ));
if retc = 0 then
begin
showmessage( gCapVideoDriverName + ': Error in capFileSetCaptureFile' );
end ;
exit ;
end ;
end ;
end ;
Result := FALSE ;
CapCloseDriver;
ghCapWnd := 0 ;
end ;
(*---------------------------------------------------------------*)
function CapInitDriver ( Index : Integer ): Boolean ;
var
Retc : LongInt ;
CapParms : TCAPTUREPARMS ;
begin
Result := FALSE ;
if ghCapWnd = 0 then exit ;
// Connect to Video Capture Driver
if capDriverConnect ( ghCapWnd , Index ) <> 0 then
begin
retc := capCaptureGetSetup ( ghCapWnd , LongInt (@ CapParms ), sizeof ( TCAPTUREPARMS ));
if retc <> 0 then
begin
// CapParms.dwRequestMicroSecPerFrame := 40000; // 25 FPS Requested capture rate
// CapParms.dwRequestMicroSecPerFrame := 100000; // 10 FPS Requested capture rate
CapParms. dwRequestMicroSecPerFrame := 66667 ; // 15 FPS Requested capture rate
CapParms. fLimitEnabled := FALSE ;
CapParms. fCaptureAudio := FALSE ; // NO Audio
CapParms. fMCIControl := FALSE ;
CapParms. fYield := TRUE ;
CapParms. vKeyAbort := VK_ESCAPE ;
CapParms. fAbortLeftMouse := FALSE ;
CapParms. fAbortRightMouse := FALSE ;
retc := capCaptureSetSetup ( ghCapWnd , LongInt (@ CapParms ), sizeof ( TCAPTUREPARMS ));
if retc = 0 then exit ;
end ;
Result := TRUE ;
end ;
end ;
(*---------------------------------------------------------------*)
procedure CapCloseDriver ;
begin
if ghCapWnd <> 0 then
begin
capSetCallbackOnStatus( ghCapWnd , LongInt ( 0 ));
capDriverDisconnect( ghCapWnd );
DestroyWindow( ghCapWnd ) ;
ghCapWnd := 0 ;
end ;
end ;
(*---------------------------------------------------------------*)
procedure CapShow ;
begin
if ghCapWnd = 0 then exit ;
// Start Video overlay by default
capPreviewScale( ghCapWnd , 1 );
capPreviewRate ( ghCapWnd , MS_FOR_25FPS );
capOverlay( ghCapWnd , 0 );
capPreview( ghCapWnd , 1 );
end ;
(*---------------------------------------------------------------*)
procedure CapSetCapSec ( NofMaxVideoFrame : Integer );
begin
gdwCapNofMaxVideoFrame := DWord ( NofMaxVideoFrame );
end ;
(*---------------------------------------------------------------*)
procedure CapStart ;
begin
if ghCapWnd = 0 then exit ;
// Start video capture to file
capCaptureSequence( ghCapWnd );
end ;
(*---------------------------------------------------------------*)
procedure CapStop ;
begin
if ghCapWnd = 0 then exit ;
// Stop video capture to file
capCaptureAbort( ghCapWnd );
end ;
(*---------------------------------------------------------------*)
function CapHasDlgVFormat : Boolean ;
var
CDrvCaps : TCapDriverCaps ;
begin
Result := TRUE ;
if ghCapWnd = 0 then exit ;
capDriverGetCaps( ghCapWnd , LongInt (@ CDrvCaps ), sizeof ( TCapDriverCaps ));
Result := CDrvCaps . fHasDlgVideoFormat ;
end ;
(*---------------------------------------------------------------*)
function CapHasDlgVDisplay : Boolean ;
var
CDrvCaps : TCapDriverCaps ;
begin
Result := TRUE ;
if ghCapWnd = 0 then exit ;
capDriverGetCaps( ghCapWnd , LongInt (@ CDrvCaps ), sizeof ( TCapDriverCaps ));
Result := CDrvCaps . fHasDlgVideoDisplay ;
end ;
(*---------------------------------------------------------------*)
function CapHasDlgVSource : Boolean ;
var
CDrvCaps : TCapDriverCaps ;
begin
Result := TRUE ;
if ghCapWnd = 0 then exit ;
capDriverGetCaps( ghCapWnd , LongInt (@ CDrvCaps ), sizeof ( TCapDriverCaps ));
Result := CDrvCaps . fHasDlgVideoSource ;
end ;
(*---------------------------------------------------------------*)
procedure CapDlgVFormat ;
begin
if ghCapWnd = 0 then exit ;
capDlgVideoFormat( ghCapWnd );
end ;
(*---------------------------------------------------------------*)
procedure CapDlgVDisplay ;
begin
if ghCapWnd = 0 then exit ;
capDlgVideoDisplay( ghCapWnd );
end ;
(*---------------------------------------------------------------*)
procedure CapDlgVSource ;
begin
if ghCapWnd = 0 then exit ;
capDlgVideoSource( ghCapWnd );
end ;
(*---------------------------------------------------------------*)
procedure CapSetVideoOverlay ;
begin
if ghCapWnd = 0 then exit ;
capPreview( ghCapWnd , 0 );
capOverlay( ghCapWnd , 1 );
end ;
(*---------------------------------------------------------------*)
procedure CapSetVideoLive ;
begin
if ghCapWnd = 0 then exit ;
capOverlay( ghCapWnd , 0 );
capPreviewScale( ghCapWnd , 1 );
capPreviewRate ( ghCapWnd , MS_FOR_25FPS );
capPreview( ghCapWnd , 1 );
end ;
(*---------------------------------------------------------------*)
procedure CapGrabSingleFrame ;
var
achSingleFileName : array [ 0 .. 255 ] of Char ;
begin
if ghCapWnd = 0 then exit ;
capGrabFrame( ghCapWnd );
StrPCopy( achSingleFileName , gCapSingleImageFileName );
capFileSaveDIB( ghCapWnd , LongInt (@ achSingleFileName ));
end ;
initialization
ghCapWnd := 0 ;
gCapVideoArea := nil ;
gCapVideoDriverName := 'No Driver' ;
gdwCapNofMaxVideoFrame := 0 ;
gCapVideoFileName := 'Video.avi' ;
gCapSingleImageFileName := 'Image.bmp' ;
gCapVideoInfoLabel := nil ;
gCapStatusProcedure := nil ;
end .
********** wvideo *****************
unit WVideo ;
interface
uses
Windows , Messages , SysUtils , Classes , Graphics , Controls , Forms ,
Dialogs , StdCtrls , ExtCtrls , Grids , Buttons , ComCtrls ,
VideoCap , VideoMci , MMSystem , jpeg ;
const
VIDEO_FILE_NAME = 'VIDEO.AVI' ;
type
TVideo = class ( TForm )
Label5 : TLabel ;
Label1 : TLabel ;
Label3 : TLabel ;
Label4 : TLabel ;
Label6 : TLabel ;
VideoLabel : TLabel ;
Panel1 : TPanel ;
VideoArea : TPanel ;
Image1 : TImage ;
CancelBtn : TBitBtn ;
StartVideoBtn : TBitBtn ;
StopVideoBtn : TBitBtn ;
Edit1 : TEdit ;
UpDown1 : TUpDown ;
SingleImageBtn : TBitBtn ;
StartDspBtn : TBitBtn ;
StopDspBtn : TBitBtn ;
VideoFormatBtn : TBitBtn ;
VideoDisplayBtn : TBitBtn ;
VideoSourceBtn : TBitBtn ;
VideoTBar : TTrackBar ;
StoreVideoFrameBBtn : TBitBtn ;
CapRBtn : TRadioButton ;
MciRBtn : TRadioButton ;
LoopCBox : TCheckBox ;
Label2 : TLabel ;
Label7 : TLabel ;
procedure CancelBtnClick ( Sender : TObject );
procedure StartVideoBtnClick ( Sender : TObject );
procedure StopVideoBtnClick ( Sender : TObject );
procedure VideoSourceBtnClick ( Sender : TObject );
procedure VideoDisplayBtnClick ( Sender : TObject );
procedure SingleImageBtnClick ( Sender : TObject );
procedure VideoFormatBtnClick ( Sender : TObject );
procedure CapRBtnClick ( Sender : TObject );
procedure MciRBtnClick ( Sender : TObject );
procedure StartDspBtnClick ( Sender : TObject );
procedure StopDspBtnClick ( Sender : TObject );
procedure CapStatus ( Sender : TObject );
procedure StoreVideoFrameBBtnClick ( Sender : TObject );
procedure VideoTBarChange ( Sender : TObject );
procedure MciStatus ( Sender : TObject );
procedure FormShow ( Sender : TObject );
private
{ Private declarations }
procedure MciNotify ( var Msg : TMessage ); message MM_MCINOTIFY ;
public
{ Public declarations }
end ;
var
Video : TVideo ;
implementation
{$R *.DFM}
(*---------------------------------------------------------------*)
procedure TVideo . CapRBtnClick ( Sender : TObject );
var
MyCapStatusProc : TCapStatusProc ;
begin
// Stop MCI - Video
MciClose;
// Start CAP - Video
CapSetVideoArea( VideoArea );
CapSetInfoLabel ( VideoLabel );
MyCapStatusProc := CAPStatus ;
CapSetStatusProcedure( MyCapStatusProc );
if CapOpenDriver then
begin
CapSetCapSec( 15 * 3 );
CapShow;
if NOT CapHasDlgVSource then VideoSourceBtn . Enabled := FALSE ;
if NOT CapHasDlgVDisplay then VideoDisplayBtn . Enabled := FALSE ;
if NOT CapHasDlgVFormat then VideoFormatBtn . Enabled := FALSE ;
end ;
end ;
(*----------------------------------------------------------------------*)
(* -- Button: C A N C E L ----------------------------------------------*)
(*----------------------------------------------------------------------*)
procedure TVideo . CancelBtnClick ( Sender : TObject );
begin
// Close CAP - Video
CapCloseDriver;
// Stop MCI - Video
MciClose;;
end ;
(*---------------------------------------------------------------*)
procedure TVideo . CAPStatus ( Sender : TObject );
begin
Panel1. Color := clBtnFace ;
Panel1. Refresh ;
StopVideoBtn. Enabled := FALSE ;
StartVideoBtn. Enabled := TRUE ;
end ;
(*---------------------------------------------------------------*)
procedure TVideo . StartVideoBtnClick ( Sender : TObject );
begin
Panel1. Color := clRed ;
Panel1 . Refresh ;
StopVideoBtn. Enabled := TRUE ;
StartVideoBtn. Enabled := FALSE ;
CapSetCapSec( StrToInt ( Edit1 . Text )* 15 );
CapStart ;
end ;
(*---------------------------------------------------------------*)
procedure TVideo . StopVideoBtnClick ( Sender : TObject );
begin
CapStop;
Panel1. Color := clBtnFace ;
Panel1. Refresh ;
StopVideoBtn. Enabled := FALSE ;
StartVideoBtn. Enabled := TRUE ;
end ;
(*---------------------------------------------------------------*)
procedure TVideo . VideoSourceBtnClick ( Sender : TObject );
begin
CapDlgVSource;
end ;
(*---------------------------------------------------------------*)
procedure TVideo . VideoDisplayBtnClick ( Sender : TObject );
begin
CapDlgVDisplay;
end ;
(*---------------------------------------------------------------*)
procedure TVideo . VideoFormatBtnClick ( Sender : TObject );
begin
CapDlgVFormat;
end ;
(*---------------------------------------------------------------*)
procedure TVideo . SingleImageBtnClick ( Sender : TObject );
var
SingleImageFileName : string ;
var
bmp : TImage ;
jpg : TJpegImage ;
begin
// Save Video as Bitmap to file in TEMP-Path
SingleImageFileName := 'Image1.bmp' ;
CapSetSingleImageFileName ( SingleImageFileName );
CapGrabSingleFrame;
CapSetVideoLive;
bmp := TImage . Create ( nil );
jpg := TJpegImage . Create ;
bmp . picture . bitmap . LoadFromFile ( SingleImageFileName );
jpg . Assign ( bmp . picture . bitmap );
jpg . SaveToFile ( 'c:picture.jpg' );
jpg . Free ;
bmp . Free ;
end ;
(*---------------------------------------------------------------*)
(*--- M C I - FUNCTIONS ---*)
(*---------------------------------------------------------------*)
procedure TVideo . MciRBtnClick ( Sender : TObject );
var
NoOfFrames : Integer ;
MyMciStatusProc : TMciStatusProc ;
begin
// Close CAP - Video
CapCloseDriver;
// Start MCI - Video
MciSetVideoArea( VideoArea );
MciSetVideoFileName( 'VIDEO.AVI' );
MciSetVideoHandle( Video . Handle );
NoOfFrames := MciGetNoOfFrames ;
if NoOfFrames > 0 then
begin
VideoTBar . Visible := TRUE ;
VideoTBar. Max := 99 ;
VideoTBar . Min := 0 ;
VideoTBar . Max := NoOfFrames - 1 ;
VideoTBar . Position := 0 ;
end
else
begin
StoreVideoFrameBBtn. Enabled := FALSE ;
VideoTBar. Enabled := FALSE ;
end ;
MyMciStatusProc := MciStatus ;
MciSetStatusProcedure( MyMciStatusProc );
MciOpen;
end ;
(*---------------------------------------------------------------*)
procedure TVideo . StartDspBtnClick ( Sender : TObject );
begin
StopDspBtn. Enabled := TRUE ;
StartDspBtn. Enabled := FALSE ;
VideoTBar. Enabled := FALSE ;
StoreVideoFrameBBtn. Enabled := FALSE ;
if VideoTBar . Position >= VideoTBar . Max then
VideoTBar. Position := 0 ;
MciPlay( VideoTBar . Position );
end ;
(*---------------------------------------------------------------*)
procedure TVideo . StopDspBtnClick ( Sender : TObject );
begin
LoopCBox. Checked := FALSE ;
MciStop;
StopDspBtn. Enabled := FALSE ;
StartDspBtn. Enabled := TRUE ;
VideoTBar. Enabled := TRUE ;
StoreVideoFrameBBtn . Enabled := TRUE ;
// Get actual Frame Position
VideoTBar. Position := MciGetPos ;
VideoTBar. Refresh ;
end ;
(*---------------------------------------------------------------*)
procedure TVideo . StoreVideoFrameBBtnClick ( Sender : TObject );
var
TmpBmp : TBitmap ;
begin
TmpBmp := TBitmap . Create ;
// Get actual Image as BMP
if MciFrameToBmp ( TmpBmp ) then
begin
// Save Bitmap to file
TmpBmp. SaveToFile ( 'Image2.bmp' );
end ;
TmpBmp . free ;
end ;
(*---------------------------------------------------------------*)
procedure TVideo . VideoTBarChange ( Sender : TObject );
begin
MciSeek ( VideoTBar . Position );
end ;
(*---------------------------------------------------------------*)
procedure TVideo . MciNotify ( var Msg : TMessage );
begin
MciStatus( nil );
Msg . Result := 0 ;
end ;
(*---------------------------------------------------------------*)
procedure TVideo . MciStatus ( Sender : TObject );
var
ActPos : Integer ;
begin
StopDspBtn. Enabled := FALSE ;
StartDspBtn. Enabled := TRUE ;
VideoTBar. Enabled := TRUE ;
StoreVideoFrameBBtn. Enabled := TRUE ;
// Get actual Frame Position
ActPos := MciGetPos ;
if ActPos >= VideoTBar . Max
then VideoTBar . Position := 0
else VideoTBar . Position := ActPos ;
VideoTBar. Refresh ;
if LoopCBox . Checked then
StartDspBtnClick( Sender );
end ;
(*---------------------------------------------------------------*)
procedure TVideo . FormShow ( Sender : TObject );
begin
MciRBtn . Checked := FALSE ;
CapRBtn . Checked := FALSE ;
end ;
end .
********* send thread ****************
unit u_sendthread ;
interface
uses
Windows , ComCtrls , Classes , SysUtils , WinSock , u_formMain ;
type
SendThread = class ( TThread )
private
FilePath , FileName , FErrorMsg : string ;
FileStream : TFileStream ;
ListItem : TListItem ;
function GetFileSize ( const Bytes : integer ): string ;
function OpenFile : Boolean ;
function SendBuf ( s : TSocket ; var Buf ; const BufSize : integer ): Boolean ;
function SendFile : Boolean ;
function SendStream ( const ASocket : TSocket ): Boolean ;
procedure OnThreadTerminate ( Sender : TObject );
procedure ShowMsg ( const ErrorMsg : string ); overload ;
procedure ShowMsg ; overload ;
procedure UpdateListItem ;
protected
procedure Execute ; override ;
public
constructor Create ( const AFilePath : string );
end ;
implementation
constructor SendThread . Create ( const AFilePath : string );
begin
inherited Create ( False );
OnTerminate := OnThreadTerminate ;
FreeOnTerminate := True ;
Priority := tpLower ;
FilePath := AFilePath ;
FileName := ExtractFileName ( FilePath );
end ;
procedure SendThread . Execute ;
begin
ShowMsg ( Format ( '"%s" dosyası açılıyor...' , [ FileName ]));
if not ( OpenFile ) then
begin
ShowMsg ( Format ( 'Hata: "%s" dosyası açılamadı' , [ FileName ]));
Exit ;
end ;
if SendFile then
ShowMsg ( Format ( '%s adresine "%s" dosyası gönderildi' , [ IP , FileName ]));
end ;
function SendThread . GetFileSize ( const Bytes : integer ): string ;
const
BytesPerKb = 1024 ;
BytesPerMb = BytesPerKb * 1024 ;
BytesPerGb = BytesPerMb * 1024 ;
begin
if Bytes > BytesPerGb then
Result := FormatFloat ( '0.00 GB' , Bytes / BytesPerGb )
else
if Bytes > BytesPerMb then
Result := FormatFloat ( '0.00 MB' , Bytes / BytesPerMb )
else
if Bytes > BytesPerKb then
Result := FormatFloat ( '0.00 KB' , Bytes / BytesPerKb )
else
Result := Format ( '%d bayt' , [ Bytes ]);
end ;
function SendThread . OpenFile : Boolean ;
begin
try
FileStream := TFileStream . Create ( FilePath , fmOpenRead , fmShareDenyNone );
Result := True ;
except
Result := False ;
end ;
end ;
function SendThread . SendBuf ( s : TSocket ; var Buf ;
const BufSize : integer ): Boolean ;
begin
Result := Send ( s , Buf , BufSize , 0 ) = BufSize ;
if not Result then
begin
ShowMsg ( Format ( '%s adresine "%s" gönderilirken socket hatası oluştu. Hata kodu: %d' ,
[IP , FileName , WSAGetLastError ]));
Exit ;
end ;
end ;
function SendThread . SendFile : Boolean ;
var
s : TSocket ;
SockAddr : TSockAddrIn ;
FileHeader : string ;
begin
Result := False ;
s := Socket ( AF_INET , SOCK_STREAM , IPPROTO_TCP );
if s = INVALID_SOCKET then
begin
ShowMsg ( 'Hata: Socket oluşturulamadı' );
Exit ;
end ;
try
SockAddr . sin_family := AF_INET ;
SockAddr . sin_port := htons ( Port );
SockAddr . sin_addr . S_addr := inet_Addr ( PChar ( IP ));
ShowMsg ( Format ( '%s adresine %d. port üzerinden bağlanıyor...' ,
[IP , Port ]));
if Connect ( s , SockAddr , Sizeof ( SockAddr )) <> 0 then
begin
ShowMsg ( Format ( 'Hata: %s adresine %d. port üzerinden bağlanılamadı' ,
[IP , Port ]));
Exit ;
end ;
ShowMsg ( Format ( '%s adresine "%s" dosyası gönderiliyor...' , [ IP , FileName ]));
FileHeader := Format ( '%s %d %s' , [ Version , FileStream . Size , FileName ]) + #0 ;
if not SendBuf ( s , FileHeader [ 1 ], Length ( FileHeader )) then
Exit ;
if not SendStream ( s ) then
Exit ;
Result := True ;
finally
CloseSocket ( s );
end ;
end ;
function SendThread . SendStream ( const ASocket : TSocket ): Boolean ;
var
Buf : array [ 0 .. 8191 ] of Char ;
ReadSize : integer ;
begin
Result := False ;
FileStream . Seek ( 0 , soFromBeginning );
while FileStream . Position < FileStream . Size do
begin
ReadSize := FileStream . Read ( Buf , Sizeof ( Buf ));
Result := SendBuf ( ASocket , Buf , ReadSize );
Synchronize ( UpdateListItem );
end ;
end ;
procedure SendThread . OnThreadTerminate ( Sender : TObject );
begin
if Assigned ( FileStream ) then FileStream . Free ;
if Assigned ( ListItem ) then ListItem . Free ;
end ;
procedure SendThread . ShowMsg ( const ErrorMsg : string );
begin
FErrorMsg := ErrorMsg ;
Synchronize ( ShowMsg );
end ;
procedure SendThread . ShowMsg ;
begin
MainForm . Status := FErrorMsg ;
end ;
procedure SendThread . UpdateListItem ;
var
Percent : Extended ;
begin
if not Assigned ( ListItem ) then
begin
ListItem := MainForm . ListView1 . Items . Add ;
ListItem . Caption := FileName ;
ListItem . SubItems . Add ( GetFileSize ( FileStream . Size ));
ListItem . SubItems . Add ( '0' );
ListItem . SubItems . Add ( '0%' );
end ;
ListItem . SubItems . Strings [ 1 ] := GetFileSize ( FileStream . Position );
Percent := FileStream . Position / FileStream . Size * 100 ;
ListItem . SubItems . Strings [ 2 ] := FormatFloat ( '0.00%' , Percent );
end ;
end .
********** videoMci **************
unit VideoMci ;
interface
uses Windows , SysUtils , Graphics , Controls , MMSystem , VfW ;
type
TMciStatusProc = procedure ( Sender : TObject ) of object ;
var
gMciVideoArea : TWinControl ;
gMciVideoFileName : string ;
gMciActive : boolean ;
gMciStatusProcedure : TMciStatusProc ;
gMciVideoHandle : THandle ;
procedure MciSetVideoArea ( Container : TWinControl );
procedure MciSetVideoFileName ( FileName : string );
procedure MciSetStatusProcedure ( StatusProc : TMciStatusProc );
procedure MciSetVideoHandle ( hVideo : THandle );
procedure MciVideoCommand ( TheCommand : string );
function MciReturnVideoCommand ( TheCommand : string ) : string ;
procedure MciOpen ;
procedure MciClose ;
procedure MciStart ;
procedure MciStop ;
procedure MciSeek ( Position : Integer );
function MciGetPos : Integer ;
procedure MciPlay ( FromPos : Integer );
function MciGetNoOfFrames : Integer ;
function MciFrameToBmp ( TmpBmp : TBitmap ) : Boolean ;
procedure MciNotify ;
implementation
(*---------------------------------------------------------------*)
(*--- M C I - V I D E O D R I V E R ---*)
(*---------------------------------------------------------------*)
uses WVideo ;
(*---------------------------------------------------------------*)
procedure MciSetVideoArea ( Container : TWinControl );
begin
gMciVideoArea := Container ;
end ;
(*---------------------------------------------------------------*)
procedure MciSetVideoFileName ( FileName : string );
begin
gMciVideoFileName := FileName ;
end ;
(*---------------------------------------------------------------*)
procedure MciSetStatusProcedure ( StatusProc : TMciStatusProc );
begin
gMciStatusProcedure := StatusProc ;
end ;
(*---------------------------------------------------------------*)
procedure MciSetVideoHandle ( hVideo : THandle );
begin
gMciVideoHandle := hVideo ;
end ;
(*---------------------------------------------------------------*)
procedure MciVideoCommand ( TheCommand : string );
var
FError : LongInt ;
ReturnStr : array [ 0 .. 255 ] of Char ;
// ErrorStr : array [0..127] of Char;
begin
FError := mciSendString ( PChar ( TheCommand ), ReturnStr , 255 , gMciVideoHandle );
if FError <> 0 then
begin
gMciActive := FALSE ;
(*
mciGetErrorString( FError, ErrorStr, 127 );
Showmessage(' Command : '+ TheCommand + #13 +
' Error : '+ string(ErrorStr) );
*)
end ;
end ;
(*---------------------------------------------------------------*)
function MciReturnVideoCommand ( TheCommand : string ) : string ;
var
FError : LongInt ;
ReturnStr : array [ 0 .. 255 ] of Char ;
// ErrorStr : array [0..127] of Char;
begin
FError := mciSendString ( PChar ( TheCommand ), ReturnStr , 255 , gMciVideoHandle );
if FError <> 0 then
begin
gMciActive := FALSE ;
(*
mciGetErrorString( FError, ErrorStr, 127 );
Showmessage(' Command : '+ TheCommand + #13 +
' Error : '+ string(ErrorStr) );
*)
end ;
Result := StrPas ( ReturnStr );
end ;
(*---------------------------------------------------------------*)
procedure MciNotify ;
begin
if @ gMciStatusProcedure <> nil then gMciStatusProcedure ( nil );
// PostMessage( gdwAppHwnd, Mci_REV_MSG_Status, 0, LongInt(50) );
end ;
(*---------------------------------------------------------------*)
procedure MciOpen ;
begin
gMciActive := TRUE ;
if gMciActive then MciVideoCommand ( 'open '
+ gMciVideoFileName + ' alias KruwoVideo style child parent '
+ IntToStr ( gMciVideoArea . Handle ) + ' wait' );
if gMciActive then MciVideoCommand ( 'put KruwoVideo window at '
+ IntToStr ( gMciVideoArea . Left - 5 ) + ' '
+ IntToStr ( gMciVideoArea . Top - 5 ) + ' '
+ IntToStr ( gMciVideoArea . Width ) + ' '
+ IntToStr ( gMciVideoArea . Height ) + ' wait' );
if gMciActive then MciVideoCommand ( 'set KruwoVideo seek exactly off wait' );
end ;
(*---------------------------------------------------------------*)
procedure MciClose ;
begin
if gMciActive then MciVideoCommand ( 'close KruwoVideo wait' );
end ;
(*---------------------------------------------------------------*)
procedure MciStart ;
begin
if gMciActive then MciVideoCommand ( 'play KruwoVideo from 0 notify' );
end ;
(*---------------------------------------------------------------*)
procedure MciStop ;
begin
if gMciActive then MciVideoCommand ( 'stop KruwoVideo wait' );
end ;
(*---------------------------------------------------------------*)
procedure MciSeek ( Position : Integer );
begin
if gMciActive then MciVideoCommand ( 'seek KruwoVideo to ' + IntToStr ( Position )+ ' wait' );
end ;
(*---------------------------------------------------------------*)
function MciGetPos : Integer ;
var
PosStr : string ;
begin
PosStr := MciReturnVideoCommand ( 'status KruwoVideo position wait' );
if Length ( PosStr ) <= 0
then Result := 0
else Result := LongInt ( StrToInt ( PosStr ));
end ;
(*---------------------------------------------------------------*)
procedure MciPlay ( FromPos : Integer );
begin
if gMciActive then MciVideoCommand ( 'play KruwoVideo from '
+ IntToStr ( FromPos ) + ' notify' );
end ;
(*---------------------------------------------------------------*)
function MciGetNoOfFrames : Integer ;
var
retc : Integer ;
pfile : PAVIFile ;
gapavi : PAVIStream ; // the current stream
asi : TAVIStreamInfo ;
begin
Result := - 1 ;
// Open and Save Video
AVIFileInit;
retc := AVIFileOpen ( pfile , PChar ( gMciVideoFileName ), 0 , nil );
if retc <> 0 then
begin
AVIFileExit;
exit;
end ;
retc := AVIFileGetStream ( pfile , gapavi , 0 , 0 );
if retc <> AVIERR_OK then
begin
AVIFileRelease( pfile );
AVIFileExit;
exit;
end ;
// Get some info about this stream
retc := AVIStreamInfo ( gapavi , asi , sizeof ( asi ));
if retc <> AVIERR_OK then
begin
AVIStreamRelease( gapavi );
AVIFileRelease( pfile );
AVIFileExit;
exit;
end ;
if asi . fccType <> streamtypeVIDEO
then Result := - 1
else Result := asi . dwLength ;
AVIStreamRelease ( gapavi );
AVIFileRelease ( pfile );
AVIFileExit;
end ;
(*---------------------------------------------------------------*)
function MciFrameToBmp ( TmpBmp : TBitmap ) : Boolean ;
var
CurrentPos : Integer ;
retc : Integer ;
pfile : PAVIFile ;
gapavi : PAVIStream ; // the current stream
gapgf : PGETFRAME ; // data for decompressing video
lpbi : PBITMAPINFOHEADER ;
bits : PChar ;
hBmp : HBITMAP ;
begin
Result := FALSE ;
CurrentPos := MciGetPos ;
// Open and Save Video
AVIFileInit;
retc := AVIFileOpen ( pfile , PChar ( gMciVideoFileName ), 0 , nil );
if retc <> 0 then
begin
AVIFileExit;
exit;
end ;
retc := AVIFileGetStream ( pfile , gapavi , 0 , 0 );
if retc <> AVIERR_OK then
begin
AVIFileRelease( pfile );
AVIFileExit;
exit;
end ;
gapgf := AVIStreamGetFrameOpen ( gapavi , nil );
if gapgf = nil then
begin
AVIStreamRelease( gapavi );
AVIFileRelease( pfile );
AVIFileExit;
exit;
end ;
// Read current Frame
lpbi := AVIStreamGetFrame ( gapgf , CurrentPos );
if lpbi = nil then
begin
AVIStreamGetFrameClose( gapgf );
AVIStreamRelease( gapavi );
AVIFileRelease( pfile );
AVIFileExit;
exit;
end ;
TmpBmp. Height := lpbi . biHeight ;
TmpBmp . Width := lpbi . biWidth ;
bits := Pointer ( Integer ( lpbi ) + sizeof ( TBITMAPINFOHEADER ));
hBmp := CreateDIBitmap (
GetDC ( gMciVideoArea . Handle ), // handle of device context
lpbi^, // address of bitmap size and format data
CBM_INIT, // initialization flag
bits, // address of initialization data
PBITMAPINFO( lpbi )^, // address of bitmap color-format data
DIB_RGB_COLORS ); // color-data usage
TmpBmp . Handle := hBmp ;
Result := TRUE ;
AVIStreamGetFrameClose( gapgf );
AVIStreamRelease ( gapavi );
AVIFileRelease ( pfile );
AVIFileExit;
end ;
initialization
gMciVideoFileName := 'Video.avi' ;
gMciActive := FALSE ;
gMciStatusProcedure := nil ;
end .
