Migaro. 技術Tips

                       

ミガロ.　製品の技術情報
IBMiの活用に役立つ情報を掲載！


【株式会社ミガロ．30周年記念】Delphi/400 シンプル共通関数30選

私たち 株式会社ミガロ．は、おかげさまで、
2021年11月19日をもって創業30周年を迎えることができました。

それを記念して、今回は便利なDelphi共通関数の中から汎用性が高いものを
30種類に厳選してお送りいたします。

貴社環境で既に息づいている共通関数もあるかもしれませんが、
中にはきっと新しい発見があるかと存じます。

=======================================
【免責事項】
本ページに掲載しているソースコードは情報提供の為のサンプルプログラムとなります。
お客様作成アプリケーション内で自由にご利用いただけます。
ただし、これらのソースコードやサンプルプログラムを使用したことによって生じた、
いかなる障害・損失に関しても一切の責を負いかねますので、ご了承下さい。
=======================================

　
　

  1. EXEの階層を取得する
  2. コンピュータ名を取得する処理
  3. ユーザー名を取得する処理
  4. EXEバージョン情報を取得する処理
  5. IPアドレスを取得する処理
  6. ログ書き出し処理（簡易版）
  7. iniファイルの内容を取得する処理
  8. iniファイルへ書込を行う処理
  9. シフト文字を考慮した文字長を取得する処理
  10. シフト文字を考慮した指定長文字列を取得する処理
  11. 半角スペース埋め処理
  12. 半角ゼロ埋め処理
  13. 半角文字列を全角に変換
  14. 全角文字列を半角に変換
  15. 全角スペースは半角スペースとし、連続スペースは詰める
  16. 文字列に対して、シフト文字の位置にダミーの半角スペースをセット
  17. 文字列に対して、シフト文字の位置の半角スペースをカット
  18. 日付整数値を取得する処理
  19. 整数型からDelphi日付型への変換処理
  20. 時刻整数値を取得する処理
  21. 整数型からDelphi日付型(時刻)への変換処理
  22. 半年前(ｎヶ月前)の日付を取得する
  23. 当月末日の日付値を取得する処理
  24. 割り算（0除算のエラー防止）
  25. 今現在マウスがあたっている場所の真下にあるコンポーネントを取得
  26. ウインドウの最前面表示/解除
  27. 指定したディレクトリ内のファイル名一覧作成
  28. メモのOnKeyDownイベントで「すべて選択」を有効化
  29. 入力項目の必須入力チェック
  30. 2点間の経度と緯度から直線距離を計測
  31. サンプルソースダウンロード

EXEの階層を取得する

{*******************************************************************************
 目的: EXEの階層を返す
 引数:
 戻値: EXEの階層（後ろに「￥」付き）
*******************************************************************************}
function AppFolder: string;
begin
  Result := ExtractFilePath(Application.Exename);
end;

　
　

コンピュータ名を取得する処理

  • 実行しているWindows端末のコンピュータ名を取得します。
{*******************************************************************************
 目的: コンピュータ名取得処理
 引数:
 戻値: 取得したコンピュータ名
*******************************************************************************}
function GetCompName: String;
var
  sBuffer: array [0..MAX_COMPUTERNAME_LENGTH] of AnsiChar;
  nSize: DWord;
begin
  nSize := SizeOf(sBuffer);

  if GetComputerNameA(sBuffer, nSize) then
    Result := Trim(sBuffer)
  else
    Result := '';
end;

　
　

ユーザー名を取得する処理

  • Windowsを実行しているログインユーザー名を取得します。
{*******************************************************************************
 目的: ユーザー名取得処理
 引数:
 戻値: 取得したユーザー名
*******************************************************************************}
function GetWinUser: String;
var
  sBuffer: array [0..20] of AnsiChar;
  nSize: DWord;
begin
  nSize := SizeOf(sBuffer);

  if GetUserNameA(sBuffer, nSize) then
    Result := Trim(sBuffer)
  else
    Result := '';
end;

　
　

EXEバージョン情報を取得する処理

  • 実行中EXEのバージョン情報を取得してメニュー画面などに表示したり、
    サーバーのEXEのバージョンと比較して最新版を取得させるような処理に使用します。
    • 下記ロジックで最初に「バージョン情報の取得で使用する型」とありますが、
      宣言部にこの最初の青字部分を記載しておきます。
// バージョン情報の取得で使用する型
type
  TVerResourceKey = (
        vrComments,         // コメント
        vrCompanyName,      // 会社名
        vrFileDescription,  // 説明
        vrFileVersion,      // ファイルバージョン
        vrInternalName,     // 内部名
        vrLegalCopyright,   // 著作権
        vrLegalTrademarks,  // 商標
        vrOriginalFilename, // 正式ファイル名
        vrPrivateBuild,     // プライベートビルド情報
        vrProductName,      // 製品名
        vrProductVersion,   // 製品バージョン
        vrSpecialBuild);    // スペシャルビルド情報


{*******************************************************************************
 目的: バージョン情報の取得
 引数: FileName - 取得したいファイルのフルパス
       KeyWord  - 取得したいバージョン情報（TVerResourceKeyの中から1つ選ぶ）
 戻値: 取得したバージョン情報
*******************************************************************************}
const
  KeyWordStr: array [TVerResourceKey] of String = (
        'Comments',
        'CompanyName',
        'FileDescription',
        'FileVersion',
        'InternalName',
        'LegalCopyright',
        'LegalTrademarks',
        'OriginalFilename',
        'PrivateBuild',
        'ProductName',
        'ProductVersion',
        'SpecialBuild');

function GetVersionInfo(FileName:string; KeyWord: TVerResourceKey): string;
const
  Translation = '\VarFileInfo\Translation';
  FileInfo = '\StringFileInfo\%0.4s%0.4s\';
var
  BufSize, HWnd: DWORD;
  VerInfoBuf: Pointer;
  VerData: Pointer;
  VerDataLen: Longword;
  PathLocale: String;
begin

  BufSize := GetFileVersionInfoSize(PChar(FileName), HWnd);
  if BufSize <> 0 then
  begin
    GetMem(VerInfoBuf, BufSize);
    try
      GetFileVersionInfo(PChar(FileName), 0, BufSize, VerInfoBuf);
      VerQueryValue(VerInfoBuf, PChar(Translation), VerData, VerDataLen);
      if not (VerDataLen > 0) then
        raise Exception.Create('情報の取得に失敗しました');
      PathLocale := Format(FileInfo + KeyWordStr[KeyWord],
        [IntToHex(Integer(VerData^) and $FFFF, 4),
         IntToHex((Integer(VerData^) shr 16) and $FFFF, 4)]);
      VerQueryValue(VerInfoBuf, PChar(PathLocale), VerData, VerDataLen);
      if VerDataLen > 0 then
      begin
        result := '';
        SetLength(result, VerDataLen);
        StrLCopy(PChar(result), VerData, VerDataLen);
      end;
    finally
      FreeMem(VerInfoBuf);
    end;
  end;
end;

記述例：ShowMessage(GetVersionInfo(Application.ExeName, vrFileVersion));

なお、ファイルバージョンの取得時には呼出時の引数に「vrFileVersion」を指定しますが、
他の型を指定する事で、プロジェクトオプションで設定した他の情報も取得することが可能です。

　
　

IPアドレスを取得する処理

  • 実行端末のIPアドレスを取得して返します。
    • ※uses節に「Winapi.WinSock」が必要
      （XE以前のバージョンでは「WinSock」となります。）
{*******************************************************************************
 目的：IPアドレス取得処理
 引数：
 戻値：取得したIPアドレス
*******************************************************************************}
function GetIPAddress: AnsiString;
var
  wsaData  : TWsaData;
  hostName : array [0..255] of AnsiChar;
  host    : PHostEnt;
  in_addr  : TInAddr;
begin
  // IPアドレスを取得する
  WSAStartup($101, wsaData);
  try
    gethostname(hostName,sizeof(hostName));
    host    := gethostbyname(hostName);
    in_addr  :=PInAddr(PInAddr(host^.h_addr_list)^)^;
    Result := inet_ntoa(in_addr);
  finally
    WSACleanup;
  end;
end;

　
　

ログ書き出し処理（簡易版）

  • バッチ処理などで、処理の記録を取るのに便利なログ出力手続きです。
  • エラー発生時、どこまで成功していてどのあたりで止まったのか検出するのにも役立ちます。
    • このサンプルロジックでは「システム日付＋時刻＋メッセージ」を出力しています。
      出力内容は要件に応じて変更ください。
  • 詳細は、こちらの個別記事でも紹介しています。
{*****************************************************************************
 目的: ログ書き出し処理(簡易版) ※このまま対象ソースの関数内手続きにできます
*****************************************************************************}
procedure WriteLog(AMsg: String);
var
  FLog: TextFile;
  SLog: string;
  sLogFileName: String;
begin
  // ログファイル名の取得（ここではEXEと同名のlogファイルを出力）
  sLogFileName := ChangeFileExt(Application.ExeName, '.log');

  // ログ書き出し処理
  try
    // ファイル変数関連付け
    AssignFile(FLog, sLogFileName);
    try
      if FileExists(sLogFileName) then
        Append(FLog)     // ファイルの末尾に追加
      else
        Rewrite(FLog);   // 新しいファイルを作成し開く

      // 出力メッセージ文字列を作成
      SLog := FormatDateTime('YYYY/MM/DD HH:NN:SS', Now) + '  ' + AMsg;
      // ファイルへ書き出し
      Writeln(FLog, SLog);
    finally
      // ファイル関連付け終了
      CloseFile(FLog);
    end;
  except
    // ログ書き出しに失敗した場合何もしない
  end;
end;

　
　

iniファイルの内容を取得する処理

  • 指定したINIファイルから、セクションとキーを指定することで値を文字列形式で取得できます
    • ※uses節に「System.IniFiles」が必要
      （XE以前のバージョンでは「IniFiles」となります。）
  • INIファイルが1つしかない場合は、引数sFileNameの部分を固定値に変更することも可能です。
{*******************************************************************************
 目的: iniファイル取得処理
 引数: sFileName - ファイル名(フルパス)
       sSection  - セクション
       sKey      - キー
       sDefault  - 取得失敗時のデフォルト値
 戻値: 取得文字列
*******************************************************************************}
function GetIniFile(sFileName, sSection, sKey :String; sDefault :String = ''): String;
const
  cINIReadError  = 'INIファイル情報が取得できません。' + #13#10 + 'Section = %s , Key = %s';
var
  FileIni: TIniFile;
begin
  // iniファイルの読み込み
  FileIni := TIniFile.Create(sFileName);
  try
    try
      Result := FileIni.ReadString(sSection, sKey , sDefault);
    except
      raise Exception.Create(Format(cINIReadError, [sSection, sKey]));
    end;
  finally
    FileIni.Free;
  end;
end;

　
　

iniファイルへ書込を行う処理

  • 指定したINIファイルに、セクションとキーと文字列値を指定することで登録できます。
    • ※uses節に「System.IniFiles」が必要
      （XE以前のバージョンでは「IniFiles」となります。）
  • INIファイルが1つしかない場合は、引数sFileNameの部分を固定値に変更することも可能です。
{*******************************************************************************
 目的: iniファイル書込処理
 引数: sFileName - ファイル名(フルパス)
       sSection  - セクション
       sKey      - キー
       sValue    - 書込値
 戻値:
*******************************************************************************}
procedure SetIniFile(sFileName, sSection, sKey, sValue: String);
const
  cINIWriteError = 'INIファイル情報が設定できません。' + #13#10 + 'Section = %s , Key = %s';
var
  FileIni: TIniFile;
begin
  // INIファイルの書み込み
  FileIni := TIniFile.Create(sFileName);
  try
    try
      if sKey <> '' then
        FileIni.WriteString(sSection, sKey, sValue)
      else
        FileIni.EraseSection(sSection);
    except
      raise Exception.Create(Format(cINIWriteError, [sSection, sKey]));
    end;
  finally
    FileIni.Free;
  end;
end;

　
　

シフト文字を考慮した文字長を取得する処理

  • 通常のバイト単位の桁数に加えて、IBM i に登録時のシフト文字を１桁と換算した結果を返します。
  • 全角文字フィールドに値を更新する前に、桁あふれのチェックを行いたいときに重宝します。
    • ※uses節に「System.AnsiStrings」が必要
      　（V2009～XEでは「AnsiStrings」となります。ロジック中も同様です。）
    • ※V2007以前ではString型がANSIのため、ロジック中の「System.AnsiStrings」部分不要
{*******************************************************************************
 目的: 文字長取得処理
 引数: AText - 該当文字列
 戻値: シフト文字を含む文字長
*******************************************************************************}
function GetCharLength(AText: AnsiString): Integer;
var
  i: integer;
  InDBCS: Boolean;
begin
  InDBCS := False;
  Result := Length(AText);
  // 文字長取得処理
  for i := 1 to Length(AText) do
  begin
    case System.AnsiStrings.ByteType(AText, i) of
      mbSingleByte: // ASCII 文字もしくは半角カタカナ
        InDBCS := False;
      mbLeadByte:   // 2バイト文字の1バイト目
        if InDBCS = False then
        begin
          InDBCS := True;
          Result := Result + 2;
        end;
      mbTrailByte:  // 2バイト文字の2バイト目
        ;
    end;
  end;
end;

　
　

シフト文字を考慮した指定長文字列を取得する処理

  • １つ上のGetCharLength関数と組み合わせて使用します。
  • 全角文字フィールドに値を更新する前に桁あふれのチェックを行い、エラーにするのではなくあふれる分の後方文字をカットしたい際に役立ちます。
{*******************************************************************************
 目的: 指定長文字列取得処理
 引数: AText      - 対象文字列
       AMaxLength - 取得文字バイト数(シフト文字込)
 戻値: バイト数に収まる文字列
*******************************************************************************}
function GetLengthText(AText: AnsiString; AMaxLength: Integer): AnsiString;
begin
  if (AMaxLength <= 0) or (GetCharLength(AText) <= AMaxLength) then
    Result := AText
  else
  begin
    repeat
      AText := Copy(WideString(AText), 1, Length(WideString(AText)) - 1);
    until (GetCharLength(AText) <= AMaxLength);
    Result := AText;
  end;
end;

　
　

半角スペース埋め処理

  • 引数１の文字列に対して、その桁数が引数２で指定した桁数に満たないときに、
    後方または前方に半角スペースを付与します。
  • 桁位置が決まっている固定長のテキストでスペース埋めを行う際に使用します。
  • シフト文字の考慮は行っていないため、必要な場合はこの関数を通した後に
    １つ上のGetLengthTextを使用して不要部分を削って下さい。
{*******************************************************************************
 目的：半角スペース埋め処理（指定されたバイト長になるように半角スペースを付与）
 引数：S      - 処理対象文字列
      iLength - バイト長指定
      bLeft   - True＝左にブランク False＝右にブランク(初期値)
 戻値：ブランク埋めされた文字列
*******************************************************************************}
function FillBlank(S: String; iLength: Integer; bLeft: Boolean = False): String;
var
  i: Integer;
begin
  i := Length(AnsiString(S));
  if iLength > i then
  begin
    if bLeft then
    begin // bLeftがTrueの時は左にスペースを詰める
      Result := StringOfChar(' ', iLength - i) + S;
    end
    else
    begin // bLeftがFalseの時は右にスペースを詰める
      Result := S + StringOfChar(' ', iLength - i);
    end;
  end
  else
  begin
    Result := S;
  end;
end;

　
　

半角ゼロ埋め処理

  • １つ上のFillBlankと同様に、半角スペースではなく半角の「0」を埋めたい時に使用します。
  • こちらは数値項目で使用する想定のため、引数１に全角文字が入る考慮は未実施となります。
{*******************************************************************************
 目的：半角ゼロ埋め処理（指定されたバイト長になるように「0」を付与）
 引数：S - 処理対象文字列
       iLength - バイト長指定
       bLeft   - True＝左にゼロ(初期値) False＝右にゼロ
 戻値：0埋めされた文字列
*******************************************************************************}
function FillZero(S: String; iLength: Integer; bLeft: Boolean = True): String;
var
  i: Integer;
begin
  i := Length(AnsiString(S));
  if iLength > i then
  begin
    if bLeft then
    begin // bLeftがTrueの時は左に「0」を詰める
      Result := StringOfChar('0', iLength - i) + S;
    end
    else
    begin // bLeftがFalseの時は右に「0」を詰める
      Result := S + StringOfChar('0', iLength - i);
    end;
  end
  else
  begin
    Result := S;
  end;
end;

　
　

半角文字列を全角に変換

  • 文字列の中の半角文字を全角に変換します。
  • Ｊタイプフィールドへの更新時などに役立ちます。
{*******************************************************************************
 目的：半角文字列を全角に変換
 引数：sValue - 処理対象文字列
 戻値：半角部分が全角になった文字列
*******************************************************************************}
function SinglebyteToDoublebyte(const sValue: string): string;
var
  cChr : array[0..255] of char;
begin
  if 0 = Length(sValue) then
    Result := ''
  else
  begin
    Fillchar(cChr, Length(sValue)*2+2, 0);
    LCMapString(LOCALE_SYSTEM_DEFAULT, LCMAP_FULLWIDTH, Pchar(sValue), Length(sValue),
                cChr, Length(sValue)*2+1);
    Result := string(cChr);
  end;
end;

　
　

全角文字列を半角に変換

  • １つ上のSinglebyteToDoublebyteとは逆に、全角文字を半角に置き換えます。
  • Aタイプフィールドへの更新時チェックで使用する場合は、この関数を通します。
    • ※uses節に「System.AnsiStrings」が必要
      　（V2009～XEでは「AnsiStrings」となります。ロジック中も同様です。）
    • ※V2007以前ではString型がANSIのため、ロジック中の「System.AnsiStrings」部分不要
{*******************************************************************************
 目的：全角文字を半角に変換
       ※漢字及び全角記号の大部分(郵便番号等)は削除されます。
       ※Unicode依存文字は非対応
 引数：sValue - 処理対象文字列
 戻値：処理結果の文字列
*******************************************************************************}
function DoublebyteToSinglebyte(sValue: string): string;
var
  cBuff: PAnsiChar;
  iSize: Integer;
  sDelete: AnsiString;
begin
  Result := '';

  // 変換後の文字列サイズを取得(変換後のサイズが0なら終了)
  iSize := LCMapStringA(LOCALE_SYSTEM_DEFAULT,
                        LCMAP_KATAKANA or LCMAP_HALFWIDTH,
                        PAnsiChar(AnsiString(sValue)), Length(AnsiString(sValue)), nil, 0);
  if iSize = 0 then
    exit;

  // 変換後の文字列受取バッファを確保
  cBuff := AllocMem(iSize + 1);
  try
    // 文字列を変換後、バッファに受け取り
    iSize := LCMapStringA(LOCALE_SYSTEM_DEFAULT,
                          LCMAP_KATAKANA or LCMAP_HALFWIDTH,
                          PAnsiChar(AnsiString(sValue)), Length(AnsiString(sValue)), cBuff, iSize);
    // 変換後の文字列サイズを確認し、関数の戻り値にセット
    if iSize <> 0 then
      Result := System.AnsiStrings.StrPas(cBuff);
  finally
    // バッファに確保したメモリを解放
    FreeMem(cBuff);
  end;

  // 全角で残っている文字を削除（全角文字を残す場合はここをコメントアウト）
  for iSize := Length(AnsiString(Result)) downto 1 do
  begin
    if System.AnsiStrings.ByteType(AnsiString(Result), iSize) = mbLeadByte then
    begin
      sDelete := AnsiString(Result);
      Delete(sDelete, iSize, 2);
      Result := sDelete;
    end;
  end;
end;

　
　

全角スペースは半角スペースとし、連続スペースは詰める

  • スペース区切りの文字列などで、連続した全半角のスペースを１つにまとめる際に使用します。
{*******************************************************************************
 目的: 全角スペースは半角スペースとし、連続スペースは詰めて１個にする
 引数: AString - 元の文字列
 戻値: 処理後の文字列
*******************************************************************************}
function ShrinkSpaces(AString: String): String;
var
  ii: Integer;
begin

  // 全角スペースを半角にする
  Result := StringReplace(AString, '　', ' ', [rfReplaceAll, rfIgnoreCase]);
  ii     := Pos('  ', Result);

  // 連続したスペースを詰めて1個にする
  while (ii >= 1) do
  begin
    Result := StringReplace(Result, '  ', ' ', [rfReplaceAll, rfIgnoreCase]);
    ii     := Pos('  ', Result);
  end;
end;

　
　

文字列に対して、シフト文字の位置にダミーの半角スペースをセット

  • IBM i から取得した文字列をWindows上でもシフト文字があるかのように見せたい場合や、
    シフト文字の桁位置を考慮して文字列処理を行う必要がある場合に使用します。
{*******************************************************************************
 目的: 文字列に対して、SI/SOの位置にダミーの半角スペースをセット
 引数: 元の文字列
 戻値: 整形された文字列
*******************************************************************************}
function AddSISO(AStr: AnsiString): String;
var
  i: Integer;
  S: AnsiString;
begin
  // (初期値) 1バイト目が全角の場合
  if (System.AnsiStrings.ByteType(AStr, 1) = mbLeadByte) then
  begin
    S := ' ';
  end
  // (初期値) 1バイト目が半角の場合
  else
  begin
    S := '';
  end;

  // 文字列を確認し、全角と半角の切替ポイントにダミーの半角スペースをセット
  for i := 1 to Length(AStr) do
  begin
    S := S + AStr[i];

    if (System.AnsiStrings.ByteType(AStr, i) = mbSingleByte) then
    begin
      if (System.AnsiStrings.ByteType(AStr, i + 1) = mbLeadByte) then
      begin
        S := S + ' ';
      end;
    end;

    if (System.AnsiStrings.ByteType(AStr, i) = mbTrailByte) then
    begin
      if (System.AnsiStrings.ByteType(AStr, i + 1) = mbSingleByte) then
      begin
        S := S + ' ';
      end;
    end;
  end;

  Result := String(S);
end;

　
　

文字列に対して、シフト文字の位置の半角スペースをカット

  • １つ上のAddSISO関数で取得して処理を行った文字列を IBM i に書き戻すにあたって、
    AddSISO関数で付与したシフト文字を取り除きます。
{*******************************************************************************
 目的: 文字列に対して、SI/SOの位置の半角スペースをカット
 引数: 元の文字列(※SI/SO考慮済みの文字列が入ってくる前提)
 戻値: 整形された文字列
*******************************************************************************}
function RmvSISO(AStr: WideString): String;
var
  i: Integer;
  bSO: Boolean;
begin

  Result := '';
  bSO    := False;

  if AStr <> '' then
  begin
    // 文字単位で後ろからカウント
    for i := Length(AStr) downto 2 do
    begin
      // 1つ後の文字でフラグセットされた半角スペース(SO)のとき、セットしない
      if (bSO) then
      begin
        bSO := False;
      end
      else
      // 半角スペース(SI)かつ1つ前の文字が全角のとき、セットしない
      if (AStr[i] = ' ') and (Length(AnsiString(AStr[i - 1])) = 2) then
      begin
      end
      else
      begin
        // 文字をセット
        Result := AStr[i] + Result;

        // 全角かつ1つ前の文字が半角スペース(SO)のとき、フラグセット
        if (Length(AnsiString(AStr[i])) = 2) and (AStr[i - 1] = ' ') then
        begin
          bSO := True;
        end;
      end;
    end;

    // 全角始まりでない場合は1文字目(SIでない)を最後に足す
    if (not bSO) then
    begin
      Result := AStr[1] + Result;
    end;

  end;
end;

　
　

日付整数値を取得する処理

  • 日付型の変数を整数に変換します。
    （例：TDate「2021/11/19」⇒ Integer「20211119」）
{*******************************************************************************
 目的: 日付整数値取得処理
 引数: ADate - 日付値
 戻値: 処理結果整数値
*******************************************************************************}
function DateToInt(ADate: TDate): Integer;
begin
  Result := 0; // 初期化(条件に一致しない場合は0を返す)

  if not VarIsNull(ADate) then
  begin
    if (ADate <> 0) then
    begin
      try
        Result := StrToInt(FormatDateTime('yyyymmdd', ADate));
      except
        ShowMessage('日付値が正しくありません。');
        Abort;
      end;
    end;
  end;
end;

　
　

整数型からDelphi日付型への変換処理

  • 整数の変数を日付型に変換します。
    （例：Integer「20211119」⇒ TDate「2021/11/19」）
    ※下記ロジックでは、日付に変換できない数値を渡して発生するエラーは考慮していません。
{*******************************************************************************
 目的: 整数型からDelphi日付型への変換処理
 引数: 整数型
 戻値: Delphi日付
*******************************************************************************}
function IntToDate(ADateInteger: Integer): TDate;
var
  iYear, iMonth, iDay: Integer;
begin
  Result := 0;
  if ADateInteger <> 0 then
  begin
    iYear  := StrToInt(Copy(FormatFloat('00000000', ADateInteger), 1, 4));
    if iYear < 100 then
    begin
      if iYear < 50 then
        iYear := 2000 + iYear
      else
        iYear := 1900 + iYear;
    end;
    iMonth := StrToInt(Copy(FormatFloat('00000000', ADateInteger), 5, 2));
    iDay   := StrToInt(Copy(FormatFloat('00000000', ADateInteger), 7, 2));
    Result := EncodeDate(iYear, iMonth, iDay);
  end;
end;

　
　

時刻整数値を取得する処理

  • 時刻型の変数を整数に変換します。
    （例：TTime「03:56:30」⇒ Integer「35630」）
{*******************************************************************************
 目的: 時刻整数値取得処理
 引数: ATime - 時刻値
 戻値: 処理結果整数値（hhnnss）
*******************************************************************************}
function TimeToInt(ATime: TTime): Integer;
begin
  Result := 0; // 初期化(条件に一致しない場合は0を返す)

  if not VarIsNull(ATime) then
  begin
    if (ATime <> 0) then
    begin
      try
        Result := StrToInt(FormatDateTime('hhnnss', ATime));
      except
        ShowMessage('時刻値が正しくありません。');
        Abort;
      end;
    end;
  end;
end;

　
　

整数型からDelphi日付型(時刻)への変換処理

  • 整数型の変数を時刻型に変換します。
    （例：Integer「35630」⇒ TTime「03:56:30」）
    ※下記ロジックでは、時刻に変換できない数値を渡して発生するエラーは考慮していません。
{*******************************************************************************
 目的: 整数型からDelphi時刻型への変換処理
 引数: 整数型（hhnnss）
 戻値: Delphi時刻
*******************************************************************************}
function IntToTime(ATimeInteger: Integer): TTime;
var
  sTime: string;
begin
  Result := 0;
  if(ATimeInteger > 0) then
  begin
    sTime   := FormatFloat('000000', ATimeInteger);
    Result  := EncodeTime(StrToIntDef(Copy(sTime, 1, 2), 0),
                          StrToIntDef(Copy(sTime, 3, 2), 0),
                          StrToIntDef(Copy(sTime, 5, 2), 0),
                          0);
  end;
end;

　
　

半年前(ｎヶ月前)の日付を取得する

  • Delphiの「IncMonth」関数は、
    第１引数の日付に対して第２引数で指定した「ヶ月」後または前の日付を返します。
  • これと先述のIntToDate・DateToInt関数を利用して、
    YYYYMMDD形式の整数値で保持されている日付に対してｎヶ月後または前の日付を
    YYYYMMDD形式の整数値で返す共通関数を作成できます。
    （※そのため、実装には「IntToDate」「DateToInt」の実装も必要となります）
  • 「６ヶ月前より古い日付が名前に入ったファイルを削除」といった処理の日付判定に活用できます。
{*******************************************************************************
 目的: 半年前の日付を取得
 引数: 整数型(YYYYMMDD)
 戻値: 処理結果整数値(YYYYMMDD)
*******************************************************************************}
function GetBeforeHalfYear(ADateInteger: Integer): Integer;
var
  dDate: TDate;
begin
  // 日付型に変換
  dDate  := IntToDate(ADateInteger);

  // 6か月前に戻す
  dDate  := IncMonth(dDate, -6); // 6ヶ月前

  // 数値型に変換
  Result := DateToInt(dDate);
end;

　
　

当月末日の日付値を取得する処理

  • YYYYMMDD形式の整数値で保持されている日付を渡すと、
    先述のIntToDate・IncMonth・DateToIntの各関数を使用して
    「翌月１日の前日」つまり当月の末日をYYYYMMDD形式の整数値で返します。
    （※そのため、実装には「IntToDate」「DateToInt」の実装も必要となります）
    　※演算誤差防止のためSimpleRoundToを使用するため、uses節に「System.Math」が必要。
    　　（XE以前では「Math」となります。）
  • この関数を使用すれば、月によって最終日の日付を条件分岐させる必要がなくなります。
{*******************************************************************************
 目的: 当月末日の日付値取得
 引数: 整数型(YYYYMMDD)
 戻値: 当月末日の日付整数値(YYYYMMDD)
*******************************************************************************}
function GetGetsumatsu(ADateInteger: Integer): Integer;
var
  dTemp: TDate;
begin
  Result := ADateInteger;

  // 日付値かどうか判定(日付でない場合はExit)
  try
    IntToDate(ADateInteger);
  except
    Exit;
  end;

  // 当月末日の日付取得
  dTemp  := IntToDate(Trunc(SimpleRoundTo((ADateInteger * 1.00), 2) + 1)); // 当月1日を日付型にする
  dTemp  := IncMonth(dTemp, 1);   // 翌月1日にする
  Result := DateToInt(dTemp - 1); // 翌月1日の前日を返す
end;

　
　

割り算（0除算のエラー防止）

  • 単純に第１引数の値を第２引数の値で割り、
    第３引数が指定されている場合はその桁数（10のｎ乗）になるよう四捨五入する関数です。
    　※四捨五入でSimpleRoundToを使用するため、uses節に「System.Math」が必要。
    　　（XE以前では「Math」となります。）
    • 数学の世界では割り算で「0で割る」計算はタブーとされており、
      プログラミングの世界でも0で割るとエラーになる言語が大半を占めます。
      （Delphiでも、そのまま0で割ると「EZeroDivide」という例外が生成されます）
    • これを回避するため、0で割った場合はエラーにする代わりに0を返す考え方が
      存在し、この関数においても実装しています。
  • 計算結果の例：
    • Division(50, 10) ⇒ 5
    • Division(3.56, 0.01, 1) ⇒ 360（第３引数が 1 の場合、10位まで四捨五入）
    • Division(35, 6, -4) ⇒ 5.8333（第３引数が -4 の場合、0.0001位まで四捨五入
    • Division(50, 0) ⇒ 0（エラー防止）
{*******************************************************************************
 目的: 割り算(小数計算付き、0除算のエラー防止)
 引数: 割られる数と割る数(A÷B)、四捨五入桁数(未入力の場合は四捨五入しない)
 戻値: 計算結果
*******************************************************************************}
function Division(A, B: Double; iRound: Integer = 2000): Double;
begin
  if B = 0 then
    Result := 0 // 割る数が0の場合、結果を0としてエラーを回避する
  else
  begin
    Result := A / B;

    // 引数で四捨五入が設定されている場合、指定された桁数まで四捨五入を行う
    if (iRound <> 2000) then
    begin
      Result := SimpleRoundTo(Result, iRound);
    end;
  end;
end;

　
　

今現在マウスがあたっている場所の真下にあるコンポーネントを取得

  • PCやフォーム上のマウス座標を取得し、そこからマウスの直下にあるコンポーネントを返します。
  • マウス座標がフォーム外にいる場合など、コンポーネントが取得できない場合はnilが返ります。
    • 戻り値をTComponent型の変数に保持し、そこに「.Name」を付ければ
      そのコンポーネントの名称も取得可能です。（nilの場合はエラーになるため注意）
  • TTimerやTApplicationEventsコンポーネント、ActionのOnUpdateイベントなど、
    処理が常時走っているロジックの中で使用すると効果的です。
{*******************************************************************************
 目的: 今現在マウスがあたっている場所の真下にあるコンポーネントを取得
 引数:
 戻値: 対象コンポーネント（無い場合はnilが返る）
*******************************************************************************}
function GetNowComp: TComponent;
var
  P : TPoint;
begin
  // 常に最新の状態を取得させるため、TimerやAction.Update等で都度呼び出す

  // マウス位置の取得
  GetCursorPos(P);
  // 今現在マウスがあたっている場所の真下にあるコンポーネントを取得
  Result := FindDragTarget(P, True);
end;

　
　

ウインドウの最前面表示/解除

  • こちらは古くから存在するロジックですが、
    対象のフォームを常に最前面に表示させたり解除したりできます。
    • 最前面解除したタイミングでフォームが背面に隠れるわけではないため、
      何らかの処理の後にフォームが背面に隠れてしまう場合、このロジックで
      「一瞬最前面に表示してから最前面解除」すると前面に戻すことも可能です。
{*******************************************************************************
 目的: 対象ウインドウの最前面表示/解除
 引数: ATopMost - True＝最前面表示、False＝最前面解除
       AHWND    - 対象ウインドウハンドル
 戻値: 対象コンポーネントの名前
*******************************************************************************}
procedure Saizenmen(ATopMost: Boolean; AHWND: HWND);
begin
  if (ATopMost) then
  begin
    // 最前面に表示する
    SetWindowPos(AHWND,HWND_TOPMOST,0,0,0,0,SWP_NOSIZE or SWP_NOMOVE);
  end
  else
  begin
    // 普通に戻す
    SetWindowPos(AHWND,HWND_NOTOPMOST,0,0,0,0,SWP_NOSIZE or SWP_NOMOVE);
  end;
end;

　

　

指定したディレクトリ内のファイル名一覧作成

  • 第１引数で指定したフォルダの中にあるファイルやサブフォルダを
    TStringListにフルパスで一覧出力します。
    　※TDirectory・TStringDynArrayを使用するため、
    　　uses節に「System.IOUtils」「System.Types」が必要。
    　　（V2010・XEでは「IOUtils」「Types」となります。）
    • 下記ロジックで最初に「type ～ フォルダ探索時のオプション」とありますが、
      宣言部にこの最初の３行（青字部分）を記載しておきます。
    • 引数に相当するTStringListは、呼出元であらかじめ生成しておく必要があります。
      （初期化は行っていないため、呼出元で初期化していない場合は結果が追記されます）

※IOUtilsがV2010で追加されたユニットのため、この関数はV2010以降でのみ使用可能となります。

type
  // フォルダ探索時のオプション
  TListDirOption = (ldNone, ldSubSearch, ldOmitFolder, ldBoth);

{*******************************************************************************
 目的: 指定したディレクトリ内のファイル名一覧作成
 引数: APath - 対象ディレクトリのパス
       AList - (戻り値)結果代入用StringList
       Aldo  - オプション(ldNone＝なし ldSubSearch＝サブフォルダ内も参照
                          ldOmitFolder＝サブフォルダそのものは除外 ldBoth＝両方)
 戻値: 処理成否
*******************************************************************************}
function ListDirTree(APath: string; var AList: TStringList; Aldo: TListDirOption = ldNone): Boolean;
var
  LDirList : TStringDynArray;
  LFilesList : TStringDynArray;
  LDirName : String;
  LFileName  : String;
begin

  // AListには追記されるため、初期化が必要な場合は呼出元でかけておく

  Result := False; // 初期化

  // AListが存在しない場合生成
  if (not Assigned(AList)) then
  begin
    AList := TStringList.Create;
  end;

  // APathが存在しない場合終了
  if (not DirectoryExists(APath)) then
  begin
    Exit;
  end;

  // APath内のディレクトリのリスト作成
  LDirList := TDirectory.GetDirectories(APath);
  for LDirName in LDirList do
  begin
    // (指定時のみ)サブフォルダを結果に追加する
    if (Aldo in [ldNone, ldSubSearch]) then
    begin
      AList.Add((LDirName));
    end;

    // (指定時のみ)サブフォルダ内再帰検索
    if (Aldo in [ldSubSearch, ldBoth]) then
    begin
      ListDirTree(LDirName, AList, Aldo);
    end;
  end;

  // APath内のファイルのリスト作成
  LFilesList := TDirectory.GetFiles(APath);
  for LFileName in LFilesList do
  begin
    AList.Add((LFileName));
  end;

  AList.Sort; // 名前順にソート
  Result := True;
end;

　
　

メモのOnKeyDownイベントで「すべて選択」を有効化

  • こちらはTMemoコンポーネントに標準で付属しているOnKeyDownイベントで
    「Ctrl＋A」ショートカットを有効にさせるためのロジックです。
{*******************************************************************************
 目的: メモコンポーネント KeyDown処理
 引数:
 戻値:
*******************************************************************************}
procedure memoKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);
begin
  // Ctrl+A すべて選択
  if (Key = 65) and (ssCtrl in Shift) then
  begin
    (Sender as TMemo).SelectAll;
  end;
end;
  • また、親となるフォームのOnKeyDownイベントで、メモにフォーカスが当たっている時に
    「Ctrl＋A」を押すと「すべて選択」させるためのロジックは以下のようになります。
    ※フォームのKeyPreviewプロパティをTrueに設定する必要があります。
{*******************************************************************************
 目的: 画面キー押下時処理
 引数:
 戻値:
*******************************************************************************}
procedure TForm1.FormKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);
begin

  // メモにフォーカスが当たっている場合、Ctrl＋A＝全選択
  if (Key = 65) and (ssCtrl in Shift) and (ActiveControl is TMemo) then
  begin
    (ActiveControl as TMemo).SelectAll;
  end;
end;

　
　

入力項目の必須入力チェック

  • 入力コンポーネントを引数として読み込み、その入力値が空の場合にエラーを出力します。
    • 下記ロジックでは例としてTEdit/TMemo/TSpinEditのチェックを行っています。
      カスタムコンポーネントをご利用の場合は、下記ロジックの冒頭にある
      条件文の箇所に対象のコンポーネントの未入力チェックを追加して下さい。
{*******************************************************************************
 目的: Edit必須チェック
 引数: AEdt   - チェック対象Edit
       AErr   - エラーのconst値
       AMoth  - 虫食い値(1種類のみ)
 戻値:
*******************************************************************************}
procedure NeccesaryCheck(AEdt: TWinControl; AErr, AMoth: string);
begin

  if ((AEdt is TEdit) and     (Trim((AEdt as TEdit).Text) = '')) or        // TEditでブランク
     ((AEdt is TMemo) and     (Trim((AEdt as TMemo).Lines.Text) = '')) or  // メモでブランク
     ((AEdt is TSpinEdit) and ((AEdt as TSpinEdit).Value = 0)) then        // 数値入力項目で入力値が0
  begin
    // エラーメッセージを返してフォーカスセット、処理中断
    ShowMessage(AMoth + AErr); // ※AErrには「が入力されていません」といった値が渡ってくる想定
    if (AEdt.CanFocus) then
    begin
      AEdt.SetFocus;
    end;
    Abort;
  end;
end;

　
　

2点間の経度と緯度から直線距離を計測

  • 地点１と地点２の経度と緯度を引数に渡すことで、その２地点間の直線距離を返します。
{*******************************************************************************
 目的: 2点間の経度と緯度から直線距離を計測 ※東経/西経、北緯/南緯は跨がない前提
 引数: AK1 - 地点１の経度
       AI1 - 地点１の緯度
       AK2 - 地点２の経度
       AI2 - 地点２の緯度
 戻値: 計測結果(メートル)
*******************************************************************************}
function GPStoDistance(AK1, AI1, AK2, AI2: Double): Double;
const
  cIDO111  = 111.3194908;  // 緯度1度あたりのkm
var
  distK, distI: Double;
begin

  // 南北方向の距離（度数の差×緯度1度あたりのkm）
  distI := Abs((AI1 - AI2)) * cIDO111;

  // 東西方向の距離（度数の差×緯度によるcos判定値×緯度1度あたりのkm）
  distK := Abs((AK1 - AK2)) * Cos((AI1 + AI2) / 2 * Pi / 180) * cIDO111;

  // 三平方の定理で距離計算
  Result := Sqrt(Sqr(distI) + Sqr(distK));
  Result := Result * 1000;  // km→mに変換
end;

　

　

　

サンプルソースダウンロード

ここまで紹介してきた関数のサンプルロジックは、以下のリンクからダウンロード可能です。

（※下記以外のバージョンをご利用のお客様は、近いバージョンの方をダウンロード下さい。）

=======================================
【免責事項】
本ページに掲載しているソースコードは情報提供の為のサンプルプログラムとなります。
お客様作成アプリケーション内で自由にご利用いただけます。
ただし、これらのソースコードやサンプルプログラムを使用したことによって生じた、
いかなる障害・損失に関しても一切の責を負いかねますので、ご了承下さい。
=======================================

　

Migaro.技術Tips一覧へ

 

株式会社ミガロ．

© 2024 MIGARO CO.,LTD.