
Por supuesto que no me metí a crear el archivo de vídeo directamente, eso seria demasiado trabajo, lo que pensé fue en generar uno a uno los diferentes frames del vídeo y que luego otro programa, virtualdub por ejemplo, se encargara de ensamblarlos en un solo archivo de vídeo.
Luego le añadí unos cuantos efectos y transiciones, y el resultado es esto:
program make; {$APPTYPE CONSOLE} uses Windows, SysUtils, Classes, Graphics, Jpeg, ShellApi; type Triplet = array[1..3]of Byte; const // El tamaño adecuado para un dvd FrameHeight = 576; FrameWidth = 720; var AppPath: string; ImgList: TStringList; LastFrame: TBitmap; FixedFrame: TBitmap; ShowFixedFrame: Boolean; Index: Cardinal; FrameSize: Cardinal; function IndexToStr(Index: Cardinal): string; begin Result:= IntToStr(Index); while Length(Result) < 8 do Result:= '0' + Result; Result:= AppPath + 'seq\' + Result + '.bmp'; end; // Transicion entre dos imagenes procedure Fade(Bitmap1, Bitmap2: TBitmap; Step: Integer; Transparent: Boolean); var P1, P2: ^Triplet; i, j: Integer; begin for j:= 0 to Bitmap1.Height - 1 do begin P1:= Bitmap1.ScanLine[j]; P2:= Bitmap2.ScanLine[j]; for i:= 0 to Bitmap1.Width - 1 do begin if not (Transparent and (P2^[1] = $FF)) then begin inc(P1^[1], Byte(((P2^[1] - P1^[1]) * Step) shr 6)); inc(P1^[2], Byte(((P2^[2] - P1^[2]) * Step) shr 6)); inc(P1^[3], Byte(((P2^[3] - P1^[3]) * Step) shr 6)); end; inc(P1); inc(P2); end; end; end; // Escribe el frame a disco, si tenemos una libreria para crear AVIs podriamos // enviar le frame directamente sin pasar por el disco. procedure WriteFrame(Bitmap: TBitmap); begin Write(Format('%sFrames=%d Tamaño=%d Kb',[#13,Index, (Index + 1) * (FrameSize shr 10)])); if ShowFixedFrame then Fade(Bitmap, FixedFrame, 64, TRUE); Bitmap.SaveToFile(IndexToStr(Index)); inc(Index); end; function GetFrameSize: Cardinal; var Mem: TMemoryStream; begin Mem:= TMemoryStream.Create; try LastFrame.SaveToStream(Mem); Result:= Mem.Size; finally Mem.Free; end; end; // Inicializa el ultimo frame procedure InitLastFrame(Color: TColor); begin with LastFrame do begin PixelFormat:= pf24bit; Width:= FrameWidth; Height:= FrameHeight; Canvas.Brush.Color:= Color; Canvas.FillRect(Canvas.ClipRect); end; end; // Hace una transcion a un color (Ej: un fundido a negro) procedure FadeLastFrame(Color: TColor; Step: Integer); var P: ^Triplet; i, j, k: Integer; R,G,B: Byte; Bitmap: TBitmap; begin R:= GetRValue(Color); G:= GetGValue(Color); B:= GetBValue(Color); Bitmap:= TBitmap.Create; try Bitmap.Assign(LastFrame); for k:= 1 to Step do begin LastFrame.Assign(Bitmap); for j:= 0 to LastFrame.Height - 1 do begin P:= LastFrame.ScanLine[j]; for i:= 0 to LastFrame.Width - 1 do begin inc(P^[1], Byte((( R - P^[1]) * k) shr 6)); inc(P^[2], Byte((( G - P^[2]) * k) shr 6)); inc(P^[3], Byte((( B - P^[3]) * k) shr 6)); inc(P); end; end; WriteFrame(LastFrame); end; finally Bitmap.Free; end; end; // Carga un fichero en un bitmap procedure FileToBitmap(Bitmap: TBitmap; Filename: string); var Image: TPicture; begin Image:= TPicture.Create; try Image.LoadFromFile(Filename); Bitmap.Width:= Image.Width; Bitmap.Height:= Image.Height; Bitmap.Canvas.Draw(0,0,Image.Graphic); finally Image.Free; end; end; // Ajusta el bitmap a las mediddas correctas, recortandolo si es necesario procedure BitmapToFrame(Bitmap, Frame: TBitmap; Zoom: Real; Align: Integer); var Ancho, Alto: integer; i, j: integer; begin Ancho:= FrameWidth; Alto:= FrameHeight; if (Ancho/Bitmap.Width) > (Alto/Bitmap.Height) then Alto:= Trunc((Ancho*Bitmap.Height)/Bitmap.Width) else Ancho:= Trunc((Bitmap.Width*Alto)/Bitmap.Height); Ancho:= Trunc(Ancho * Zoom); Alto:= Trunc(Alto * Zoom); Frame.Width:= FrameWidth; Frame.Height:= FrameHeight; i:= ((Frame.Width - Ancho)) * Align div 128; j:= ((Frame.Height - Alto)) * Align div 128; Frame.Canvas.StretchDraw(Rect(i,j,Ancho + i,Alto + j),Bitmap); end; // Repite el ultimo frame tantas veces como se le indique procedure Loop(Frames: Integer); begin while Frames > 0 do begin WriteFrame(LastFrame); dec(Frames); end; end; // Hace la transicion entre el ultimo frame y el bitmap que se le pasa como parametro procedure Transition(Bitmap: TBitmap); var i: integer; Frame: TBitmap; begin Frame:= TBitmap.Create; try for i:= 1 to 64 do begin Frame.Assign(LastFrame); Fade(Frame,Bitmap,i, FALSE); WriteFrame(Frame); end; LastFrame.Assign(Bitmap); WriteFrame(LastFrame); finally Frame.Free; end; end; // Muestra un texto que va apareciendo con una transicion procedure TextAnimation(Text: string; Color: TColor; Size: Integer); var Bitmap: TBitmap; begin Bitmap:= TBitmap.Create; with Bitmap, Bitmap.Canvas do try Bitmap.Assign(LastFrame); Font.Name:= 'Arial'; Font.Size:= Size; Font.Color:= Color; Font.Style:= [fsBold]; Brush.Style:= bsClear; TextOut((Width - TextWidth(Text)) shr 1, (Height - TextHeight(Text)) shr 1, Text); Transition(Bitmap); finally Free; end; end; // Muestra un texto que va aparecido letra a letra procedure TypeWriter(Text: string; Color: TColor; Size: Integer); var i: integer; Bitmap: TBitmap; begin Bitmap:= TBitmap.Create; with Bitmap,Bitmap.Canvas do try Font.Name:= 'Arial'; Font.Size:= Size; Font.Color:= Color; Font.Style:= [fsBold]; Brush.Style:= bsClear; i:= (LastFrame.Width - TextWidth(Text)) shr 1; while Length(Text) > 0 do begin if Copy(Text,1,1) <> #32 then begin Bitmap.Assign(LastFrame); TextOut(i,(Height - TextHeight(Copy(Text,1,1))) shr 1, Copy(Text,1,1)); Transition(Bitmap); end; inc(i,TextWidth(Copy(Text,1,1))); Delete(Text,1,1); end; finally Free; end; end; // Muestraa un texto que va apareciendo letra a letra deslizandose procedure TextSlide(Text: string; Color: TColor; Size: Integer); var i,j: integer; Bitmap: TBitmap; begin Bitmap:= TBitmap.Create; with Bitmap,Bitmap.Canvas do try Font.Name:= 'Arial'; Font.Size:= Size; Font.Color:= Color; Font.Style:= [fsBold]; Brush.Style:= bsClear; i:= (LastFrame.Width - TextWidth(Text)) shr 1; while Length(Text) > 0 do begin if Copy(Text,1,1) <> #32 then begin for j:= 32 downto 0 do begin Bitmap.Assign(LastFrame); TextOut(i + (((Width - i)*j) shr 5), (Height - TextHeight(Copy(Text,1,1))) shr 1, Copy(Text,1,1)); WriteFrame(Bitmap); end; LastFrame.Assign(Bitmap); end; inc(i,TextWidth(Copy(Text,1,1))); Delete(Text,1,1); end; finally Free; end; end; // Acerca la imagen procedure Zoom(Bitmap: TBitmap; Steps: Integer); var i: integer; Frame: TBitmap; begin Frame:= TBitmap.Create; try Frame.PixelFormat:= pf24bit; for i:= 1 to Steps do begin BitmapToFrame(Bitmap,Frame,1 + ((0.5 * i) / Steps),64); WriteFrame(Frame); end; LastFrame.Assign(Frame); finally Frame.Free end; end; // Mueve la "camara" por la imagen procedure Paneo(Bitmap: TBitmap; Steps: Integer); var i: integer; Frame: TBitmap; begin Frame:= TBitmap.Create; try Frame.PixelFormat:= pf24bit; for i:= 1 to Steps do begin BitmapToFrame(Bitmap,Frame,1 + ((0.5 * i) / Steps),i*128 div Steps); WriteFrame(Frame); end; LastFrame.Assign(Frame); finally Frame.Free end; end; // Crea una secuencia a partir de las imagenes en la lista // Con el parametro coun le decimos cuantas imagenes debe usar procedure Sequence(Count: integer); var Bitmap: TBitmap; Frame: TBitmap; begin Bitmap:= TBitmap.Create; Frame:= TBitmap.Create; try Bitmap.PixelFormat:= pf24bit; Frame.PixelFormat:= pf24bit; while (ImgList.Count > 0) and (Count > 0) do begin FileToBitmap(Bitmap,ImgList[0]); BitmapToFrame(Bitmap,Frame,1,64); Transition(Frame); Loop(64); if Random(2)=0 then Zoom(Bitmap,128) else Paneo(Bitmap,128); ImgList.Delete(0); Dec(Count); end; finally Bitmap.Free; Frame.Free; end; end; // Muestra una imagen estatica durante varios frames procedure InsertBanner(Banner: string; Frames: Integer); var Bitmap: TBitmap; Frame: TBitmap; begin Bitmap:= TBitmap.Create; Frame:= TBitmap.Create; try Bitmap.PixelFormat:= pf24bit; Frame.PixelFormat:= pf24bit; FileToBitmap(Bitmap,Banner); BitmapToFrame(Bitmap,Frame,1,64); Transition(Frame); Loop(Frames); finally Bitmap.Free; Frame.Free; end; end; procedure DeleteAll; var SR: TSearchRec; Count: Cardinal; begin Count:= 0; if FindFirst(AppPath + 'seq\*.*', faArchive, SR) = 0 then repeat DeleteFile(AppPath + 'seq\' + SR.Name); inc(Count); until FindNext(SR) <> 0; FindClose(SR); Writeln(Format('%d Archivo(s) borrado(s)',[Count])); end; // Carga la lista de imagenes a partir del directorio img procedure LoadList(Path: string); var SR: TSearchRec; begin if FindFirst(AppPath + Path + '*.*', faArchive, SR) = 0 then repeat ImgList.Add(AppPath + Path + SR.Name); until FindNext(SR) <> 0; FindClose(SR); end; // Aqui hacemos el "script" que se debe seguir procedure Script; begin Index:= 0; DeleteAll; InitLastFrame(clBlack); FrameSize:= GetFrameSize; Writeln(Format('El tamaño de cada frame es: %d Kb',[FrameSize shr 10])); Writeln; Writeln('Progreso ...'); //FileToBitmap(FixedFrame,AppPath + '\img\imagen_fija.bmp'); //FixedFrame.PixelFormat:= pf24bit; LoadList('img\'); //ShowFixedFrame:= TRUE; Sequence(ImgList.Count); // Generamos una sola secuencia con todas las imagenes { O por ejemplo: FadeLastFrame($C0C0C0,32); TextSlide('Iberco', clBlack, 96); Sequence(4); FadeLastFrame($C0C0C0,32); TextSlide('Iberco', clBlack, 96); Sequence(4); } end; begin Writeln; Writeln('Creando secuencia de imagenes ...'); AppPath:= IncludeTrailingBackSlash(ExtractFilePath(ParamStr(0))); Writeln('El directorio base es: ' + AppPath); LastFrame:= TBitmap.Create; FixedFrame:= TBitmap.Create; ImgList:= TStringList.Create; try ShowFixedFrame:= FALSE; Script; finally ImgList.Free; LastFrame.Free; FixedFrame.Free; end; Writeln; Writeln; Writeln('Pulsa "enter" para finalizar ...'); Writeln; Readln; // Aqui abrimos el virtualdub para crear el fichero de video ShellExecute(0,nil,'D:\VirtualDub-1.9.10\VirtualDub.exe', '"D:\make\seq\00000000.bmp"',nil, SW_SHOW); end.
Es una aplicación de consola. Las imágenes la toma de la carpeta "img" que tiene que estar en el mismo directorio que la aplicación y los frames generados los guarda en la carpeta "seq". En el procedure "script" es donde configuramos las diferentes secuencias y efectos.
Un consejo, hacer esto en un disco con abundante espacio libre. Unas pocas fotos, 20 o 30, pueden generar varios Gigabytes de frames así que tener esto en cuenta a la hora de escoger la localización de las carpetas. Pero no os preocupéis, una vez cargado en el virtualdub podemos escoger un buen compresor (divx, xvid, etc ...) y el archivo avi resultante sera mucho mas pequeño.
Como ya he dicho, es reinventar la rueda, pero ... yo soy asi
