├── AviFileHandler.pas ├── ClientDM.dfm ├── ClientDM.pas ├── ClientU.dfm ├── ClientU.pas ├── CommonU.pas ├── Defines.inc ├── DisplayU.dfm ├── DisplayU.pas ├── Preview.dfm ├── Preview.pas ├── SettingsU.dfm ├── SettingsU.pas ├── VfW.pas ├── VidCoDecDemo.bpg ├── VideoCoDec.pas ├── VideoCoDecDemo.cfg ├── VideoCoDecDemo.dpr ├── VideoCoDecDemo.res ├── VideoCodecClient.cfg ├── VideoCodecClient.dpr ├── VideoCodecClient.res ├── dmMainU.dfm └── dmMainU.pas /AviFileHandler.pas: -------------------------------------------------------------------------------- 1 | unit AviFileHandler; 2 | 3 | interface 4 | 5 | uses Windows, Classes, sysutils, vfw, mmsystem, graphics; 6 | 7 | type 8 | TFourCC = packed record 9 | case Integer of 10 | 0: (AsCardinal: Cardinal); 11 | 1: (AsString: array[0..3] of Char); 12 | end; 13 | 14 | TAVIBaseStream = class(TObject) 15 | private 16 | FName: string; 17 | FStream: IAVIStream; 18 | FStreamInfo: TAVIStreamInfoW; 19 | FAviFile: IAVIFile; 20 | protected 21 | FSamples: Cardinal; 22 | public 23 | constructor Create(AviFile: IAVIFile; StreamInfo: TAVIStreamInfoW); virtual; 24 | destructor Destroy; override; 25 | 26 | function WriteSample(Index: Integer; cbSize: Cardinal; lpData: Pointer; Flags: Cardinal): Boolean; 27 | function AddSample(cbSize: Cardinal; lpData: Pointer; Flags: Cardinal): Boolean; 28 | function ReadSample(Index: Integer; cbSize: Cardinal; lpData: Pointer): Boolean; 29 | function DeleteSamples(Index, Count: Cardinal): Integer; 30 | 31 | procedure SetName(Value: string); 32 | // returns the FOURCC code of the type 33 | function GetStreamType: Cardinal; 34 | 35 | property Name: string read FName write SetName; // streams name ... just to eat more memory 36 | property Stream: IAVIStream read FStream; // direct acces to the stream object if needed 37 | property StreamType: Cardinal read GetStreamType; // the streams type (streamtypeVIDEO/AUDIO, ...) 38 | property Samples: Cardinal read FSamples; // number of samples in the stream 39 | end; 40 | 41 | TAVIVideoStream = class(TAVIBaseStream) 42 | private 43 | FFormat: TBitmapInfoHeader; 44 | function Samples: Cardinal; 45 | public 46 | constructor Create(AviFile: IAVIFile; AFormat: TBitmapInfoHeader; 47 | FrameRate: Integer; fccHandler: Cardinal); reintroduce; 48 | destructor Destroy; override; 49 | 50 | function InsertFrame(Index: Integer; cbSize: Cardinal; lpData: Pointer; KeyFrame: Boolean): Boolean; overload; 51 | function InsertFrame(Index: Integer; Bmp: TBitmap; KeyFrame: Boolean): Boolean; overload; 52 | function AddFrame(cbSize: Cardinal; lpData: Pointer; KeyFrame: Boolean): Boolean; overload; 53 | function AddFrame(Bmp: TBitmap; KeyFrame: Boolean): Boolean; overload; 54 | function DeleteFrames(Index, Count: Cardinal): Integer; 55 | 56 | property Frames: Cardinal read Samples; 57 | end; 58 | 59 | TAVIAudioStream = class(TAVIBaseStream) 60 | private 61 | FFormat: TWaveFormatEx; 62 | public 63 | constructor Create(AviFile: IAVIFile; AFormat: TWaveFormatEx); reintroduce; 64 | destructor Destroy; override; 65 | end; 66 | 67 | TAviStreamList = class(TList) 68 | private 69 | function Get(Index: Integer): TAVIBaseStream; 70 | procedure Put(Index: Integer; Stream: TAVIBaseStream); 71 | protected 72 | procedure Notify(Ptr: Pointer; Action: TListNotification); override; 73 | public 74 | function Insert(Index: Integer; Stream: TAVIBaseStream): Integer; 75 | function Add(Stream: TAVIBaseStream): Integer; 76 | 77 | property Items[Index: Integer]: TAVIBaseStream read Get write Put; default; 78 | end; 79 | 80 | TAviFileHandler = class(TObject) 81 | private 82 | FAviFile: IAVIFile; 83 | FStreams: TAviStreamList; 84 | public 85 | constructor Create(FileName: string); 86 | destructor Destroy; override; 87 | 88 | function FirstVideoStream: TAVIVideoStream; 89 | function FirstAudioStream: TAVIAudioStream; 90 | 91 | function AddVideoStream(BmpFormat: TBitmapInfoHeader; FrameRate: Integer; Codec: Cardinal): Integer; overload; 92 | function AddVideoStream(BmpFormat: TBitmap; FrameRate: Integer; Codec: Cardinal): Integer; overload; 93 | function AddVideoStream2(BmpFormat: TBitmap; FrameRate: Integer; Codec: Cardinal): TAVIVideoStream; 94 | 95 | function AddAudioStream(WaveFormat: TWaveFormatEx): Integer; overload; 96 | function AddAudioStream2(WaveFormat: TWaveFormatEx): TAVIAudioStream; 97 | 98 | property Streams: TAviStreamList read FStreams; 99 | end; 100 | 101 | function BIHFromBitmap(Bmp: TBitmap; var BMIH: TBitmapInfoHeader): Boolean; 102 | 103 | 104 | implementation 105 | 106 | function BitmapImageSize(bmp: TBitmap): Cardinal; 107 | var ihs: Cardinal; 108 | begin 109 | GetDIBSizes(bmp.Handle, ihs, Result); 110 | end; 111 | 112 | function BIHFromBitmap(Bmp: TBitmap; var BMIH: TBitmapInfoHeader): Boolean; 113 | var ihs, ims: Cardinal; 114 | bits: Pointer; 115 | begin 116 | GetDIBSizes(Bmp.Handle, ihs, ims); 117 | GetMem(bits, ims); 118 | try 119 | GetDIB(Bmp.Handle, 0, BMIH, bits^); 120 | Result:=true; 121 | finally 122 | FreeMem(bits); 123 | end; 124 | end; 125 | 126 | 127 | 128 | { TAVIBaseStream } 129 | 130 | constructor TAVIBaseStream.Create(AviFile: IAVIFile; 131 | StreamInfo: TAVIStreamInfoW); 132 | begin 133 | if AviFile = nil then 134 | exit; 135 | 136 | FAviFile:=AviFile; 137 | FStreamInfo:=StreamInfo; 138 | AviFile.CreateStream(FStream, FStreamInfo); 139 | end; 140 | 141 | destructor TAVIBaseStream.Destroy; 142 | begin 143 | FStream:=nil; 144 | inherited; 145 | end; 146 | 147 | function TAVIBaseStream.WriteSample(Index: Integer; cbSize: Cardinal; 148 | lpData: Pointer; Flags: Cardinal): Boolean; 149 | var bt, smp: Integer; 150 | begin 151 | Result:=Succeeded(FStream.Write(Index, 1, lpData, cbSize, Flags, smp, bt)); 152 | Inc(FSamples); 153 | end; 154 | 155 | function TAVIBaseStream.AddSample(cbSize: Cardinal; lpData: Pointer; 156 | Flags: Cardinal): Boolean; 157 | var bt, smp: Integer; 158 | begin 159 | Result:=Succeeded(FStream.Write(FSamples, 1, lpData, cbSize, Flags, smp, bt)); 160 | Inc(FSamples); 161 | end; 162 | 163 | function TAVIBaseStream.DeleteSamples(Index, Count: Cardinal): Integer; 164 | begin 165 | if Succeeded(FStream.Delete(Index, Count)) then 166 | begin 167 | Result:=Count; 168 | Dec(FSamples, Result); 169 | end 170 | else 171 | Result:=0; 172 | end; 173 | 174 | function TAVIBaseStream.ReadSample(Index: Integer; cbSize: Cardinal; 175 | lpData: Pointer): Boolean; 176 | var bt, smp: Integer; 177 | begin 178 | Result:=Succeeded(FStream.Read(Index, 1, lpData, cbSize, bt, smp)); 179 | end; 180 | 181 | procedure TAVIBaseStream.SetName(Value: string); 182 | begin 183 | FName:=Value; 184 | end; 185 | 186 | 187 | function TAVIBaseStream.GetStreamType: Cardinal; 188 | begin 189 | Result:=FStreamInfo.fccType; 190 | end; 191 | 192 | 193 | { TAVIVideoStream } 194 | 195 | constructor TAVIVideoStream.Create(AviFile: IAVIFile; 196 | AFormat: TBitmapInfoHeader; FrameRate: Integer; fccHandler: Cardinal); 197 | begin 198 | FAviFile:=AviFile; 199 | FFormat:=AFormat; 200 | FillChar(FStreamInfo, SizeOf(FStreamInfo), 0); 201 | FStreamInfo.fccType:=streamtypeVIDEO; 202 | FStreamInfo.fccHandler:=fccHandler; 203 | FStreamInfo.dwRate:=FrameRate; 204 | if Succeeded(AviFile.CreateStream(FStream, FStreamInfo)) then 205 | FStream.SetFormat(0, @FFormat, SizeOf(FFormat)); 206 | end; 207 | 208 | destructor TAVIVideoStream.Destroy; 209 | begin 210 | 211 | inherited; 212 | end; 213 | 214 | function TAVIVideoStream.InsertFrame(Index: Integer; cbSize: Cardinal; 215 | lpData: Pointer; KeyFrame: Boolean): Boolean; 216 | const flagKeyFrame: array[Boolean] of Integer = (0, AVIIF_KEYFRAME); 217 | begin 218 | if Index = -1 then 219 | Index:=FSamples; 220 | Result:=WriteSample(Index, cbSize, lpData, flagKeyFrame[KeyFrame]); 221 | end; 222 | 223 | function TAVIVideoStream.InsertFrame(Index: Integer; Bmp: TBitmap; KeyFrame: Boolean): Boolean; 224 | var BmpSize: Cardinal; 225 | begin 226 | Result:=Assigned(Bmp); 227 | if not Result then exit; 228 | BmpSize:=BitmapImageSize(Bmp); 229 | if Index = -1 then 230 | Index:=FSamples; 231 | Result:=InsertFrame(Index, BmpSize, Bmp.ScanLine[Bmp.Height-1], KeyFrame); 232 | end; 233 | 234 | function TAVIVideoStream.AddFrame(Bmp: TBitmap; KeyFrame: Boolean): Boolean; 235 | begin 236 | Result:=InsertFrame(FSamples, Bmp, KeyFrame); 237 | end; 238 | 239 | function TAVIVideoStream.AddFrame(cbSize: Cardinal; lpData: Pointer; 240 | KeyFrame: Boolean): Boolean; 241 | begin 242 | Result:=InsertFrame(FSamples, cbSize, lpData, KeyFrame); 243 | end; 244 | 245 | function TAVIVideoStream.DeleteFrames(Index, Count: Cardinal): Integer; 246 | begin 247 | Result:=DeleteSamples(Index, Count); 248 | end; 249 | 250 | function TAVIVideoStream.Samples: Cardinal; 251 | begin 252 | Result:=FSamples; 253 | end; 254 | 255 | 256 | { TAVIAudioStream } 257 | 258 | constructor TAVIAudioStream.Create(AviFile: IAVIFile; 259 | AFormat: TWaveFormatEx); 260 | begin 261 | FAviFile:=AviFile; 262 | FFormat:=AFormat; 263 | end; 264 | 265 | destructor TAVIAudioStream.Destroy; 266 | begin 267 | 268 | inherited; 269 | end; 270 | 271 | 272 | { TAviStreamList } 273 | 274 | function TAviStreamList.Add(Stream: TAVIBaseStream): Integer; 275 | begin 276 | inherited Add(Stream); 277 | Result:=Count-1; 278 | end; 279 | 280 | function TAviStreamList.Insert(Index: Integer; Stream: TAVIBaseStream): Integer; 281 | begin 282 | inherited Insert(Index, Stream); 283 | Result:=Index; 284 | end; 285 | 286 | function TAviStreamList.Get(Index: Integer): TAVIBaseStream; 287 | begin 288 | Result:=TAVIBaseStream(inherited Get(Index)); 289 | end; 290 | 291 | procedure TAviStreamList.Put(Index: Integer; Stream: TAVIBaseStream); 292 | begin 293 | inherited Put(Index, Stream); 294 | end; 295 | 296 | 297 | procedure TAviStreamList.Notify(Ptr: Pointer; Action: TListNotification); 298 | begin 299 | if Action = lnDeleted then 300 | TAVIBaseStream(Ptr).Free; 301 | 302 | inherited Notify(Ptr, Action); 303 | end; 304 | 305 | 306 | { TAviFileHandler } 307 | 308 | function TAviFileHandler.AddAudioStream( 309 | WaveFormat: TWaveFormatEx): Integer; 310 | begin 311 | Result:=Streams.Add(TAVIAudioStream.Create(FAviFile, WaveFormat)); 312 | end; 313 | 314 | function TAviFileHandler.AddAudioStream2( 315 | WaveFormat: TWaveFormatEx): TAVIAudioStream; 316 | begin 317 | Result:=TAVIAudioStream(Streams.Items[AddAudioStream(WaveFormat)]); 318 | end; 319 | 320 | function TAviFileHandler.AddVideoStream(BmpFormat: TBitmapInfoHeader; 321 | FrameRate: Integer; Codec: Cardinal): Integer; 322 | begin 323 | Result:=Streams.Add(TAVIVideoStream.Create(FAviFile, BmpFormat, FrameRate, Codec)); 324 | end; 325 | 326 | function TAviFileHandler.AddVideoStream(BmpFormat: TBitmap; 327 | FrameRate: Integer; Codec: Cardinal): Integer; 328 | var BMIH: TBitmapInfoHeader; 329 | begin 330 | if BIHFromBitmap(BmpFormat, BMIH) then 331 | Result:=AddVideoStream(BMIH, FrameRate, Codec) 332 | else 333 | Result:=-1; 334 | end; 335 | 336 | function TAviFileHandler.AddVideoStream2(BmpFormat: TBitmap; 337 | FrameRate: Integer; Codec: Cardinal): TAVIVideoStream; 338 | begin 339 | Result:=TAVIVideoStream(Streams.Items[AddVideoStream(BmpFormat, FrameRate, Codec)]); 340 | end; 341 | 342 | constructor TAviFileHandler.Create(FileName: string); 343 | begin 344 | AVIFileInit; 345 | if AVIFileOpen(FAVIFile, PChar(FileName), OF_CREATE or OF_WRITE, nil) <> AVIERR_OK then 346 | raise Exception.CreateFmt('Can''t open file %s for writing', [FileName]); 347 | FStreams:=TAviStreamList.Create; 348 | end; 349 | 350 | destructor TAviFileHandler.Destroy; 351 | begin 352 | AVIFileExit; 353 | FreeAndNil(FStreams); 354 | FAVIFile:=nil; 355 | inherited; 356 | end; 357 | 358 | function TAviFileHandler.FirstAudioStream: TAVIAudioStream; 359 | var I: Integer; 360 | begin 361 | Result:=nil; 362 | for I:=0 to Streams.Count-1 do 363 | if Streams.Items[I].StreamType = streamtypeAUDIO then 364 | begin 365 | Result:=TAVIAudioStream(Streams.Items[I]); 366 | break; 367 | end; 368 | end; 369 | 370 | function TAviFileHandler.FirstVideoStream: TAVIVideoStream; 371 | var I: Integer; 372 | begin 373 | Result:=nil; 374 | for I:=0 to Streams.Count-1 do 375 | if Streams.Items[I].StreamType = streamtypeVIDEO then 376 | begin 377 | Result:=TAVIVideoStream(Streams.Items[I]); 378 | break; 379 | end; 380 | end; 381 | 382 | end. 383 | -------------------------------------------------------------------------------- /ClientDM.dfm: -------------------------------------------------------------------------------- 1 | object dmClient: TdmClient 2 | OldCreateOrder = False 3 | OnCreate = DataModuleCreate 4 | OnDestroy = DataModuleDestroy 5 | Left = 215 6 | Top = 123 7 | Height = 171 8 | Width = 205 9 | object TCPClient: TIdTCPClient 10 | MaxLineAction = maException 11 | ReadTimeout = 0 12 | OnDisconnected = TCPClientDisconnected 13 | OnConnected = TCPClientConnected 14 | Port = 0 15 | Left = 44 16 | Top = 24 17 | end 18 | object tmrDisplay: TTimer 19 | Enabled = False 20 | OnTimer = tmrDisplayTimer 21 | Left = 116 22 | Top = 24 23 | end 24 | end 25 | -------------------------------------------------------------------------------- /ClientDM.pas: -------------------------------------------------------------------------------- 1 | unit ClientDM; 2 | 3 | interface 4 | 5 | uses 6 | Windows, SysUtils, Classes, ExtCtrls, IdBaseComponent, IdComponent, 7 | IdTCPConnection, IdTCPClient, 8 | VideoCoDec, CommonU; 9 | 10 | type 11 | TdmClient = class(TDataModule) 12 | TCPClient: TIdTCPClient; 13 | tmrDisplay: TTimer; 14 | procedure DataModuleCreate(Sender: TObject); 15 | procedure DataModuleDestroy(Sender: TObject); 16 | procedure TCPClientConnected(Sender: TObject); 17 | procedure TCPClientDisconnected(Sender: TObject); 18 | procedure tmrDisplayTimer(Sender: TObject); 19 | private 20 | VideoCoDec: TVideoCoDec; 21 | FFrames, FKeyFrames: Cardinal; 22 | procedure UpdateVideoFormat(InputFormat: TBitmapInfoHeader); 23 | end; 24 | 25 | var 26 | dmClient: TdmClient; 27 | 28 | implementation 29 | 30 | uses SettingsU, DisplayU; 31 | 32 | {$R *.dfm} 33 | 34 | procedure TdmClient.DataModuleCreate(Sender: TObject); 35 | begin 36 | VideoCoDec := TVideoCoDec.Create; 37 | end; 38 | 39 | procedure TdmClient.DataModuleDestroy(Sender: TObject); 40 | begin 41 | FreeAndNil(VideoCoDec); 42 | end; 43 | 44 | procedure TdmClient.TCPClientConnected(Sender: TObject); 45 | var 46 | bmih: TBitmapInfoHeader; 47 | CH: TCommHeader; 48 | begin 49 | FFrames := 0; 50 | FKeyFrames := 0; 51 | SettingsF.btnConnect.Enabled := False; 52 | SettingsF.btnDisconnect.Enabled := True; 53 | ZeroMemory(@CH, SizeOf(CH)); 54 | CH.DPType := 1; // request for frame format 55 | TCPClient.WriteBuffer(CH, SizeOf(CH), True); 56 | TCPClient.ReadBuffer(CH, SizeOf(CH)); 57 | if CH.DPType <> 1 then 58 | Exit; // not the right packet 59 | if CH.DPSize <> SizeOf(bmih) then 60 | Exit; // not what we expected 61 | // Read the format 62 | TCPClient.ReadBuffer(bmih, SizeOf(bmih)); 63 | // Update the format 64 | UpdateVideoFormat(bmih); 65 | tmrDisplay.Interval := 1000 div CH.DPExtra; 66 | tmrDisplay.Enabled := True; 67 | 68 | DisplayF.lbClientSt.Caption := 'CONNECTED'; 69 | end; 70 | 71 | procedure TdmClient.TCPClientDisconnected(Sender: TObject); 72 | begin 73 | tmrDisplay.Enabled := False; 74 | SettingsF.btnConnect.Enabled := True; 75 | SettingsF.btnDisconnect.Enabled := False; 76 | 77 | DisplayF.lbClientSt.Caption := 'DISCONNECTED'; 78 | end; 79 | 80 | procedure TdmClient.UpdateVideoFormat(InputFormat: TBitmapInfoHeader); 81 | var 82 | bmihOut: TBitmapInfoHeader; 83 | FrameRate: Integer; 84 | FCC: TFourCC; 85 | begin 86 | FCC.AsCardinal := InputFormat.biCompression; 87 | SettingsF.lbFCC.Caption := FCC.AsString; 88 | bmihOut := InputFormat; 89 | FrameRate := 30; 90 | InputFormat.biCompression :=0; // rgb - used to decompress 91 | InputFormat.biBitCount := 24; // decompress to 24 bit rgb 92 | VideoCoDec.Finish; 93 | VideoCoDec.Init(InputFormat, bmihOut, 100, 10); 94 | VideoCoDec.SetDataRate(1024, 1000 * 1000 div FrameRate, 1); 95 | if not VideoCoDec.StartDeCompressor then 96 | SettingsF.lbClientError.Caption := TranslateICError(VideoCoDec.LastError); 97 | DisplayF.ClientHeight := InputFormat.biHeight + 98 | DisplayF.Panel1.Height + DisplayF.Panel2.Height; 99 | DisplayF.ClientWidth := InputFormat.biWidth; 100 | end; 101 | 102 | procedure TdmClient.tmrDisplayTimer(Sender: TObject); 103 | var 104 | CH: TCommHeader; 105 | Data: PByte; 106 | begin 107 | if not VideoCoDec.DecompressorStarted then 108 | Exit; 109 | 110 | ZeroMemory(@CH, SizeOf(CH)); 111 | CH.DPType := 2; // request the frame 112 | TCPClient.WriteBuffer(CH, SizeOf(CH), True); 113 | 114 | // Read the frame 115 | TCPClient.ReadBuffer(CH, SizeOf(CH)); 116 | 117 | if CH.DPType <> 2 then 118 | Exit; // not a frame packet 119 | if CH.DPSize < 1 then 120 | Exit; 121 | 122 | GetMem(Data, CH.DPSize); 123 | try 124 | TCPClient.ReadBuffer(Data^, CH.DPSize); 125 | if VideoCoDec.UnpackBitmap(Data, Boolean(CH.DPCode), DisplayF.imgDisplay.Picture.Bitmap) then begin 126 | Inc(FFrames); 127 | Inc(FKeyFrames, CH.DPCode); 128 | DisplayF.imgDisplay.Repaint; 129 | SettingsF.lbFrames.Caption := Format('Frames: %d (%d kf)', [FFrames, FKeyFrames]); 130 | SettingsF.Update; 131 | end; 132 | finally 133 | FreeMem(Data); 134 | end; 135 | end; 136 | 137 | end. 138 | -------------------------------------------------------------------------------- /ClientU.dfm: -------------------------------------------------------------------------------- 1 | object ClientF: TClientF 2 | Left = 745 3 | Top = 376 4 | Width = 346 5 | Height = 404 6 | Caption = 'VideoCoDec Demo Client' 7 | Color = clBtnFace 8 | Font.Charset = DEFAULT_CHARSET 9 | Font.Color = clWindowText 10 | Font.Height = -11 11 | Font.Name = 'MS Sans Serif' 12 | Font.Style = [] 13 | OldCreateOrder = False 14 | Position = poDesktopCenter 15 | OnCreate = FormCreate 16 | OnDestroy = FormDestroy 17 | PixelsPerInch = 96 18 | TextHeight = 13 19 | object imgDisplay: TImage 20 | Left = 8 21 | Top = 8 22 | Width = 320 23 | Height = 240 24 | Center = True 25 | Proportional = True 26 | end 27 | object Panel1: TPanel 28 | Left = 0 29 | Top = 268 30 | Width = 338 31 | Height = 98 32 | Align = alBottom 33 | BevelInner = bvLowered 34 | TabOrder = 0 35 | DesignSize = ( 36 | 338 37 | 98) 38 | object Label1: TLabel 39 | Left = 8 40 | Top = 12 41 | Width = 22 42 | Height = 13 43 | Anchors = [akLeft, akBottom] 44 | Caption = 'Host' 45 | end 46 | object Label2: TLabel 47 | Left = 216 48 | Top = 12 49 | Width = 19 50 | Height = 13 51 | Anchors = [akLeft, akBottom] 52 | Caption = 'Port' 53 | end 54 | object txtHost: TEdit 55 | Left = 8 56 | Top = 30 57 | Width = 201 58 | Height = 21 59 | Anchors = [akLeft, akBottom] 60 | BevelKind = bkFlat 61 | BorderStyle = bsNone 62 | TabOrder = 0 63 | Text = '192.168.1.31' 64 | end 65 | object txtPort: TEdit 66 | Left = 216 67 | Top = 30 68 | Width = 113 69 | Height = 21 70 | Anchors = [akLeft, akBottom] 71 | BevelKind = bkFlat 72 | BorderStyle = bsNone 73 | TabOrder = 1 74 | Text = '33000' 75 | end 76 | object btnConnect: TButton 77 | Left = 8 78 | Top = 61 79 | Width = 75 80 | Height = 25 81 | Anchors = [akLeft, akBottom] 82 | Caption = 'Connect' 83 | TabOrder = 2 84 | OnClick = btnConnectClick 85 | end 86 | object btnDisconnect: TButton 87 | Left = 96 88 | Top = 61 89 | Width = 75 90 | Height = 25 91 | Anchors = [akLeft, akBottom] 92 | Caption = 'Disconnect' 93 | Enabled = False 94 | TabOrder = 3 95 | OnClick = btnDisconnectClick 96 | end 97 | end 98 | object TCPClient: TIdTCPClient 99 | MaxLineAction = maException 100 | ReadTimeout = 0 101 | OnDisconnected = TCPClientDisconnected 102 | OnConnected = TCPClientConnected 103 | Port = 0 104 | Left = 16 105 | Top = 16 106 | end 107 | object tmrDisplay: TTimer 108 | Enabled = False 109 | OnTimer = tmrDisplayTimer 110 | Left = 80 111 | Top = 16 112 | end 113 | end 114 | -------------------------------------------------------------------------------- /ClientU.pas: -------------------------------------------------------------------------------- 1 | unit ClientU; 2 | 3 | interface 4 | 5 | uses 6 | Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, 7 | Dialogs, ExtCtrls, StdCtrls, 8 | IdBaseComponent, IdComponent, IdTCPConnection, IdTCPClient, 9 | VideoCoDec, CommonU; 10 | 11 | type 12 | TClientF = class(TForm) 13 | TCPClient: TIdTCPClient; 14 | imgDisplay: TImage; 15 | tmrDisplay: TTimer; 16 | Panel1: TPanel; 17 | Label1: TLabel; 18 | Label2: TLabel; 19 | txtHost: TEdit; 20 | txtPort: TEdit; 21 | btnConnect: TButton; 22 | btnDisconnect: TButton; 23 | procedure TCPClientConnected(Sender: TObject); 24 | procedure TCPClientDisconnected(Sender: TObject); 25 | procedure btnConnectClick(Sender: TObject); 26 | procedure btnDisconnectClick(Sender: TObject); 27 | procedure FormCreate(Sender: TObject); 28 | procedure FormDestroy(Sender: TObject); 29 | procedure tmrDisplayTimer(Sender: TObject); 30 | private 31 | VideoCoDec: TVideoCoDec; 32 | FFrames, FKeyFrames: Cardinal; 33 | procedure UpdateVideoFormat(InputFormat: TBitmapInfoHeader); 34 | end; 35 | 36 | var 37 | ClientF: TClientF; 38 | 39 | implementation 40 | 41 | {$R *.dfm} 42 | 43 | procedure TClientF.FormCreate(Sender: TObject); 44 | begin 45 | VideoCoDec := TVideoCoDec.Create; 46 | end; 47 | 48 | procedure TClientF.FormDestroy(Sender: TObject); 49 | begin 50 | FreeAndNil(VideoCoDec); 51 | end; 52 | 53 | procedure TClientF.TCPClientConnected(Sender: TObject); 54 | var 55 | bmih: TBitmapInfoHeader; 56 | CH: TCommHeader; 57 | begin 58 | FFrames := 0; 59 | FKeyFrames := 0; 60 | btnConnect.Enabled := False; 61 | btnDisconnect.Enabled := True; 62 | ZeroMemory(@CH, SizeOf(CH)); 63 | CH.DPType := 1; // request for frame format 64 | TCPClient.WriteBuffer(CH, SizeOf(CH), True); 65 | TCPClient.ReadBuffer(CH, SizeOf(CH)); 66 | if CH.DPType <> 1 then Exit; // not the right packet 67 | if CH.DPSize <> SizeOf(bmih) then Exit; // not what we expected 68 | // Read the format 69 | TCPClient.ReadBuffer(bmih, SizeOf(bmih)); 70 | // Update the format 71 | UpdateVideoFormat(bmih); 72 | tmrDisplay.Interval := 1000 div CH.DPExtra; 73 | tmrDisplay.Enabled := True; 74 | end; 75 | 76 | procedure TClientF.TCPClientDisconnected(Sender: TObject); 77 | begin 78 | tmrDisplay.Enabled := False; 79 | btnConnect.Enabled := True; 80 | btnDisconnect.Enabled := False; 81 | end; 82 | 83 | procedure TClientF.btnConnectClick(Sender: TObject); 84 | begin 85 | TCPClient.Host := txtHost.Text; 86 | TCPClient.Port := StrToIntDef(txtPort.Text, 33000); 87 | TCPClient.Connect; 88 | end; 89 | 90 | procedure TClientF.btnDisconnectClick(Sender: TObject); 91 | begin 92 | TCPClient.Disconnect; 93 | end; 94 | 95 | procedure TClientF.UpdateVideoFormat(InputFormat: TBitmapInfoHeader); 96 | var 97 | bmihOut: TBitmapInfoHeader; 98 | FrameRate: Integer; 99 | FCC: TFourCC; 100 | begin 101 | FCC.AsCardinal := InputFormat.biCompression; 102 | Caption := FCC.AsString; 103 | bmihOut := InputFormat; 104 | FrameRate := 30; 105 | InputFormat.biCompression :=0; // rgb - used to decompress 106 | InputFormat.biBitCount := 24; // decompress to 24 bit rgb 107 | VideoCoDec.Finish; 108 | VideoCoDec.Init(InputFormat, bmihOut, 100, 10); 109 | VideoCoDec.SetDataRate(1024, 1000 * 1000 div FrameRate, 1); 110 | if not VideoCoDec.StartDeCompressor then 111 | Caption := TranslateICError(VideoCoDec.LastError); 112 | imgDisplay.Height := InputFormat.biHeight; 113 | imgDisplay.Width := InputFormat.biWidth; 114 | end; 115 | 116 | procedure TClientF.tmrDisplayTimer(Sender: TObject); 117 | var 118 | CH: TCommHeader; 119 | Data: PByte; 120 | begin 121 | if not VideoCoDec.DecompressorStarted then 122 | Exit; 123 | 124 | ZeroMemory(@CH, SizeOf(CH)); 125 | CH.DPType := 2; // request the frame 126 | TCPClient.WriteBuffer(CH, SizeOf(CH), True); 127 | 128 | // Read the frame 129 | TCPClient.ReadBuffer(CH, SizeOf(CH)); 130 | 131 | if CH.DPType <> 2 then 132 | Exit; // not a frame packet 133 | if CH.DPSize < 1 then 134 | Exit; 135 | 136 | GetMem(Data, CH.DPSize); 137 | try 138 | TCPClient.ReadBuffer(Data^, CH.DPSize); 139 | if VideoCoDec.UnpackBitmap(Data, Boolean(CH.DPCode), imgDisplay.Picture.Bitmap) then begin 140 | Inc(FFrames); 141 | Inc(FKeyFrames, CH.DPCode); 142 | imgDisplay.Repaint; 143 | Caption := Format('Frames: %d (%d kf)', [FFrames, FKeyFrames]); 144 | Update; 145 | end; 146 | finally 147 | FreeMem(Data); 148 | end; 149 | end; 150 | 151 | end. 152 | -------------------------------------------------------------------------------- /CommonU.pas: -------------------------------------------------------------------------------- 1 | unit CommonU; 2 | 3 | interface 4 | 5 | uses 6 | Classes, Windows, 7 | IdTCPServer, IdTCPClient; 8 | 9 | type 10 | // this packet should always be the first thing in a communications packet 11 | TCommHeader = packed record 12 | DPType: Byte; // type of packet 13 | DPCode: Byte; // some extra code 14 | DPExtra: Word; // other extra data 15 | DPSize: Cardinal; // size of the following data 16 | end; 17 | 18 | TFramePacket = packed record 19 | KeyFrame: Boolean; 20 | Size: Cardinal; 21 | Data: PByte; 22 | end; 23 | 24 | procedure SendData(Conn: TidTCPServerConnection; var Header: TCommHeader; Data: PByte); 25 | procedure SendFrame(Conn: TidTCPServerConnection; var Header: TCommHeader; Packet: TFramePacket); 26 | procedure ReceiveData(Conn: TIdTCPClient; var Header: TCommHeader; Data: PByte); 27 | function CopyFrame(Source: TFramePacket): TFramePacket; 28 | procedure FreeFrame(Packet: TFramePacket); 29 | 30 | implementation 31 | 32 | procedure SendData(Conn: TidTCPServerConnection; var Header: TCommHeader; Data: PByte); 33 | var 34 | ms: TMemoryStream; 35 | begin 36 | ms := TMemoryStream.Create; 37 | try 38 | ms.Write(Header, SizeOf(Header)); 39 | if Header.DPSize > 0 then 40 | ms.Write(Data^, Header.DPSize); 41 | ms.Seek(0, soFromBeginning); 42 | if Conn.Connected then 43 | Conn.WriteStream(ms, false, false, ms.Size); 44 | finally 45 | ms.Free; 46 | end; 47 | end; 48 | 49 | procedure SendFrame(Conn: TidTCPServerConnection; var Header: TCommHeader; Packet: TFramePacket); 50 | begin 51 | Header.DPCode:=Byte(Packet.KeyFrame); 52 | Header.DPSize:=Packet.Size; 53 | SendData(Conn, Header, Packet.Data); 54 | end; 55 | 56 | procedure ReceiveData(Conn: TIdTCPClient; var Header: TCommHeader; Data: PByte); 57 | begin 58 | ReallocMem(Data, Header.DPSize); 59 | if Conn.Connected then 60 | Conn.ReadBuffer(Data^, Header.DPSize); 61 | end; 62 | 63 | function CopyFrame(Source: TFramePacket): TFramePacket; 64 | begin 65 | Result.KeyFrame:=Source.KeyFrame; 66 | Result.Size:=Source.Size; 67 | GetMem(Result.Data, Result.Size); 68 | CopyMemory(Result.Data, Source.Data, Result.Size); 69 | end; 70 | 71 | procedure FreeFrame(Packet: TFramePacket); 72 | begin 73 | FreeMem(Packet.Data, Packet.Size); 74 | ZeroMemory(@Packet, SizeOf(Packet)); 75 | end; 76 | 77 | end. 78 | -------------------------------------------------------------------------------- /Defines.inc: -------------------------------------------------------------------------------- 1 | // uncomment this to use manual yuy2torgb conversion 2 | // for codecs that cannot handle yuv input formats 3 | {.$DEFINE MANUALYUY2TORGB} 4 | 5 | -------------------------------------------------------------------------------- /DisplayU.dfm: -------------------------------------------------------------------------------- 1 | object DisplayF: TDisplayF 2 | Left = 288 3 | Top = 190 4 | BorderStyle = bsSingle 5 | Caption = 'Delphi Streaming' 6 | ClientHeight = 289 7 | ClientWidth = 320 8 | Color = clBlack 9 | Font.Charset = DEFAULT_CHARSET 10 | Font.Color = clWindowText 11 | Font.Height = -11 12 | Font.Name = 'MS Sans Serif' 13 | Font.Style = [] 14 | OldCreateOrder = False 15 | ShowHint = True 16 | OnActivate = FormActivate 17 | OnClose = FormClose 18 | OnCreate = FormCreate 19 | PixelsPerInch = 96 20 | TextHeight = 13 21 | object imgDisplay: TImage 22 | Left = 0 23 | Top = 29 24 | Width = 320 25 | Height = 240 26 | Align = alClient 27 | Center = True 28 | Proportional = True 29 | end 30 | object Panel1: TPanel 31 | Left = 0 32 | Top = 0 33 | Width = 320 34 | Height = 29 35 | Align = alTop 36 | BevelOuter = bvNone 37 | Color = clWhite 38 | TabOrder = 0 39 | object SpeedButton1: TSpeedButton 40 | Left = 4 41 | Top = 4 42 | Width = 23 43 | Height = 22 44 | Hint = 'Settings' 45 | Flat = True 46 | Glyph.Data = { 47 | 76010000424D7601000000000000760000002800000020000000100000000100 48 | 04000000000000010000120B0000120B00001000000000000000000000000000 49 | 800000800000008080008000000080008000808000007F7F7F00BFBFBF000000 50 | FF0000FF000000FFFF00FF000000FF00FF00FFFF0000FFFFFF00555550FF0559 51 | 1950555FF75F7557F7F757000FF055591903557775F75557F77570FFFF055559 52 | 1933575FF57F5557F7FF0F00FF05555919337F775F7F5557F7F700550F055559 53 | 193577557F7F55F7577F07550F0555999995755575755F7FFF7F5570F0755011 54 | 11155557F755F777777555000755033305555577755F75F77F55555555503335 55 | 0555555FF5F75F757F5555005503335505555577FF75F7557F55505050333555 56 | 05555757F75F75557F5505000333555505557F777FF755557F55000000355557 57 | 07557777777F55557F5555000005555707555577777FF5557F55553000075557 58 | 0755557F7777FFF5755555335000005555555577577777555555} 59 | NumGlyphs = 2 60 | OnClick = SpeedButton1Click 61 | end 62 | end 63 | object Panel2: TPanel 64 | Left = 0 65 | Top = 269 66 | Width = 320 67 | Height = 20 68 | Align = alBottom 69 | BevelOuter = bvNone 70 | Color = clWhite 71 | TabOrder = 1 72 | object Label1: TLabel 73 | Left = 4 74 | Top = 4 75 | Width = 34 76 | Height = 13 77 | Caption = 'Server:' 78 | end 79 | object lbServerSt: TLabel 80 | Left = 40 81 | Top = 4 82 | Width = 20 83 | Height = 13 84 | Caption = 'OFF' 85 | end 86 | object Label2: TLabel 87 | Left = 68 88 | Top = 4 89 | Width = 29 90 | Height = 13 91 | Caption = 'Client:' 92 | end 93 | object lbClientSt: TLabel 94 | Left = 100 95 | Top = 4 96 | Width = 85 97 | Height = 13 98 | Caption = 'DISCONNECTED' 99 | end 100 | end 101 | end 102 | -------------------------------------------------------------------------------- /DisplayU.pas: -------------------------------------------------------------------------------- 1 | unit DisplayU; 2 | 3 | interface 4 | 5 | uses 6 | Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, 7 | Dialogs, ExtCtrls, Buttons, 8 | DSPack, CommonU, StdCtrls; 9 | 10 | type 11 | TDisplayF = class(TForm) 12 | Panel1: TPanel; 13 | SpeedButton1: TSpeedButton; 14 | Panel2: TPanel; 15 | Label1: TLabel; 16 | imgDisplay: TImage; 17 | lbServerSt: TLabel; 18 | Label2: TLabel; 19 | lbClientSt: TLabel; 20 | procedure FormClose(Sender: TObject; var Action: TCloseAction); 21 | procedure FormCreate(Sender: TObject); 22 | procedure SpeedButton1Click(Sender: TObject); 23 | procedure FormActivate(Sender: TObject); 24 | end; 25 | 26 | var 27 | DisplayF: TDisplayF; 28 | 29 | implementation 30 | 31 | uses 32 | dmMainU, SettingsU; 33 | 34 | {$R *.dfm} 35 | 36 | procedure TDisplayF.FormClose(Sender: TObject; var Action: TCloseAction); 37 | begin 38 | with dmMain.fgMain do 39 | if Active then begin 40 | Stop; 41 | Active := false; 42 | end; 43 | end; 44 | 45 | procedure TDisplayF.FormCreate(Sender: TObject); 46 | begin 47 | Left := 0; 48 | Top := 0; 49 | end; 50 | 51 | procedure TDisplayF.SpeedButton1Click(Sender: TObject); 52 | begin 53 | SettingsF.Show; 54 | end; 55 | 56 | procedure TDisplayF.FormActivate(Sender: TObject); 57 | begin 58 | if SettingsF = nil then 59 | SettingsF := TSettingsF.Create(Application); 60 | end; 61 | 62 | end. 63 | -------------------------------------------------------------------------------- /Preview.dfm: -------------------------------------------------------------------------------- 1 | object frmPreview: TfrmPreview 2 | Left = 215 3 | Top = 123 4 | BorderStyle = bsSingle 5 | Caption = 'Preview' 6 | ClientHeight = 240 7 | ClientWidth = 320 8 | Color = clBtnFace 9 | Font.Charset = DEFAULT_CHARSET 10 | Font.Color = clWindowText 11 | Font.Height = -11 12 | Font.Name = 'MS Sans Serif' 13 | Font.Style = [] 14 | OldCreateOrder = False 15 | PixelsPerInch = 96 16 | TextHeight = 13 17 | object VideoWindow: TVideoWindow 18 | Left = 0 19 | Top = 0 20 | Width = 320 21 | Height = 240 22 | FilterGraph = dmMain.fgMain 23 | VMROptions.Mode = vmrWindowed 24 | VMROptions.Streams = 1 25 | VMROptions.Preferences = [] 26 | Color = clBlack 27 | Align = alClient 28 | end 29 | end 30 | -------------------------------------------------------------------------------- /Preview.pas: -------------------------------------------------------------------------------- 1 | unit Preview; 2 | 3 | interface 4 | 5 | uses 6 | Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, 7 | Dialogs, DSPack; 8 | 9 | type 10 | TfrmPreview = class(TForm) 11 | VideoWindow: TVideoWindow; 12 | end; 13 | 14 | var 15 | frmPreview: TfrmPreview; 16 | 17 | implementation 18 | 19 | uses dmMainU; 20 | 21 | {$R *.dfm} 22 | 23 | end. 24 | -------------------------------------------------------------------------------- /SettingsU.dfm: -------------------------------------------------------------------------------- 1 | object SettingsF: TSettingsF 2 | Left = 215 3 | Top = 158 4 | Width = 468 5 | Height = 280 6 | Caption = 'Settings' 7 | Color = clWhite 8 | Font.Charset = DEFAULT_CHARSET 9 | Font.Color = clWindowText 10 | Font.Height = -11 11 | Font.Name = 'MS Sans Serif' 12 | Font.Style = [] 13 | OldCreateOrder = False 14 | Visible = True 15 | OnCreate = FormCreate 16 | OnDestroy = FormDestroy 17 | DesignSize = ( 18 | 460 19 | 242) 20 | PixelsPerInch = 96 21 | TextHeight = 13 22 | object btnOK: TButton 23 | Left = 4 24 | Top = 212 25 | Width = 75 26 | Height = 25 27 | Anchors = [akLeft, akBottom] 28 | Caption = 'OK' 29 | Default = True 30 | TabOrder = 0 31 | OnClick = btnOKClick 32 | end 33 | object btnCancel: TButton 34 | Left = 92 35 | Top = 212 36 | Width = 75 37 | Height = 25 38 | Anchors = [akLeft, akBottom] 39 | Cancel = True 40 | Caption = 'Cancel' 41 | TabOrder = 1 42 | OnClick = btnCancelClick 43 | end 44 | object btnApply: TButton 45 | Left = 180 46 | Top = 212 47 | Width = 75 48 | Height = 25 49 | Anchors = [akLeft, akBottom] 50 | Caption = 'Apply' 51 | TabOrder = 2 52 | OnClick = btnApplyClick 53 | end 54 | object PageControl1: TPageControl 55 | Left = 0 56 | Top = 0 57 | Width = 460 58 | Height = 203 59 | ActivePage = TabSheet3 60 | Anchors = [akLeft, akTop, akRight, akBottom] 61 | Style = tsButtons 62 | TabOrder = 3 63 | object TabSheet1: TTabSheet 64 | Caption = 'Video Streaming' 65 | DesignSize = ( 66 | 452 67 | 172) 68 | object Label1: TLabel 69 | Left = 0 70 | Top = 4 71 | Width = 34 72 | Height = 13 73 | Caption = 'Device' 74 | end 75 | object Label2: TLabel 76 | Left = 0 77 | Top = 52 78 | Width = 32 79 | Height = 13 80 | Caption = 'Format' 81 | end 82 | object Label3: TLabel 83 | Left = 0 84 | Top = 100 85 | Width = 31 86 | Height = 13 87 | Caption = 'Codec' 88 | end 89 | object cbxCameras: TComboBox 90 | Left = 0 91 | Top = 20 92 | Width = 452 93 | Height = 21 94 | BevelKind = bkFlat 95 | Style = csDropDownList 96 | Anchors = [akLeft, akTop, akRight] 97 | ItemHeight = 13 98 | TabOrder = 0 99 | OnChange = cbxCamerasChange 100 | end 101 | object cbxFormats: TComboBox 102 | Left = 0 103 | Top = 68 104 | Width = 452 105 | Height = 21 106 | BevelKind = bkFlat 107 | Style = csDropDownList 108 | Anchors = [akLeft, akTop, akRight] 109 | ItemHeight = 13 110 | TabOrder = 1 111 | end 112 | object cbxCodecs: TComboBox 113 | Left = 0 114 | Top = 116 115 | Width = 452 116 | Height = 21 117 | BevelKind = bkFlat 118 | Style = csDropDownList 119 | Anchors = [akLeft, akTop, akRight] 120 | ItemHeight = 13 121 | TabOrder = 2 122 | end 123 | object chkPreview: TCheckBox 124 | Left = 0 125 | Top = 152 126 | Width = 97 127 | Height = 17 128 | Caption = 'Video Preview' 129 | Checked = True 130 | Ctl3D = False 131 | ParentCtl3D = False 132 | State = cbChecked 133 | TabOrder = 3 134 | end 135 | end 136 | object TabSheet2: TTabSheet 137 | Caption = 'TCP/IP Server' 138 | ImageIndex = 1 139 | DesignSize = ( 140 | 452 141 | 172) 142 | object Label5: TLabel 143 | Left = 0 144 | Top = 8 145 | Width = 19 146 | Height = 13 147 | Anchors = [akLeft, akBottom] 148 | Caption = 'Port' 149 | end 150 | object txtServerPort: TEdit 151 | Left = 0 152 | Top = 24 153 | Width = 89 154 | Height = 21 155 | Anchors = [akLeft, akBottom] 156 | BevelKind = bkFlat 157 | BorderStyle = bsNone 158 | TabOrder = 0 159 | Text = '33000' 160 | end 161 | object chkServer: TCheckBox 162 | Left = 104 163 | Top = 24 164 | Width = 97 165 | Height = 17 166 | Caption = 'Active' 167 | Checked = True 168 | State = cbChecked 169 | TabOrder = 1 170 | end 171 | end 172 | object TabSheet3: TTabSheet 173 | Caption = 'TCP/IP Client' 174 | ImageIndex = 2 175 | DesignSize = ( 176 | 452 177 | 172) 178 | object Label4: TLabel 179 | Left = 0 180 | Top = 4 181 | Width = 22 182 | Height = 13 183 | Anchors = [akLeft, akBottom] 184 | Caption = 'Host' 185 | end 186 | object Label6: TLabel 187 | Left = 208 188 | Top = 4 189 | Width = 19 190 | Height = 13 191 | Anchors = [akLeft, akBottom] 192 | Caption = 'Port' 193 | end 194 | object lbFrames: TLabel 195 | Left = 0 196 | Top = 96 197 | Width = 46 198 | Height = 13 199 | Caption = 'Frames: 0' 200 | end 201 | object Label7: TLabel 202 | Left = 0 203 | Top = 120 204 | Width = 23 205 | Height = 13 206 | Caption = 'FCC:' 207 | end 208 | object lbFCC: TLabel 209 | Left = 28 210 | Top = 120 211 | Width = 20 212 | Height = 13 213 | Caption = 'FCC' 214 | end 215 | object Label8: TLabel 216 | Left = 0 217 | Top = 144 218 | Width = 25 219 | Height = 13 220 | Caption = 'Error:' 221 | end 222 | object lbClientError: TLabel 223 | Left = 32 224 | Top = 144 225 | Width = 24 226 | Height = 13 227 | Caption = 'none' 228 | end 229 | object txtClientHost: TEdit 230 | Left = 0 231 | Top = 20 232 | Width = 201 233 | Height = 21 234 | Anchors = [akLeft, akBottom] 235 | BevelKind = bkFlat 236 | BorderStyle = bsNone 237 | TabOrder = 0 238 | Text = '192.168.1.31' 239 | end 240 | object txtClientPort: TEdit 241 | Left = 208 242 | Top = 20 243 | Width = 113 244 | Height = 21 245 | Anchors = [akLeft, akBottom] 246 | BevelKind = bkFlat 247 | BorderStyle = bsNone 248 | TabOrder = 1 249 | Text = '33000' 250 | end 251 | object btnConnect: TButton 252 | Left = 0 253 | Top = 53 254 | Width = 75 255 | Height = 25 256 | Anchors = [akLeft, akBottom] 257 | Caption = 'Connect' 258 | TabOrder = 2 259 | OnClick = btnConnectClick 260 | end 261 | object btnDisconnect: TButton 262 | Left = 88 263 | Top = 53 264 | Width = 75 265 | Height = 25 266 | Anchors = [akLeft, akBottom] 267 | Caption = 'Disconnect' 268 | Enabled = False 269 | TabOrder = 3 270 | OnClick = btnDisconnectClick 271 | end 272 | end 273 | end 274 | end 275 | -------------------------------------------------------------------------------- /SettingsU.pas: -------------------------------------------------------------------------------- 1 | unit SettingsU; 2 | 3 | interface 4 | 5 | {$I Defines.inc} 6 | 7 | uses 8 | Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, 9 | Dialogs, StdCtrls, 10 | DSPack, DSUtil, DirectShow9, ComCtrls; 11 | 12 | type 13 | TSettingsF = class(TForm) 14 | btnOK: TButton; 15 | btnCancel: TButton; 16 | btnApply: TButton; 17 | PageControl1: TPageControl; 18 | TabSheet1: TTabSheet; 19 | Label1: TLabel; 20 | Label2: TLabel; 21 | Label3: TLabel; 22 | cbxCameras: TComboBox; 23 | cbxFormats: TComboBox; 24 | cbxCodecs: TComboBox; 25 | chkPreview: TCheckBox; 26 | TabSheet2: TTabSheet; 27 | Label5: TLabel; 28 | txtServerPort: TEdit; 29 | chkServer: TCheckBox; 30 | TabSheet3: TTabSheet; 31 | Label4: TLabel; 32 | Label6: TLabel; 33 | txtClientHost: TEdit; 34 | txtClientPort: TEdit; 35 | btnConnect: TButton; 36 | btnDisconnect: TButton; 37 | lbFrames: TLabel; 38 | Label7: TLabel; 39 | lbFCC: TLabel; 40 | Label8: TLabel; 41 | lbClientError: TLabel; 42 | procedure FormCreate(Sender: TObject); 43 | procedure FormDestroy(Sender: TObject); 44 | procedure cbxCamerasChange(Sender: TObject); 45 | procedure btnCancelClick(Sender: TObject); 46 | procedure btnOKClick(Sender: TObject); 47 | procedure btnApplyClick(Sender: TObject); 48 | procedure btnConnectClick(Sender: TObject); 49 | procedure btnDisconnectClick(Sender: TObject); 50 | private 51 | DevEnum: TSysDevEnum; 52 | VideoMediaTypes: TEnumMediaType; 53 | end; 54 | 55 | var 56 | SettingsF: TSettingsF; 57 | 58 | implementation 59 | 60 | uses 61 | dmMainU, DisplayU, ActiveX, Preview, ClientDM; 62 | 63 | {$R *.dfm} 64 | 65 | function PinListForMoniker(Moniker: IMoniker): TPinList; 66 | var 67 | BF: TBaseFilter; 68 | IBF: IBaseFilter; 69 | begin 70 | BF := TBaseFilter.Create; 71 | try 72 | BF.Moniker := Moniker; 73 | IBF := BF.CreateFilter; 74 | Result := TPinList.Create(IBF); 75 | finally 76 | IBF := nil; 77 | BF.Free; 78 | end; 79 | end; 80 | 81 | procedure TSettingsF.FormCreate(Sender: TObject); 82 | var 83 | I: Integer; 84 | begin 85 | PageControl1.ActivePageIndex := 0; 86 | 87 | DevEnum := TSysDevEnum.Create(CLSID_VideoInputDeviceCategory); 88 | VideoMediaTypes := TEnumMediaType.Create; 89 | 90 | for I := 0 to DevEnum.CountFilters - 1 do 91 | cbxCameras.Items.Add(DevEnum.Filters[I].FriendlyName); 92 | 93 | dmMain.VideoCoDec.EnumCodecs(cbxCodecs.Items); 94 | end; 95 | 96 | procedure TSettingsF.FormDestroy(Sender: TObject); 97 | begin 98 | FreeAndNil(DevEnum); 99 | FreeAndNil(VideoMediaTypes); 100 | end; 101 | 102 | procedure TSettingsF.cbxCamerasChange(Sender: TObject); 103 | var 104 | PinList: TPinList; 105 | I: Integer; 106 | begin 107 | if cbxCameras.ItemIndex < 0 then 108 | Exit; 109 | 110 | DevEnum.SelectGUIDCategory(CLSID_VideoInputDeviceCategory); 111 | PinList := PinListForMoniker(DevEnum.GetMoniker(cbxCameras.ItemIndex)); 112 | try 113 | cbxFormats.Clear; 114 | VideoMediaTypes.Assign(PinList.First); 115 | for I := 0 to VideoMediaTypes.Count - 1 do 116 | cbxFormats.Items.Add(VideoMediaTypes.MediaDescription[I]); 117 | finally 118 | PinList.Free; 119 | end; 120 | end; 121 | 122 | procedure TSettingsF.btnCancelClick(Sender: TObject); 123 | begin 124 | Close; 125 | end; 126 | 127 | procedure TSettingsF.btnOKClick(Sender: TObject); 128 | begin 129 | btnApply.Click; 130 | Close; 131 | end; 132 | 133 | procedure TSettingsF.btnApplyClick(Sender: TObject); 134 | var 135 | PinList: TPinList; 136 | ok: Boolean; 137 | bmih: TBitmapInfoHeader; 138 | DefPort: Integer; 139 | begin 140 | if (cbxCameras.ItemIndex > -1) and (cbxFormats.ItemIndex > -1) then begin 141 | with dmMain do begin 142 | if fgMain.Active then begin 143 | fgMain.Stop; 144 | fgMain.Active := False; 145 | end; 146 | 147 | dsfCam.BaseFilter.Moniker := DevEnum.GetMoniker(cbxCameras.ItemIndex); 148 | sgVideo.MediaType := VideoMediaTypes.Items[cbxFormats.ItemIndex]; 149 | with VideoMediaTypes.Items[cbxFormats.ItemIndex].AMMediaType^ do 150 | case formattype.D1 of 151 | $05589F80: bmih := PVideoInfoHeader(pbFormat)^.bmiHeader; 152 | $F72A76A0: bmih := PVideoInfoHeader2(pbFormat)^.bmiHeader; 153 | end; 154 | 155 | if cbxCodecs.ItemIndex > -1 then 156 | bmih.biCompression := Cardinal(cbxCodecs.Items.Objects[cbxCodecs.ItemIndex]); 157 | UpdateVideoFormat(bmih); 158 | 159 | FrameHeight := bmih.biHeight; 160 | FrameWidth := bmih.biWidth; 161 | 162 | dsfCam.FilterGraph := fgMain; 163 | sgVideo.FilterGraph := fgMain; 164 | fgMain.Active := True; 165 | 166 | //PinList:=PinListForMoniker(DevEnum.GetMoniker(cbxCameras.ItemIndex)); // Erro!!! 167 | PinList := TPinList.Create(dmMain.dsfCam as IBaseFilter); 168 | try 169 | with (PinList.First as IAMStreamConfig) do 170 | ok := Succeeded(SetFormat(VideoMediaTypes.Items[cbxFormats.ItemIndex].AMMediaType^)); 171 | if not ok then begin 172 | MessageBox(0, 'aaaaaa', nil, 0); 173 | Exit; 174 | end; 175 | finally 176 | PinList.Free; 177 | end; 178 | 179 | // Now render streams 180 | with fgMain as ICaptureGraphBuilder2 do 181 | try 182 | // render the grabber - must be here to get rendered at all 183 | RenderStream(@PIN_CATEGORY_CAPTURE, nil, dsfCam as IBaseFilter, nil, sgVideo as IBaseFilter); 184 | 185 | // Connect Video preview (VideoWindow) 186 | if chkPreview.Checked and (dsfCam.BaseFilter.DataLength > 0) then begin 187 | frmPreview.VideoWindow.FilterGraph := dmMain.fgMain; 188 | RenderStream(@PIN_CATEGORY_PREVIEW, nil, dsfCam as IBaseFilter, 189 | nil, frmPreview.VideoWindow as IBaseFilter); 190 | if not frmPreview.Visible then 191 | frmPreview.Show; 192 | end else begin 193 | frmPreview.VideoWindow.FilterGraph := nil; 194 | frmPreview.Hide; 195 | end; 196 | except 197 | end; 198 | 199 | fgMain.Play; 200 | 201 | DefPort := StrToIntDef(txtServerPort.Text, 33000); 202 | if dmMain.TCPServer.DefaultPort <> DefPort then 203 | dmMain.TCPServer.Active := False; 204 | dmMain.TCPServer.DefaultPort := StrToIntDef(txtServerPort.Text, 33000); 205 | dmMain.TCPServer.Active := chkServer.Checked; 206 | end; 207 | end else begin 208 | dmMain.TCPServer.Active := False; 209 | end; 210 | 211 | if dmMain.TCPServer.Active then 212 | DisplayF.lbServerSt.Caption := 'ON' 213 | else 214 | DisplayF.lbServerSt.Caption := 'OFF'; 215 | end; 216 | 217 | procedure TSettingsF.btnConnectClick(Sender: TObject); 218 | begin 219 | dmClient.TCPClient.Host := txtClientHost.Text; 220 | dmClient.TCPClient.Port := StrToIntDef(txtClientPort.Text, 33000); 221 | dmClient.TCPClient.Connect; 222 | end; 223 | 224 | procedure TSettingsF.btnDisconnectClick(Sender: TObject); 225 | begin 226 | dmClient.TCPClient.Disconnect; 227 | end; 228 | 229 | end. 230 | -------------------------------------------------------------------------------- /VidCoDecDemo.bpg: -------------------------------------------------------------------------------- 1 | #------------------------------------------------------------------------------ 2 | VERSION = BWS.01 3 | #------------------------------------------------------------------------------ 4 | !ifndef ROOT 5 | ROOT = $(MAKEDIR)\.. 6 | !endif 7 | #------------------------------------------------------------------------------ 8 | MAKE = $(ROOT)\bin\make.exe -$(MAKEFLAGS) -f$** 9 | DCC = $(ROOT)\bin\dcc32.exe $** 10 | BRCC = $(ROOT)\bin\brcc32.exe $** 11 | #------------------------------------------------------------------------------ 12 | PROJECTS = VideoCoDecDemo.exe VideoCodecClient.exe 13 | #------------------------------------------------------------------------------ 14 | default: $(PROJECTS) 15 | #------------------------------------------------------------------------------ 16 | 17 | VideoCoDecDemo.exe: VideoCoDecDemo.dpr 18 | $(DCC) 19 | 20 | VideoCodecClient.exe: VideoCodecClient.dpr 21 | $(DCC) 22 | 23 | 24 | -------------------------------------------------------------------------------- /VideoCoDec.pas: -------------------------------------------------------------------------------- 1 | { 2 | Compression scheme taken from VirtualDub 3 | Converted for Delphi by Lee_Nover - Lee_Nover@delphi-si.com 27.5.2002 4 | } 5 | 6 | unit VideoCoDec; 7 | 8 | interface 9 | 10 | uses windows, sysutils, Classes, vfw, Graphics, AviFileHandler; 11 | 12 | const 13 | VFW_EXT_RESULT = 1; 14 | 15 | resourcestring 16 | sErrorICGetInfo = 'Unable to retrieve video compressor information'; 17 | sErrorICCompressBegin = 'Cannot start video compression'#13#10'Error code: %d'; 18 | sErrorICCompressBeginBF = 'Cannot start video compression'#13#10'Unsupported format (Error code: %d)'; 19 | 20 | type 21 | TFourCC = packed record 22 | case Integer of 23 | 0: (AsCardinal: Cardinal); 24 | 1: (AsString: array[0..3] of Char); 25 | end; 26 | 27 | TVideoCoDec = class(TObject) 28 | private 29 | hICDec: Cardinal; 30 | cv: TCompVars; 31 | FFlags: Cardinal; 32 | FPrevBuffer: PChar; 33 | FBuffCompOut: PChar; 34 | FBuffDeCompOut: PChar; 35 | FCompressorStarted: Boolean; 36 | FDecompressorStarted: Boolean; 37 | 38 | FFrameNum: Integer; 39 | FKeyRateCounter: Integer; 40 | FForceKeyFrameRate: Boolean; 41 | FMaxKeyFrameInterval: Cardinal; 42 | FMaxFrameSize: Cardinal; 43 | FMaxPackedSize: Cardinal; 44 | FSlopSpace: Cardinal; 45 | 46 | FCodecName: string; 47 | FCodecDescription: string; 48 | 49 | pConfigData: Pointer; 50 | cbConfigData: Cardinal; 51 | FLastError: Integer; 52 | 53 | function InternalInit(const HasComp: Boolean = false): Boolean; 54 | procedure SetCompVars(CompVars: TCompVars); 55 | procedure ClearCompVars(var CompVars: TCompVars); 56 | procedure CloseDrivers; 57 | public 58 | constructor Create; 59 | destructor Destroy; override; 60 | 61 | function Init(CompVars: TCompVars): Boolean; overload; 62 | function Init(InputFormat, OutputFormat: TBitmapInfo; 63 | const Quality, KeyRate: Integer): Boolean; overload; 64 | function Init(InputFormat, OutputFormat: TBitmapInfoHeader; 65 | const Quality, KeyRate: Integer): Boolean; overload; 66 | 67 | function StartCompressor: Boolean; 68 | function StartDecompressor: Boolean; 69 | // start calls the 2 functions above 70 | procedure Start; 71 | 72 | procedure CloseDecompressor; 73 | procedure CloseCompressor; 74 | // finish calls the 2 procedures above 75 | procedure Finish; 76 | function ChooseCodec: Boolean; 77 | procedure ConfigureCompressor; 78 | 79 | procedure SetDataRate(const lDataRate, lUsPerFrame, lFrameCount: Integer); 80 | procedure SetQuality(const Value: Integer); 81 | function GetQuality: Integer; 82 | 83 | function EnumCodecs(List: TStrings): Integer; 84 | 85 | procedure DropFrame; 86 | function PackFrame(ImageData: Pointer; var IsKeyFrame: Boolean; var Size: Cardinal): Pointer; 87 | function UnpackFrame(ImageData: Pointer; KeyFrame: Boolean; var Size: Cardinal): Pointer; 88 | function CompressImage(ImageData: Pointer; Quality: Integer; var Size: Cardinal): HBITMAP; 89 | function DecompressImage(ImageData: Pointer): HBITMAP; 90 | function PackBitmap(Bitmap: TBitmap; var IsKeyFrame: Boolean; var Size: Cardinal): Pointer; 91 | function UnpackBitmap(ImageData: Pointer; KeyFrame: Boolean; Bitmap: TBitmap): Boolean; 92 | 93 | function GetBitmapInfoIn: TBitmapInfo; 94 | function GetBitmapInfoOut: TBitmapInfo; 95 | 96 | property CompressorStarted: Boolean read FCompressorStarted; 97 | property DecompressorStarted: Boolean read FDecompressorStarted; 98 | property BIInput: TBitmapInfo read GetBitmapInfoIn; 99 | property BIOutput: TBitmapInfo read GetBitmapInfoOut; 100 | property Quality: Integer read GetQuality write SetQuality; 101 | property ForceKeyFrameRate: Boolean read FForceKeyFrameRate write FForceKeyFrameRate; 102 | property MaxKeyFrameRate: Cardinal read FMaxKeyFrameInterval write FMaxKeyFrameInterval; 103 | property CodecName: string read FCodecName; 104 | property CodecDescription: string read FCodecDescription; 105 | property LastError: Integer read FLastError; 106 | end; 107 | 108 | 109 | function IIF(const Condition: Boolean; const ifTrue, ifFalse: Integer): Integer;overload; 110 | function IIF(const Condition: Boolean; const ifTrue, ifFalse: Pointer): Pointer;overload; 111 | function HasFlag(const Flags, CheckFlag: Integer): Boolean;overload; 112 | function HasFlag(const Flags, CheckFlag: Cardinal): Boolean;overload; 113 | function TranslateICError(ErrCode: Integer): string; 114 | 115 | implementation 116 | 117 | resourcestring 118 | sVideoCoDecAbort = 'Abort'; 119 | sVideoCoDecBadBitDepth = 'Bad bit-depth'; 120 | sVideoCoDecBadFlags = 'Bad flags'; 121 | sVideoCoDecBadFormat = 'Bad format'; 122 | sVideoCoDecBadHandle = 'Bad handle'; 123 | sVideoCoDecBadImageSize = 'Bad image size'; 124 | sVideoCoDecBadParameter = 'Bad parameter'; 125 | sVideoCoDecBadSize = 'Bad size'; 126 | sVideoCoDecCanTUpdate = 'Can''t update'; 127 | sVideoCoDecDonTDraw = 'Don''t draw'; 128 | sVideoCoDecError = 'Error'; 129 | sVideoCoDecGoToKeyFrame = 'Go to KeyFrame'; 130 | sVideoCoDecInternalError = 'Internal error'; 131 | sVideoCoDecNewPalette = 'New palette'; 132 | sVideoCoDecNoError = 'No error'; 133 | sVideoCoDecNotEnoughMemory = 'Not enough memory'; 134 | sVideoCoDecStopDrawing = 'Stop drawing'; 135 | sVideoCoDecUnknownError = 'Unknown error'; 136 | sVideoCoDecUnsupportedFunctionFormat = 'Unsupported function/format'; 137 | 138 | function IIF(const Condition: Boolean; const ifTrue, ifFalse: Integer): Integer;overload; 139 | begin 140 | if Condition then 141 | Result:=ifTrue 142 | else 143 | Result:=ifFalse; 144 | end; 145 | 146 | function IIF(const Condition: Boolean; const ifTrue, ifFalse: Pointer): Pointer;overload; 147 | begin 148 | if Condition then 149 | Result:=ifTrue 150 | else 151 | Result:=ifFalse; 152 | end; 153 | 154 | function HasFlag(const Flags, CheckFlag: Integer): Boolean;overload; 155 | begin 156 | Result:=(Flags and CheckFlag) = CheckFlag; 157 | end; 158 | 159 | function HasFlag(const Flags, CheckFlag: Cardinal): Boolean;overload; 160 | begin 161 | Result:=(Flags and CheckFlag) = CheckFlag; 162 | end; 163 | 164 | function TranslateICError(ErrCode: Integer): string; 165 | begin 166 | case ErrCode of 167 | ICERR_OK: Result:=sVideoCoDecNoError; 168 | ICERR_DONTDRAW: Result:=sVideoCoDecDonTDraw; 169 | ICERR_NEWPALETTE: Result:=sVideoCoDecNewPalette; 170 | ICERR_GOTOKEYFRAME: Result:=sVideoCoDecGoToKeyFrame; 171 | ICERR_STOPDRAWING: Result:=sVideoCoDecStopDrawing; 172 | 173 | ICERR_UNSUPPORTED: Result:=sVideoCoDecUnsupportedFunctionFormat; 174 | ICERR_BADFORMAT: Result:=sVideoCoDecBadFormat; 175 | ICERR_MEMORY: Result:=sVideoCoDecNotEnoughMemory; 176 | ICERR_INTERNAL: Result:=sVideoCoDecInternalError; 177 | ICERR_BADFLAGS: Result:=sVideoCoDecBadFlags; 178 | ICERR_BADPARAM: Result:=sVideoCoDecBadParameter; 179 | ICERR_BADSIZE: Result:=sVideoCoDecBadSize; 180 | ICERR_BADHANDLE: Result:=sVideoCoDecBadHandle; 181 | ICERR_CANTUPDATE: Result:=sVideoCoDecCanTUpdate; 182 | ICERR_ABORT: Result:=sVideoCoDecAbort; 183 | ICERR_ERROR: Result:=sVideoCoDecError; 184 | ICERR_BADBITDEPTH: Result:=sVideoCoDecBadBitDepth; 185 | ICERR_BADIMAGESIZE: Result:=sVideoCoDecBadImageSize; 186 | else Result:=sVideoCoDecUnknownError; 187 | end; 188 | end; 189 | 190 | { TVideoCoDec } 191 | 192 | constructor TVideoCoDec.Create; 193 | begin 194 | hICDec:=0; 195 | FillChar(cv, SizeOf(cv), 0); 196 | cv.cbSize:=SizeOf(cv); 197 | cv.lpbiIn:=AllocMem(SizeOf(TBitmapInfo)); 198 | cv.lpbiOut:=AllocMem(SizeOf(TBitmapInfo)); 199 | FFlags:=0; 200 | FPrevBuffer:=nil; 201 | FBuffCompOut:=nil; 202 | FBuffDeCompOut:=nil; 203 | FCompressorStarted:=false; 204 | FDecompressorStarted:=false; 205 | FForceKeyFrameRate:=false; 206 | pConfigData:=nil; 207 | cbConfigData:=0; 208 | FLastError:=ICERR_OK; 209 | end; 210 | 211 | destructor TVideoCoDec.Destroy; 212 | begin 213 | ReallocMem(FPrevBuffer, 0); 214 | ReallocMem(FBuffCompOut, 0); 215 | ReallocMem(FBuffDeCompOut, 0); 216 | ReallocMem(pConfigData, 0); 217 | // these could be freed by ICCompressFree 218 | // but I don't know what that function REALLY does ! 219 | CloseDrivers; 220 | ClearCompVars(cv); 221 | inherited; 222 | end; 223 | 224 | procedure TVideoCoDec.ClearCompVars(var CompVars: TCompVars); 225 | begin 226 | ReallocMem(CompVars.lpbiIn, 0); 227 | ReallocMem(CompVars.lpbiOut, 0); 228 | ReallocMem(CompVars.lpBitsOut, 0); 229 | ReallocMem(CompVars.lpBitsPrev, 0); 230 | ReallocMem(CompVars.lpState, 0); 231 | FillChar(CompVars, SizeOf(TCompVars), 0); 232 | end; 233 | 234 | procedure TVideoCoDec.SetCompVars(CompVars: TCompVars); 235 | begin 236 | cv.cbState:=CompVars.cbState; 237 | cv.dwFlags:=CompVars.dwFlags; 238 | cv.fccHandler:=CompVars.fccHandler; 239 | cv.fccType:=CompVars.fccType; 240 | 241 | if CompVars.hic > 0 then 242 | begin 243 | if cv.hic > 0 then 244 | ICClose(cv.hic); 245 | 246 | cv.hic:=CompVars.hic; 247 | end; 248 | 249 | cv.lDataRate:=CompVars.lDataRate; 250 | cv.lFrame:=CompVars.lFrame; 251 | cv.lKey:=CompVars.lKey; 252 | cv.lKeyCount:=CompVars.lKeyCount; 253 | cv.lQ:=CompVars.lQ; 254 | CopyMemory(cv.lpbiIn, CompVars.lpbiIn, SizeOf(TBitmapInfo)); 255 | CopyMemory(cv.lpbiOut, CompVars.lpbiOut, SizeOf(TBitmapInfo)); 256 | end; 257 | 258 | procedure TVideoCoDec.CloseCompressor; 259 | begin 260 | if cv.hic > 0 then 261 | ICClose(cv.hic); 262 | cv.hic:=0; 263 | end; 264 | 265 | procedure TVideoCoDec.CloseDecompressor; 266 | begin 267 | if hICDec > 0 then 268 | ICClose(hICDec); 269 | hICDec:=0; 270 | end; 271 | 272 | procedure TVideoCoDec.CloseDrivers; 273 | begin 274 | CloseCompressor; 275 | CloseDecompressor; 276 | end; 277 | 278 | function TVideoCoDec.InternalInit(const HasComp: Boolean = false): Boolean; 279 | var info: TICINFO; 280 | lRealMaxPackedSize: Cardinal; 281 | begin 282 | FCodecName:=''; 283 | FCodecDescription:=''; 284 | 285 | CloseDecompressor; 286 | if not HasComp then 287 | begin 288 | CloseCompressor; 289 | cv.hic:=ICOpen(cv.fccType, cv.fccHandler, ICMODE_COMPRESS); 290 | end; 291 | hICDec:=ICOpen(cv.fccType, cv.fccHandler, ICMODE_DECOMPRESS); 292 | 293 | FKeyRateCounter:=1; 294 | 295 | // Retrieve compressor information. 296 | FillChar(info, SizeOf(info), 0); 297 | FLastError:=ICGetInfo(cv.hic, @info, SizeOf(info)); 298 | Result:=FLastError <> 0; 299 | if not Result then 300 | begin 301 | // SetLastError(); 302 | exit; 303 | end 304 | else 305 | FLastError:=0; 306 | 307 | FCodecName:=info.szName; 308 | FCodecDescription:=info.szDescription; 309 | 310 | FFlags:=info.dwFlags; 311 | if HasFlag(info.dwFlags, VIDCF_TEMPORAL) then 312 | if not HasFlag(info.dwFlags, VIDCF_FASTTEMPORALC) then 313 | // Allocate backbuffer 314 | ReallocMem(FPrevBuffer, cv.lpbiIn^.bmiHeader.biSizeImage); 315 | 316 | if not HasFlag(info.dwFlags, VIDCF_QUALITY) then 317 | cv.lQ:=0; 318 | 319 | // Allocate destination buffer 320 | 321 | FMaxPackedSize:=ICCompressGetSize(cv.hic, @(cv.lpbiIn^.bmiHeader), @(cv.lpbiOut^.bmiHeader)); 322 | 323 | // Work around a bug in Huffyuv. Ben tried to save some memory 324 | // and specified a "near-worst-case" bound in the codec instead 325 | // of the actual worst case bound. Unfortunately, it's actually 326 | // not that hard to exceed the codec's estimate with noisy 327 | // captures -- the most common way is accidentally capturing 328 | // static from a non-existent channel. 329 | // 330 | // According to the 2.1.1 comments, Huffyuv uses worst-case 331 | // values of 24-bpp for YUY2/UYVY and 40-bpp for RGB, while the 332 | // actual worst case values are 43 and 51. We'll compute the 333 | // 43/51 value, and use the higher of the two. 334 | 335 | if info.fccHandler = MKFOURCC('U', 'Y', 'F', 'H') then 336 | begin 337 | lRealMaxPackedSize:=cv.lpbiIn^.bmiHeader.biWidth * cv.lpbiIn^.bmiHeader.biHeight; 338 | 339 | if (cv.lpbiIn^.bmiHeader.biCompression = BI_RGB) then 340 | lRealMaxPackedSize:=(lRealMaxPackedSize * 51) shr 3 341 | else 342 | lRealMaxPackedSize:=(lRealMaxPackedSize * 43) shr 3; 343 | 344 | if lRealMaxPackedSize > FMaxPackedSize then 345 | FMaxPackedSize:=lRealMaxPackedSize; 346 | end; 347 | 348 | ReallocMem(FBuffCompOut, FMaxPackedSize); 349 | 350 | // Save configuration state. 351 | // 352 | // Ordinarily, we wouldn't do this, but there seems to be a bug in 353 | // the Microsoft MPEG-4 compressor that causes it to reset its 354 | // configuration data after a compression session. This occurs 355 | // in all versions from V1 through V3. 356 | // 357 | // Stupid fscking Matrox driver returns -1!!! 358 | 359 | cbConfigData:=ICGetStateSize(cv.hic); 360 | 361 | if cbConfigData > 0 then 362 | begin 363 | ReallocMem(pConfigData, cbConfigData); 364 | 365 | cbConfigData:=ICGetState(cv.hic, pConfigData, cbConfigData); 366 | // As odd as this may seem, if this isn't done, then the Indeo5 367 | // compressor won't allow data rate control until the next 368 | // compression operation! 369 | 370 | if cbConfigData <> 0 then 371 | ICSetState(cv.hic, pConfigData, cbConfigData); 372 | end; 373 | 374 | FMaxFrameSize:=0; 375 | FSlopSpace:=0; 376 | end; 377 | 378 | function TVideoCoDec.Init(CompVars: TCompVars): Boolean; 379 | begin 380 | Finish; 381 | SetCompVars(CompVars); 382 | Result:=InternalInit(CompVars.hic > 0); 383 | end; 384 | 385 | function TVideoCoDec.Init(InputFormat, OutputFormat: TBitmapInfo; 386 | const Quality, KeyRate: Integer): Boolean; 387 | begin 388 | cv.lQ:=Quality; 389 | cv.lKey:=KeyRate; 390 | cv.lpbiIn^:=InputFormat; 391 | cv.lpbiOut^:=OutputFormat; 392 | cv.fccType:=MKFOURCC('V', 'I', 'D', 'C'); 393 | cv.fccHandler:=OutputFormat.bmiHeader.biCompression; 394 | Result:=InternalInit; 395 | end; 396 | 397 | function TVideoCoDec.Init(InputFormat, OutputFormat: TBitmapInfoHeader; 398 | const Quality, KeyRate: Integer): Boolean; 399 | begin 400 | cv.lQ:=Quality; 401 | cv.lKey:=KeyRate; 402 | cv.lpbiIn^.bmiHeader:=InputFormat; 403 | cv.lpbiOut^.bmiHeader:=OutputFormat; 404 | cv.fccType:=MKFOURCC('V', 'I', 'D', 'C'); 405 | cv.fccHandler:=OutputFormat.biCompression; 406 | Result:=InternalInit; 407 | end; 408 | 409 | procedure TVideoCoDec.SetDataRate(const lDataRate, lUsPerFrame, 410 | lFrameCount: Integer); 411 | var ici: TICINFO; 412 | icf: TICCOMPRESSFRAMES; 413 | begin 414 | if cv.hic = 0 then exit; 415 | 416 | if (lDataRate > 0) and HasFlag(FFlags, VIDCF_CRUNCH) then 417 | FMaxFrameSize:=MulDiv(lDataRate, lUsPerFrame, 1000000) 418 | else 419 | FMaxFrameSize:=0; 420 | 421 | // Indeo 5 needs this message for data rate clamping. 422 | 423 | // The Morgan codec requires the message otherwise it assumes 100% 424 | // quality :( 425 | 426 | // The original version (2700) MPEG-4 V1 requires this message, period. 427 | // V3 (DivX) gives crap if we don't send it. So special case it. 428 | 429 | ICGetInfo(cv.hic, @ici, SizeOf(ici)); 430 | 431 | FillChar(icf, SizeOf(icf), 0); 432 | 433 | icf.dwFlags:=Cardinal(@icf.lKeyRate); 434 | icf.lStartFrame:=0; 435 | icf.lFrameCount:=lFrameCount; 436 | icf.lQuality:=cv.lQ; 437 | icf.lDataRate:=lDataRate; // = dwRate div dwScale 438 | icf.lKeyRate:=cv.lKey; 439 | icf.dwRate:=1000000; 440 | icf.dwScale:=lUsPerFrame; 441 | 442 | FLastError:=ICSendMessage(cv.hic, ICM_COMPRESS_FRAMES_INFO, WPARAM(@icf), SizeOf(TICCOMPRESSFRAMES)); 443 | end; 444 | 445 | procedure TVideoCoDec.Start; 446 | begin 447 | StartCompressor; 448 | StartDecompressor; 449 | end; 450 | 451 | function TVideoCoDec.StartCompressor: Boolean; 452 | begin 453 | FFrameNum:=0; 454 | FCompressorStarted:=false; 455 | 456 | // Start compression process 457 | FLastError:=ICCompressBegin(cv.hic, @(cv.lpbiIn^.bmiHeader), @(cv.lpbiOut^.bmiHeader)); 458 | Result:=FLastError = ICERR_OK; 459 | if not Result then exit; 460 | 461 | // Start decompression process if necessary 462 | if Assigned(FPrevBuffer) then 463 | begin 464 | FLastError:=ICDecompressBegin(cv.hic, @(cv.lpbiOut^.bmiHeader), @(cv.lpbiIn^.bmiHeader)); 465 | Result:=FLastError = ICERR_OK; 466 | if not Result then 467 | begin 468 | ICCompressEnd(cv.hic); 469 | exit; 470 | end; 471 | end; 472 | 473 | FCompressorStarted:=true; 474 | end; 475 | 476 | function TVideoCoDec.StartDecompressor: Boolean; 477 | begin 478 | // Start decompression process 479 | FLastError:=ICDecompressBegin(hICDec, @(cv.lpbiOut^.bmiHeader), @(cv.lpbiIn^.bmiHeader)); 480 | FDecompressorStarted:=FLastError = ICERR_OK; 481 | Result:=FDecompressorStarted; 482 | end; 483 | 484 | procedure TVideoCoDec.Finish; 485 | begin 486 | if FCompressorStarted then 487 | begin 488 | if Assigned(FPrevBuffer) then 489 | ICDecompressEnd(cv.hic); 490 | 491 | ICCompressEnd(cv.hic); 492 | 493 | FCompressorStarted:=false; 494 | // Reset MPEG-4 compressor 495 | if (cbConfigData > 0) and Assigned(pConfigData) then 496 | ICSetState(cv.hic, pConfigData, cbConfigData); 497 | end; 498 | 499 | if FDecompressorStarted then 500 | begin 501 | FDecompressorStarted:=false; 502 | ICDecompressEnd(hICDec); 503 | end; 504 | end; 505 | 506 | function TVideoCoDec.ChooseCodec: Boolean; 507 | var pc: TCompVars; 508 | begin 509 | Result:=not FCompressorStarted; 510 | if not Result then exit; 511 | 512 | pc:=cv; 513 | pc.dwFlags:=ICMF_COMPVARS_VALID; 514 | pc.lpbiIn:=nil; 515 | pc.hic:=0; 516 | pc.lpbiOut:=AllocMem(SizeOf(TBitmapInfo)); 517 | 518 | Result:=ICCompressorChoose(0, ICMF_CHOOSE_DATARATE or ICMF_CHOOSE_KEYFRAME, 519 | nil {maybe check input format ? @(cv.lpbiIn^.bmiHeader)}, nil, @pc, nil); 520 | 521 | // copy the original input format as it will be copied back in SetCompVars :) 522 | pc.lpbiIn:=AllocMem(SizeOf(TBitmapInfo)); 523 | CopyMemory(pc.lpbiIn, cv.lpbiIn, SizeOf(TBitmapInfo)); 524 | 525 | if Result then 526 | begin 527 | SetCompVars(pc); 528 | InternalInit(pc.hic > 0); 529 | end; 530 | ClearCompVars(pc); 531 | end; 532 | 533 | procedure TVideoCoDec.ConfigureCompressor; 534 | begin 535 | if cv.hic > 0 then 536 | FLastError:=ICConfigure(cv.hic, 0); 537 | end; 538 | 539 | function TVideoCoDec.CompressImage(ImageData: Pointer; Quality: Integer; 540 | var Size: Cardinal): HBITMAP; 541 | begin 542 | Result:=ICImageCompress(cv.hic, 0, @(cv.lpbiIn^.bmiHeader), ImageData, 543 | @(cv.lpbiOut^.bmiHeader), Quality, @Size); 544 | end; 545 | 546 | function TVideoCoDec.DecompressImage(ImageData: Pointer): HBITMAP; 547 | begin 548 | Result:=ICImageDecompress(hICDec, 0, @(cv.lpbiOut^.bmiHeader), ImageData, 549 | @(cv.lpbiIn^.bmiHeader)); 550 | end; 551 | 552 | procedure TVideoCoDec.DropFrame; 553 | begin 554 | if (cv.lKey > 0) and (FKeyRateCounter > 1) then 555 | Dec(FKeyRateCounter); 556 | Inc(FFrameNum); 557 | end; 558 | 559 | function TVideoCoDec.PackFrame(ImageData: Pointer; var IsKeyFrame: Boolean; 560 | var Size: Cardinal): Pointer; 561 | var 562 | dwChunkId: Cardinal; 563 | dwFlags: Cardinal; 564 | dwFlagsIn: Cardinal; 565 | sizeImage: Cardinal; 566 | lAllowableFrameSize: Cardinal; 567 | lKeyRateCounterSave: Cardinal; 568 | bNoOutputProduced: Boolean; 569 | begin 570 | Size:=0; 571 | Result:=nil; 572 | if not FCompressorStarted then exit; 573 | 574 | dwChunkId:=0; 575 | dwFlags:=0; 576 | dwFlagsIn:=ICCOMPRESS_KEYFRAME; 577 | lAllowableFrameSize:=0;//xFFFFFF; // yes, this is illegal according to the docs (see below) 578 | lKeyRateCounterSave:=FKeyRateCounter; 579 | 580 | // Figure out if we should force a keyframe. If we don't have any 581 | // keyframe interval, force only the first frame. Otherwise, make 582 | // sure that the key interval is lKeyRate or less. We count from 583 | // the last emitted keyframe, since the compressor can opt to 584 | // make keyframes on its own. 585 | 586 | if FForceKeyFrameRate then 587 | begin 588 | if (cv.lKey = 0) then 589 | begin 590 | if (FFrameNum > 0) then 591 | dwFlagsIn:=0; 592 | end 593 | else 594 | begin 595 | Dec(FKeyRateCounter); 596 | if (FKeyRateCounter > 0) then 597 | dwFlagsIn:=0 598 | else 599 | FKeyRateCounter:=cv.lKey; 600 | end; 601 | end 602 | else 603 | dwFlagsIn:=0; 604 | 605 | // Figure out how much space to give the compressor, if we are using 606 | // data rate stricting. If the compressor takes up less than quota 607 | // on a frame, save the space for later frames. If the compressor 608 | // uses too much, reduce the quota for successive frames, but do not 609 | // reduce below half datarate. 610 | if (FMaxFrameSize > 0) then 611 | begin 612 | lAllowableFrameSize:=FMaxFrameSize + (FSlopSpace shr 2); 613 | if (lAllowableFrameSize < (FMaxFrameSize shr 1)) then 614 | lAllowableFrameSize:=FMaxFrameSize shr 1; 615 | end; 616 | 617 | // A couple of notes: 618 | // 619 | // o ICSeqCompressFrame() passes 0x7FFFFFFF when data rate control 620 | // is inactive. Docs say 0. We pass 0x7FFFFFFF here to avoid 621 | // a bug in the Indeo 5 QC driver, which page faults if 622 | // keyframe interval=0 and max frame size = 0. 623 | 624 | sizeImage:=cv.lpbiOut^.bmiHeader.biSizeImage; 625 | 626 | // pbiOutput->bmiHeader.biSizeImage = 0; 627 | 628 | // Compress! 629 | 630 | if (dwFlagsIn > 0) then 631 | dwFlags:=AVIIF_KEYFRAME; 632 | 633 | FLastError:=ICCompress( 634 | cv.hic, dwFlagsIn, @(cv.lpbiOut^.bmiHeader), FBuffCompOut, 635 | @(cv.lpbiIn^.bmiHeader), ImageData, @dwChunkId, @dwFlags, FFrameNum, 636 | IIF(FFrameNum > 0, lAllowableFrameSize, $0FFFFFF), cv.lQ, 637 | IIF(HasFlag(dwFlagsIn, ICCOMPRESS_KEYFRAME), nil, @(cv.lpbiIn^.bmiHeader)), 638 | IIF(HasFlag(dwFlagsIn, ICCOMPRESS_KEYFRAME), nil, FPrevBuffer)); 639 | 640 | // Special handling for DivX 5 codec: 641 | // 642 | // A one-byte frame starting with 0x7f should be discarded 643 | // (lag for B-frame). 644 | 645 | bNoOutputProduced:=false; 646 | if (cv.lpbiOut^.bmiHeader.biCompression = MKFOURCC('0', '5', 'x', 'd')) or 647 | (cv.lpbiOut^.bmiHeader.biCompression = MKFOURCC('0', '5', 'X', 'D')) then 648 | begin 649 | if (cv.lpbiOut^.bmiHeader.biSizeImage = 1) and (FBuffCompOut^ = Char($7f)) then 650 | bNoOutputProduced:=true; 651 | end; 652 | 653 | // Special handling for XviD codec: 654 | // 655 | // Query codec for extended status. 656 | 657 | if bNoOutputProduced then 658 | begin 659 | cv.lpbiOut^.bmiHeader.biSizeImage:=sizeImage; 660 | FKeyRateCounter:=lKeyRateCounterSave; 661 | Result:=nil; 662 | exit; 663 | end; 664 | 665 | Inc(FFrameNum); 666 | 667 | Size:=cv.lpbiOut^.bmiHeader.biSizeImage; 668 | 669 | // If we're using a compressor with a stupid algorithm (Microsoft Video 1), 670 | // we have to decompress the frame again to compress the next one.... 671 | if (FLastError = ICERR_OK) and Assigned(FPrevBuffer) and 672 | ((cv.lKey = 0) or (FKeyRateCounter > 1)) then 673 | FLastError:=ICDecompress(cv.hic, 674 | IIF(HasFlag(dwFlags, AVIIF_KEYFRAME), 0, ICDECOMPRESS_NOTKEYFRAME), 675 | @(cv.lpbiOut^.bmiHeader), FBuffCompOut, @(cv.lpbiIn^.bmiHeader), FPrevBuffer); 676 | 677 | cv.lpbiOut^.bmiHeader.biSizeImage:=sizeImage; 678 | 679 | { 680 | if (res <> ICERR_OK) then 681 | raise Exception.Create('Video compression error'); 682 | } 683 | if FLastError <> ICERR_OK then 684 | begin 685 | Result:=nil; 686 | Size:=0; 687 | exit; 688 | end; 689 | 690 | // Update quota. 691 | 692 | if (FMaxFrameSize > 0) then 693 | begin 694 | FSlopSpace:=FSlopSpace + FMaxFrameSize - Size; 695 | end; 696 | 697 | // Was it a keyframe? 698 | if HasFlag(dwFlags, AVIIF_KEYFRAME) then 699 | begin 700 | IsKeyframe:=true; 701 | FKeyRateCounter:=cv.lKey; 702 | end 703 | else 704 | begin 705 | IsKeyframe:=false; 706 | end; 707 | 708 | // handle PB frames ( I263 and maybe some other codecs also) 709 | if (Size = 8) and (FBuffCompOut^ = #0) then 710 | Result:=PackFrame(ImageData, IsKeyFrame, Size) 711 | else 712 | Result:=FBuffCompOut; 713 | end; 714 | 715 | function TVideoCoDec.UnpackFrame(ImageData: Pointer; KeyFrame: Boolean; 716 | var Size: Cardinal): Pointer; 717 | begin 718 | Size:=cv.lpbiIn^.bmiHeader.biSizeImage; 719 | ReallocMem(FBuffDecompOut, Size); 720 | FLastError:=ICDecompress(hICDec, 721 | IIF(KeyFrame, 0, ICDECOMPRESS_NOTKEYFRAME), 722 | @(cv.lpbiOut^.bmiHeader), ImageData, @(cv.lpbiIn^.bmiHeader), FBuffDecompOut); 723 | 724 | 725 | Result:=nil; 726 | if (FLastError <> ICERR_OK) then 727 | begin 728 | Size:=0; 729 | exit; 730 | end; 731 | 732 | Result:=FBuffDecompOut; 733 | end; 734 | 735 | function TVideoCoDec.GetBitmapInfoIn: TBitmapInfo; 736 | begin 737 | Result:=cv.lpbiIn^; 738 | end; 739 | 740 | function TVideoCoDec.GetBitmapInfoOut: TBitmapInfo; 741 | begin 742 | Result:=cv.lpbiOut^; 743 | end; 744 | 745 | function TVideoCoDec.GetQuality: Integer; 746 | begin 747 | Result:=cv.lQ; 748 | end; 749 | 750 | procedure TVideoCoDec.SetQuality(const Value: Integer); 751 | begin 752 | cv.lQ:=Value; 753 | end; 754 | 755 | function TVideoCoDec.PackBitmap(Bitmap: TBitmap; var IsKeyFrame: Boolean; 756 | var Size: Cardinal): Pointer; 757 | begin 758 | if not Assigned(Bitmap) then 759 | begin 760 | Result:=nil; 761 | Size:=0; 762 | exit; 763 | end 764 | else 765 | Result:=PackFrame(Bitmap.ScanLine[0], IsKeyFrame, Size); 766 | end; 767 | 768 | function TVideoCoDec.UnpackBitmap(ImageData: Pointer; KeyFrame: Boolean; 769 | Bitmap: TBitmap): Boolean; 770 | var Size: Cardinal; 771 | lpData: Pointer; 772 | bmi: TBitmapInfo; 773 | bmih: TBitmapInfoHeader; 774 | usage, paintmode: Integer; 775 | begin 776 | Result:=Assigned(ImageData) and Assigned(Bitmap); 777 | if not Result then exit; 778 | try 779 | bmi:=BIInput; 780 | bmih:=bmi.bmiHeader; 781 | lpData:=UnpackFrame(ImageData, KeyFrame, Size); 782 | Result:=Assigned(lpData) and (Size > 0); 783 | if not Result then exit; 784 | usage:=IIF(bmih.biClrUsed = 0, DIB_RGB_COLORS, DIB_PAL_COLORS); 785 | PaintMode:=IIF(KeyFrame, SRCCOPY, MERGECOPY); 786 | with Bitmap do 787 | begin 788 | Width:=bmih.biWidth; 789 | Height:=bmih.biHeight; 790 | Result:=StretchDIBits(Canvas.Handle, 0, 0, bmih.biWidth, bmih.biHeight, 791 | 0, 0, bmih.biWidth, bmih.biHeight, lpData, bmi, usage, paintmode) > 0; 792 | end; 793 | except 794 | Result:=false; 795 | end; 796 | end; 797 | 798 | // typecast the List.Objects[I] as Cardinal to get the fccHandler code ! 799 | function TVideoCoDec.EnumCodecs(List: TStrings): Integer; 800 | var pII: TICINFO; 801 | c: Integer; 802 | ok: Boolean; 803 | fccType: TFourCC; 804 | hIC: Cardinal; 805 | begin 806 | c:=0; 807 | List.Clear; 808 | fccType.AsString:='vidc'; 809 | ZeroMemory(@pII, SizeOf(pII)); 810 | repeat 811 | ok:=ICInfo(fccType.AsCardinal, c, @pII); 812 | if ok then 813 | begin 814 | Inc(c); 815 | // open the compressor .. 816 | // should get all the info with ICInfo but it doesn't ?!?! 817 | // this slows the whole thing quite a bit .. about 0.5 - 1 sec ! 818 | hIC:=ICOpen(fccType.AsCardinal, pII.fccHandler, ICMODE_COMPRESS); 819 | if hIC > 0 then 820 | try 821 | if ICGetInfo(hIC, @pII, SizeOf(pII)) > 0 then 822 | List.AddObject(pII.szDescription, TObject(pII.fccHandler)); 823 | finally 824 | ICClose(hIC); 825 | end; 826 | end; 827 | until not ok; 828 | 829 | // return the number of installed codecs 830 | // the list can contain less codecs ! 831 | Result:=c; 832 | end; 833 | 834 | end. 835 | 836 | 837 | -------------------------------------------------------------------------------- /VideoCoDecDemo.cfg: -------------------------------------------------------------------------------- 1 | -$A8 2 | -$B- 3 | -$C+ 4 | -$D+ 5 | -$E- 6 | -$F- 7 | -$G+ 8 | -$H+ 9 | -$I+ 10 | -$J- 11 | -$K- 12 | -$L+ 13 | -$M- 14 | -$N+ 15 | -$O+ 16 | -$P+ 17 | -$Q- 18 | -$R- 19 | -$S- 20 | -$T- 21 | -$U- 22 | -$V+ 23 | -$W- 24 | -$X+ 25 | -$YD 26 | -$Z1 27 | -cg 28 | -AWinTypes=Windows;WinProcs=Windows;DbiTypes=BDE;DbiProcs=BDE;DbiErrs=BDE; 29 | -H+ 30 | -W+ 31 | -M 32 | -$M16384,1048576 33 | -K$00400000 34 | -E"c:\temp" 35 | -N"c:\temp" 36 | -LE"c:\arquivos de programas\borland\delphi7\Projects\Bpl" 37 | -LN"c:\arquivos de programas\borland\delphi7\Projects\Bpl" 38 | -w-UNSAFE_TYPE 39 | -w-UNSAFE_CODE 40 | -w-UNSAFE_CAST 41 | -------------------------------------------------------------------------------- /VideoCoDecDemo.dpr: -------------------------------------------------------------------------------- 1 | program VideoCoDecDemo; 2 | 3 | {%File 'Defines.inc'} 4 | 5 | uses 6 | Forms, 7 | SysUtils, 8 | Windows, 9 | VideoCoDec in 'VideoCoDec.pas', 10 | AviFileHandler in 'AviFileHandler.pas', 11 | dmMainU in 'dmMainU.pas' {dmMain: TDataModule}, 12 | DisplayU in 'DisplayU.pas' {DisplayF}, 13 | SettingsU in 'SettingsU.pas' {SettingsF}, 14 | CommonU in 'CommonU.pas', 15 | Preview in 'Preview.pas' {frmPreview}, 16 | ClientDM in 'ClientDM.pas' {dmClient: TDataModule}; 17 | 18 | {$R *.res} 19 | 20 | 21 | begin 22 | with Application do 23 | begin 24 | Initialize; 25 | CreateForm(TdmMain, dmMain); 26 | CreateForm(TdmClient, dmClient); 27 | CreateForm(TDisplayF, DisplayF); 28 | CreateForm(TfrmPreview, frmPreview); 29 | Run; 30 | end; 31 | end. 32 | 33 | -------------------------------------------------------------------------------- /VideoCoDecDemo.res: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/winddriver/delphi-dspack-video-streaming/d7164113f50341b2b3bbf6e17842b85c38cc2e48/VideoCoDecDemo.res -------------------------------------------------------------------------------- /VideoCodecClient.cfg: -------------------------------------------------------------------------------- 1 | -$A8 2 | -$B- 3 | -$C+ 4 | -$D+ 5 | -$E- 6 | -$F- 7 | -$G+ 8 | -$H+ 9 | -$I+ 10 | -$J- 11 | -$K- 12 | -$L+ 13 | -$M- 14 | -$N+ 15 | -$O+ 16 | -$P+ 17 | -$Q- 18 | -$R- 19 | -$S- 20 | -$T- 21 | -$U- 22 | -$V+ 23 | -$W- 24 | -$X+ 25 | -$YD 26 | -$Z1 27 | -cg 28 | -AWinTypes=Windows;WinProcs=Windows;DbiTypes=BDE;DbiProcs=BDE;DbiErrs=BDE; 29 | -H+ 30 | -W+ 31 | -M 32 | -$M16384,1048576 33 | -K$00400000 34 | -E"c:\temp" 35 | -N"c:\temp" 36 | -LE"c:\arquivos de programas\borland\delphi7\Projects\Bpl" 37 | -LN"c:\arquivos de programas\borland\delphi7\Projects\Bpl" 38 | -w-UNSAFE_TYPE 39 | -w-UNSAFE_CODE 40 | -w-UNSAFE_CAST 41 | -------------------------------------------------------------------------------- /VideoCodecClient.dpr: -------------------------------------------------------------------------------- 1 | program VideoCodecClient; 2 | 3 | uses 4 | Forms, 5 | ClientU in 'ClientU.pas' {ClientF}, 6 | CommonU in 'CommonU.pas', 7 | VideoCoDec in 'VideoCoDec.pas'; 8 | 9 | {$R *.res} 10 | 11 | begin 12 | Application.Initialize; 13 | Application.CreateForm(TClientF, ClientF); 14 | Application.Run; 15 | end. 16 | -------------------------------------------------------------------------------- /VideoCodecClient.res: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/winddriver/delphi-dspack-video-streaming/d7164113f50341b2b3bbf6e17842b85c38cc2e48/VideoCodecClient.res -------------------------------------------------------------------------------- /dmMainU.dfm: -------------------------------------------------------------------------------- 1 | object dmMain: TdmMain 2 | OldCreateOrder = False 3 | OnCreate = DataModuleCreate 4 | OnDestroy = DataModuleDestroy 5 | Left = 627 6 | Top = 108 7 | Height = 257 8 | Width = 229 9 | object fgMain: TFilterGraph 10 | Mode = gmCapture 11 | GraphEdit = True 12 | Left = 16 13 | Top = 16 14 | end 15 | object sgVideo: TSampleGrabber 16 | OnBuffer = sgVideoBuffer 17 | FilterGraph = fgMain 18 | MediaType.data = { 19 | 7669647300001000800000AA00389B715955593200001000800000AA00389B71 20 | FFFFFFFF00000000010000000000000000000000000000000000000000000000 21 | 0000000000000000} 22 | Left = 112 23 | Top = 16 24 | end 25 | object dsfCam: TFilter 26 | BaseFilter.data = { 27 | EC00000037D415438C5BD011BD3B00A0C911CE86D80000004000640065007600 28 | 6900630065003A0070006E0070003A005C005C003F005C007500730062002300 29 | 7600690064005F00300034003600640026007000690064005F00300038006200 30 | 300026006D0069005F0030003000230036002600320035003400340065003700 31 | 64006200260030002600300030003000300023007B0036003500650038003700 32 | 3700330064002D0038006600350036002D0031003100640030002D0061003300 33 | 620039002D003000300061003000630039003200320033003100390036007D00 34 | 5C0067006C006F00620061006C000000} 35 | FilterGraph = fgMain 36 | Left = 64 37 | Top = 16 38 | end 39 | object TCPServer: TIdTCPServer 40 | Bindings = <> 41 | CommandHandlers = <> 42 | CommandHandlersEnabled = False 43 | DefaultPort = 33000 44 | Greeting.NumericCode = 0 45 | MaxConnectionReply.NumericCode = 0 46 | OnExecute = TCPServerExecute 47 | ReplyExceptionCode = 0 48 | ReplyTexts = <> 49 | ReplyUnknownCommand.NumericCode = 0 50 | ThreadMgr = ThdMgr 51 | Left = 16 52 | Top = 72 53 | end 54 | object ThdMgr: TIdThreadMgrDefault 55 | Left = 64 56 | Top = 72 57 | end 58 | end 59 | -------------------------------------------------------------------------------- /dmMainU.pas: -------------------------------------------------------------------------------- 1 | unit dmMainU; 2 | 3 | interface 4 | 5 | {$I Defines.inc} 6 | {.$DEFINE MANUALYUY2TORGB} //debug ON /OFF 7 | 8 | uses 9 | Windows, Graphics, SysUtils, Classes, Forms, ExtCtrls, 10 | IdThreadMgr, IdThreadMgrDefault, IdBaseComponent, IdComponent, IdTCPServer, 11 | DSPack, DirectShow9, 12 | CommonU, VideoCoDec; 13 | 14 | type 15 | TYUY2Word = packed record 16 | Y : Byte; 17 | UV : Byte; 18 | end; 19 | 20 | PRGBTripleArray = ^TRGBTripleArray; 21 | TRGBTripleArray = array[0..32767] of TRGBTriple; 22 | 23 | TdmMain = class(TDataModule) 24 | fgMain: TFilterGraph; 25 | sgVideo: TSampleGrabber; 26 | dsfCam: TFilter; 27 | TCPServer: TIdTCPServer; 28 | ThdMgr: TIdThreadMgrDefault; 29 | procedure DataModuleCreate(Sender: TObject); 30 | procedure DataModuleDestroy(Sender: TObject); 31 | procedure TCPServerExecute(AThread: TIdPeerThread); 32 | procedure sgVideoBuffer(sender: TObject; SampleTime: Double; 33 | pBuffer: Pointer; BufferLen: Integer); 34 | private 35 | YUY2Stream: TMemoryStream; 36 | {$IFDEF MANUALYUY2TORGB} 37 | LastFrame: TBitmap; 38 | {$ENDIF} 39 | LastPacket: TFramePacket; 40 | public 41 | FrameWidth: Integer; 42 | FrameHeight: Integer; 43 | VideoCoDec: TVideoCoDec; 44 | procedure UpdateVideoFormat(InputFormat: TBitmapInfoHeader); 45 | end; 46 | 47 | var 48 | dmMain: TdmMain; 49 | MREWS: TMultiReadExclusiveWriteSynchronizer; 50 | 51 | implementation 52 | 53 | uses 54 | DisplayU, Preview; 55 | 56 | {$R *.dfm} 57 | 58 | {------------------------------------------------------------------------------- 59 | Procedure: YUY2ToBMP 60 | Author: Michael Andersen - slightly modified by Lee_Nover 61 | Date: 18-nov-2002 62 | Arguments: const aWidth, aHeight: Integer; MemBuf: TMemoryStream 63 | Result: TBitmap 64 | -------------------------------------------------------------------------------} 65 | 66 | {$IFDEF MANUALYUY2TORGB} 67 | function YUY2ToBMP(const aWidth, aHeight: Integer; MemBuf: TMemoryStream; bmp: TBitmap = nil): TBitmap; 68 | 69 | function FixValue(const x: Double): Byte; 70 | var 71 | v: Integer; 72 | begin 73 | v := Round(x); 74 | if v > 255 then 75 | Result := 255 76 | else if v < 0 then 77 | Result := 0 78 | else 79 | Result := Byte(v); 80 | end; 81 | 82 | var 83 | BufferYUV: array[0..32767] of TYUY2Word; 84 | i, j, Y, U, V: Integer; 85 | Row: PRGBTripleArray; 86 | begin 87 | // quick hack - change this 88 | if Assigned(bmp) then 89 | Result:=bmp 90 | else 91 | Result := TBitmap.Create; 92 | 93 | Result.PixelFormat := pf24Bit; 94 | Result.Width := aWidth; 95 | Result.Height := aHeight; 96 | 97 | MemBuf.Position := 0; 98 | for j := 0 to aHeight-1 do begin 99 | MemBuf.Read(BufferYUV, Round((SizeOf(BufferYUV) / 32768) * aWidth) ); 100 | 101 | Row := Result.Scanline[j]; 102 | 103 | for i := 0 to aWidth-1 do begin 104 | if i mod 2 = 0 then begin 105 | Y := BufferYUV[i].Y; 106 | U := BufferYUV[i].UV; 107 | V := BufferYUV[i+1].UV; 108 | end else begin 109 | Y := BufferYUV[i].Y; 110 | U := BufferYUV[i-1].UV; 111 | V := BufferYUV[i].UV 112 | end; 113 | 114 | with Row[i] do begin 115 | rgbtRed := FixValue( 1.164383 * (Y -16) + 1.596027 * (V-128) ); 116 | rgbtGreen := FixValue( 1.164383 * (Y - 16) - (0.391762 * (U-128)) - (0.812968 * (V-128)) ); 117 | rgbtBlue := FixValue( 1.164383 * (Y - 16) + 2.017232 * (U-128) ); 118 | end; 119 | end; 120 | end; 121 | end; 122 | {$ENDIF} 123 | 124 | procedure TdmMain.DataModuleCreate(Sender: TObject); 125 | begin 126 | ZeroMemory(@LastPacket, SizeOf(TFramePacket)); 127 | VideoCoDec := TVideoCoDec.Create; 128 | MREWS := TMultiReadExclusiveWriteSynchronizer.Create; 129 | YUY2Stream := TMemoryStream.Create; 130 | {$IFDEF MANUALYUY2TORGB} 131 | LastFrame := TBitmap.Create; 132 | {$ENDIF} 133 | TCPServer.DefaultPort := 33000; 134 | //TCPServer.Active := True; 135 | end; 136 | 137 | procedure TdmMain.DataModuleDestroy(Sender: TObject); 138 | begin 139 | TCPServer.Active := False; 140 | FreeAndNil(MREWS); 141 | {$IFDEF MANUALYUY2TORGB} 142 | FreeAndNil(LastFrame); 143 | {$ENDIF} 144 | FreeAndNil(YUY2Stream); 145 | FreeAndNil(VideoCoDec); 146 | 147 | sgVideo.MediaType := nil; 148 | end; 149 | 150 | procedure TdmMain.TCPServerExecute(AThread: TIdPeerThread); 151 | var 152 | CH: TCommHeader; 153 | FP: TFramePacket; 154 | bmih: TBitmapInfoHeader; 155 | begin 156 | // ALL messages should have a standard packet (easier coding) 157 | AThread.Connection.ReadBuffer(CH, SizeOf(CH)); 158 | // check what the client wants 159 | 160 | case CH.DPType of 161 | 1: // the client wants frame format and refresh rate 162 | begin 163 | bmih := VideoCoDec.BIOutput.bmiHeader; 164 | // set the size of the data part to the size of the header 165 | CH.DPSize := SizeOf(bmih); 166 | CH.DPExtra := 30; // hardcoded .. find out the real RR from the source 167 | // send the header 168 | SendData(AThread.Connection, CH, @bmih); 169 | end; 170 | 171 | 2: // request for frame 172 | begin 173 | // synch the copying of the last frame 174 | MREWS.BeginRead; 175 | try 176 | FP := CopyFrame(LastPacket); 177 | finally 178 | MREWS.EndRead; 179 | end; 180 | // send the frame 181 | SendFrame(AThread.Connection, CH, FP); 182 | // free the copied packet 183 | FreeFrame(FP); 184 | end; 185 | end; 186 | end; 187 | 188 | procedure TdmMain.UpdateVideoFormat(InputFormat: TBitmapInfoHeader); 189 | var 190 | bmihOut: TBitmapInfoHeader; 191 | FrameRate: Integer; 192 | begin 193 | bmihOut := InputFormat; 194 | InputFormat.biCompression := 0; 195 | FrameRate := 30; 196 | VideoCoDec.Finish; 197 | VideoCoDec.ForceKeyFrameRate := true; 198 | VideoCoDec.Init(InputFormat, bmihOut, 100, 10); 199 | VideoCoDec.SetDataRate(1024, 1000 * 1000 div FrameRate, 1); 200 | if not VideoCoDec.StartCompressor then 201 | DisplayF.Caption := TranslateICError(VideoCoDec.LastError) 202 | else 203 | //DisplayF.Caption := VideoCoDec.CodecDescription; 204 | DisplayF.Caption := 'Delphi Streaming'; 205 | 206 | frmPreview.ClientHeight := InputFormat.biHeight; 207 | frmPreview.ClientWidth := InputFormat.biWidth; 208 | end; 209 | 210 | procedure TdmMain.sgVideoBuffer(sender: TObject; SampleTime: Double; 211 | pBuffer: Pointer; BufferLen: Integer); 212 | var 213 | p: PByte; 214 | begin 215 | if not VideoCoDec.CompressorStarted then 216 | Exit; 217 | 218 | {$IFDEF MANUALYUY2TORGB} 219 | // the data is in YUY2 format because of overlay so we need to convert it to RGB 220 | YUY2Stream.Clear; 221 | YUY2Stream.Write(pBuffer^, BufferLen); 222 | YUY2ToBMP(FrameWidth, FrameHeight, YUY2Stream, LastFrame); 223 | {$ENDIF} 224 | 225 | MREWS.BeginWrite; // remove to gain performance but at desynch risk 226 | with LastPacket do 227 | try 228 | {$IFDEF MANUALYUY2TORGB} 229 | p := VideoCoDec.PackBitmap(LastFrame, KeyFrame, Size); 230 | {$ELSE} 231 | p := VideoCoDec.PackFrame(pBuffer, KeyFrame, Size); 232 | {$ENDIF} 233 | if Size < 1 then 234 | Exit; 235 | ReallocMem(Data, Size); 236 | CopyMemory(Data, p, Size); 237 | finally 238 | MREWS.EndWrite; // remove to gain performance but at desynch risk 239 | end; 240 | end; 241 | 242 | end. 243 | --------------------------------------------------------------------------------