Fontを文字列化する時 (ID:30085)

名前

ホームページ(ブログ、Twitterなど)のURL (省略可)

本文

『俺ならこういう実装する』の方で
TMemoryStreamに一旦詰め込むとコードがすっきりしますZE！
もちろん文字列化された情報は人間には読めませんが。

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls;

type
  TForm1 = class(TForm)
    Button1: TButton;
    Button2: TButton;
    Label1: TLabel;
    Label2: TLabel;
    FontDialog1: TFontDialog;
    procedure Button1Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);
  private
    { Private 宣言 }
  public
    { Public 宣言 }
  end;

var
  Form1: TForm1;

implementation

uses Math;

{$R *.dfm}

function StreamToString(aStream:TMemoryStream):String;
var
  i:Longint;
  b:Byte;
begin
  aStream.Position:=0;
  for i:=0 to aStream.Size-1 do
  begin
    aStream.Read(b,SizeOf(b));
    Result:= Result + IntToHex(b,2);
  end;
end;

function HexCharToInt(aChar:Char):byte;
begin
  Result:=Word(aChar);
  case Result of
    48..58: Result:= Result-48;
    65..70: Result:= Result-65+10;
    else  Result:=0;
  end;
end;

procedure StringToStream(str:String; var aStream:TMemoryStream);
var
  i:Longint;
  b:Byte;
begin
  aStream.Position:=0;
  aStream.Size:=0;
  for i:=1 to Length(str) div 2 do
  begin
    b := HexCharToInt(str[i*2-1])*16 +
         HexCharToInt(str[i*2  ]);
    aStream.Write(b,SizeOf(b));
  end;
end;

function FontToString(aFont:TFont):String;
var
  mStream:TMemoryStream;
  i:Integer;
  aFontCharset: TFontCharset;
  aColor:TColor;
  aHeight:Integer;
  aName:TFontName;
  aPitch:TFontPitch;
  aSize:Integer;
  aStyle:TFontStyles;
begin
  mStream:=TMemoryStream.Create;
  mStream.Position:=0;

//  String型だけ特殊
  //  property Name: TFontName read GetName write SetName;
  aName:=aFont.Name;
  i:=Length(aName);
  mStream.Write(i ,SizeOf(i));
  mStream.Write(aName[1] ,i);

//  property Charset: TFontCharset read GetCharset write SetCharset;
  aFontCharset:=aFont.Charset;
  mStream.Write(aFontCharset ,SizeOf(aFontCharset));
  //  property Color: TColor read FColor write SetColor;
  aColor:=aFont.Color;
  mStream.Write(aColor ,SizeOf(aColor));
  //  property Height: Integer read GetHeight write SetHeight;
  aHeight:=aFont.Height;
  mStream.Write(aHeight ,SizeOf(aHeight));
  //  property Pitch: TFontPitch read GetPitch write SetPitch default fpDefault;
  aPitch:=aFont.Pitch;
  mStream.Write(aPitch ,SizeOf(aPitch));
  //  property Size: Integer read GetSize write SetSize stored False;
  aSize:=aFont.Size;
  mStream.Write(aSize ,SizeOf(aSize));
  //  property Style: TFontStyles read GetStyle write SetStyle;
  aStyle:= aFont.Style;
  mStream.Write(aStyle ,SizeOf(aStyle));

Result:=StreamToString(mStream);
  mStream.Free;
end;

procedure StrToFont(aFont: TFont; FontStr: string);
var
  mStream:TMemoryStream;
  i:Integer;
  aFontCharset: TFontCharset;
  aColor:TColor;
  aHeight:Integer;
  aName:TFontName;
  aPitch:TFontPitch;
  aSize:Integer;
  aStyle:TFontStyles;
begin
  mStream:=TMemoryStream.Create;
  StringToStream(FontStr,mStream);
  mStream.Position:=0;

//  String型だけ特殊
  //  property Name: TFontName read GetName write SetName;
  mStream.Read(i ,SizeOf(i));
  SetLength(aName,i);
  mStream.Read(aName[1] ,i);
  aFont.Name := aName;
  //  property Charset: TFontCharset read GetCharset write SetCharset;
  mStream.Read(aFontCharset ,SizeOf(aFontCharset));
  aFont.Charset:=aFontCharset;
  //  property Color: TColor read FColor write SetColor;
  mStream.Read(aColor ,SizeOf(aColor));
  aFont.Color:=aColor;
  //  property Height: Integer read GetHeight write SetHeight;
  mStream.Read(aHeight ,SizeOf(aHeight));
  aFont.Height:=aHeight;
  //  property Pitch: TFontPitch read GetPitch write SetPitch default fpDefault;
  mStream.Read(aPitch ,SizeOf(aPitch));
  aFont.Pitch:=aPitch;
  //  property Size: Integer read GetSize write SetSize stored False;
  mStream.Read(aSize ,SizeOf(aSize));
  aFont.Size:=aSize;
  //  property Style: TFontStyles read GetStyle write SetStyle;
  mStream.Read(aStyle ,SizeOf(aStyle));
  aFont.Style:=aStyle;

mStream.Free;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  If FontDialog1.Execute then
  begin
    Label1.Font:=FontDialog1.Font;
    caption:= FontToString(Label1.Font);
  end;
end;

procedure TForm1.Button2Click(Sender: TObject);
begin
  StrToFont(Label2.Font,caption);
  FontDialog1.Font:=Label2.Font;
  FontDialog1.Execute;
end;

end.

←解決時は質問者本人がここをチェックしてください。

戻る