delphi Image32 SVG图形查看器

DELPHI 中没有SVG显示组件，需要用到第三方组件，高版本可以使用skia（但必须带上skia.dll）.

最新版Image32修改了很多，SVGIconImageList 也因此换成了Image32做为基础库，安装了 SVGIconImageList 就可以不用再单独安装 Image32了（基本上是绿色不用安装包，直接引用就行）。

unit uFrmSVGShow;

interface

uses
  Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants,
  System.Classes, Vcl.Graphics, Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.Menus,
  Vcl.StdCtrls, Vcl.ComCtrls, Vcl.ExtCtrls, Img32.Panels, Vcl.Buttons;

type
  TfrmSVGShow = class(TForm)
    Splitter1: TSplitter;
    ListBox1: TListBox;
    OpenDialog1: TOpenDialog;
    PopupMenu1: TPopupMenu;
    mnuOpenInTextEditor: TMenuItem;
    mnuOpenInBrowser: TMenuItem;
    SaveDialog1: TSaveDialog;
    Panel1: TPanel;
    btnSave: TSpeedButton;
    btnOpen: TSpeedButton;
    btnOpenSVGText: TSpeedButton;
    btnOpenBrowser: TSpeedButton;
    Label1: TLabel;
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure btnOpenClick(Sender: TObject);
    procedure mnuOpenInTextEditorClick(Sender: TObject);
    procedure mnuOpenInBrowserClick(Sender: TObject);
    procedure ListBox1Click(Sender: TObject);
    procedure btnSaveClick(Sender: TObject);
    procedure FormShow(Sender: TObject);
  private
    procedure ImagePanelResize(Sender: TObject);
    procedure ListSVGFilesInFolder;
  protected
    folder: string;
    filename: string;
    ImagePanel: TImage32Panel;
    procedure OpenFile(const filename: string);
    procedure WMDropFiles(var Msg: TMessage); message WM_DROPFILES;
    procedure DrawCurrentItem;
  end;

var
  frmSVGShow: TfrmSVGShow;

implementation

{$R *.dfm}

uses
  Winapi.ShellAPI, Winapi.ShLwApi, //
  System.Math, System.IOUtils, Img32, Img32.Vector, Img32.Draw, Img32.Fmt.PNG,
  Img32.Fmt.JPG, Img32.Fmt.SVG, Img32.Text;

procedure OpenDocument(const filename: string);
begin
  //默认程序打开
  ShellExecute(0, 'open', PChar(filename), nil, nil, SW_SHOWNORMAL);
end;

function GetDefaultTextEditor: string;
var
  exeFileBuffer: array[0..1024] of char;
  len: DWORD;
begin   //查找系统中注册的 .txt 默认打开程序
  len := 1024;
  if AssocQueryString(0, ASSOCSTR_EXECUTABLE, '.txt', nil, @exeFileBuffer[0], @len) = S_OK then
    SetString(Result, exeFileBuffer, len - 1)
  else
    Result := '';
end;

procedure OpenDocumentWithDefaultTxt(const filename: string);
var
  txtEditor: string;
begin
  txtEditor := GetDefaultTextEditor;
  ShellExecute(0, 'open', PChar(txtEditor), PChar('"' + filename + '"'), nil, SW_SHOWNORMAL);  //返回>32  表示句柄
end;

{ TfrmSVGShow }

procedure TfrmSVGShow.btnOpenClick(Sender: TObject);
begin
  if OpenDialog1.Execute then
    OpenFile(OpenDialog1.filename);
end;

procedure TfrmSVGShow.btnSaveClick(Sender: TObject);
begin
  if SaveDialog1.Execute then
    ImagePanel.Image.SaveToFile(SaveDialog1.filename);
end;

procedure TfrmSVGShow.DrawCurrentItem;
var
  svgFilenameAndPath: string;
  rec: TRect;
begin
  if ListBox1.ItemIndex < 0 then
    Exit;

  filename := ListBox1.Items[ListBox1.ItemIndex];
  svgFilenameAndPath := TPath.Combine(folder, filename);
  rec := ImagePanel.InnerClientRect;

  ImagePanel.Image.BeginUpdate;
  Screen.Cursor := crHourGlass;
  try
    ImagePanel.Image.SetSize(RectWidth(rec), RectHeight(rec));
    ImagePanel.Image.LoadFromFile(svgFilenameAndPath);   //加载文件（支持 .svg）
  finally
    ImagePanel.Image.EndUpdate;
    Screen.Cursor := crDefault;
  end;
//  ActiveControl := ListBox1;
end;

procedure TfrmSVGShow.FormCreate(Sender: TObject);
var
  rec: TRect;
begin
  Self.BorderStyle := bsNone;

  ImagePanel := TImage32Panel.create(self);
  ImagePanel.BorderWidth := 0;     //默认有一个大的边框，这里设置后可去掉边框。
  ImagePanel.BorderStyle := bsNone;
  ImagePanel.BevelOuter := bvNone;
  ImagePanel.parent := self;
  ImagePanel.Align := alClient;
  ImagePanel.OnResize := ImagePanelResize;
  ImagePanel.BkgType := pbtChessBoard;
//  DragAcceptFiles(Handle, True);   //允许拖曳文件到窗口 (窗体做为其它窗口的子对象时，此外的Handle可能会再次创建而发生变化，要放到Show中)
  ImagePanel.ParentBackground := false;
  ImagePanel.Color := clBtnFace;
  rec := ImagePanel.InnerClientRect;
  ImagePanel.Image.SetSize(RectWidth(rec), RectHeight(rec));

  // FontManager.Load('Segoe UI');   //要加载一些字体，svg文件中可能指定了字体，如果不加载，svg中的文字不会显示

  //win10 下可以从 打开字体预览 （窗口标题栏显示的为字体名称,并非完全是预览内容中的 字体名称）

  FontManager.Load('Arial Bold');
  FontManager.Load('Arial Italic');
  FontManager.Load('Arial Bold Italic');
  FontManager.Load('Times New Roman');
  FontManager.Load('Times New Roman Bold');
  FontManager.Load('Times New Roman Italic');
  FontManager.Load('Times New Roman Bold Italic');

  FontManager.Load('Symbol');
  FontManager.Load('Webdings');
  FontManager.Load('Wingdings');
  FontManager.Load('Segoe UI Symbol');

  OpenFile('.\SVGs\textpath2.svg');
  // OpenFile('.\*.svg');
  ListSVGFilesInFolder;
  DrawCurrentItem;

end;

procedure TfrmSVGShow.FormDestroy(Sender: TObject);
begin
  ImagePanel.Free;
  DragAcceptFiles(Handle, false);    //不允许拖曳到窗口
end;

procedure TfrmSVGShow.FormShow(Sender: TObject);
begin
  DragAcceptFiles(Handle, True);   //允许拖曳文件到窗口
end;

procedure TfrmSVGShow.ImagePanelResize(Sender: TObject);
var
  rec: TRect;
begin
  rec := ImagePanel.InnerClientRect;
  ImagePanel.Image.SetSize(RectWidth(rec), RectHeight(rec));
  DrawCurrentItem;
end;

procedure TfrmSVGShow.ListBox1Click(Sender: TObject);
begin
  DrawCurrentItem;
end;

procedure TfrmSVGShow.ListSVGFilesInFolder;
var
  sr: TSearchRec;
  i, idx, searchResult: integer;
begin  //将文件列表，显示在 ListBox中
  ListBox1.Items.BeginUpdate;
  try
    ListBox1.Items.Clear;
    searchResult := FindFirst(TPath.Combine(folder, '*.svg'), faAnyFile, sr);    //查找 文件
    idx := -1;
    while searchResult = 0 do
    begin
      if sr.Name[1] = '.' then
        Continue;
      i := ListBox1.Items.Add(sr.Name);
      if sr.Name = filename then
        idx := i;
      searchResult := FindNext(sr);      //查找 下一个
    end;
    ListBox1.Visible := ListBox1.Items.Count > 0;
    if not ListBox1.Visible then
      Exit;
    idx := Max(0, idx);
    ListBox1.ItemIndex := idx;
  finally
    ListBox1.Items.EndUpdate;
  end;
end;

procedure TfrmSVGShow.mnuOpenInBrowserClick(Sender: TObject);
var
  fn: string;
begin      //默认程序打开
  if ListBox1.ItemIndex < 0 then
    Exit;
  fn := TPath.Combine(folder, ListBox1.Items[ListBox1.ItemIndex]);
  OpenDocument(PChar(fn));
end;

procedure TfrmSVGShow.mnuOpenInTextEditorClick(Sender: TObject);
var
  fn: string;
begin    //文本编辑器打开
  if ListBox1.ItemIndex < 0 then
    Exit;
  fn := TPath.Combine(folder, ListBox1.Items[ListBox1.ItemIndex]);
  OpenDocumentWithDefaultTxt(fn);
end;

procedure TfrmSVGShow.OpenFile(const filename: string);
var
  i: integer;
begin
  self.filename := ExtractFileName(filename);
  folder := ExtractFilePath(filename);
  if (folder = '') or (folder[1] = '.') then
    folder := ExpandFileName(folder);  //如果是相对路径，展开成完整绝对路径
  OpenDialog1.InitialDir := folder;
  ListSVGFilesInFolder;
  i := ListBox1.Items.IndexOf(self.filename);
  if i <> ListBox1.ItemIndex then
    ListBox1.ItemIndex := i
  else
    DrawCurrentItem;
end;

procedure TfrmSVGShow.WMDropFiles(var Msg: TMessage);
var
  hDrop: THandle;
  filenameLen: integer;
  filename: string;
begin   //拖曳文件过来,打开
  Msg.Result := 0;
  hDrop := Msg.wParam;
  filenameLen := DragQueryFile(hDrop, 0, nil, 0);
  SetLength(filename, filenameLen);
  DragQueryFile(hDrop, 0, Pointer(filename), filenameLen + 1);
  DragFinish(hDrop);
  OpenFile(filename);
end;

end.

有些svg图形展示效果比浏览器展示的更好