Autor Tema: [Delphi] Base64 Image Encoder 0.2  (Leído 2481 veces)

0 Usuarios y 1 Visitante están viendo este tema.

BigBear

  • **
  • Mensajes: 165
  • Liked: 47
[Delphi] Base64 Image Encoder 0.2
« : septiembre 17, 2016, 04:15:08 pm »
Un programa en Delphi para codificar cualquier imagen a Base64 para usar en HTML , se puede copiar el codigo en el portapapeles o guardar en un archivo desde el programa mismo.

Una imagen :



El codigo :

Código: delphi [Seleccionar]

// Base64 Image Encoder 0.2
// (C) Doddy Hackman 2016

unit encoder;

interface

uses
  Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants,
  System.Classes, Vcl.Graphics,
  Vcl.Forms, Vcl.Dialogs, Vcl.StdCtrls,
  Vcl.Menus, Vcl.Controls, Vcl.Styles.Utils.ComCtrls, Vcl.Styles.Utils.Menus,
  Vcl.Styles.Utils.SysStyleHook,
  Vcl.Styles.Utils.SysControls, Vcl.Styles.Utils.Forms,
  Vcl.Styles.Utils.StdCtrls, Vcl.Styles.Utils.ScreenTips, IdCoderMIME, ShellApi,
  Vcl.ImgList, Vcl.ExtCtrls, Vcl.Imaging.pngimage;

type
  TFormHome = class(TForm)
    gbEnterFilename: TGroupBox;
    txtFilename: TEdit;
    btnLoad: TButton;
    gbOutput: TGroupBox;
    mmOutput: TMemo;
    btnEncode: TButton;
    pmOptions: TPopupMenu;
    copy: TMenuItem;
    save: TMenuItem;
    odLoad: TOpenDialog;
    clear: TMenuItem;
    sdSave: TSaveDialog;
    ilIconos: TImageList;
    imgLogo: TImage;
    procedure btnEncodeClick(Sender: TObject);
    procedure btnLoadClick(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure clearClick(Sender: TObject);
    procedure copyClick(Sender: TObject);
    procedure saveClick(Sender: TObject);
  private
    procedure DragDropFile(var Msg: TMessage); message WM_DROPFILES;
  public
    { Public declarations }
  end;

var
  FormHome: TFormHome;

implementation

{$R *.dfm}
// Functions

function message_box(title, message_text, type_message: string): string;
begin
  if not(title = '') and not(message_text = '') and not(type_message = '') then
  begin
    try
      begin
        if (type_message = 'Information') then
        begin
          MessageBox(FormHome.Handle, PChar(message_text), PChar(title),
            MB_ICONINFORMATION);
        end
        else if (type_message = 'Warning') then
        begin
          MessageBox(FormHome.Handle, PChar(message_text), PChar(title),
            MB_ICONWARNING);
        end
        else if (type_message = 'Question') then
        begin
          MessageBox(FormHome.Handle, PChar(message_text), PChar(title),
            MB_ICONQUESTION);
        end
        else if (type_message = 'Error') then
        begin
          MessageBox(FormHome.Handle, PChar(message_text), PChar(title),
            MB_ICONERROR);
        end
        else
        begin
          MessageBox(FormHome.Handle, PChar(message_text), PChar(title),
            MB_ICONINFORMATION);
        end;
        Result := '[+] MessageBox : OK';
      end;
    except
      begin
        Result := '[-] Error';
      end;
    end;
  end
  else
  begin
    Result := '[-] Error';
  end;
end;

// Function to DragDrop

// Based in : http://www.clubdelphi.com/foros/showthread.php?t=85665
// Thanks to ecfisa

var
  bypass_window: function(Msg: Cardinal; dwFlag: Word): BOOL; stdcall;

procedure TFormHome.DragDropFile(var Msg: TMessage);
var
  nombre_archivo, extension: string;
  limite, number: integer;
  path: array [0 .. MAX_COMPUTERNAME_LENGTH + MAX_PATH] of char;
begin
  limite := DragQueryFile(Msg.WParam, $FFFFFFFF, path, 255) - 1;
  if (Win32MajorVersion = 6) and (Win32MinorVersion > 0) then
    for number := 0 to limite do
    begin
      bypass_window(number, 1);
    end;
  for number := 0 to limite do
  begin
    DragQueryFile(Msg.WParam, number, path, 255);

    //

    if (FileExists(path)) then
    begin
      nombre_archivo := ExtractFilename(path);
      extension := ExtractFileExt(path);
      extension := StringReplace(extension, '.', '',
        [rfReplaceAll, rfIgnoreCase]);
      if (extension = 'jpg') or (extension = 'png') or (extension = 'bmp') then
      begin
        txtFilename.Text := path;
        message_box('Base64 Image Encoder 0.2', 'Image loaded', 'Information');
      end
      else
      begin
        message_box('Base64 Image Encoder 0.2', 'The image is not valid',
          'Warning');
      end;
    end;

    //

  end;
  DragFinish(Msg.WParam);
end;

function base64_encodefile(filename: String): String;
var
  stream: TFileStream;
  base64: TIdEncoderMIME;
  output: string;
begin
  if (FileExists(filename)) then
  begin
    try
      begin
        base64 := TIdEncoderMIME.Create(nil);
        stream := TFileStream.Create(filename, fmOpenRead);
        output := TIdEncoderMIME.EncodeStream(stream);
        stream.Free;
        base64.Free;
        if not(output = '') then
        begin
          Result := output;
        end
        else
        begin
          Result := 'Error';
        end;
      end;
    except
      begin
        Result := 'Error';
      end;
    end;
  end
  else
  begin
    Result := 'Error';
  end;
end;

function savefile(archivo, texto: string): BOOL;
var
  open_file: TextFile;
begin
  try
    begin
      AssignFile(open_file, archivo);
      FileMode := fmOpenWrite;

      if FileExists(archivo) then
      begin
        Append(open_file);
      end
      else
      begin
        Rewrite(open_file);
      end;
      Write(open_file, texto);
      CloseFile(open_file);
      Result := True;
    end;
  except
    Result := False;
  end;
end;

//

procedure TFormHome.btnEncodeClick(Sender: TObject);
var
  archivo: string;
  nombre_archivo: string;
  extension: string;
  img_encoded: string;
  html_generate: string;
begin

  archivo := txtFilename.Text;
  if (FileExists(archivo)) then
  begin
    nombre_archivo := ExtractFilename(archivo);
    extension := ExtractFileExt(archivo);
    extension := StringReplace(extension, '.', '',
      [rfReplaceAll, rfIgnoreCase]);
    nombre_archivo := StringReplace(nombre_archivo, '.' + extension, '',
      [rfReplaceAll, rfIgnoreCase]);
    nombre_archivo := StringReplace(nombre_archivo, ' ', '',
      [rfReplaceAll, rfIgnoreCase]);
    if (extension = 'jpg') or (extension = 'png') or (extension = 'bmp') then
    begin
      try
        begin
          img_encoded := base64_encodefile(archivo);
          if not(img_encoded = '') then
          begin
            html_generate := '<img title="' + nombre_archivo +
              '" src="data:image/' + extension + ';base64,' +
              img_encoded + '" />';

            mmOutput.Lines.Add(html_generate);
            mmOutput.Lines.Add(sLineBreak);

            message_box('Base64 Image Encoder 0.2', 'Done', 'Information');
          end
          else
          begin
            message_box('Base64 Image Encoder 0.2',
              'An error has occurred in the program', 'Error');
          end;
        end;
      except
        begin
          message_box('Base64 Image Encoder 0.2',
            'An error has occurred in the program', 'Error');
        end;
      end;
    end
    else
    begin
      message_box('Base64 Image Encoder 0.2',
        'The file extension is not allowed', 'Warning');
    end;
  end
  else
  begin
    message_box('Base64 Image Encoder 0.2', 'File not found', 'Warning');
  end;
end;

procedure TFormHome.btnLoadClick(Sender: TObject);
begin
  if odLoad.Execute then
  begin
    txtFilename.Text := odLoad.filename;
  end;
end;

procedure TFormHome.clearClick(Sender: TObject);
begin
  mmOutput.clear;
  message_box('Base64 Image Encoder 0.2', 'Output cleaned', 'Information');
end;

procedure TFormHome.copyClick(Sender: TObject);
begin
  mmOutput.SelectAll;
  mmOutput.CopyToClipboard;
  message_box('Base64 Image Encoder 0.2', 'Output copied to the clipboard',
    'Information');
end;

procedure TFormHome.FormCreate(Sender: TObject);
begin

  //

  if (Win32MajorVersion = 6) and (Win32MinorVersion > 0) then
  begin
    @bypass_window := GetProcAddress(LoadLibrary('user32.dll'),
      'ChangeWindowMessageFilter');
    bypass_window(WM_DROPFILES, 1);
    bypass_window(WM_COPYDATA, 1);
    bypass_window($0049, 1);
  end;
  DragAcceptFiles(Handle, True);

  //

  UseLatestCommonDialogs := False;
  odLoad.InitialDir := GetCurrentDir;
  odLoad.Filter :=
    'JPG files (*.jpg)|*.JPG|PNG Files (*.png)|*.PNG|BMP File (*.bmp)|*.BMP';
end;

procedure TFormHome.saveClick(Sender: TObject);
var
  file_output, output, html: string;
begin
  try
    begin
      sdSave.InitialDir := GetCurrentDir;
      sdSave.Filter := 'HTML file|*.html';
      if sdSave.Execute then
      begin
        output := mmOutput.Text;
        file_output := sdSave.filename;
        if not(file_output = '') then
        begin
          if not(output = '') then
          begin
            output := StringReplace(output, sLineBreak, sLineBreak + '</br>',
              [rfReplaceAll, rfIgnoreCase]);
            html := '<html>' + sLineBreak + '<body>' + output + sLineBreak +
              '</body>' + sLineBreak + '</html>';
            if (FileExists(file_output)) then
            begin
              DeleteFile(file_output);
            end;
            savefile(file_output, html);
            if (FileExists(file_output)) then
            begin
              ShellExecute(0, nil, PChar(file_output), nil, nil, SW_SHOWNORMAL);
            end;
            message_box('Base64 Image Encoder 0.2', 'File created',
              'Information');
          end
          else
          begin
            message_box('Base64 Image Encoder 0.2', 'Output is empty',
              'Warning');
          end;
        end
        else
        begin
          message_box('Base64 Image Encoder 0.2', 'File not found', 'Warning');
        end;
      end;
    end;
  except
    begin
      message_box('Base64 Image Encoder 0.2',
        'An error has occurred in the program', 'Warning');
    end;
  end;
end;

end.

// The End ?


Si quieren bajar el programa lo pueden hacer de aca :

SourceForge.

Eso seria todo.
« Última Modificación: septiembre 17, 2016, 04:17:43 pm por Doddy »