☆式の評価（数式の計算）

(0.5+2)*(8.3+2) というような式を計算します。
言語の種類を問わず数式を計算したいという質問は多いようですが、具体的なコードを見かけることが少ないため、下記書籍のコードを利用したものを載せますね。

function Calc(S: String; var Ans: Extended): Boolean;
var
  Err : Boolean;
  P: PChar;

  procedure Error;
  begin
    Err := True;
  end;

  function Number: Extended;
  var
    X, A: Extended;
    Sign: Char;
  begin
    Result := 0;
    Sign := P^;
    if P^ in ['+','-'] then
    begin
      Sign := P^;
      Inc(P);
    end;
    if P^ in ['0'..'9'] then
    begin
      X := Ord(P^) - Ord('0');
      Inc(P);
      while P^ in ['0'..'9'] do
      begin
        X := 10 * X + Ord(P^) - Ord('0');
        Inc(P);
      end;
      if P^ ='.' then
      begin
        A := 1;
        Inc(P);
        while P^ in ['0'..'9'] do
        begin
          A := 0.1 * A;
          X := X + A * (Ord(P^) - Ord('0'));
          Inc(P);
        end;
      end;
      if Sign = '-' then
        Result := -X
      else
        Result := X;
    end
    else
      Error;
  end;

  function Expression: Extended;
  var
    X: Extended;

    function Term: Extended;
    var
      X, Y: Extended;

      function Factor: Extended;
      begin
        if P^ <> '(' then
          Result := Number
        else
        begin
          Inc(P);
          Result := Expression;
          if P^ = ')' then
            Inc(P)
          else
            Error;
        end;
      end;

    begin
      X := Factor;
      while P^ in ['*','/'] do
      if P^ = '*' then
      begin
        Inc(P);
        X := X * Factor;
      end
      else
      begin
        Inc(P);
        Y := Factor;
        if Y <> 0 then
          X := X / Y
        else
          Error;
      end;
      Result := X;
    end;

  begin
    X := Term;
    while P^ in ['+','-'] do
      case P^ of
        '+': begin
               Inc(P);
               X := X + Term;

             end;
        '-': begin
               Inc(P);
               X := X - Term;
             end;
      end;
    Result := X;
  end;

begin
  { 初期設定 }
  Ans := 0;
  Err := False;

  { 計算します。 }
  P := PChar(S);
  Ans := Expression;

  {
  計算式が、最後まで計算されたかどうかをチェック
  （制御文字等があれば途中で計算を終了するため）
  }
  if (Trim(P) <> '') then  Error;

  if Err then Ans := 0;
  Result := not Err;
end;

procedure TForm1.Button1Click(Sender: TObject);
var
  Ans: Extended;
begin
  if Calc(Edit1.Text, Ans) then
    Edit2.Text := FloatToStr(Ans)
  else
    Edit2.Text := 'error';
end;

この処理は、技術評論社「コンピュータ・アルゴリズム事典」という書籍のソースコードを利用したものです。 ソースコードを利用したものを公開することについて、著者である奥村晴彦先生から許可を得ております。

奥村晴彦先生のオリジナルは、下記のリンクからダウンロードできます。
（式の評価はCHAP12.PRGに含まれています）


奥村晴彦
『コンピュータ・アルゴリズム事典』サポートページ
http://oku.edu.mie-u.ac.jp/~okumura/algo/algo_pas.html

☆文字列を後方から検索する。

次のような規則に従って作られたファイル名から部分文字列(金額)を取り出す処理です。

年[半角空白]名称[-]金額.txt

ここで問題だったのは、名称と金額を繋いでいる－(hyphen)が名称にも含まれている場合があるため、 後方から－(hyphen)の位置を検索しなくてはいけないことでした。
そこで今回はAnsiReverseString関数を使って処理してみました。

uses StrUtils;

procedure TForm1.Button1Click(Sender: TObject);
const
  S = '2008 Delphi-fan-123,456,789円.txt';
  Delimiter = '-';
var
  WS, RS: WideString;
  Len, I: Integer;
begin
  // 拡張子を削除する。
  WS := ChangeFileExt(S,'');
  // 後方から検索したいので、文字列をリバースさせてPos関数が使えるようにする。
  RS := AnsiReverseString(WS);
  Len := Length(WS);
  I := Len-Pos(Delimiter, RS)+1;
  Edit1.Text := Copy(WS, I+1, Len-I);
end;

この処理できちんと123,456,789円が取得できました。

☆検索文字列の分解？

SQLで、複数の単語での検索ができるように、検索文字列を分解するコードを書いてみました。
ここでの検索文字列は、半角及び全角スペースをDelimiterと判断します。" "で括られたものはそのまま空白も取得します。

// 検索文字列Sを分解して、SLに設定します。
// Delimiterは、半角及び全角スペースです。
// ex)コンクリート "床　モルタル鏝押エ" t=
//  下記の３つに分けます。
//  コンクリート
//  床　モルタル鏝押エ
//  t=
function SearchStrPaser(const S: String; var SL: TStringList): Boolean;
var
  P: PChar;
  I, Len: Integer;
  Str: String;
  F: Boolean;
  wc: word;
begin
  try
    SL.Clear;
    Str := '';
    P := PChar(S);
    Len := Length(S);
    F := False;
    I := 1;
    repeat
      if IsDBCSLeadByte(Byte(P^)) then
        begin
          wc := (Byte(P^) shl 8) or Byte((P+1)^);
          if (not F) and (wc = $8140) then
            begin
              SL.Add(Str);
              Str := '';
              Inc(P);
              Inc(I);
            end
          else
            begin
              Str := Str + P^;
              Inc(P);
              Inc(I);
              Str := Str + P^;
            end;
          end
      else if (P^ = #34) then              { #34(") }
        F := not F
      else if (not F) and (P^ = #32) then  { #32(半角スペース) }
        begin
          SL.Add(Str);
          Str := '';
        end
      else
        Str := Str + P^;
      Inc(P);
      Inc(I);
    until I > Len;
    SL.Add(Str);
    Result := True;
  except
    Result := False;
  end;
end;

☆メモ上でマウス下のテキスト取得

ブラウザでのGoogleの翻訳機能ってどうしてるのかなという疑問から、マウス下のテキストの取得に挑戦してみましたが、ブラウザでの取得は全くわかりませんでした。ということで簡単なところから、エディットコントロールでのサンプルです(笑)

実行するとこんな感じです。






ごちゃごちゃと検索する関数です。（日本語の処理は面倒ですね）
きちんとまとめるともう少しすっきりしそうですが、サンプルということで・・・。

unit GetWordAndPhrase;

interface

uses
  Windows;

//マウス下の語句を返します。＜Delimiterで区切られているか英単語単位＞
//Ptには、語句の開始位置と終了位置を返します。
function GetWordAndPhraseUnderMouse(const Index: Integer;const  S: String;
  var StartPos, EndPos: Integer): String;

implementation

//半角アルファベットかどうか
function IsAlphabet(C: Byte): Boolean;
begin
  Result := (C in [65..90, 97..122]);
end;

//英単語を取得するかどうか
function IsAlphabetMode(Index: Integer; S: String): Boolean;
var
  P: PChar;
begin
  P := PChar(S);
  Result := (Ord(P[Index]) in [65..90, 97..122]);
end;

//IndexがDelimiterかどうか
function IsDelimiter(Index: Integer; S: String): Boolean;
var
  P: PChar;
  wc: Word;
begin
  Result := True;
  P := PChar(S);

  //Delimiterの場合には終了
  if Ord(P[Index]) in [9,10,13,32] then Exit;

  //全角スペースの１バイト目
  if IsDBCSLeadByte(Byte(P[Index])) then
  begin
    wc := (Byte(P[Index]) shl 8) or Byte(P[Index+1]);
    //$8140-全角スペース $8141-、$8142-。
    if (wc = $8140) or (wc = $8141) or (wc = $8142) then Exit;
  end;

  //Indexが0の場合は、全角スペースの２バイト目はありえないので処理を終了します。
  if Index = 0 then
  begin
    Result := False;
    Exit;
  end;

  //全角スペースの２バイト目
  if IsDBCSLeadByte(Byte(P[Index-1])) then
  begin
    wc := (Byte(P[Index-1]) shl 8) or Byte(P[Index]);
    //$8140-全角スペース $8141-、$8142-。
    if  (wc = $8140) or (wc = $8141) or (wc = $8142) then Exit;
  end;
  Result := False;
end;

//前方検索
function PrevCheckAlphabetMode(Index: Integer; S: String): Integer;
var
  P: PChar;
begin
  if Index = 0 then
  begin
    Result := 0;
    Exit;
  end;

  P := PChar(S);
  repeat
    // 全角かどうかのチェック -- ２バイト目かどうか
    // 前方検索なので、１バイト目が先に出てくることはない。
    // ２バイト目が確認できたら、１バイト目分も移動させる。
    if (Index > 0) and IsDBCSLeadByte(Byte(P[Index-1])) then
      begin
        //全角の場合は終了する。
        Inc(Index);
        Break;
      end
    else if not IsAlphabet(Byte(P[Index])) then
      begin
        Inc(Index);
        Break;
      end
    else if Ord(P[Index]) in [9,10,13,32] then //半角Delimiter文字のチェック
      begin
        Inc(Index); //IndexがDelimiterなら一つ戻して終了する。
        Break;
      end
    else
      Dec(Index);
  until Index <= 0;
  if Index < 0 then Index := 0;
  Result := Index;
end;

//後方検索
function NextCheckAlphabetMode(Index: Integer; S: String): Integer;
var
  P: PChar;
  max: Integer;
begin
  Result := -1;
  P := PChar(S);
  Max := Length(S);

  //Indexが全角の２バイトの場合一つ戻しておきます。
  if (Index > 0) and IsDBCSLeadByte(Byte(P[Index-1])) then Exit;

  repeat
    // 全角の場合
    if IsDBCSLeadByte(Byte(P[Index])) then //１バイト目かどうかのチェック
      Break
    else if not IsAlphabet(Byte(P[Index])) then
      Break
    else if Ord(P[Index]) in [9,10,13,32] then
      Break
    else
      Inc(Index);
  until Index >= max;  //Index=maxというのは文字列より一つ多い。
  Dec(Index);
  Result := Index;
end;


//前方検索 -- Delimiterのみで判定する
function PrevCheck(Index: Integer; S: String): Integer;
var
  P: PChar;
  wc: Word;
begin
  if Index = 0 then
  begin
    Result := 0;
    Exit;
  end;

  P := PChar(S);
  // Indexが２バイト目の先頭バイトの場合には、一つ進めておきます。
  if IsDBCSLeadByte(Byte(P[Index])) then
  begin
    if Index = 0 then
    begin
      Result := 0;
      Exit;
    end;
    Dec(Index);
  end;

  repeat
    // 全角かどうかのチェック -- ２バイト目かどうか
    // 前方検索なので、１バイト目が先に出てくることはない。
    // ２バイト目が確認できたら、１バイト目分も移動させる。
    if (Index > 0) and IsDBCSLeadByte(Byte(P[Index-1])) then
      begin
        wc := (Byte(P[Index-1]) shl 8) or Byte(P[Index]);
        //$8140-全角スペース $8141-、$8142-。
        if  (wc = $8140) or (wc = $8141) or (wc = $8142) then
          begin
            Inc(Index); //Indexが２バイト文字だと確認できたら一つ戻して終了する。
            Break;
          end
        else
          Index := Index - 2; //全角文字の一つ前に進める。
      end
    else if Ord(P[Index]) in [9,10,13,32] then //半角Delimiter文字のチェック
      begin
        Inc(Index); //IndexがDelimiterなら一つ戻して終了する。
        Break;
      end
    else
      Dec(Index);
  until Index <= 0;
  if Index < 0 then Index := 0;
  Result := Index;
end;

//後方検索 -- Delimiterのみ判定する
function NextCheck(Index: Integer; S: String): Integer;
var
  P: PChar;
  wc: Word;
  max: Integer;
begin
  P := PChar(S);
  Max := Length(S);

  //Indexが全角の２バイトの場合一つ戻しておきます。
  if (Index > 0) and IsDBCSLeadByte(Byte(P[Index-1])) then
    Dec(Index);

  repeat
    // 全角の場合
    if IsDBCSLeadByte(Byte(P[Index])) then //１バイト目かどうかのチェック
      begin
        //全角スペースのチェック
        wc := (Byte(P[Index]) shl 8) or Byte(P[Index+1]);
        //$8140-全角スペース $8141-、$8142-。
        if  (wc = $8140) or (wc = $8141) or (wc = $8142) then
          Break;
        Index := Index + 2;
      end
    else if Ord(P[Index]) in [9,10,13,32] then
      Break
    else
      Inc(Index);
  until Index >= max;  //Index=maxというのは文字列より一つ多い。
  Dec(Index);
  Result := Index;
end;


//マウス下の語句を返します。＜Delimiterで区切られているか英単語単位＞
//Ptには、語句の開始位置と終了位置を返します。
function GetWordAndPhraseUnderMouse(const Index: Integer;const  S: String;
  var StartPos, EndPos: Integer): String;
begin
  StartPos := -1;
  EndPos := -1;
  Result := '';
  if not IsDelimiter(Index,S) then
  begin
    if IsAlphabetMode(Index,S)  then
      begin
        // 英単語のみの取得
        StartPos := PrevCheckAlphabetMode(Index,S);
        EndPos := NextCheckAlphabetMode(Index,S);
      end
    else
      begin
        // delimiterによる語句の取得
        StartPos := PrevCheck(Index,S);
        EndPos := NextCheck(Index,S);
      end;
  end;
  if (StartPos = -1) and (EndPos = -1) then
    Result := ''
  else
    Result := Copy(S, StartPos+1, EndPos-StartPos+1);
end;

end.

上記、関数の利用例です。
メモとタイマーを各１個ずつ配置して、それぞれの手続きを設定します。

unit Sample2_UseMemo;

interface

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

type
  TForm1 = class(TForm)
    Memo1: TMemo;
    Timer1: TTimer;
    procedure Memo1MouseMove(Sender: TObject; Shift: TShiftState; X,
      Y: Integer);
    procedure Timer1Timer(Sender: TObject);
    procedure FormCreate(Sender: TObject);
  private
    HW: THintWindow;
    procedure ShowHintWindow(X, Y: Integer; S: String);
    procedure HideHintWindow;
  public
    { Public 宣言 }
  end;

var
  Form1: TForm1;

implementation

uses GetWordAndPhrase;

{$R *.dfm}

procedure TForm1.FormCreate(Sender: TObject);
begin
  HW := THintWindow.Create(Self);
end;

var
  bkPos: TPoint;

procedure TForm1.Memo1MouseMove(Sender: TObject; Shift: TShiftState; X,
  Y: Integer);
const
  A = 5; //マウスの感度調整
begin
  if ((X < bkPos.X -A) or (X > bkPos.X +A)) or
     ((Y < bkPos.Y -A) or (Y > bkPos.Y +A)) then
    HideHintWindow;
end;

// ヒントウィンドウの表示
procedure TForm1.Timer1Timer(Sender: TObject);
var
  I, sp, ep: Integer;
  S: String;
  csPos,clPos: TPoint;
begin
  GetCursorPos(csPos);
  clPos := Memo1.ScreenToClient(csPos);
  bkPos := clPos;
  I := LoWord(Memo1.Perform(EM_CHARFROMPOS, 0, MakeLParam(clPos.X, clPos.Y)));
  S := GetWordAndPhraseUnderMouse(I, Memo1.Text, sp, ep);
  if (S <> '') then
  begin
    ShowHintWindow(csPos.X, csPos.Y, S);
    Timer1.Enabled := False;
  end;
end;

// ヒントウィンドウ
procedure TForm1.ShowHintWindow(X, Y: Integer; S: String);
var
  Rect: TRect;
begin
  if not HW.HandleAllocated then
    HW.HandleNeeded;

  Rect := Bounds(0, 0, 0, 0);
  DrawText(HW.Canvas.Handle, PChar(S), -1, Rect, DT_CALCRECT or DT_LEFT);
  OffsetRect(Rect, X,Y + 10);
  //ヒントウィンドウの微調整
  Inc(Rect.Right, 6);
  Inc(Rect.Bottom, 2);
  //表示
  HW.ActivateHint(Rect, S);
end;

procedure TForm1.HideHintWindow;
begin
  if HW.HandleAllocated then
  begin
    HW.ReleaseHandle;
    Timer1.Enabled := True;
  end;
end;

end.

delimiterは、全角スペース、半角スペース、改行(CRLF)、句読点（。、）としています。

☆コードを簡易HTMLにする。

このブログ、プログラム関係のくせにココログの標準設定のままというあまりに低レベルな表現しかしていなかったので、コード部分ぐらい読みやすくしようと、CSSを少し修正してみました。
ついでに、「Delphi予約語を強調文字にしたHTML」を作成するコードを書いてみました。 かなり力技＆簡易なものなのですが、今後はこれを使って更新していきたいと思います。

// 文字列S中でIndex番目のSubstrの位置を返します。
function AnsiPosEx(const Substr: String; const S: String;
  Index: Integer): Integer;
var
  I,K: Integer;
  Str: String;
begin
  Str := S;
  Result := 0;
  K := 0;
  repeat
    Inc(K);
    I := AnsiPos(Substr, Str);
    if I =  0 then
    begin
      Result := 0;
      Break;
    end;
    if K = 1 then
      Result := I
    else
      Result := Result + I +Length(Substr) -1;
    Str := Copy(Str, I + Length(Substr) , Length(Str)-I+Length(Substr) +1);
  until K = Index;
end;


function TForm1.MakeHTML(const Str: String): String;
const
  S1 = '-----------------------------------';
  S2 = '-----------------------------------';
var
  I, J, K, L,M: Integer;
  DefineSL, SrcSL: TStringList;
  S, FileName : String;
begin
  FileName := ExtractFilePath(Application.ExeName) + 'define.txt';
  if not FileExists(FileName) then Exit;

  DefineSL := TStringList.Create;
  SrcSL := TStringList.Create;
  try
    DefineSL.LoadFromFile(FileName);
    SrcSL.Text := Str;

    SrcSL.Text := StringReplace(Str,'<', '<',[rfReplaceAll]);
    SrcSL.Text := StringReplace(SrcSL.Text,'>', '>',[rfReplaceAll]);

    for I := 0 to SrcSL.Count - 1 do
    begin
      for J := 0 to DefineSL.Count - 1 do
      begin
        S := '';
        M := 0;
        L := 1;
        while True do
        begin
          {M番目の文字列位置を取得します。}
          Inc(M);
          K := AnsiPosEx(DefineSL[J],SrcSL[I],M);
          if K = 0 then
            begin
              S := S + Copy(SrcSL[I], L , 1000);
              Break;
            end
          else
            begin
              S := S + Copy(SrcSL[I], L , K-L) +
                   '<strong>' + DefineSL[J] + '</strong>';
              L := K + Length(DefineSL[J]);
            end;
        end;
        SrcSL[I] := S;
      end;
    end;

    S := '<pre class=code>'+ #13#10 + SrcSL.Text + #13#10 + '</pre>';
    Result := '<HTML><BODY>'+#13#10+ S1 + #13#10+ S
       +#13#10+S2+#13#10+'</BODY><HTML>';
  finally
    SrcSL.Free;
    DefineSL.Free;
  end;
end;

define.txtの中身は・・・

function 
implementation
if 
 then
else
try
finally
begin
end;
end.
var
string
 do
 and 
repeat
until 
while 
class
const
string
interface
stdcall
external
nil
for 
to 
downto 
case 
 of

というような感じのテキストファイルです。