12 respuestas en este tema

[seoane]

Hace algún tiempo me pidió un amigo que le hiciera un dvd con algunas fotos de sus productos, el típico "slideshow" para poner en una televisión y que los clientes le echen un vistazo. Lo normal hubiera sido usar uno de los mil programas que hay para hacer esto en le mercado, en los que solo tienes que agregar las fotos y ya te graban el dvd con su menú y todo. Pero como ya sabéis a veces me gusta matar moscas a cañonazos, y como ningún programa terminaba de darme el resultado que buscaba, y estaba con mucho tiempo libre me decidí por crear mi propio programa.

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:

delphi

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:= &#39;0&#39; + Result;
  Result:= AppPath + &#39;seq\&#39; + Result + &#39;.bmp&#39;;
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(&#39;%sFrames=%d Tamaño=%d Kb&#39;,[#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:= &#39;Arial&#39;;
    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:= &#39;Arial&#39;;
    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:= &#39;Arial&#39;;
    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 + &#39;seq\*.*&#39;, faArchive, SR) = 0 then
  repeat
    DeleteFile(AppPath + &#39;seq\&#39; + SR.Name);
    inc(Count);
  until FindNext(SR) <> 0;
  FindClose(SR);
  Writeln(Format(&#39;%d Archivo(s) borrado(s)&#39;,[Count]));
end;
 
// Carga la lista de imagenes a partir del directorio img
procedure LoadList(Path: string);
var
  SR: TSearchRec;
begin
  if FindFirst(AppPath + Path + &#39;*.*&#39;, 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(&#39;El tamaño de cada frame es: %d Kb&#39;,[FrameSize shr 10]));
  Writeln;
  Writeln(&#39;Progreso ...&#39;);
  //FileToBitmap(FixedFrame,AppPath + &#39;\img\imagen_fija.bmp&#39;);
  //FixedFrame.PixelFormat:= pf24bit;
  LoadList(&#39;img\&#39;);
  //ShowFixedFrame:= TRUE;
  Sequence(ImgList.Count);  // Generamos una sola secuencia con todas las imagenes
  {
   O por ejemplo:
  FadeLastFrame($C0C0C0,32);
  TextSlide(&#39;Iberco&#39;, clBlack, 96);
  Sequence(4);
  FadeLastFrame($C0C0C0,32);
  TextSlide(&#39;Iberco&#39;, clBlack, 96);
  Sequence(4);
  }
end;
 
begin
  Writeln;
  Writeln(&#39;Creando secuencia de imagenes ...&#39;);
  AppPath:= IncludeTrailingBackSlash(ExtractFilePath(ParamStr(0)));
  Writeln(&#39;El directorio base es: &#39; + 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(&#39;Pulsa "enter" para finalizar ...&#39;);
  Writeln;
  Readln;
  // Aqui abrimos el virtualdub para crear el fichero de video
  ShellExecute(0,nil,&#39;D:\VirtualDub-1.9.10\VirtualDub.exe&#39;,
    &#39;"D:\make\seq\00000000.bmp"&#39;,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 

Archivos adjuntos

•  1854_3a23134811c9d96c026f64ffd5cd28ef11c3ea89.zip   123,88KB   8 descargas

[egostar]

A ver si entendí amigo, creo una carpeta img para las imagenes, una carpeta seq para los frames creados y el programa VirtualDub dentro del directorio de esta aplicación ?

Salud OS

[seoane]

Si descomprimes el zip ya tienes una carpeta img y otra seq dentro, no hace falta que las crees, solo tienes que meter fotos en la carpeta img.

El virtualdub puede estar en la carpeta que tu quieras, solo tienes que abrir el primer fichero bmp de la carpeta frames y listo. Si te fijas en el código yo lo llamo directamente, pero hay que cambiar la ruta dependiendo de donde tengas instalado el virtualdub

[egostar]

Si, ya me di cuenta de eso

Pero si que consume buena cantidad de espacio, con solo 10 fotos ocupó la friolera de 3GB para crear los frames y el video (AVI) tambien 

Que lástima, quería subirles el slideshow, pero bueno les muestro de qué imágenes es

Salud OS

Archivos adjuntos

•  1857_37a5e14321aed1858843f79cb24a36e6541c5873.jpg   50,52KB   23 descargas
•  1855_169ffe7256c089f69415a271b88955f026d63cbb.jpg   58,94KB   12 descargas

[felipe]

Cada día nos asombras más amigo

Sería interesante aplicar el concepto que usas del fade en algo como un Panel o similar, de la misma forma en que funciona el AlphaBlend del formulario.


Saludos!

[seoane]

Interesantes imágenes egostar

Lo del tamaño del avi puedes solucionarlo escogiendo un buen compresor en el virtualdub, en el menu "Video/Compresion" ahi puedes escoger, si lo tienes instalado, el divx o el xvid, o cualquiera similar. Por defecto no comprime nada así que el avi tienen el mismo tamaño que las imágenes originales.

[egostar]

Interesantes imágenes egostar

Lo del tamaño del avi puedes solucionarlo escogiendo un buen compresor en el virtualdub, en el menu "Video/Compresion" ahi puedes escoger, si lo tienes instalado, el divx o el xvid, o cualquiera similar. Por defecto no comprime nada así que el avi tienen el mismo tamaño que las imágenes originales.

Ah, bueno vere que se puede hacer, no tengo instalados esos compresores, utilice uno de los que tiene y lo redujo a 1.5 MB, pero el video se ve al revés, que cosas 

Salud OS

Archivos adjuntos

•  1860_02e1619eefb98c7c3d1bb5b56f11218681a855d9.jpg   43,26KB   14 descargas

[escafandra]

Buen ejemplo seoane

Sería interesante aplicar el concepto que usas del fade en algo como un Panel o similar, de la misma forma en que funciona el AlphaBlend del formulario.

Puedes revisar este tema para ver como realizar efectos de transparencias, en concreto usando la API AlphaBlend.

Saludos.

[felipe]

Buen ejemplo seoane

Sería interesante aplicar el concepto que usas del fade en algo como un Panel o similar, de la misma forma en que funciona el AlphaBlend del formulario.

Puedes revisar este tema para ver como realizar efectos de transparencias, en concreto usando la API AlphaBlend.

Saludos.

Gracias amigo por recordarmelo

Sirve mucho para "jugar" con el diseño de interfaces.


Saludos!

[seoane]

Puedes revisar este tema para ver como realizar efectos de transparencias, en concreto usando la API AlphaBlend.

Gracias, ya no me acordaba de ese tema. Y eso que en su momento te di las gracias :-D

[felipe]

egostar, aún esperamos el video


Saludos!

[egostar]

egostar, aún esperamos el video


Saludos!

Pues parece que será mejor que te envíe un DVD por mensajería

Salud OS

[felipe]

egostar, aún esperamos el video


Saludos!

Pues parece que será mejor que te envíe un DVD por mensajería

Salud OS

Pues usa el Format Factory



Saludos!