Programlama yapalım ve Öğrenelim.

neoturk: Forum - "web cam kullanımı"

******** 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;

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;

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;

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;

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;

(*---------------------------------------------------------------*)

procedure CapCloseDriver;

begin

if ghCapWnd <> 0 then

begin

capSetCallbackOnStatus(ghCapWnd, LongInt(0));

capDriverDisconnect( ghCapWnd );

DestroyWindow( ghCapWnd ) ;

ghCapWnd := 0;

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;

(*----------------------------------------------------------------------*)

(* -- 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;

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;

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;

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;

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;

(*---------------------------------------------------------------*)

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;
end.