unit _myWStrings; //{$DEFINE _DEBUG} //{$DEFINE MYLIB} interface uses Windows, Classes; const CP_SHIFTJIS = 932; CP_JIS = 50220; //半角カナは全角に変換される。 // CP_JIS = 50221; //半角カナOK。 // CP_JIS = 50222; //漢字SI/SO // CP_EUC = 51932; //MultiByteToWideCharとWideCharToMultiByteではエラーになる。 CP_EUC = 20932; //変わりにこちらを使うとOK。 type TMyCharCode = ( cdAuto, //自動判定 cdSJis, //Shift_JIS cdUnicodeLE, //UTF-16 LE (リトルエンディアン) BOMあり cdUTF_16LE, //UTF-16 LE (リトルエンディアン) BOMなし cdUnicodeBE, //UTF-16 BE (ビッグエンディアン) BOMあり cdUTF_16BE, //UTF-16 BE (ビッグエンディアン) BOMなし cdUTF_8, //UTF-8 BOMあり cdUTF_8N, //UTF-8 BOMなし cdUTF_7, //UTF-7 cdJIS, //JIS cdEUC, //EUC-JP cdBINDUMP //バイナリダンプ ); function gfnsCharCodeToDescription(cdCode : TMyCharCode) : String; function gfnsCharCodeToText (cdCode : TMyCharCode) : String; function gfnCodePageToCharCode(iCodePage : Integer) : TMyCharCode; type TMyNewLine = ( nlCRLF, //CR + LF nlCR, //CR nlLF //LF ); function gfnsNewLineGet(nlLineFeed : TMyNewLine) : String; function gfnsNewLineToDescription(nlLineFeed : TMyNewLine) : String; //------------------------------------------------------------------------------ //UTF-16LE⇔UTF-7 function gfnsWideToUtf7(sSrc : String) : AnsiString; function gfnsUtf7ToWide(sSrc : AnsiString) : String; //UTF-16LE⇔UTF-8 function gfnsWideToUtf8(sSrc : String) : AnsiString; function gfnsUtf8ToWide(sSrc : AnsiString) : String; function gfnsJisToWide(sSrc : AnsiString) : String; function gfnsWideToJis(sSrc : String) : AnsiString; function gfnsEucToWide(sSrc : AnsiString) : String; function gfnsWideToEuc(sSrc : String) : AnsiString; //Unicode→Shift_JIS function gfnsWideToAnsi(sSrc : String) : AnsiString; //AnsiString⇔WideString //function gfnsWideToAnsiEx(sSrc : String) : AnsiString; //function gfnsAnsiToWideEx(sSrc : AnsiString) : String; //ウムラウトのようなUnicodeを含んでいるか function gfnbIsUnicode(sSrc: String): Boolean; function gfniCodePageGet(pBuff: PAnsiChar; iCount: Integer): Integer; function gfnCharCodeGet(pBuff: PAnsiChar; iCount: Integer): TMyCharCode; //------------------------------------------------------------------------------ //ファイルとのやり取り function gfnsFileReadText(sFile : String) : String; overload; function gfnsFileReadText(sFile : String; var cdCode : TMyCharCode) : String; overload; function gfnsFileReadText(sFile : String; var cdCode : TMyCharCode; iByte: DWORD) : String; overload; function gfnbFileWriteText(sFile, sText : String) : Boolean; overload; function gfnbFileWriteText(sFile, sText : String; const cdCode : TMyCharCode) : Boolean; overload; //------------------------------------------------------------------------------ {TMyWStrings} {TStringsでWideStringを持つために。 2011-11-10: 　RawStringsプロパティ追加。 　RawStringsをTMyFileStringsなどの引数に指定してCreateすることでTMyFileStringsの 　メソッドや関数を適用できるようにするため。 　AnsiStringsやAnsiExStringsはコピーされたものなのでF_slListには影響が及ばないの 　でこのような場合にはNGであったため。 2011-06-20: 　function TMyWStrings.GetTextStr: String; 　改行コード付加の条件式を(i < li_Count)としていたのでエラーが出ていたのを修正。 2011-04-21: 　このユニットだけで完結するように汎用ルーチンを取り込み。 　WideString関係の汎用ルーチンをmyString.pasから移動。 2008-07-09: 　WideToAnsiとAnsiToWideを抽象メソッドから仮想メソッドに変更。 　TMyWStringsでCreateしても問題ないように。 } type TMyWStrings = class; //カスタムソート用下請け関数の型定義 TMyWStringsSortCompare = function(slList: TMyWStrings; iIndex1, iIndex2: Integer): Integer; TMyWStringsOnAdd = procedure(Sender: TObject; iCount: Integer; iLength: Int64) of object; TMyWStrings = class(TObject) private FList : TStrings; FOutList : TStrings; FbListFree : Boolean; //FListをFreeするか //検索用 //and検索か FbFindAnd : Boolean; //Trueで区別しない FbIgnoreCase : Boolean; //大文字と小文字を区別しません FbIgnoreKanaType : Boolean; //ひらがなとカタカナを区別しません FbIgnoreNonSpace : Boolean; //濁音や拗音を無視します FbIgnoreSymbols : Boolean; //記号を無視します FbIgnoreWidth : Boolean; //全角と半角を区別しません FbCaseSensitive : Boolean; //比較に大文字小文字を区別するか FbSorted : Boolean; FiSortDepth : Int64; FsProgressMsg : String; FDuplicates : TDuplicates; FsDelimiter : String; //TextEx用区切り文字 FsQuoteChar : String; FcdCharCode : TMyCharCode; FnlNewLine : TMyNewLine; FbObjectsFree : Boolean; //ClearやDeleteでObjectsをFreeするか FOnAdd : TMyWStringsOnAdd; FOnChange : TNotifyEvent; //オブジェクト開放 procedure FFreeObject(iIndex: Integer); procedure FSetCaseSensitive(bSensitive: Boolean); procedure FSetIgnoreCase(bIgnore: Boolean); function FGetName(iIndex : Integer) : String; procedure FSetSorted(bValue: Boolean); function FGetValue (sName: String): String; procedure FSetValue (sName, sValue: String); // function FGetAnsiStrings: TStrings; function FGetUtf7Strings: TStrings; function FGetUtf8Strings: TStrings; //検索オプション function FGetFindCmpFlags: DWORD; function FGetFindString(sStr: String): String; protected function Get(iIndex: Integer): String; virtual; procedure Put(iIndex: Integer; sStr: String); virtual; function GetCommaText: String; function GetDelimitedText: String; function GetObject(Index: Integer): TObject; virtual; procedure PutObject(Index: Integer; AObject: TObject); virtual; function GetTextStr: String; virtual; procedure SetTextStr(sText: String); virtual; function GetTextStrEx: String; virtual; procedure SetTextStrEx(sText: String); virtual; procedure SortDupDelete; virtual; function GetCount: Integer; function GetCapacity: Integer; virtual; procedure SetCapacity(NewCapacity: Integer); virtual; property ProgressMessage : String read FsProgressMsg; public constructor Create; overload; virtual; constructor Create(AList: TStrings); overload; virtual; destructor Destroy; override; function Add(sStr: String): Integer; virtual; procedure AddFile(sFile: String); overload; virtual; procedure AddFile(AList: TMyWStrings); overload; virtual; function AddObject(S: String; AObject: TObject): Integer; virtual; function AddName(sName, sValue: String): Integer; virtual; procedure AddStrings(AList: TStrings); overload; virtual; procedure AddStrings(AList: TMyWStrings); overload; virtual; procedure AddStrings(iCount: Integer); overload; virtual; procedure AddText(sText: String); virtual; procedure Append(sStr: String); virtual; procedure Assign(AList: TStrings); overload; virtual; procedure Assign(AList: TMyWStrings); overload; virtual; procedure Attach(AList: TStrings); virtual; procedure BeginUpdate; virtual; procedure Clear; virtual; procedure CustomSort(fniCompare: TMyWStringsSortCompare); virtual; procedure Delete(iIndex: Integer); virtual; procedure Detach; virtual; procedure EndUpdate; virtual; function Equals(AList: TMyWStrings): Boolean; reintroduce; procedure Exchange(iIndex1, iIndex2: Integer); virtual; procedure FileInsertionSort; overload; procedure FileInsertionSort(bUnique: Boolean); overload; procedure FileSort; overload; virtual; procedure FileSort(bUnique: Boolean); overload; virtual; procedure FileSort(iStart, iEnd : Integer); overload; virtual; function Find(sStr: String; var iIndex: Integer): Boolean; overload; virtual; function FindDown(sStr: String; iIndex: Integer = 0): Integer; overload; virtual; function FindUp (sStr: String; iIndex: Integer = 0): Integer; overload; virtual; function FindDown(sStrs: array of String; iIndex: Integer = 0): Integer; overload; virtual; function FindUp (sStrs: array of String; iIndex: Integer = 0): Integer; overload; virtual; function FindDown(AStr: TStrings; iIndex: Integer = 0): Integer; overload; virtual; function FindUp (AStr: TStrings; iIndex: Integer = 0): Integer; overload; virtual; function IndexOf(sStr: String): Integer; overload; function IndexOf(sStr: String; iIndex: Integer): Integer; overload; function IndexOfName(sName: String): Integer; overload; function IndexOfName(sName: String; iIndex: Integer): Integer; overload; function InHeadStringOf(sStr: String): Integer; overload; virtual; function InHeadStringOf(sStr: String; iIndex: Integer): Integer; overload; virtual; procedure Insert(iIndex: Integer; sStr: String); virtual; procedure InsertionSort(const bUnique: Boolean); overload; virtual; procedure InsertionSort(fniCompare: TMyWStringsSortCompare); overload; procedure InsertionSort(fniCompare: TMyWStringsSortCompare; const bUnique: Boolean); overload; virtual; procedure InsertObject(Index: Integer; S: String; AObject: TObject); virtual; procedure InsertStrings(iIndex: Integer; slList: TStrings); overload; virtual; procedure InsertStrings(iIndex: Integer; slList: TMyWStrings); overload; virtual; function InStringOf(sStr: String): Integer; overload; virtual; function InStringOf(sStr: String; iIndex: Integer): Integer; overload; virtual; procedure LoadFromFile(sFile: String); overload; virtual; procedure LoadFromFile(sFile: String; var cdCode: TMyCharCode); overload; virtual; procedure LoadFromFile(sFile: String; var cdCode: TMyCharCode; iByte: DWORD); overload; virtual; procedure MergeSort(iStart, iEnd : Integer; fniCompare : TMyWStringsSortCompare); overload; virtual; procedure MergeSort(iStart, iEnd : Integer); overload; virtual; procedure MergeSort(fniCompare : TMyWStringsSortCompare; bUnique : Boolean); overload; virtual; procedure MergeSort(fniCompare : TMyWStringsSortCompare); overload; virtual; procedure MergeSort; overload; virtual; procedure Move(iCurrentIndex, iNewIndex: Integer); virtual; procedure QuickSort(fniCompare: TMyWStringsSortCompare); overload; virtual; procedure QuickSort(fniCompare: TMyWStringsSortCompare; bUnique: Boolean); overload; virtual; procedure Reverse; virtual; function SaveToFile(sFile: String; cdCode: TMyCharCode; nlNewLine: TMyNewLine): Boolean; overload; virtual; function SaveToFile(sFile: String; cdCode: TMyCharCode): Boolean; overload; virtual; function SaveToFile(sFile: String): Boolean; overload; virtual; procedure Sort; virtual; property Capacity: Integer read GetCapacity write SetCapacity; property CharCode: TMyCharCode read FcdCharCode write FcdCharCode; property CommaText: String read GetCommaText; property Count: Integer read GetCount; property Delimiter: String read FsDelimiter write FsDelimiter; property DelimitedText: String read GetDelimitedText; property Duplicates: TDuplicates read FDuplicates write FDuplicates; property NewLine: TMyNewLine read FnlNewLine write FnlNewLine; property ObjectsFree: Boolean read FbObjectsFree write FbObjectsFree; property QuoteChar: String read FsQuoteChar write FsQuoteChar; property Sorted: Boolean read FbSorted write FSetSorted; property Text: String read GetTextStr write SetTextStr; property TextEx: String read GetTextStrEx write SetTextStrEx; // property AnsiStrings: TStrings read FGetAnsiStrings; //gfnsWideToAnsi property Utf7Strings: TStrings read FGetUtf7Strings; //gfnsWideToUtf7 property Utf8Strings: TStrings read FGetUtf8Strings; //gfnsWideToUtf8 property UStrings: TStrings read FList; property Names [iIndex: Integer]: String read FGetName; property Objects[iIndex: Integer]: TObject read GetObject write PutObject; property Strings[iIndex: Integer]: String read Get write Put; default; property Values [sName: String]: String read FGetValue write FSetValue; property OnAdd : TMyWStringsOnAdd read FOnAdd write FOnAdd; property OnChange : TNotifyEvent read FOnChange write FOnChange; //検索用 Trueで区別する property CaseSensitive : Boolean read FbCaseSensitive write FSetCaseSensitive; //検索用 Trueで区別しない property IgnoreCase : Boolean read FbIgnoreCase write FSetIgnoreCase; //大文字と小文字を区別しません property IgnoreKanaType : Boolean read FbIgnoreKanaType write FbIgnoreKanaType; //ひらがなとカタカナを区別しません // property IgnoreNonSpace : Boolean read FbIgnoreNonSpace write FbIgnoreNonSpace; //濁音や拗音を無視します // property IgnoreSymbols : Boolean read FbIgnoreSymbols write FbIgnoreSymbols; //記号を無視します property IgnoreWidth : Boolean read FbIgnoreWidth write FbIgnoreWidth; //全角と半角を区別しません end; //============================================================================== implementation uses {$IFDEF _DEBUG} myDebug, myTag, {$ENDIF} Forms, {$IFDEF MYLIB} myFile, myIniFile, myList, myMessageBox, myNum, myString, myWindow, {$ENDIF} ActiveX, PsApi, ShellApi, SysUtils; function _fniSortFuncFileList(slList: TMyWStrings; iIndex1, iIndex2: Integer): Integer; forward; {$IFNDEF MYLIB} //汎用ルーチン ---------------------------------------------------------------- //myNum.pas -------------------------------------------------------------------- //数値 function gfniNumLimit(iNum: Integer; iMin, iMax: Integer): Integer; begin if (iMin = iMax) then begin Result := iMin; end else begin if (iNum < iMin) then begin Result := iMin; end else if (iNum > iMax) then begin Result := iMax; end else begin Result := iNum; end; end; end; function gfniMin(iNum: array of Integer): Integer; {2007-12-16: 引数の中の最小値を返す } var i: Integer; begin Result := iNum[0]; for i := 1 to High(iNum) do begin if (iNum[i] < Result) then Result := iNum[i]; end; end; function gfnbIsInsideRange(iNum, iMin, iMax: Integer): Boolean; {2010-07-13: } var li_Min : Int64; li_Max : Int64; begin li_Min := iMin; li_Max := iMax; // l_pcNumSwap_MinMax(li_Min, li_Max); Result := (iNum >= li_Min) and (iNum <= li_Max); end; //myFile.pas ------------------------------------------------------------------- //ファイル function gfnsFileMainGet(sFile: String): String; {2007-08-05,10-26: ファイル名のうちパスと拡張子を除いた部分を返す メインファイル名の拡張子のないもの \ と . はつかない 2007-10-26:ピリオドつきの主ファイル名の処理がうまくいっていなかったのを修正 lb_Extを判定に追加 } var i: Integer; lb_Ext: Boolean; //2007-10-26 begin Result := ''; lb_Ext := True; for i := Length(sFile) downto 1 do begin if (sFile[i] = '\') or (sFile[i] = '/') or (sFile[i] = ':') then begin //\と/と:が出てきた時点でファイル名の終了なのでループを抜ける Break; end else if (sFile[i] = '.') and (lb_Ext) then begin; //2007-10-26 //拡張子であったので今までのをチャラにする Result := ''; lb_Ext := False; end else begin Result := sFile[i] + Result; end; end; end; procedure gpcFileDirNameDiv(sFile: String; out sPath, sName: String); //sPathにパスをsNameにファイル名をセットして返す //末尾の \ は"返らない" var i, li_Pos, li_Start: Integer; begin li_Pos := -1; li_Start := 0; for i := Length(sFile) downto 1 do begin if (sFile[i] = '\') or (sFile[i] = '/') then begin li_Pos := i - 1; li_Start := i + 1; Break; end else if (sFile[i] = ':') then begin li_Pos := i; li_Start := i + 1; Break; end; end; sPath := Copy(sFile, 1, li_Pos); sName := Copy(sFile, li_Start, Length(sFile)); end; function gfniFileSizeGet(sFile: String): Int64; //sWFileのサイズをByte単位で返す var lh_File: Cardinal; lr_Info: TWin32FindData; begin Result := 0; lh_File := FindFirstFile(PChar(sFile), lr_Info); try if (lh_File <> INVALID_HANDLE_VALUE) then begin repeat if not(BOOL(lr_Info.dwFileAttributes and FILE_ATTRIBUTE_DIRECTORY)) then begin Result := lr_Info.nFileSizeHigh * (Int64(MAXDWORD) + 1) + lr_Info.nFileSizeLow; Break; end; until not(FindNextFile(lh_File, lr_Info)); end; finally Windows.FindClose(lh_File); end; end; function gfnsExeNameGet(sStr: String): String; overload; var li_Count: Integer; lpp_Arg, lpp_Param: PPWideChar; begin Result := ''; if (sStr <> '') then begin lpp_Param := CommandLineToArgvW(PWideChar(sStr), li_Count); try lpp_Arg := lpp_Param; Result := String(lpp_Arg^); //実行ファイル名 finally LocalFree(Cardinal(lpp_Param)); end; end; end; function gfnsExeNameGet: String; overload; {2007-09-24,2009-09-23: WideString対応の実行プログラム名を返す。 2009-09-23: 　コマンドラインを分解して取得するのではなくApplicationのウィンドウハンドルから 　取得するように変更。 　コマンドプロンプトから実行させるとパスがつかないことがあることへの対処。 } function lfni_ProcessIDGet(hHandle: HWND): DWORD; begin GetWindowThreadProcessId(hHandle, @Result); end; function lfns_ExeNameGet(hHandle: HWND): String; //ウィンドウハンドルからexeファイル名を返す //http://m--takahashi.com/bbs/pastlog/02500/02414.html //http://www.geocities.jp/fjtkt/problems/2003_0004.html var lh_Process: THandle; ls_PWExe: PWideChar; begin Result := ''; lh_Process := OpenProcess(PROCESS_QUERY_INFORMATION or PROCESS_VM_READ, False, lfni_ProcessIDGet(hHandle)); try ls_PWExe := AllocMem((MAX_PATH + 1) * 2); try //プロセスハンドルを渡すだけで実行ファイル名を得られた。インスタンスハンドルはいらないようだ。 if (GetModuleFileNameExW(lh_Process, 0, ls_PWExe, MAX_PATH) <> 0) then begin Result := String(ls_PWExe); end; finally FreeMem(ls_PWExe); end; finally CloseHandle(lh_Process); end; end; var lh_Handle: HWND; begin lh_Handle := Application.Handle; if (lh_Handle <> 0) then begin Result := lfns_ExeNameGet(lh_Handle); end; if (Result = '') then begin Result := gfnsExeNameGet(GetCommandLineW); end; end; //ファイルバージョン type TMyFileVersionInfo = record Comments, // コメント CompanyName, // 会社名 FileDescription, // 説明 FileVersion, // ファイルバージョン InternalName, // 内部名 LegalCopyright, // 著作権 LegalTrademarks, // 商標 OriginalFilename, // 正式ファイル名 PrivateBuild, // プライベートビルド情報 ProductName, // 製品名 ProductVersion, // 製品バージョン SpecialBuild: String; // スペシャルビルド情報 end; function gfnrFileVersionInfoGet(sFile: String): TMyFileVersionInfo; {2007-06-09: ファイルのバージョン情報を返す http://www2.big.or.jp/~osamu/Delphi/Tips/key.cgi?key=13#0226.txt } type TLangAndCodePage = record iLanguage: WORD; iCodePage: WORD; end; PLangAndCodePage = ^TLangAndCodePage; var li_Size, li_Reserved, li_Len : DWORD; lp_Buff, // lp_Locale, lp_Dat : Pointer; // li_Hi, // li_Lo : Integer; lp_LangPage : PLangAndCodePage; ls_FileInfo : String; begin // 必要なバッファのサイズを取得 li_Size := GetFileVersionInfoSizeW(PWideChar(sFile), li_Reserved); if (li_Size > 0) then begin //メモリ確保 lp_Buff := AllocMem((li_Size +1) * 2); try if (GetFileVersionInfoW(PWideChar(sFile), 0, li_Size, lp_Buff)) then begin //変数情報ブロック内の変換テーブルを指定 // if (VerQueryValueW(lp_Buff, '\VarFileInfo\Translation', lp_Locale, li_Len) and (li_Len > 0)) then begin // gpcInt32ToHiLo(Integer(lp_Locale^), li_Hi, li_Lo); // ls_FileInfo := Format('\StringFileInfo\%.4x%.4x\', [li_Lo, li_Hi]); if (VerQueryValueW(lp_Buff, '\VarFileInfo\Translation', Pointer(lp_LangPage), li_Len) and (li_Len > 0)) then begin ls_FileInfo := String(Format('\StringFileInfo\%.4x%.4x\', [lp_LangPage^.iLanguage, lp_LangPage^.iCodePage])); //コメント if (VerQueryValueW(lp_Buff, PWideChar(ls_FileInfo + 'Comments'), lp_Dat, li_Len) and (li_Len > 0)) then begin Result.Comments := String(PWideChar(lp_Dat)); end; //会社名 if (VerQueryValueW(lp_Buff, PWideChar(ls_FileInfo + 'CompanyName'), lp_Dat, li_Len) and (li_Len > 0)) then begin Result.CompanyName := String(PWideChar(lp_Dat)); end; //説明 if (VerQueryValueW(lp_Buff, PWideChar(ls_FileInfo + 'FileDescription'), lp_Dat, li_Len) and (li_Len > 0)) then begin Result.FileDescription := String(PWideChar(lp_Dat)); end; //ファイルバージョン if (VerQueryValueW(lp_Buff, PWideChar(ls_FileInfo + 'FileVersion'), lp_Dat, li_Len) and (li_Len > 0)) then begin Result.FileVersion := String(PWideChar(lp_Dat)); end; //内部名 if (VerQueryValueW(lp_Buff, PWideChar(ls_FileInfo + 'InternalName'), lp_Dat, li_Len) and (li_Len > 0)) then begin Result.InternalName := String(PWideChar(lp_Dat)); end; //著作権 if (VerQueryValueW(lp_Buff, PWideChar(ls_FileInfo + 'LegalCopyright'), lp_Dat, li_Len) and (li_Len > 0)) then begin Result.LegalCopyright := String(PWideChar(lp_Dat)); end; //商標 if (VerQueryValueW(lp_Buff, PWideChar(ls_FileInfo + 'LegalTrademarks'), lp_Dat, li_Len) and (li_Len > 0)) then begin Result.LegalTrademarks := String(PWideChar(lp_Dat)); end; //正式ファイル名 if (VerQueryValueW(lp_Buff, PWideChar(ls_FileInfo + 'OriginalFilename'), lp_Dat, li_Len) and (li_Len > 0)) then begin Result.OriginalFilename := String(PWideChar(lp_Dat)); end; //プライベートビルド情報 if (VerQueryValueW(lp_Buff, PWideChar(ls_FileInfo + 'PrivateBuild'), lp_Dat, li_Len) and (li_Len > 0)) then begin Result.PrivateBuild := String(PWideChar(lp_Dat)); end; //製品名 if (VerQueryValueW(lp_Buff, PWideChar(ls_FileInfo + 'ProductName'), lp_Dat, li_Len) and (li_Len > 0)) then begin Result.ProductName := String(PWideChar(lp_Dat)); end; //製品バージョン if (VerQueryValueW(lp_Buff, PWideChar(ls_FileInfo + 'ProductVersion'), lp_Dat, li_Len) and (li_Len > 0)) then begin Result.ProductVersion := String(PWideChar(lp_Dat)); end; //スペシャルビルド情報 if (VerQueryValueW(lp_Buff, PWideChar(ls_FileInfo + 'SpecialBuild'), lp_Dat, li_Len) and (li_Len > 0)) then begin Result.SpecialBuild := String(PWideChar(lp_Dat)); end; end; end; finally // 解放 FreeMem(lp_Buff); end; end; end; function gfnsProductNameGet: String; //自アプリの製品名。 var lr_Info: TMyFileVersionInfo; begin lr_Info := gfnrFileVersionInfoGet(gfnsExeNameGet); Result := lr_Info.ProductName; if (Result = '') then begin //製品名が指定されていなければ主ファイル名を返す。 Result := gfnsFileMainGet(gfnsExeNameGet); end; end; //myString.pas ----------------------------------------------------------------- //StringReplace のUnicode対応版的。 function gfnsStrReplace(sSrc, sOld, sNew: String; const bCaseSensitive: Boolean): String; overload; {2008-12-07,2011-11-21: StringReplaceのUnicode対応版。 bCaseSensitiveは大文字小文字の区別をするかしないか。 Trueで区別する。 } var li_Pos : Integer; li_SrcIndex : Integer; li_ResIndex : Integer; ls_CmpSrc : String; ls_CmpOld : String; lp_Src : PWideChar; lp_CmpSrc : PWideChar; li_SrcLen : Integer; li_OldLen : Integer; li_NewLen : Integer; li_Count : Integer; li_Indexs : array of Integer; li_Len : Integer; i : Integer; begin if (sSrc = '') or (sOld = '') then begin Result := sSrc; Exit; end; if not(bCaseSensitive) then begin ls_CmpOld := UpperCase(sOld); ls_CmpSrc := UpperCase(sSrc); end else begin ls_CmpOld := sOld; ls_CmpSrc := sSrc; end; li_SrcLen := Length(sSrc); li_OldLen := Length(sOld); SetLength(li_Indexs, li_SrcLen +1); //最大 li_Indexs[0] := 0; li_Count := 0; li_SrcIndex := 0; repeat lp_CmpSrc := @PWideChar(ls_CmpSrc)[li_SrcIndex]; li_Pos := Pos(ls_CmpOld, String(lp_CmpSrc)); if (li_Pos > 0) then begin //置換対象文字列があった。 li_Indexs[li_Count +1] := li_SrcIndex + li_Pos -1; Inc(li_Count); li_SrcIndex := li_SrcIndex + li_Pos + li_OldLen -1; end; until (li_Pos = 0); if (li_Count <= 0) then begin Result := sSrc; end else begin li_NewLen := Length(sNew); li_Len := Length(sSrc) + (li_NewLen - li_OldLen) * li_Count; if (li_Len <= 0) then begin Result := ''; Exit; end; SetLength(Result, li_Len); li_ResIndex := 1; //ResultはWideStringなので0ではなく1 lp_Src := @PWideChar(sSrc)[0]; for i := 1 to li_Count do begin li_Len := li_Indexs[i] - li_Indexs[i-1]; if (i = 1) then begin Inc(li_Len); end; lstrcpynW(PWideChar(@Result[li_ResIndex]), lp_Src, li_Len); Inc(li_ResIndex, li_Len -1); if (li_NewLen > 0) then begin lstrcpynW(PWideChar(@Result[li_ResIndex]), PWideChar(sNew), li_NewLen +1); Inc(li_ResIndex, li_NewLen); end; lp_Src := @PWideChar(sSrc)[li_Indexs[i] +1]; end; //残りをコピー lstrcpynW(PWideChar(@Result[li_ResIndex]), lp_Src, li_SrcLen - li_Indexs[li_Count]); //実装が正しければ必要のない処理。 // Result := String(PWideChar(Result)); end; end; function gfnsStrReplace(sSrc, sOld, sNew: String): String; overload; {2008-12-07: StringReplaceのUnicode対応版。 大文字小文字の区別あり。 } begin Result := gfnsStrReplace(sSrc, sOld, sNew, True); end; function gfnsPCharToBinDump(pStr: PAnsiChar; iCount: Integer): AnsiString; {2010-10-05: pStrを16進ダンプして返す } const lcs_NOTCHAR = '.'; lci_DUMP = 16; lci_DUMPHEX = lci_DUMP * 3 +2; lci_COLUMN = lci_DUMPHEX +1 + lci_DUMP +1; //間の#$9と改行の#$Dでそれぞれ+1 var i, k, li_Count, li_Mod, li_Index, li_ResultLen: Integer; ls_Dump, ls_Ansi: AnsiString; ls_Char: AnsiChar; li_Byte: Byte; begin // Result := ''; li_Count := iCount div lci_DUMP; li_Mod := iCount mod lci_DUMP; SetLength(ls_Ansi, lci_DUMP); SetLength(ls_Dump, lci_DUMPHEX); if (li_Mod > 0) then begin li_ResultLen := (li_Count +1) * lci_COLUMN +1; //半端のライン分でli_Count +1 end else begin li_ResultLen := li_Count * lci_COLUMN; Dec(li_Count); end; SetLength(Result, li_ResultLen); FillChar(Result[1], li_ResultLen, 0); for i := 0 to li_Count do begin { if (li_Mod = 0) and (i = li_Count) then begin Break; end; } FillChar(ls_Ansi[1], lci_DUMP, $20); FillChar(ls_Dump[1], lci_DUMPHEX, $20); li_Index := 1; for k := 0 to lci_DUMP -1 do begin if (i = li_Count) and (k >= li_Mod) then begin ls_Dump[li_Index] := ' '; Break; end; ls_Char := pStr[lci_DUMP * i + k]; li_Byte := Ord(ls_Char); case li_Byte of 0..$1F, $7F, $FD..$FF: begin ls_Ansi[k +1] := lcs_NOTCHAR; end; else begin if ((IsDBCSLeadByte(li_Byte)) and (k = lci_DUMP -1)) or ((li_Byte = $A0) and (k > 0) and not(IsDBCSLeadByte(Ord(pStr[lci_DUMP * i + k -1])))) then begin ls_Ansi[k +1] := lcs_NOTCHAR; end else begin ls_Ansi[k +1] := ls_Char; end; end; end; if (k = 8) then begin ls_Dump[li_Index] := '-'; ls_Dump[li_Index +1] := ' '; Inc(li_Index, 2); end; StrFmt(@ls_Dump[li_Index], '%.2x ', [li_Byte]); Inc(li_Index, 3); end; Application.ProcessMessages; ls_Dump[lci_DUMPHEX] := ' '; // Result := Result + Format('%-*s'#9'%s'#$C, [lci_DUMPHEX, ls_Dump, ls_Str]); //myDebug.gpcDebug([li_Line, ls_Dump, ls_Ascii]); StrFmt(@Result[i * lci_COLUMN +1], '%-*s'#9'%s'#$D, [lci_DUMPHEX, ls_Dump, ls_Ansi]); end; end; //myWindow.pas ----------------------------------------------------------------- (* function gfnsOsNameGet: String; {2007-12-13: OSが'2000', 'XP', 'Vista'のいずれであるかを返す } var lr_Info: TOSVersionInfo; begin Result := 'Unknown'; FillChar(lr_Info, SizeOf(lr_Info), 0); lr_Info.dwOSVersionInfoSize := SizeOf(TOSVersionInfo);; if (GetVersionEx(lr_Info)) then begin with lr_Info do begin if (dwPlatformId = VER_PLATFORM_WIN32_NT) then begin //NT系 if (dwMajorVersion = 7) then begin Result := '7'; end else if (dwMajorVersion = 6) then begin Result := 'Vista'; end else if (dwMajorVersion = 5) then begin if (dwMinorVersion = 0) then begin Result := '2000'; end else begin Result := 'XP'; end; end else if (dwMajorVersion = 4) then begin Result := 'NT4'; end; end else if (dwPlatformId = VER_PLATFORM_WIN32_WINDOWS) then begin //9x系 if (dwMinorVersion = 9) then begin Result := 'me'; end else if (dwMinorVersion = 1) then begin Result := '98'; end else if (dwMinorVersion = 0) then begin Result := '95'; end; end else if (dwPlatformId = VER_PLATFORM_WIN32s) then begin //Windows 3.1上のWin32s Result := 'Win32s'; end; end; end; end; *) //myMessageBox ----------------------------------------------------------------- function gfniMessageBox(const sWMsg, sWTitle: String; const iStyle: UINT): Integer; {2007-10-06,2009-09-25,27: Unicode対応のMessageBox。 2009-09-27: Application.MainForm.Handleはメインウィンドウが表示された後でないとアクセス違反 となるので、その場合はApplication.Handleにするように変更。 2009-09-25: 　MB_SETFOREGROUNDはタスクバーがフラッシュしてしまうのでSetWindowPosを利用して前 　面に表示させるように変更。 } var lh_Window: HWND; begin try lh_Window := Screen.ActiveForm.Handle; except lh_Window := Application.Handle; end; SetWindowPos(lh_Window, HWND_TOP, 0, 0, 0, 0, SWP_NOMOVE or SWP_NOSIZE); //iStyleに0を指定した場合はMB_OKを指定したのと同じ Result := MessageBoxW(Application.Handle, PWideChar(sWMsg), PWideChar(sWTitle), iStyle or MB_APPLMODAL or MB_SETFOREGROUND); end; procedure gpcShowMessage(const sWMsg: String); {2007-10-06: ShowMessageのUnicode版。 } begin gfniMessageBox(sWMsg, gfnsProductNameGet, MB_OK); end; //myList.pas ------------------------------------------------------------------- //比較 function gfniStringCompareText(sSrc1, sSrc2: String): Integer; //sSrc1とsSrc2を単語ソートではなく文字列ソートで比較して返す //大文字と小文字は区別しない begin Result := CompareString( LOCALE_USER_DEFAULT, NORM_IGNORECASE or SORT_STRINGSORT or NORM_IGNORENONSPACE, PChar(sSrc1), -1, PChar(sSrc2), -1 ) - 2; end; //ファイルソート用の比較関数 function gfniCompareFileName(sStr1, sStr2: String): Integer; procedure lpc_StrNumDiv(sSrc: String; out sHeadStr, sNum, sEndStr: String); //sSrcを文字列と数値に分解する。 var i, k, li_Len: Integer; lb_Num: Boolean; begin sHeadStr := sSrc; sNum := ''; sEndStr := ''; lb_Num := False; li_Len := Length(sSrc); for i := 1 to li_Len do begin if (Pos(sSrc[i], '0123456789') > 0) then begin sHeadStr := Copy(sSrc, 1, i -1); for k := i+1 to li_Len do begin if (Pos(sSrc[k], '0123456789') = 0) then begin sNum := Copy(sSrc, i, k - i); sEndStr := Copy(sSrc, k, MAXINT); lb_Num := True; //最後まで数値文字の場合この中に入ってこないことへの対策。 Break; end; end; if not(lb_Num) then begin sNum := Copy(sSrc, i, MAXINT); end; Break; end; end; end; function lfni_CompareFile(sStr1, sStr2: String): Integer; var ls_Head1, ls_Num1, ls_End1, ls_Head2, ls_Num2, ls_End2: String; li_Re: Integer; li_Num1, li_Num2: Int64; begin if (sStr1 = '') and (sStr2 = '') then begin Result := 0; end else if (sStr2 = '') then begin Result := 1; end else if (sStr1 = '') then begin Result := -1; end else begin Result := CompareText(sStr1, sStr2); if (Result = 0) then begin //sStr1とsStr2は同じ並び順。 if (UpperCase(sStr1) <> UpperCase(sStr2)) then begin //比較した場合は同じだが文字列としては同じではない場合への対処。 //「が」とUnicodeの「か゛」の合成文字など。 if (Length(sStr1) > Length(sStr2)) then begin //「が」より「か゛」の合成文字を前に持っていくため（簡単に済ませている） Result := -1; end else begin Result := 1; end; end; end else begin //sStr1とsStr2は違う並び順。 //数値の比較でエラーになった時のために退避しておく。 li_Re := Result; //文字列と数値文字列に分解'abc_12-A'->'abc_', '12, '-A'。 lpc_StrNumDiv(sStr1, ls_Head1, ls_Num1, ls_End1); lpc_StrNumDiv(sStr2, ls_Head2, ls_Num2, ls_End2); //数値文字列以前の文字列で比較。 if ((ls_Head1 = '') and (ls_Head2 <> '')) or ((ls_Head2 = '') and (ls_Head1 <> '')) then begin //どちらかが空文字だった。 //'[.txt'と'1.txt'だと'[.txt'の方が先に並べられることへの対応。 end else begin Result := gfniStringCompareText(ls_Head1, ls_Head2); if (Result = 0) then begin //数値文字列以前は同じだった if (UpperCase(ls_Head1) <> (UpperCase(ls_Head2))) then begin //比較した場合は同じだが文字列としては同じではない場合への対処。 //「が」とUnicodeの「か゛」の合成文字など。 if (Length(ls_Head1) > Length(ls_Head2)) then begin //「が」より「か゛」の合成文字を前に持っていくため（簡単に済ませている） Result := -1; end else begin Result := 1; end; end else begin //数値以前の文字列が同じだったので数値文字列で比較。 if (ls_Num1 = '') and (ls_Num2 = '') then begin Result := 0; end else if (ls_Num2 = '') then begin Result := 1; end else if (ls_Num1 = '') then begin Result := -1; end else begin try li_Num1 := StrToInt64(ls_Num1); li_Num2 := StrToInt64(ls_Num2); if (li_Num1 = li_Num2) then begin Result := 0; end else if (li_Num1 > li_Num2) then begin Result := 1; end else if (li_Num1 < li_Num2) then begin Result := -1; end; if (Result = 0) then begin Result := lfni_CompareFile(ls_End1, ls_End2); end; except //エラーが起きたら数値の比較は無効にしてしまう。 Result := li_Re; end; end; end; end; end; end; end; end; var ls_Path1, ls_Name1, ls_Path2, ls_Name2: String; begin if (sStr1 = sStr2) then begin Result := 0; Exit; end; gpcFileDirNameDiv(sStr1, ls_Path1, ls_Name1); gpcFileDirNameDiv(sStr2, ls_Path2, ls_Name2); //まずフォルダーだけで比較 Result := lfni_CompareFile(ls_Path1, ls_Path2); if (Result = 0) then begin //フォルダーが同じならファイル名で比較 Result := lfni_CompareFile(ls_Name1, ls_Name2); end; end; function gfnbIsIncludeList(sValue: String; slList: TStrings): Boolean; //slList中にsValueがあればTrueを返す //大文字小文字の違いは無視 var i: Integer; begin Result := False; for i := 0 to slList.Count -1 do begin if (CompareText(sValue, slList[i]) = 0) then begin Result := True; Break; end; end; end; //Name=Value形式のデータ function gfnsIniNameGet(const sItem: String): String; overload; var li_Pos: Integer; begin if (sItem <> '') then begin li_Pos := Pos('=', sItem); if (li_Pos <= 1) then begin Result := ''; end else begin Result := Trim(Copy(sItem, 1, li_Pos - 1)); end; end else begin Result := ''; end; end; function gfnsIniValueGet(sItem: String): String; var li_Pos: Integer; begin if (sItem <> '') then begin li_Pos := Pos('=', sItem); if (li_Pos = 0) then begin Result := sItem; end else begin Result := Copy(sItem, li_Pos + 1, MaxInt); end; end else begin Result := ''; end; end; {$ENDIF} //============================================================================== function gfnsCharCodeToDescription(cdCode: TMyCharCode): String; {2009-07-30: 文字コードをあらわす文字列を返す。 } begin case cdCode of cdSJis: Result := 'Shift_JIS'; cdUnicodeLE: Result := 'UTF-16 LE(リトルエンディアン)BOMあり'; cdUTF_16LE: Result := 'UTF-16 LE(リトルエンディアン)BOMなし'; cdUnicodeBE: Result := 'UTF-16 BE(ビッグエンディアン)BOMあり'; cdUTF_16BE: Result := 'UTF-16 BE(ビッグエンディアン)BOMなし'; cdUTF_8: Result := 'UTF-8 BOMあり'; cdUTF_8N: Result := 'UTF-8 BOMなし'; cdUTF_7: Result := 'UTF-7'; cdJIS: Result := 'JIS'; cdEUC: Result := 'EUC-JP'; cdBINDUMP: Result := 'バイナリダンプ'; cdAuto: Result := '自動判定'; else Result := ''; end; end; function gfnsCharCodeToText(cdCode: TMyCharCode): String; begin case cdCode of cdSJis :begin Result := 'Shift_JIS'; end; cdUnicodeLE, cdUTF_16LE, cdUnicodeBE, cdUTF_16BE :begin Result := 'UTF-16'; end; cdUTF_8, cdUTF_8N :begin Result := 'UTF-8'; end; cdUTF_7 :begin Result := 'UTF-7'; end; cdJIS :begin Result := 'JIS'; end; cdEUC :begin Result := 'EUC-JP'; end; cdBINDUMP :begin Result := 'バイナリダンプ'; end; else begin Result := 'Shift_JIS'; end; end; end; function gfnCodePageToCharCode(iCodePage: Integer): TMyCharCode; {2010-10-02: コードページからそれに対応する文字コードを返す } begin case iCodePage of 932: Result := cdSJis; //日本語 (シフト JIS) shift_jis 1200: Result := cdUTF_16LE; //Unicode utf-16 1201: Result := cdUTF_16BE; //Unicode (Big-Endian) unicodeFFFE 10001: Result := cdSJis; //日本語 (Mac) x-mac-japanese 20127: Result := cdSJis; //US-ASCII us-ascii 20932: Result := cdEUC; //日本語 (JIS 0208-1990 および 0212-1990) EUC-JP 50220: Result := cdJIS; //日本語 (JIS) iso-2022-jp 50221: Result := cdJIS; //日本語 (JIS 1 バイト カタカナ可) csISO2022JP 50222: Result := cdJIS; //日本語 (JIS 1 バイト カタカナ可 - SO/SI) iso-2022-jp 50225: Result := cdJIS; //韓国語 (ISO) iso-2022-kr 50227: Result := cdJIS; //簡体字中国語 (ISO-2022) x-cp50227 51932: Result := cdEUC; //日本語 (EUC) euc-jp 51936: Result := cdEUC; //簡体字中国語 (EUC) EUC-CN 51949: Result := cdEUC; //韓国語 (EUC) euc-kr 65000: Result := cdUTF_7; 65001: Result := cdUTF_8N; else Result := cdSJis; end; end; function gfnsNewLineGet(nlLineFeed: TMyNewLine): String; begin case nlLineFeed of nlCR: Result := String(#$D); nlLF: Result := String(#$A); else Result := String(#$D#$A); end; end; function gfnsNewLineToDescription(nlLineFeed: TMyNewLine): String; begin case nlLineFeed of nlCR: Result := 'CR'; nlLF: Result := 'LF'; else Result := 'CR+LF'; end; end; //------------------------------------------------------------------------------ //Unicode文字列 //UTF-16LE⇔UTF-7 function gfnsWideToUtf7(sSrc: String): AnsiString; //WideStringをUTF-7にエンコードして返す var li_Len: Integer; lp_Buff: PAnsiChar; begin //WC_COMPOSITECHECKはNG li_Len := WideCharToMultiByte(CP_UTF7, 0, PWideChar(sSrc), -1, nil, 0, nil, nil); lp_Buff := AllocMem(li_Len + 1); try WideCharToMultiByte(CP_UTF7, 0, PWideChar(sSrc), -1, lp_Buff, li_Len, nil, nil); Result := AnsiString(lp_Buff); finally FreeMem(lp_Buff); end; end; function gfnsUtf7ToWide(sSrc: AnsiString): String; //UTF-7でエンコードされている文字列をWideStringにして返す var li_Len: Integer; lp_Buff: PWideChar; begin li_Len := MultiByteToWideChar(CP_UTF7, 0, PAnsiChar(sSrc), -1, nil, 0); lp_Buff := AllocMem((li_Len + 1) * 2); try MultiByteToWideChar(CP_UTF7, 0, PAnsiChar(sSrc), -1, lp_Buff, li_Len); Result := String(lp_Buff); finally FreeMem(lp_Buff); end; end; //UTF-16LE⇔UTF-8 function gfnsWideToUTF8(sSrc: String): AnsiString; {2008-06-06: WideStringをUTF-8にエンコードして返す。 UTF8Encodeの方が速い。が、UTF8Encodeはサロゲートペアに対応していない。 } var li_Len: Integer; lp_Buff: PAnsiChar; begin li_Len := WideCharToMultiByte(CP_UTF8, 0, PWideChar(sSrc), -1, nil, 0, nil, nil); lp_Buff := AllocMem(li_Len + 1); try WideCharToMultiByte(CP_UTF8, 0, PWideChar(sSrc), -1, lp_Buff, li_Len +1, nil, nil); Result := AnsiString(lp_Buff); finally FreeMem(lp_Buff); end; end; function gfnsUTF8ToWide(sSrc: AnsiString): String; {2008-06-06: UTF-8でエンコードされている文字列をWideStringにして返す。 UTF8Decodeの方が速い。が、UTF8Decodeはサロゲートペアに対応していない。 } var li_Len: Integer; lp_Buff: PWideChar; begin li_Len := MultiByteToWideChar(CP_UTF8, 0, PAnsiChar(sSrc), -1, nil, 0); lp_Buff := AllocMem((li_Len + 1) * 2); try MultiByteToWideChar(CP_UTF8, 0, PAnsiChar(sSrc), -1, lp_Buff, li_Len); Result := String(lp_Buff); finally FreeMem(lp_Buff); end; end; function gfnsJisToWide(sSrc: AnsiString): String; var li_Len: Integer; lp_Buff: PWideChar; begin li_Len := MultiByteToWideChar(CP_JIS, 0, PAnsiChar(sSrc), -1, nil, 0); lp_Buff := AllocMem((li_Len + 1) * 2); try MultiByteToWideChar(CP_JIS, 0, PAnsiChar(sSrc), -1, lp_Buff, li_Len); Result := String(lp_Buff); finally FreeMem(lp_Buff); end; end; function gfnsWideToJis(sSrc: String): AnsiString; var li_Src : Integer; li_Len : Integer; lp_Buff : PAnsiChar; begin //http://www.gesource.jp/weblog/?p=738 //http://ht-deko.minim.ne.jp/ft0909.html#090927 li_Src := Length(sSrc); li_Len := (li_Src * 5) + 4 - (li_Src div 2); lp_Buff := AllocMem(li_Len + 1); try WideCharToMultiByte(CP_JIS, 0, PWideChar(sSrc), -1, lp_Buff, li_Len +1, nil, nil); Result := AnsiString(lp_Buff); finally FreeMem(lp_Buff); end; end; function gfnsEucToWide(sSrc: AnsiString): String; var li_Len: Integer; lp_Buff: PWideChar; begin li_Len := MultiByteToWideChar(CP_EUC, 0, PAnsiChar(sSrc), -1, nil, 0); lp_Buff := AllocMem((li_Len + 1) * 2); try MultiByteToWideChar(CP_EUC, 0, PAnsiChar(sSrc), -1, lp_Buff, li_Len); Result := String(lp_Buff); finally FreeMem(lp_Buff); end; end; function gfnsWideToEuc(sSrc: String): AnsiString; var li_Len: Integer; lp_Buff: PAnsiChar; begin li_Len := WideCharToMultiByte(CP_EUC, WC_COMPOSITECHECK, PWideChar(sSrc), -1, nil, 0, nil, nil); lp_Buff := AllocMem(li_Len + 1); try WideCharToMultiByte(CP_EUC, WC_COMPOSITECHECK, PWideChar(sSrc), -1, lp_Buff, li_Len +1, nil, nil); Result := AnsiString(lp_Buff); finally FreeMem(lp_Buff); end; end; function gfnsWideToAnsi(sSrc: String): AnsiString; //合成文字をきちんとあつかってAnsiStringに変換。 //例)「か゛」→「が」みたいな感じで。 const lcs_DEF = ''; var li_Len: Integer; lp_Buff: PAnsiChar; begin //WC_COMPOSITECHECKが肝 li_Len := WideCharToMultiByte(CP_ACP, WC_COMPOSITECHECK{ or WC_SEPCHARS}, PWideChar(sSrc), -1, nil, 0, nil, nil); Inc(li_Len); lp_Buff := AllocMem(li_Len); try WideCharToMultiByte(CP_ACP, WC_COMPOSITECHECK{ or WC_SEPCHARS}, PWideChar(sSrc), -1, lp_Buff, li_Len, nil, nil); Result := AnsiString(lp_Buff); finally FreeMem(lp_Buff); end; end; (* //AnsiStringとWideStringとの可逆変換関数。 const l_csDEFAULT_CHAR = #1; l_csPREFIX_CHAR = '$'; const WC_NO_BEST_FIT_CHARS = $00000400; function gfnsWideToAnsiEx(sSrc: String): AnsiString; {2007-07-27,08-28,10-22,11-05,12-05,12-18,2008-02-12,19,03-07,04-13,06-02,2011-03-31,8-28: ウムラウトなどのUnicodeな文字だけを$+16進に変換して返す。 http://yokohama.cool.ne.jp/chokuto/urawaza/api/WideCharToMultiByte.html 0x00000400 (WC_NO_BEST_FIT_CHARS) Windows 2000/XP:直接マルチバイト文字に変換できない文字をデフォルトキャラクタに置きかえます。 2011-08-28:IsDBCSLeadByteの判定をif判定のelseの中に入れた。またApplication.ProcessMessagesを遅くなるのでコメントアウト 2011-03-31:SetLengthであらかじめ必要なバイト数を確保して書き込んでゆくやり方に変えた。10倍速くなった。それでもUTF-7利用の方が2倍速い。 2010-06-06:プリフィクスを%から$に変更。 2008-04-13:WC_COMPOSITECHECKをコメントアウトUnicodeの3099（「゛」のような文字）があるとおかしなことになってしまうことが判明したので。 2008-03-07:%を%%ではなく%0025に変換するように変更。 2008-02-19:%は2バイト文字の第一バイトにも第二バイトにも現れないのでAnsiPosでなくPosに変更。 2008-02-12:ウムラウトのようなUnicode文字かプリフィクスがあるか判定し、なければ変換ぜずsSrcをそのまま返すように変更。 2007-12-18:WideCharToMultiByteは終わりの#0も含めた必要なバッファ数を返すことから終わりの#0まで返していた不具合を修正。 2007-12-05:repeatを使ったものに書き換え。 2007-11-05:プリフィクスの扱いの間違いを修正。 2007-10-22:1バイトのウムラウトのような文字だけでなく2バイトの(中国語のような)文字にも対応できるように変更。 2007-08-28:プリフィクス文字がsSrc中にあった場合の処理を追加。 } var i : Integer; li_Pos : Integer; li_Len : Integer; li_Count : Integer; li_Index : Integer; ls_Char : AnsiChar; lb_Bool : LongBool; lp_Buff : PAnsiChar; begin Result := ''; if (sSrc <> '') then begin //WC_COMPOSITECHECKは指定してはいけない。 li_Len := WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS, PWideChar(sSrc), -1, nil, 0, l_csDEFAULT_CHAR, @lb_Bool); if (lb_Bool = False) and (Pos(l_csPREFIX_CHAR, sSrc) = 0) then begin //ウムラウトのようなUnicode文字がなくプリフィクス文字($)もない場合は変換する必要なし。 //'$'は2バイト文字の第一バイトにも第二バイトにも現れないのでPosでよい。 Result := sSrc; end else begin lp_Buff := AllocMem(li_Len + 1); try li_Len := WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS, PWideChar(sSrc), -1, lp_Buff, li_Len, l_csDEFAULT_CHAR, @lb_Bool); if (li_Len > 0) then begin //まず必要なバイト数を求める li_Count := li_Len; //必要なバイト数 i := 0; Dec(li_Len); //forで回すよりこっちの方が速い。 repeat ls_Char := lp_Buff[i]; if (ls_Char = l_csDEFAULT_CHAR) or (ls_Char = l_csPREFIX_CHAR) then begin //#1→'$xxxx' xxxx は元の文字の4桁の16進値 //$→ '$0024' Inc(li_Count, 4); end; Inc(i); until (i >= li_Len); //untilは条件がTrueで終了。 SetLength(Result, li_Count); i := 0; //lp_Buffのインデックス li_Pos := 1; //sSrc のインデックス li_Index := 1; //Result のインデックス repeat ls_Char := lp_Buff[i]; if (ls_Char = l_csDEFAULT_CHAR) or (ls_Char = l_csPREFIX_CHAR) then begin //#1→'$xxxx' xxxx は元の文字の4桁の16進値 //$→ '$0024' Result[li_Index] := l_csPREFIX_CHAR; Inc(li_Index); StrFmt(@Result[li_Index], '%0.4x', [Ord(sSrc[li_Pos])]); Inc(li_Index, 4); end else begin Result[li_Index] := ls_Char; Inc(li_Index); //2011-08-28:位置を変更 //この判定はないといけない。 // if (IsDBCSLeadByte(Byte(ls_Char))) then begin //こっちの方が10%程度速い case ls_Char of #$81..#$9F, #$E0..#$EF :begin //2バイト文字の先頭バイトなのでもう1バイトスキップ。 Inc(i); Result[li_Index] := lp_Buff[i]; Inc(li_Index); end; end; end; Inc(i); Inc(li_Pos); //2011-08-28:遅くなるのでコメントアウト // Application.ProcessMessages; 遅くなる until (i >= li_Len); //untilは条件がTrueで終了。 SetLength(Result, li_Index -1); end; finally FreeMem(lp_Buff); end; end; end; end; function gfnsAnsiToWideEx(sSrc: AnsiString): String; {2007-07-27,10-22,11-05,12-05,2008-02-12,19,03-07,16,05-30,2010-06-02,2011-03-31: gfnsWideToStrExの逆。 2011-03-31:Resultに逐次上書きしてゆき最後にSetLengthする方式に変更。30倍ほど速くなった。それでもUTF-7利用のほうが30%程度高速。 2010-06-06:プリフィクスを%から$に変更。 2008-05-30:速度向上のため書き換え。200倍くらいの差が出た…。 2008-03-16:プリフィクスに続く四文字が数値変換できない場合はプリフクスも含めてそのままにするよう変更。 2008-03-07:%を%%ではなく%0025に変換するようにgfnsWideToStrExを変えたのでそれに対応。 2008-02-19:%は2バイト文字の第一バイトにも第二バイトにも現れないのでAnsiPosでなくPosに変更。 2008-02-12:プリフィクスがあるか判定し、なければ変換ぜずsSrcをそのまま返すように変更。 2007-12-05:repeatを使ったものに書き換え。 2007-11-05:プリフィクスの扱いの間違いを修正。 2007-10-22:1バイトのウムラウトのような文字だけでなく2バイトの(中国語のような)文字にも対応。 } var ls_Code : array[0..4] of WideChar; ls_Char : WideChar; li_Read : Integer; li_Write : Integer; li_Pos : Integer; li_Len : Integer; begin Result := ''; if (sSrc <> '') then begin Result := String(sSrc); li_Pos := Pos(l_csPREFIX_CHAR, Result); //プリフィクス文字($)がなければ独自変換する必要はない。 if (li_Pos > 0) then begin ls_Code[0] := '$'; li_Len := Length(Result); li_Read := li_Pos; //読み込む位置 li_Write := li_Read; //書き込む位置 repeat if (Result[li_Read] = l_csPREFIX_CHAR) then begin try //'$'に続く(はずの)4文字の数値をUnicode文字に変換。 Move(Result[li_Read +1], ls_Code[1], 4 * SizeOf(WideChar)); ls_Char := WideChar(StrToInt(ls_Code)); Result[li_Write] := ls_Char; Inc(li_Read, 5); Inc(li_Write); except //イレギュラー //イレギュラー時はそのままにする。 Result[li_Write] := Result[li_Read]; Inc(li_Read); Inc(li_Write); end; end else begin Result[li_Write] := Result[li_Read]; Inc(li_Read); Inc(li_Write); end; //Application.ProcessMessages; until (li_Read > li_Len); //untilは条件がTrueで終了。 SetLength(Result, li_Write -1); end; end; end; *) function gfnbIsUnicode(sSrc: String): Boolean; //sSrcにウムラウトのようなUnicode文字があればTrueを返す var lb_Bool: LongBool; begin WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS, PWideChar(sSrc), -1, nil, 0, nil, @lb_Bool); Result := lb_Bool; end; //------------------------------------------------------------------------------ //文字コードの自動判定 //http://mrxray.on.coocan.jp/Delphi/plSamples/886_ChangeCodePage.htm //http://www.delphikingdom.com/asp/answer.asp?IDAnswer=16895 const IID_IMultiLanguage2 : TGUID = '{DCCFC164-2B38-11D2-B7EC-00C04F8F5D9A}'; CLASS_CMultiLanguage : TGUID = '{275C23E2-3747-11D0-9FEA-00AA003F8646}'; type tagMIMECPINFO = packed record dwFlags : LongWord; uiCodePage : SYSUINT; uiFamilyCodePage : SYSUINT; wszDescription : array[0..63] of Word; wszWebCharset : array[0..49] of Word; wszHeaderCharset : array[0..49] of Word; wszBodyCharset : array[0..49] of Word; wszFixedWidthFont : array[0..31] of Word; wszProportionalFont : array[0..31] of Word; bGDICharset : Byte; end; tagMIMECSETINFO = packed record uiCodePage : SYSUINT; uiInternetEncoding : SYSUINT; wszCharset : array[0..49] of Word; end; tagRFC1766INFO = packed record lcid : LongWord; wszRfc1766 : array[0..5] of Word; wszLocaleName : array[0..31] of Word; end; tagDetectEncodingInfo = packed record nLangID : SYSUINT; nCodePage : SYSUINT; nDocPercent : SYSINT; nConfidence : SYSINT; end; tagSCRIPTINFO = packed record ScriptId : Byte; uiCodePage : SYSUINT; wszDescription : array[0..47] of Word; wszFixedWidthFont : array[0..31] of Word; wszProportionalFont : array[0..31] of Word; end; __MIDL_IWinTypes_0009 = record case Integer of 0 : (hInproc : Integer); 1 : (hRemote : Integer); end; _RemotableHandle = packed record fContext : Integer; u : __MIDL_IWinTypes_0009; end; // Constants for enum tagMIMECONTF //type tagMIMECONTF = TOleEnum; // *********************************************************************// // Interface: IEnumCodePage // Flags: (0) // GUID: {275C23E3-3747-11D0-9FEA-00AA003F8646} // *********************************************************************// IEnumCodePage = interface(IUnknown) ['{275C23E3-3747-11D0-9FEA-00AA003F8646}'] function Clone(out ppEnum: IEnumCodePage): HResult; stdcall; function Next(celt: LongWord; out rgelt: tagMIMECPINFO; out pceltFetched: LongWord): HResult; stdcall; function Reset: HResult; stdcall; function Skip(celt: LongWord): HResult; stdcall; end; // *********************************************************************// // Interface: IEnumRfc1766 // Flags: (0) // GUID: {3DC39D1D-C030-11D0-B81B-00C04FC9B31F} // *********************************************************************// IEnumRfc1766 = interface(IUnknown) ['{3DC39D1D-C030-11D0-B81B-00C04FC9B31F}'] function Clone(out ppEnum: IEnumRfc1766): HResult; stdcall; function Next(celt: LongWord; out rgelt: tagRFC1766INFO; out pceltFetched: LongWord): HResult; stdcall; function Reset: HResult; stdcall; function Skip(celt: LongWord): HResult; stdcall; end; // *********************************************************************// // Interface: IMLangConvertCharset // Flags: (0) // GUID: {D66D6F98-CDAA-11D0-B822-00C04FC9B31F} // *********************************************************************// IMLangConvertCharset = interface(IUnknown) ['{D66D6F98-CDAA-11D0-B822-00C04FC9B31F}'] function Initialize(uiSrcCodePage: SYSUINT; uiDstCodePage: SYSUINT; dwProperty: LongWord): HResult; stdcall; function GetSourceCodePage(out puiSrcCodePage: SYSUINT): HResult; stdcall; function GetDestinationCodePage(out puiDstCodePage: SYSUINT): HResult; stdcall; function GetProperty(out pdwProperty: LongWord): HResult; stdcall; //***** // function DoConversion(var pSrcStr: Byte; var pcSrcSize: SYSUINT; var pDstStr: Byte; // var pcDstSize: SYSUINT): HResult; stdcall; function DoConversion( pSrcStr : PAnsiChar; var pcSrcSize : SYSUINT; pDstStr : PAnsiChar; var pcDstSize : SYSUINT ) : HResult; stdcall; function DoConversionToUnicode(var pSrcStr: Shortint; var pcSrcSize: SYSUINT; var pDstStr: Word; var pcDstSize: SYSUINT): HResult; stdcall; function DoConversionFromUnicode(var pSrcStr: Word; var pcSrcSize: SYSUINT; var pDstStr: Shortint; var pcDstSize: SYSUINT): HResult; stdcall; end; // *********************************************************************// // Interface: IEnumScript // Flags: (0) // GUID: {AE5F1430-388B-11D2-8380-00C04F8F5DA1} // *********************************************************************// IEnumScript = interface(IUnknown) ['{AE5F1430-388B-11D2-8380-00C04F8F5DA1}'] function Clone(out ppEnum: IEnumScript): HResult; stdcall; function Next(celt: LongWord; out rgelt: tagSCRIPTINFO; out pceltFetched: LongWord): HResult; stdcall; function Reset: HResult; stdcall; function Skip(celt: LongWord): HResult; stdcall; end; // *********************************************************************// // Interface: IMultiLanguage2 // Flags: (0) // GUID: {DCCFC164-2B38-11D2-B7EC-00C04F8F5D9A} // *********************************************************************// IMultiLanguage2 = interface(IUnknown) ['{DCCFC164-2B38-11D2-B7EC-00C04F8F5D9A}'] function GetNumberOfCodePageInfo(out pcCodePage: SYSUINT): HResult; stdcall; function GetCodePageInfo(uiCodePage: SYSUINT; LangId: Word; out pCodePageInfo: tagMIMECPINFO): HResult; stdcall; function GetFamilyCodePage(uiCodePage: SYSUINT; out puiFamilyCodePage: SYSUINT): HResult; stdcall; function EnumCodePages(grfFlags: LongWord; LangId: Word; out ppEnumCodePage: IEnumCodePage): HResult; stdcall; function GetCharsetInfo(const Charset: String; out pCharsetInfo: tagMIMECSETINFO): HResult; stdcall; function IsConvertible(dwSrcEncoding: LongWord; dwDstEncoding: LongWord): HResult; stdcall; //***** // function ConvertString(var pdwMode: LongWord; dwSrcEncoding: LongWord; dwDstEncoding: LongWord; // var pSrcStr: Byte; var pcSrcSize: SYSUINT; var pDstStr: Byte; // var pcDstSize: SYSUINT): HResult; stdcall; function ConvertString( var pdwMode : LongWord; dwSrcEncoding : LongWord; dwDstEncoding : LongWord; var pSrcStr : Byte; var pcSrcSize : SYSUINT; var pDstStr : Byte; var pcDstSize : SYSUINT ) : HResult; stdcall; //***** // function ConvertStringToUnicode(var pdwMode: LongWord; dwEncoding: LongWord; // var pSrcStr: Shortint; var pcSrcSize: SYSUINT; // var pDstStr: Word; var pcDstSize: SYSUINT): HResult; stdcall; function ConvertStringToUnicode( var pdwMode : DWORD; dwEncoding : DWORD; pSrcStr : PAnsiChar; var pcSrcSize : SYSUINT; pDstStr : PWideChar; var pcDstSize : SYSUINT ) : HResult; stdcall; //***** // function ConvertStringFromUnicode(var pdwMode: LongWord; dwEncoding: LongWord; // var pSrcStr: Word; var pcSrcSize: SYSUINT; // var pDstStr: Shortint; var pcDstSize: SYSUINT): HResult; stdcall; function ConvertStringFromUnicode( var pdwMode : DWORD; dwEncoding : DWORD; pSrcStr : PWideChar; var pcSrcSize : SYSUINT; pDstStr : PAnsiChar; var pcDstSize : SYSUINT ) : HResult; stdcall; function ConvertStringReset: HResult; stdcall; function GetRfc1766FromLcid(locale: LongWord; out pbstrRfc1766: String): HResult; stdcall; function GetLcidFromRfc1766(out plocale: LongWord; const bstrRfc1766: String): HResult; stdcall; function EnumRfc1766(LangId: Word; out ppEnumRfc1766: IEnumRfc1766): HResult; stdcall; function GetRfc1766Info(locale: LongWord; LangId: Word; out pRfc1766Info: tagRFC1766INFO): HResult; stdcall; function CreateConvertCharset(uiSrcCodePage: SYSUINT; uiDstCodePage: SYSUINT; dwProperty: LongWord; out ppMLangConvertCharset: IMLangConvertCharset): HResult; stdcall; function ConvertStringInIStream(var pdwMode: LongWord; dwFlag: LongWord; var lpFallBack: Word; dwSrcEncoding: LongWord; dwDstEncoding: LongWord; const pstmIn: ISequentialStream; const pstmOut: ISequentialStream): HResult; stdcall; function ConvertStringToUnicodeEx(var pdwMode: LongWord; dwEncoding: LongWord; var pSrcStr: Shortint; var pcSrcSize: SYSUINT; var pDstStr: Word; var pcDstSize: SYSUINT; dwFlag: LongWord; var lpFallBack: Word): HResult; stdcall; function ConvertStringFromUnicodeEx(var pdwMode: LongWord; dwEncoding: LongWord; var pSrcStr: Word; var pcSrcSize: SYSUINT; var pDstStr: Shortint; var pcDstSize: SYSUINT; dwFlag: LongWord; var lpFallBack: Word): HResult; stdcall; function DetectCodepageInIStream(dwFlag: LongWord; dwPrefWinCodePage: LongWord; const pstmIn: ISequentialStream; var lpEncoding: tagDetectEncodingInfo; var pnScores: SYSINT): HResult; stdcall; //***** // function DetectInputCodepage(dwFlag: LongWord; dwPrefWinCodePage: LongWord; // var pSrcStr: Shortint; var pcSrcSize: SYSINT; // var lpEncoding: tagDetectEncodingInfo; var pnScores: SYSINT): HResult; stdcall; function DetectInputCodepage( dwFlag : DWORD; dwPrefWinCodePage : DWORD; pSrcStr : PAnsiChar; var pcSrcSize : SYSINT; var lpEncoding : tagDetectEncodingInfo; var pnScores : SYSINT ) : HResult; stdcall; function ValidateCodePage(uiCodePage: SYSUINT; var hwnd: _RemotableHandle): HResult; stdcall; function GetCodePageDescription(uiCodePage: SYSUINT; lcid: LongWord; lpWideCharStr: PWideChar; cchWideChar: SYSINT): HResult; stdcall; function IsCodePageInstallable(uiCodePage: SYSUINT): HResult; stdcall; function SetMimeDBSource(dwSource: tagMIMECONTF): HResult; stdcall; function GetNumberOfScripts(out pnScripts: SYSUINT): HResult; stdcall; function EnumScripts(dwFlags: LongWord; LangId: Word; out ppEnumScript: IEnumScript): HResult; stdcall; function ValidateCodePageEx(uiCodePage: SYSUINT; var hwnd: _RemotableHandle; dwfIODControl: LongWord): HResult; stdcall; end; function gfniCodePageGet(pBuff: PAnsiChar; iCount: Integer): Integer; {2010-10-02: 文字コードを判定してコードページを返す。 BOMなしのUTF-16は正しく判定できず1252が返る。 } var F_iMultiLanguage : IMultiLanguage2; l_Encoding : tagDetectEncodingInfo; li_Source : SYSINT; begin Result := 1252; //指定されたCLSID関連付けクラスの1つの未初期化オブジェクトを作成 if (Succeeded(CoCreateInstance( CLASS_CMultiLanguage, //オブジェクトのCLSID nil, //複数オブジェクトの一部の時はIUnknownインターフェイスのポインタ CLSCTX_INPROC_SERVER, //管理コードを実行するコンテキスト IID_IMultiLanguage2, //取得するIID F_iMultiLanguage //生成オブジェクトの変数アドレス ))) then begin li_Source := 1; if (Succeeded(F_iMultiLanguage.DetectInputCodepage(0, 0, pBuff, iCount, l_Encoding, li_Source))) then begin Result := l_Encoding.nCodePage; end; F_iMultiLanguage := nil; end; end; function gfnsWStrBCopy(pStr: PAnsiChar; iIndex, iCount: DWORD; cdCode: TMyCharCode): WideString; {2008-05-08,2009-10-07,2011-07-09,2013-12-16: pStrのiIndexバイト目からiCountバイトの文字列をコピーしてWideStringにして返す iIndexは0ベース。 pStrがUTF-16であった場合返る文字数はiCountの半分になる(iIndex、iCountともバイトで あることに注意)。2で割り切れない半端は切り捨てる。 pStrのiIndex番目からがBOMであった場合、iCountはBOMも含めたバイト数なので返る文字 数は更に1減ることになる。 2013-12-16: 　↓を元に戻す。 　書き込み違反のエラーが出ることがあるため。 2011-07-09: 　UTF-16LEをCopyを使ったものからlstrcpynWを使ったものに書き換え。 　Copyを使ったものだとCPUウィンドウが立ち上がってしまうことがあるため。 2009-10-07: 　UTF-16BEのエンディアンの入れ替えをLCMapStringWを使ったものに書き換え。 　その他をCopyを使ったものに書き換え。 } var li_Len : Integer; // i: DWORD; // ls_Temp: AnsiString; // lp_Buff: PAnsiChar; begin Result := ''; if (pStr[iIndex] = #$EF) and (pStr[iIndex +1] = #$BB) and (pStr[iIndex +2] = #$BF) then begin //UTF-8 BOMあり cdCode := cdUTF_8; Inc(iIndex, 3); Dec(iCount, 3); end else if (pStr[iIndex] = #$FF) and (pStr[iIndex +1] = #$FE) then begin //UTF-16 BOMありのリトルエンディアン cdCode := cdUnicodeLE; Inc(iIndex, 2); Dec(iCount, 2); end else if (pStr[iIndex] = #$FE) and (pStr[iIndex +1] = #$FF) then begin //UTF-16 BOMありのビッグエンディアン cdCode := cdUnicodeBE; Inc(iIndex, 2); Dec(iCount, 2); end; if (cdCode = cdUTF_16BE) or (cdCode = cdUnicodeBE) then begin //UTF-16 ビッグエンディアン li_Len := Trunc(iCount / 2); SetLength(Result, li_Len); LCMapStringW(GetUserDefaultLCID(), LCMAP_BYTEREV, @pStr[iIndex], li_Len, PWideChar(Result), li_Len); end else begin if (cdCode = cdSJis) then begin //Shift-JIS Result := Copy(String(AnsiString(@pStr[iIndex])), 1, iCount); end else if (cdCode = cdUTF_7) then begin //UTF-7 Result := gfnsUTF7ToWide(Copy(AnsiString(@pStr[iIndex]), 1, iCount)); end else if (cdCode = cdUTF_8) or (cdCode = cdUTF_8N) then begin //UTF-8 Result := gfnsUTF8ToWide(Copy(AnsiString(@pStr[iIndex]), 1, iCount)); end else if (cdCode = cdUnicodeLE) or (cdCode = cdUTF_16LE) then begin //UTF-16 リトルエンディアン Result := Copy(WideString(@pStr[iIndex]), 1, iCount div 2); end; end; //2011-09-14:後ろに#0がついてしまう場合へ対処。 Result := WideString(PWideChar(Result)); end; function gfnCharCodeGet(pBuff: PAnsiChar; iCount: Integer): TMyCharCode; function _CheckEndian(sStr: WideString): Boolean; var i : Integer; li_Kana : Integer; li_Len : Integer; begin li_Len := Length(sStr); if (li_Len = 0) then begin Result := True; Exit; end; li_Kana := 0; for i := 1 to li_Len do begin case Ord(sStr[i]) of $3041..$3093, //'ぁ'..'ん', ひらがな $30A1..$30F6 //'ァ'..'ヶ' カタカナ :begin Inc(li_Kana); end; end; end; Result := (li_Kana / li_Len * 100 > 1); end; function _CheckUTF16(pBuff: PAnsiChar; iCount: Integer): TMyCharCode; var i : Integer; lb_U16 : Boolean; lb_1st : Boolean; lb_SJis : Boolean; ls_Code : AnsiChar; ls_Str : WideString; begin lb_U16 := False; lb_1st := False; lb_SJis := True; for i := 0 to iCount-1 do begin ls_Code := pBuff[i]; case (ls_Code) of #0 :begin lb_U16 := True; lb_1st := False; lb_SJis := False; //#0があったのでShift_JISではない。 end; #$81..#$9F, #$E0..#$EF :begin //Shift_JISの漢字の第1バイトの範囲。但し第2バイトの範囲でもある if (lb_1st) then begin lb_1st := False; end else begin lb_1st := True; end; end; else begin case ls_Code of #$80, #$A0, #$F0..#$FC :begin //Shift_JISの漢字の第2バイトで第1バイトの次に来るべき範囲。 //lb_1stがTrueでなければShift_JISとしては不正。 if not(lb_1st) then begin lb_SJis := False; end; end; #$1..#$3F :begin //Shift_JISの範囲内だが漢字の第1バイトにも第2バイトにも含まれない範囲。 //lb_1stがTrueの時にここに来たら不正。 if (lb_1st) then begin lb_SJis := False; end; end; #$7F, #$FD..#$FF :begin //Shift_JISの範囲外。 lb_SJis := False; end; end; lb_1st := False; end; end; end; if (lb_U16 and not(lb_SJis)) then begin //リトルエンディアンでテスト ls_Str := gfnsWStrBCopy(pBuff, 0, iCount, cdUTF_16LE); if (_CheckEndian(ls_Str)) then begin Result := cdUTF_16LE; Exit; end else begin //ビッグエンディアンでテスト ls_Str := gfnsWStrBCopy(pBuff, 0, iCount, cdUTF_16BE); if (_CheckEndian(ls_Str)) then begin Result := cdUTF_16BE; Exit; end else begin Result := cdBINDUMP; Exit; end; end; end else if not(lb_SJis) then begin Result := cdBINDUMP; end else begin Result := cdSJis; end; end; begin if (iCount >= 3) and (pBuff[0] = #$EF) and (pBuff[1] = #$BB) and (pBuff[2] = #$BF) then begin //UTF-8 BOMあり Result := cdUTF_8; end else if (iCount >= 2) and (pBuff[0] = #$FF) and (pBuff[1] = #$FE) then begin //UTF-16 BOMありのリトルエンディアン Result := cdUnicodeLE; end else if (iCount >= 2) and (pBuff[0] = #$FE) and (pBuff[1] = #$FF) then begin //UTF-16 BOMありのビッグエンディアン Result := cdUnicodeBE; end else begin Result := gfnCodePageToCharCode(gfniCodePageGet(pBuff, iCount)); if (Result = cdSJis) then begin Result := _CheckUTF16(pBuff, iCount); end; end; end; //------------------------------------------------------------------------------ //ファイルとのやり取り function gfnsFileReadText(sFile: String): String; {,2010-10-26: 2010-10-26:文字コードのデフォルトを自動判定にした。 } var lcd_Code: TMyCharCode; begin //2010-10-26:文字コードのデフォルトは自動判定。 lcd_Code := cdAuto; Result := gfnsFileReadText(sFile, lcd_Code); end; function gfnsFileReadText(sFile: String; var cdCode: TMyCharCode): String; begin Result := gfnsFileReadText(sFile, cdCode, gfniFileSizeGet(sFile)); end; function gfnsFileReadText(sFile: String; var cdCode: TMyCharCode; iByte: DWORD): String; overload; {2008-05-23,29,2009-01-05,2010-10-03: Unicode対応テキストファイル読み込み。 cdCodeにはBOMがない時に適用する文字コードを指定する。 cdAnsi : Shift_JIS cdUTF_16LE : UTF-16LE cdUTF_16BE : UTF-16BE cdUTF_8N : BOMなしのUTF-8 cdUTF_7 : UTF-7 cdJIS : JIS cdEUC : EUC cdBINDUMP : バイナリダンプ cdAuto : 自動判定 ※sFileの先頭がBOMであるかcdCodeがcdAutoであればcdCodeの値は変更後の文字コードに 　変更される。 2010-10-03: 　JISとEUCを追加。 　cdCodeがcdAutoのとき文字コードの自動判定を行うように変更。 2009-01-05: sFileのサイズが0であったときFreeMemでエラーになっていた不具合を修正。 2008-05-29: UTF-8に対応。 http://ja.wikipedia.org/wiki/UTF-8 gfniFileReadで2バイト余計にAllocMemでメモリ確保するようにしたことによる簡素化。 } var lh_Handle : THandle; lp_Buff : PAnsiChar; lp_Endian : PWideChar; ls_Text : AnsiString; li_Aiu : Integer; li_Len : Integer; lb_Flag : Boolean; li_Size : DWORD; li_Start : DWORD; li_Count : DWORD; begin li_Size := iByte; if (li_Size = 0) then begin Result := ''; Exit; end; lp_Buff := AllocMem(li_Size + SizeOf(Char)); //String(lp_Buff)としても問題ないように try li_Aiu := 0; repeat lh_Handle := CreateFile( PChar(sFile), //ファイル名 GENERIC_READ, //アクセスモード FILE_SHARE_READ //共有モード or FILE_SHARE_WRITE , nil, //セキュリティ OPEN_EXISTING, //作成方法 FILE_ATTRIBUTE_NORMAL, //ファイル属性 0 //テンプレート ); lb_Flag := ReadFile(lh_Handle, lp_Buff^, li_Size, li_Count, nil); CloseHandle(lh_Handle); if not(lb_Flag) then begin Sleep(200); Inc(li_Aiu); if (li_Aiu > 3) then begin Break; //3回を超えたらループを抜ける end; Application.ProcessMessages; end; until (lb_Flag); if not(lb_Flag) then begin Beep; // gpcShowMessage('開けませんでした'); end; if (li_Count <= 0) then begin Result := ''; end else begin li_Start := 0; case cdCode of cdAuto..cdBINDUMP :begin //何もしない end; else begin //範囲外なら自動判定にしてしまう cdCode := cdAuto; end; end; if (cdCode = cdAuto) then begin //自動判定 if (li_Count >= 3) and (lp_Buff[0] = #$EF) and (lp_Buff[1] = #$BB) and (lp_Buff[2] = #$BF) then begin //UTF-8 BOMあり cdCode := cdUTF_8; Inc(li_Start, 3); end else if (li_Count >= 2) and (lp_Buff[0] = #$FF) and (lp_Buff[1] = #$FE) then begin //UTF-16 BOMありのリトルエンディアン cdCode := cdUnicodeLE; Inc(li_Start, 2); end else if (li_Count >= 2) and (lp_Buff[0] = #$FE) and (lp_Buff[1] = #$FF) then begin //UTF-16 BOMありのビッグエンディアン cdCode := cdUnicodeBE; Inc(li_Start, 2); end else begin cdCode := gfnCharCodeGet(lp_Buff, gfniMin([li_Count, 1024])); end; end; if (cdCode = cdBINDUMP) then begin Result := String(gfnsPCharToBinDump(lp_Buff, li_Count)); end else if (cdCode = cdUTF_8) or (cdCode = cdUTF_8N) then begin //UTF-8 Result := gfnsUtf8ToWide(AnsiString(PAnsiChar(@lp_Buff[li_Start]))); end else if (cdCode = cdUnicodeLE) or (cdCode = cdUnicodeBE) or (cdCode = cdUTF_16LE) or (cdCode = cdUTF_16BE) then begin //UTF-16 Result := String(PChar(@lp_Buff[li_Start])); if (cdCode = cdUTF_16BE) or (cdCode = cdUnicodeBE) then begin //エンディアン入れ替え li_Len := LCMapStringW(GetUserDefaultLCID(), LCMAP_BYTEREV, PWideChar(Result), -1, nil, 0); lp_Endian := AllocMem((li_Len +1) * 2); try LCMapStringW(GetUserDefaultLCID(), LCMAP_BYTEREV, PWideChar(Result), -1, lp_Endian, li_Len); Result := String(lp_Endian); finally FreeMem(lp_Endian); end; end; end else begin //Shift_JIS、UTF-7、JIS、EUC //gfniFileReadでlp_Buffを2バイト余計にAllocMemでメモリ確保しているのでAnsiStringでキャストOK //ResultをgfnsEucToWideの引数に渡すと文字化けするのでそれへの対処。 // Result := AnsiString(lp_Buff); ls_Text := AnsiString(lp_Buff); if (cdCode = cdUTF_7) then begin //UTF-7 Result := gfnsUtf7ToWide(ls_Text); end else if (cdCode = cdJIS) then begin Result := gfnsJisToWide(ls_Text); end else if (cdCode = cdEUC) then begin Result := gfnsEucToWide(ls_Text); end else begin if (cdCode <> cdSJIS) then begin cdCode := cdSJis; end; Result := String(ls_Text); end; end; end; finally FreeMem(lp_Buff); end; end; function gfnbFileWriteText(sFile, sText: String): Boolean; {2008-05-24,2009-02-01: Unicode対応のファイル書き込み。 2009-02-01:cdAnsiからcdAutoに変更。 } begin Result := gfnbFileWriteText(sFile, sText, cdAuto); end; function gfnbFileWriteText(sFile, sText: String; const cdCode: TMyCharCode): Boolean; {2008-05-24,29,12-19,2009-02-01,2010-10-03: Unicode対応のファイル書き込み。 文字コードcdCodeの指定により ・Shift_JIS ・UTF-16 BOMありのリトルエンディアン ・UTF-16 BOMありのビッグエンディアン ・UTF-16LE ・UTF-16BE ・UTF-8 (BOMあり) ・UTF-8N (BOMなし) ・UTF-7 ・JIS ・EUC に対応。さらに、cdCodeがcdAutoでsTextにUnicode文字があればUTF-8で、なければShift_JISで保存。 2010-10-03: 　JISとEUCに対応。 2009-02-01: cdCodeにcdAutoを追加。 2008-12-19: UTF-8でなぜかLength(ls_Str) -1としていた間違いを修正。なんなんだこの-1は、、？ 恐らくUtf8Encodeの後ろに#0がついてしまうことへの対症療法だったのだと思われ。 2008-05-29: UTF-8対応 文字コード指定でUTF-16LE,UTF-16BE,UTF-8Nの書き込みもできるようにした } var lh_Handle: THandle; lp_Buff: PChar; lp_Byte: PAnsiChar; li_Len: Integer; li_Count: DWORD; ls_Str: AnsiString; li_ErrMode: UINT; begin Result := True; lh_Handle := CreateFile( PChar(sFile), //ファイル名 GENERIC_WRITE, //アクセスモード 0, //共有モード nil, //セキュリティ CREATE_ALWAYS, //作成方法 FILE_ATTRIBUTE_NORMAL, //ファイル属性 0 //テンプレート ); // lh_Handle := gfnhFileWriteOpen(sFile); if (lh_Handle <> INVALID_HANDLE_VALUE) then begin try try li_ErrMode := SetErrorMode(SEM_FAILCRITICALERRORS); if (cdCode = cdUTF_8) or (cdCode = cdUTF_8N) or ((cdCode = cdAuto) and gfnbIsUnicode(sText)) //自動判別で、sTextにUnicode文字があればUtf-8で書き込み then begin //UTF-8 ls_Str := gfnsWideToUTF8(sText); if (Length(ls_Str) >= 3) and (ls_Str[1] = #$EF) and (ls_Str[2] = #$BB) and (ls_Str[3] = #$BF) then begin //BOMがついているなら後の処理がやりやすいように取り除く。 ls_Str := Copy(ls_Str, 4, MAXINT); end; if (cdCode = cdUTF_8N) then begin //BOMなし WriteFile(lh_Handle, PAnsiChar(ls_Str)^, Length(ls_Str), li_Count, nil); end else begin //BOMあり WriteFile(lh_Handle, #$EF#$BB#$BF, 3, li_Count, nil); WriteFile(lh_Handle, PAnsiChar(ls_Str)^, Length(ls_Str), li_Count, nil); end; end else if (cdCode = cdUTF_7) then begin //UTF-7 ls_Str := gfnsWideToUtf7(sText); WriteFile(lh_Handle, PAnsiChar(ls_Str)^, Length(ls_Str), li_Count, nil); end else if (cdCode = cdUnicodeLE) or (cdCode = cdUnicodeBE) or (cdCode = cdUTF_16LE) or (cdCode = cdUTF_16BE) then begin //UTF-16 lp_Byte := PAnsiChar(PWideChar(sText)); //あえてPWideChar if (Length(sText) >= 1) //#$FF#$FEで1文字相当の長さ。 and (lp_Byte[0] = #$FF) and (lp_Byte[1] = #$FE) then begin //BOMがついているなら後の処理がやりやすいように取り除く。 sText := Copy(sText, 2, MAXINT); end; li_Len := Length(sText) * 2; if (cdCode = cdUnicodeBE) or (cdCode = cdUTF_16BE) then begin //ビッグエンディアン if (cdCode = cdUnicodeBE) then begin //UTF-16 BOMありのビッグエンディアン。 WriteFile(lh_Handle, #$FE#$FF, 2, li_Count, nil); end; lp_Buff := AllocMem(li_Len + SizeOf(WideChar)); //あえてWideChar try LCMapStringW(GetUserDefaultLCID(), LCMAP_BYTEREV, PWideChar(sText), -1, lp_Buff, li_Len); WriteFile(lh_Handle, lp_Buff^, DWORD(li_Len), li_Count, nil); finally FreeMem(lp_Buff); end; end else if (cdCode = cdUnicodeLE) or (cdCode = cdUTF_16LE) then begin //リトルエンディアン。 if (cdCode = cdUnicodeLE) then begin //UTF-16 BOMありのリトルエンディアン。 WriteFile(lh_Handle, #$FF#$FE, 2, li_Count, nil); end; WriteFile(lh_Handle, PAnsiChar(PWideChar(sText))^, DWORD(li_Len), li_Count, nil); end; end else if (cdCode = cdJIS) then begin //JIS ls_Str := gfnsWideToJis(sText); WriteFile(lh_Handle, PAnsiChar(ls_Str)^, Length(ls_Str), li_Count, nil); end else if (cdCode = cdEUC) then begin //EUC ls_Str := gfnsWideToEuc(sText); WriteFile(lh_Handle, PAnsiChar(ls_Str)^, Length(ls_Str), li_Count, nil); end else begin //Shift_JIS ls_Str := gfnsWideToAnsi(sText); //AnsiString(sText)では合成文字を正しく変換しない場合あり WriteFile(lh_Handle, PAnsiChar(ls_Str)^, Length(ls_Str), li_Count, nil); end; SetErrorMode(li_ErrMode); except Result := False; end; finally CloseHandle(lh_Handle); end; end else begin Result := False; end; end; //============================================================================== {MyWStrings} constructor TMyWStrings.Create; begin Create(nil); //↓を呼んでいる end; constructor TMyWStrings.Create(AList: TStrings); begin inherited Create; if (AList = nil) then begin if not(Assigned(FList)) then begin FList := TStringList.Create; FbListFree := True; //FListはFreeしなければならない end; end else begin FList := AList; FbListFree := False; //FListはFreeしてはいけない end; FOutList := TStringList.Create; //CaseSensiitiveとIgnoreCaseはFSetCaseSensitiveかFSetIgnoreCaseのどちらかを呼ばないといけない //この二つは連動しているので直接FbCaseSensiitiveまたはFbIgnoreCaseに値を代入してしまうと整合性がとれなくなる FSetCaseSensitive(True); if (AList <> nil) and (AList is TStringList) then begin {TStringList等CaseSensitiveのあるものはCreateの後に改めてセットしないといけない} FSetCaseSensitive(TStringList(AList).CaseSensitive); end; //検索用 FbFindAnd := True; //and検索 // FbIgnoreCase := False; //大文字と小文字を区別する FbIgnoreKanaType := False; //ひらがなとカタカナを区別する FbIgnoreNonSpace := False; //濁音や拗音を無視しない FbIgnoreSymbols := False; //記号を無視しない FbIgnoreWidth := False; //全角と半角を区別する FcdCharCode := cdAuto; //自動判定 FnlNewLine := nlCRLF; //CR+LF FbObjectsFree := False; FDuplicates := dupIgnore; FsDelimiter := ','; FsQuoteChar := '"'; FOnAdd := nil; end; destructor TMyWStrings.Destroy; begin if (FbListFree) then begin //2011-07-10:TMyMediaStringsにTMyTagオブジェクトを持つことによりClearを呼ばな //いとメモリーリークするようになったのでClearが必須になった。 Self.Clear; FList.Free; FList := nil; end; FOutList.Free; FOutList := nil; inherited Destroy; end; //外部のリストに付け替える procedure TMyWStrings.Attach(AList: TStrings); begin if (FbListFree) and (AList <> nil) then begin //内部リストを開放 Self.Clear; FList.Free; FList := nil; FbListFree := False; end; if (AList <> nil) then begin //付け替え。 FList := AList; end else begin if (FbListFree) then begin //引数がnilなら既存の内部リストをそのまま利用 FList.Clear; end else begin FList := TStringList.Create; FbListFree := True; //F_slListはFreeしなければならない end; end; end; //外部リスト解除。外部リストの開放はしない。 procedure TMyWStrings.Detach; begin if not(FbListFree) then begin //外部リストであった。 if not(Assigned(FList)) then begin //内部リストを作成。 FList := TStringList.Create; FbListFree := True; //F_slListはFreeしなければならない end else begin //内部リストが作成されている（ここにくることはないはず） //クリアする。 Clear; end; end else begin //リストは外部リストではなかった。 //クリアはする。 Clear; end; end; (* function TMyWStrings.WideToAnsi(sStr: String): AnsiString; begin Result := gfnsWideToAnsiEx(sStr); end; function TMyWStrings.AnsiToWide(sStr: AnsiString): String; begin Result := gfnsAnsiToWideEx(sStr); end; *) function TMyWStrings.Get(iIndex: Integer): String; begin if (iIndex >= 0) and (iIndex < FList.Count) then begin Result := FList[iIndex]; end else begin Result := ''; end; end; procedure TMyWStrings.Put(iIndex: Integer; sStr: String); begin if (iIndex >= 0) and (iIndex < FList.Count) then begin FList[iIndex] := sStr; end; end; procedure TMyWStrings.SetTextStr(sText: String); {2008-06-06,2009-07-15: 2009-07-15:テキストを追加できるように本体の処理をAddTextへ分割移動。 2008-06-06:一度にまとめて変換していたのをインデックスごとに変換するように変更。 データにもよるだろうけれど、4倍速くなった。 } begin Clear; AddText(sText); end; procedure TMyWStrings.AddText(sText: String); {2008-06-06,2009-07-15,2010-10-26,2011-06-11,20: 2011-10-06:sTextの最後が改行であったら1行足していた処理を削除。 　s-padでソート機能を実装したら余計な空行ができてしまっていたため。 2011-06-20:↓を改善。 2011-06-11:末尾が改行であった時にSelf.Add('')としたらエラーが出ることが判明。 暫定でコメントアウト。 2010-10-26:空行の時の処理をFList.AddとしていたのをSelf.Addに修正。 2009-07-15:テキストを追加できるように本体の処理をSetTextStrから分割移動。 2008-06-06:一度にまとめて変換していたのをインデックスごとに変換するように変更。 データにもよるだろうけれど、4倍速くなった。 } var li_Len : Integer; li_Count : Integer; lp_Pos : PWideChar; lp_Start : PWideChar; lp_Item : PWideChar; lb_Cr : Boolean; lb_Lf : Boolean; begin lb_Cr := False; lb_Lf := False; BeginUpdate; try lp_Pos := PWideChar(sText); while (lp_Pos[0] <> #0) do begin lp_Start := lp_Pos; li_Len := 0; //1行に必要な文字数を算出 while (lp_Pos^ <> #0) //終了文字でなく and (lp_Pos^ <> #$D) //改行でなければ and (lp_Pos^ <> #$A) //同上 do begin Inc(li_Len); Inc(lp_Pos); end; if (li_Len > 0) then begin Inc(li_Len); lp_Item := AllocMem(li_Len * 2); try lstrcpynW(lp_Item, lp_Start, li_Len); li_Count := Add(String(lp_Item)); //myDebug.gpcDebug(Self.Text); if (@FOnAdd <> nil) then begin FOnAdd(Self, li_Count, li_Len); end; finally FreeMem(lp_Item); end; end else begin //2010-10-26:FList.Addから変更。 //myWMPlayerのTMyWMPlaylistで拡張子を制限している場合にF_slList.Addだと引っかからないのでNG Self.Add(''); end; if (lp_Pos^ = #$D) then begin lb_Cr := True; Inc(lp_Pos); end; if (lp_Pos^ = #$A) then begin lb_Lf := True; Inc(lp_Pos); end; end; finally EndUpdate; end; if (lb_Cr and not(lb_Lf)) then begin //CRのみ FnlNewLine := nlCR; end else if (not(lb_Cr) and lb_Lf) then begin //LFのみ FnlNewLine := nlLF; end else begin //CRとLFが混在していた場合もCR+LFとみなす。 FnlNewLine := nlCRLF; end; end; procedure TMyWStrings.AddFile(sFile: String); //ファイルから追加 var lcd_Code: TMyCharCode; begin lcd_Code := cdAuto; AddText(gfnsFileReadText(sFile, lcd_Code)); end; procedure TMyWStrings.AddFile(AList: TMyWStrings); var i: Integer; begin for i := 0 to AList.Count -1 do begin AddFile(AList[i]); end; end; function TMyWStrings.GetTextStr: String; { 2011-06-20:改行コード付加の条件式を(i < li_Count)としていたのでエラーが出ていたのを修正。 　2011-05-16の修正で起きるようになった致命的なバグ。 2011-05-16:末尾が改行コードでないテキストに改行コードを付加していたのを付加しないように変更。 2009-02-01:SetLength(Result, li_Len+1)としていたため終わりに余計な#0がくっついていたのを修正。 2008-06-06:一度にまとめて変換していたのをインデックスごとに変換するように変更。 } var i : Integer; li_Len : Integer; li_NewLine : Integer; li_Count : Integer; lp_Pos : PChar; ls_Str : String; ls_NewLine : String; begin Result := ''; ls_NewLine := gfnsNewLineGet(FnlNewLine); li_NewLine := Length(ls_NewLine); li_Len := 0; li_Count := GetCount; for i := 0 to li_Count-1 do begin Inc(li_Len, Length(Get(i)) + li_NewLine); //li_NewLineは改行コードの長さ end; // Dec(li_Len, li_NewLine); //最後の行の改行分を削除 SetLength(Result, li_Len); lp_Pos := PChar(Result); for i := 0 to li_Count-1 do begin ls_Str := Get(i); li_Len := Length(ls_Str); if (li_Len <> 0) then begin //lstrcpynは終端のNULL分も含めての文字数を指定するのでli_Lenに+1する lstrcpyn(lp_Pos, PChar(ls_Str), li_Len +1); Inc(lp_Pos, li_Len); end; //2011-06-20:条件式を(i < li_Count)としていたのでエラーが出ていた // if (i < li_Count-1) then begin lstrcpy(lp_Pos, PChar(ls_NewLine)); Inc(lp_Pos, li_NewLine); // end; // Application.ProcessMessages; end; end; function TMyWStrings.GetTextStrEx: String; //区切りを改行ではなくF_sDelimiterにしたテキストを返す。 var i, li_Len, li_Delimitor: Integer; li_Count : Integer; lp_Pos : PChar; ls_Str : String; begin Result := ''; li_Delimitor := Length(FsDelimiter); li_Len := 0; li_Count := GetCount; for i := 0 to li_Count -1 do begin Inc(li_Len, Length(Get(i)) + li_Delimitor); //li_Delimitorは区切り文字の長さ end; Dec(li_Len, li_Delimitor); //最後の行の区切り分を削除 SetLength(Result, li_Len); lp_Pos := PChar(Result); for i := 0 to li_Count -1 do begin ls_Str := Get(i); li_Len := Length(ls_Str); if (li_Len <> 0) then begin //lstrcpynは終端のNULL分も含めての文字数を指定するのでli_Lenに+1する lstrcpyn(lp_Pos, PWideChar(ls_Str), li_Len +1); Inc(lp_Pos, li_Len); end; if (i < li_Count -1) then begin lstrcpyn(lp_Pos, PChar(FsDelimiter), li_Delimitor +1); Inc(lp_Pos, li_Delimitor); end; Application.ProcessMessages; end; end; procedure TMyWStrings.SetTextStrEx(sText: String); var li_Len : Integer; li_Pos : Integer; li_Cr : Integer; lp_Pos : PWideChar; lp_Item : PWideChar; begin BeginUpdate; try Clear; if (sText = '') then begin Abort; end; li_Cr := Length(FsDelimiter); li_Len := Length(sText); lp_Pos := PWideChar(sText); repeat li_Pos := Pos(FsDelimiter, String(lp_Pos)); if (li_Pos > 0) then begin lp_Item := AllocMem((li_Pos+1) * 2); try lstrcpynW(lp_Item, lp_Pos, li_Pos); Add(String(lp_Item)); finally FreeMem(lp_Item); end; Inc(lp_Pos, (li_Pos + li_Cr -1)); Dec(li_Len, (li_Pos + li_Cr -1)); end else begin if (li_Len = 0) then begin Add(''); end else begin lp_Item := AllocMem((li_Len+1) * 2); try lstrcpynW(lp_Item, lp_Pos, li_Len+1); Add(String(lp_Item)); finally FreeMem(lp_Item); end; // Add(Copy(String(lp_Pos), 1, li_Len)); end; Break; end; Application.ProcessMessages; until (li_Len <= 0); finally EndUpdate; end; end; function TMyWStrings.GetCommaText: String; //文字列にスペース、カンマ、引用符がある場合には文字列は二重引用符で囲まれる。 //更に二重引用符には二重引用符が連続して付けらる。 const lcs_DELIMITER = ','; lcs_QUOTECHAR = '"'; var ls_Quote, ls_Delim : String; begin ls_Quote := FsQuoteChar; ls_Delim := FsDelimiter; FsQuoteChar := '"'; FsDelimiter := ','; Result := GetDelimitedText; FsQuoteChar := ls_Quote; FsDelimiter := ls_Delim; end; function TMyWStrings.GetDelimitedText: String; const lci_CTRLCHAR = Ord(WideChar(' ')); var ls_Str, ls_Item : String; i, k, li_DPos, li_QPos : Integer; lb_Quote : Boolean; begin if (GetCount = 1) and (Get(0) = '') then begin Result := FsQuoteChar + FsQuoteChar end else begin for i := 0 to GetCount-1 do begin ls_Str := Get(i); //制御コードorスペースがあるか lb_Quote := False; for k := 1 to Length(ls_Str) do begin if (Ord(ls_Str[k]) <= lci_CTRLCHAR) then begin lb_Quote := True; Break; end; end; if not(lb_Quote) then begin //区切り(F_sDelimiter)があるか li_DPos := Pos(FsDelimiter, ls_Str); lb_Quote := (li_DPos > 0); end; //引用符(F_sQuoteChar)があるか li_QPos := Pos(FsQuoteChar, ls_Str); if (li_QPos > 0) then begin lb_Quote := True; ls_Str := gfnsStrReplace(ls_Str, FsQuoteChar, FsQuoteChar + FsQuoteChar); end; if (lb_Quote) then begin ls_Item := FsQuoteChar + ls_Str + FsQuoteChar; end else begin ls_Item := ls_Str; end; if (i = 0) then begin Result := ls_Item; end else begin Result := Result + FsDelimiter + ls_Item; end; end; end; end; function TMyWStrings.GetObject(Index: Integer): TObject; begin if (Index < 0) or (GetCount <= Index) then begin Result := nil; end else begin Result := FList.Objects[Index]; end; end; procedure TMyWStrings.PutObject(Index: Integer; AObject: TObject); begin if (0 <= Index) and (Index < GetCount) then begin //Exchangeなどで入れ替える場合にFreeされると困るのでNG // if (FList.Objects[Index] <> nil) then begin //NG! FList.Objects[Index].Free; // end; FList.Objects[Index] := AObject; end; end; function TMyWStrings.GetCount: Integer; begin try Result := FList.Count; except //エラーに対応(手抜き) Result := 0; end; end; function TMyWStrings.GetCapacity: Integer; begin Result := FList.Capacity; end; procedure TMyWStrings.SetCapacity(NewCapacity: Integer); begin FList.Capacity := NewCapacity; end; procedure TMyWStrings.FFreeObject(iIndex: Integer); begin if (FList.Objects[iIndex] <> nil) then begin FList.Objects[iIndex].Free; FList.Objects[iIndex] := nil; end; end; procedure TMyWStrings.Clear; {,2011-07-08: TMyFileStringsでリストの取得中にオブジェクトにファイル情報を持たせられるようにし た結果Clearでオブジェクトを解放しないとならないことになったので対応。 ただし勝手に解放されると困ることもあるのでObjectsFreeで明示しないと解放しない。 } var i: Integer; begin if (FbObjectsFree) then begin for i := 0 to GetCount-1 do begin FFreeObject(i); end; end; FList.Clear; end; procedure TMyWStrings.Assign(AList: TStrings); begin if (GetCount > 0) then begin Clear; end; FList.Assign(AList); end; procedure TMyWStrings.Assign(AList: TMyWStrings); begin if (GetCount > 0) then begin Clear; end; AddStrings(AList); end; //一気追加 procedure TMyWStrings.AddStrings(AList: TStrings); var i: Integer; begin // FList.Capacity := FList.Count + AList.Count + 100; //ちょっと多めに // FList.AddStrings(AList); BeginUpdate; try FList.Capacity := FList.Count + AList.Count + 100; //ちょっと多めに for i := 0 to AList.Count-1 do begin AddObject(AList[i], AList.Objects[i]); end; finally EndUpdate; end; end; procedure TMyWStrings.AddStrings(AList: TMyWStrings); var i: Integer; begin BeginUpdate; try FList.Capacity := FList.Count + AList.Count + 100; //ちょっと多めに for i := 0 to AList.Count-1 do begin AddObject(AList[i], AList.Objects[i]); end; finally EndUpdate; end; end; procedure TMyWStrings.AddStrings(iCount: Integer); //空白行追加 var i: Integer; begin BeginUpdate; try FList.Capacity := FList.Count + iCount + 100; //ちょっと多めに for i := 1 to iCount do begin Add(''); end; finally EndUpdate; end; end; //一気挿入　 procedure TMyWStrings.InsertStrings(iIndex: Integer; slList: TStrings); var i: Integer; begin iIndex := gfniNumLimit(iIndex, 0, GetCount); for i := slList.Count - 1 downto 0 do begin FList.Insert(iIndex, slList[i]); end; end; procedure TMyWStrings.InsertStrings(iIndex: Integer; slList: TMyWStrings); var i: Integer; begin iIndex := gfniNumLimit(iIndex, 0, GetCount); BeginUpdate; try for i := slList.Count-1 downto 0 do begin Insert(iIndex, slList[i]); end; finally EndUpdate; end; end; function TMyWStrings.Add(sStr: String): Integer; begin //TMyFileStringsから呼ばれる関係でAddObjectを呼ばないといけない Result := AddObject(sStr, nil); end; function TMyWStrings.AddObject(S: String; AObject: TObject): Integer; begin InsertObject(GetCount, S, AObject); Result := GetCount -1; end; function TMyWStrings.AddName(sName, sValue: String): Integer; begin Result := Add(Format('%s=%s', [sName, sValue])); end; procedure TMyWStrings.Append(sStr: String); //Addより多少効率は良い begin InsertObject(GetCount, sStr, nil); end; procedure TMyWStrings.Insert(iIndex: Integer; sStr: String); begin InsertObject(iIndex, sStr, nil); end; procedure TMyWStrings.InsertObject(Index: Integer; S: String; AObject: TObject); var li_Index: Integer; begin //最終的に追加処理はここにくる if (FbSorted) and (FDuplicates <> dupAccept) then begin if (Find(S, li_Index)) then begin if (FDuplicates = dupError) then begin //エラーメッセージを出す。 //メッセージを出すだけで例外は投げないので注意。 gpcShowMessage('文字列リストは重複を許しません'); end; Exit; end; end else begin li_Index := gfniNumLimit(Index, 0, GetCount); //範囲内に収めてエラーを防ぐ end; try FList.InsertObject(li_Index, S, AObject); if (@FOnChange <> nil) then begin FOnChange(Self); end; except on EOutOfMemory do begin gpcShowMessage('データが大きすぎて操作が完了できませんでした'); end else begin gpcShowMessage('操作が完了できませんでした'); end; end; end; procedure TMyWStrings.Delete(iIndex: Integer); {,2011-07-08: TMyFileStringsでリストの取得中にオブジェクトにファイル情報を持たせられるようにし た結果Deleteでオブジェクトを解放しないとならないことになったので対応。 ただし勝手に解放されると困ることもあるのでObjectsFreeで明示しないと解放しない。 } begin //範囲チェック if (iIndex >= 0) and (iIndex < FList.Count) then begin if (FbObjectsFree) then begin FFreeObject(iIndex); end; FList.Delete(iIndex); if (@FOnChange <> nil) then begin FOnChange(Self); end; end; end; procedure TMyWStrings.FSetCaseSensitive(bSensitive: Boolean); begin FbCaseSensitive := bSensitive; FbIgnoreCase := not(bSensitive); end; procedure TMyWStrings.FSetIgnoreCase(bIgnore: Boolean); begin FbCaseSensitive := not(bIgnore); FbIgnoreCase := bIgnore ; end; function TMyWStrings.Find(sStr: String; var iIndex: Integer): Boolean; var i, li_Cmp: Integer; begin Result := False; iIndex := -1; for i := 0 to GetCount-1 do begin if (FbCaseSensitive) then begin //大文字小文字の区別あり li_Cmp := CompareStr(Get(i), sStr); end else begin //大文字小文字の区別無し li_Cmp := CompareText(Get(i), sStr); end; if (li_Cmp = 0) then begin Result := True; iIndex := i; Exit; end else if (li_Cmp > 0) then begin iIndex := i; Exit; end; end; end; function TMyWStrings.FindDown(sStr: String; iIndex: Integer = 0): Integer; begin Result := FindDown([sStr], iIndex); end; function TMyWStrings.FindUp(sStr: String; iIndex: Integer = 0): Integer; begin Result := FindUp([sStr], iIndex); end; function TMyWStrings.FindDown(sStrs: array of String; iIndex: Integer = 0): Integer; var i : Integer; l_List : TStrings; begin Result := -1; l_List := nil; try l_List := TStringList.Create; for i := Low(sStrs) to High(sStrs) do begin l_List.Add(sStrs[i]); end; Result := FindDown(l_List, iIndex); finally l_List.Free; end; end; function TMyWStrings.FindUp(sStrs: array of String; iIndex: Integer = 0): Integer; var i : Integer; l_List : TStrings; begin Result := -1; l_List := nil; try l_List := TStringList.Create; for i := Low(sStrs) to High(sStrs) do begin l_List.Add(sStrs[i]); end; Result := FindUp(l_List, iIndex); finally l_List.Free; end; end; function TMyWStrings.FGetFindCmpFlags: DWORD; begin Result := 0; if (FbIgnoreCase) then Result := Result or NORM_IGNORECASE; if (FbIgnoreKanaType) then Result := Result or NORM_IGNOREKANATYPE; // if (FbIgnoreNonSpace) then Result := Result or NORM_IGNORENONSPACE; // if (FbIgnoreSymbols) then Result := Result or NORM_IGNORESYMBOLS; if (FbIgnoreWidth) then Result := Result or NORM_IGNOREWIDTH; end; function TMyWStrings.FGetFindString(sStr: String): String; var li_Len : Integer; li_Ret : Integer; pDest : PChar; begin pDest := nil; li_Len := LCMapString( LOCALE_USER_DEFAULT, // ロケール識別子 FGetFindCmpFlags, // マップ変換の種類 PChar(sStr), // マップ元文字列のアドレス -1, // マップ元文字列の文字数 pDest, // マップ先バッファのアドレス 0 // マップ先バッファのサイズ ); if (li_Len <= 0) then begin Result := sStr; Exit; end; pDest := AllocMem(li_Len * SizeOf(Char)); li_Ret := LCMapString( LOCALE_USER_DEFAULT, // ロケール識別子 FGetFindCmpFlags, // マップ変換の種類 PChar(sStr), // マップ元文字列のアドレス -1, // マップ元文字列の文字数 pDest, // マップ先バッファのアドレス li_Len // マップ先バッファのサイズ ); if (li_Ret = 0) then begin Result := sStr; end else begin Result := String(pDest); end end; function TMyWStrings.FindDown(AStr: TStrings; iIndex: Integer = 0): Integer; var i : Integer; ls_Text : String; l_List : TStrings; begin Result := -1; if not(gfnbIsInsideRange(iIndex, 0, Self.Count -1)) or (AStr.Count <= 0) then begin Exit; end; l_List := nil; try l_List := TStringList.Create; for i := 0 to AStr.Count -1 do begin l_List.Add(FGetFindString(AStr[i])); end; for i := iIndex to Self.Count -1 do begin ls_Text := FGetFindString(Get(i)); end; finally l_List.Free; end; end; function TMyWStrings.FindUp(AStr: TStrings; iIndex: Integer = 0): Integer; begin Result := -1; if not(gfnbIsInsideRange(iIndex, 0, Self.Count -1)) then begin Exit; end; end; function TMyWStrings.IndexOf(sStr: String): Integer; begin Result := Self.IndexOf(sStr, 0); end; function TMyWStrings.IndexOf(sStr: String; iIndex: Integer): Integer; //IndexOfの開始インデックス指定版 begin if (iIndex < 0) then begin iIndex := 0; end; for Result := iIndex to FList.Count -1 do begin if (FbCaseSensitive) then begin //大文字小文字の区別あり if (CompareStr(Get(Result), sStr) = 0) then begin Exit; end; end else begin //大文字小文字の区別無し if (CompareText(Get(Result), sStr) = 0) then begin Exit; end; end; end; Result := -1; end; function TMyWStrings.InStringOf(sStr: String): Integer; //sStrを含む最初の行を返す。 begin Result := InStringOf(sStr, 0); end; function TMyWStrings.InStringOf(sStr: String; iIndex: Integer): Integer; //iIndex行以降でsStrを含む最初の行を返す。 begin if (iIndex < 0) then begin iIndex := 0; end; if not(FbCaseSensitive) then begin sStr := UpperCase(sStr); end; for Result := iIndex to GetCount -1 do begin if (FbCaseSensitive) then begin //大文字小文字の区別あり if (Pos(sStr, Get(Result)) > 0) then begin Exit; end; end else begin //大文字小文字の区別無し if (Pos(sStr, UpperCase(Get(Result))) > 0) then begin Exit; end; end; end; Result := -1; end; function TMyWStrings.InHeadStringOf(sStr: String): Integer; //sStrが行頭に現れる最初の行を返す。 begin Result := InHeadStringOf(sStr, 0); end; function TMyWStrings.InHeadStringOf(sStr: String; iIndex: Integer): Integer; //iIndex行以降でsStrが行頭に現れる最初の行を返す。 begin if (iIndex < 0) then begin iIndex := 0; end; if not(FbCaseSensitive) then begin sStr := UpperCase(sStr); end; for Result := iIndex to GetCount -1 do begin if (FbCaseSensitive) then begin //大文字小文字の区別あり if (Pos(sStr, Get(Result)) = 1) then begin Exit; end; end else begin //大文字小文字の区別無し if (Pos(sStr, UpperCase(Get(Result))) = 1) then begin Exit; end; end; end; Result := -1; end; function TMyWStrings.IndexOfName(sName: String): Integer; begin Result := Self.IndexOfName(sName, 0); end; function TMyWStrings.IndexOfName(sName : String; iIndex : Integer) : Integer; var ls_Name: String; begin if (iIndex < 0) then begin iIndex := 0; end; for Result := iIndex to FList.Count -1 do begin ls_Name := FGetName(Result); { if (FbCaseSensitive) then begin if (CompareStr(sName, ls_Name) = 0) then begin Exit; end; end else begin if (CompareText(sName, ls_Name) = 0) then begin Exit; end; end; } if (CompareText(sName, ls_Name) = 0) then begin Exit; end; end; Result := -1; end; function TMyWStrings.FGetName(iIndex: Integer): String; begin Result := gfnsIniNameGet(FList[iIndex]); end; function TMyWStrings.FGetValue(sName: String): String; var li_Index: Integer; begin li_Index := IndexOfName(sName); if (li_Index >= 0) then begin Result := gfnsIniValueGet(FList[li_Index]); end else begin Result := ''; end; end; procedure TMyWStrings.FSetValue(sName, sValue: String); { TStringsのSetValueと違いsValueに空文字を許す。 つまり'Name='の行の存在を許すということ。 } var li_Index: Integer; ls_Item: String; begin li_Index := IndexOfName(sName); ls_Item := Format('%s=%s', [Trim(sName), sValue]); if (li_Index >= 0) then begin Put(li_Index, ls_Item); end else begin Add(ls_Item); end; end; { //AnsiString function TMyWStrings.FGetAnsiStrings: TStrings; var i: Integer; begin FOutList.Clear; for i := 0 to GetCount -1 do begin FOutList.Add(gfnsWideToAnsi(Get(i))); end; Result := FOutList; end; } //UTF7 function TMyWStrings.FGetUtf7Strings: TStrings; var i: Integer; begin FOutList.Clear; for i := 0 to GetCount -1 do begin FOutList.Add(String(gfnsWideToUtf7(Get(i)))); end; Result := FOutList; end; //UTF8 function TMyWStrings.FGetUtf8Strings: TStrings; var i: Integer; begin FOutList.Clear; for i := 0 to GetCount -1 do begin FOutList.Add(String(gfnsWideToUtf8(Get(i)))); // FOutList.Add(Utf8Encode(Get(i))); end; Result := FOutList; end; (* //独自関数。 function TMyWStrings.F_GetWideToAnsiExStrings: TStrings; var i: Integer; begin FOutList.Clear; for i := 0 to GetCount -1 do begin FOutList.Add(gfnsWideToAnsiEx(Get(i))); end; Result := FOutList; end; *) function TMyWStrings.Equals(AList: TMyWStrings): Boolean; {2008-06-01: F_slListとslListの内容が同じならTrueを返す。 大文字と小文字の区別はCaseSensitiveの値による。 } var li_Comp, i: Integer; begin if (FList.Count <> AList.Count) then begin Result := False; end else begin Result := True; for i := 0 to FList.Count -1 do begin if (FbCaseSensitive) then begin li_Comp := CompareStr(Get(i), AList[i]); end else begin li_Comp := CompareText(Get(i), AList[i]); end; if (li_Comp <> 0) then begin Result := False; Break; end; end; end; end; procedure TMyWStrings.Exchange(iIndex1, iIndex2: Integer); begin FList.Exchange(iIndex1, iIndex2); if (@FOnChange <> nil) then begin FOnChange(Self); end; end; procedure TMyWStrings.Move(iCurrentIndex, iNewIndex: Integer); begin FList.Move(iCurrentIndex, iNewIndex); if (@FOnChange <> nil) then begin FOnChange(Self); end; end; procedure TMyWStrings.Reverse; //リストの並びを反転 var i: Integer; // lsl_List: TStrings; begin if (GetCount = 0) then begin Exit; end; for i := 0 to Trunc((FList.Count -1) / 2) do begin Exchange(i, FList.Count -1 - i); end; { //Exchageを使うよりもTStringListを使ったほうが速い。 //が、Exchangeを使う方が下位クラスで都合が良い。 //具体的にはmyWMPlayer.pasのTMyCustomWMPListなど。 lsl_List := TStringList.Create; try for i := GetCount -1 downto 0 do begin lsl_List.Add(FList[i]); end; Assign(lsl_List); finally lsl_List.Free; end; } end; procedure TMyWStrings.SortDupDelete; //ソート済みリストの重複削除 //ソート済みでないと意味がない var i, li_Comp: Integer; begin for i := FList.Count-1 downto 1 do begin //downto 0 ではないことに注意 if (FbCaseSensitive) then begin li_Comp := CompareStr (Get(i), Get(i-1)); end else begin li_Comp := CompareText(Get(i), Get(i-1)); end; if (li_Comp = 0) then begin FList.Delete(i); end; end; end; //------------------------------------------------------------------------------ //ソート function lfni_SortFunc(slList: TMyWStrings; iIndex1, iIndex2: Integer): Integer; begin if (slList.CaseSensitive) then begin //大文字と小文字を区別する Result := CompareStr(slList[iIndex1], slList[iIndex2]); end else begin //大文字と小文字を区別しない Result := CompareText(slList[iIndex1], slList[iIndex2]); end; end; procedure TMyWStrings.Sort; begin CustomSort(lfni_SortFunc); end; procedure TMyWStrings.CustomSort(fniCompare: TMyWStringsSortCompare); //カスタムソート begin //2011-03-31:クイックソートからマージソートへ変更。 // QuickSort(fniCompare); MergeSort(fniCompare); end; //クイックソート procedure TMyWStrings.QuickSort(fniCompare: TMyWStringsSortCompare); begin // QuickSort(fniCompare, (Sorted and (Duplicates = dupIgnore)); QuickSort(fniCompare, False); end; procedure TMyWStrings.QuickSort(fniCompare: TMyWStringsSortCompare; bUnique: Boolean); {2008-04-14,06-03: QuickSort TStringListのQuickSortをコピー 2008-06-03:リストが1つ以下の時処理を行わないように変更。 } procedure lpc_QSort(slList: TMyWStrings; L, R: Integer; SCompare: TMyWStringsSortCompare); var I, J, P: Integer; begin repeat I := L; J := R; P := (L + R) shr 1; repeat while (SCompare(slList, I, P) < 0) do Inc(I); while (SCompare(slList, J, P) > 0) do Dec(J); if (I <= J) then begin slList.Exchange(I, J); if (P = I) then begin P := J end else if (P = J) then begin P := I; end; Inc(I); Dec(J); end; Application.ProcessMessages; until (I > J); if L < J then lpc_QSort(slList, L, J, SCompare); L := I; until (I >= R); end; begin if (FList.Count >= 2) then begin FList.BeginUpdate; try lpc_QSort(Self, 0, FList.Count - 1, fniCompare); finally FList.EndUpdate; end; end; //重複削除 if (bUnique) then begin SortDupDelete; end; end; //マージソート procedure TMyWStrings.MergeSort(fniCompare: TMyWStringsSortCompare; bUnique: Boolean); begin FList.BeginUpdate; try MergeSort(fniCompare); //重複削除 if (bUnique) then begin SortDupDelete; end; finally FList.EndUpdate; end; end; (* procedure TMyWStrings.MergeSort(fniCompare: TMyWStringsSortCompare); procedure lpc_MergeSort(slList: TMyWStrings; iIndex, iCount: Integer; fniCompare: TMyWStringsSortCompare); overload; //iIndexはソートを開始するインデックス行。 //iCountはソートするリストの数。 var i, k: Integer; li_Index1, li_Index2, li_Count1, li_Count2: Integer; lsl_Buff: TMyWStrings; begin if (iCount <= 1) then Exit; li_Count1 := iCount div 2; //前半のリストの数 li_Count2 := iCount - li_Count1; //後半のリストの数 li_Index1 := iIndex; //前半のリストの頭のインデックス li_Index2 := iIndex + li_Count1; //後半のリストの頭のインデックス lpc_MergeSort(slList, li_Index1, li_Count1, fniCompare); //前半をソート lpc_MergeSort(slList, li_Index2, li_Count2, fniCompare); //後半をソート //ソートされた前半と後半をマージ i := 0; k := 0; lsl_Buff := TMyWStrings.Create; try while (i < li_Count1) and (k < li_Count2) do begin //↓の比較関数を書き換えるだけで色々応用がきく if (fniCompare(slList, li_Index1 + i, li_Index2 + k) > 0) then begin lsl_Buff.AddObject(slList[li_Index2 + k], slList.Objects[li_Index2 + k]); Inc(k); end else begin lsl_Buff.AddObject(slList[li_Index1 + i], slList.Objects[li_Index1 + i]); Inc(i); end; end; if (i = li_Count1) then begin while (k < li_Count2) do begin lsl_Buff.AddObject(slList[li_Index2 + k], slList.Objects[li_Index2 + k]); Inc(k); end end else begin while (i < li_Count1) do begin lsl_Buff.AddObject(slList[li_Index1 + i], slList.Objects[li_Index1 + i]); Inc(i); end; end; for i := 0 to iCount -1 do begin slList[iIndex + i] := lsl_Buff[i]; slList.Objects[iIndex + i] := lsl_Buff.Objects[i]; end; finally lsl_Buff.Free; end; end; begin if (FList.Count >= 2) then begin FList.BeginUpdate; try lpc_MergeSort(Self, 0, FList.Count, fniCompare); finally FList.EndUpdate; end; end; end; *) procedure TMyWStrings.MergeSort(iStart, iEnd : Integer; fniCompare: TMyWStringsSortCompare); //インデックスの配列を使った更にもうちょっとだけ速いマージソートの部分ソート対応版。 //iStartとiEndは部分ソートの0ベースの開始インデックスと終了インデックス。 procedure lpc_MergeSort(AList: TMyWStrings; var Index: array of Integer; fniCompare: TMyWStringsSortCompare); //http://www.ics.kagoshima-u.ac.jp/~fuchida/edu/algorithm/sort-algorithm/merge-sort.html var i, k: Integer; li_Count : Integer; li_Count_1 : Integer; li_Count_2 : Integer; l_Index_1 : array of Integer; l_Index_2 : array of Integer; begin Inc(FiSortDepth); FsProgressMsg := Format('リストのソート中 [%d]', [FiSortDepth]); li_Count := Length(Index); if (li_Count > 1) then begin li_Count_1 := li_Count div 2; li_Count_2 := li_Count - li_Count_1; SetLength(l_Index_1, li_Count_1); //前半のインデックス SetLength(l_Index_2, li_Count_2); //後半のインデックス for i := 0 to li_Count_1 -1 do //前半のインデックスをコピー begin l_Index_1[i] := Index[i]; end; for i := 0 to li_Count_2 -1 do //後半のインデックスをコピー begin l_Index_2[i] := Index[li_Count_1 +i]; end; lpc_MergeSort(AList, l_Index_1, fniCompare); //この中で順番が変わっている lpc_MergeSort(AList, l_Index_2, fniCompare); //この中で順番が変わっている i := 0; k := 0; while (i < li_Count_1) or (k < li_Count_2) do begin if (i >= li_Count_1) or ((k < li_Count_2) and (fniCompare(AList, l_Index_1[i], l_Index_2[k]) > 0)) then begin Index[i+k] := l_Index_2[k]; Inc(k); end else begin Index[i+k] := l_Index_1[i]; Inc(i); end; end; end; end; var i : Integer; l_Index : array of Integer; lsl_List : TMyWStrings; begin SetLength(l_Index, iEnd - iStart +1); for i := 0 to High(l_Index) do begin l_Index[i] := iStart +i; end; FsProgressMsg := ''; FiSortDepth := 0; // FbSortTurn := False; //この中で並べ替えられるのはリスト本体ではなくインデックスのリスト(l_Index)の方 lpc_MergeSort(Self, l_Index, fniCompare); lsl_List := TMyWStrings.Create; try { //iStartまでをコピー for i := 0 to iStart -1 do begin lsl_List.AddObject(Self.Strings[i], Self.Objects[i]); end; for i := 0 to High(l_Index) do begin //並べ替えられたインデックスを基にバッファへリストを書き出す lsl_List.AddObject(Self.Strings[l_Index[i]], Self.Objects[l_Index[i]]); end; //iEndからをコピー for i := iEnd +1 to GetCount -1 do begin lsl_List.AddObject(Self.Strings[i], Self.Objects[i]); end; //バッファに書き出した整列済みのリストを書き戻す Self.Assign(lsl_List); } for i := 0 to High(l_Index) do begin //並べ替えられたインデックスを基にバッファへリストを書き出す lsl_List.AddObject(Self.Strings[l_Index[i]], Self.Objects[l_Index[i]]); end; //バッファに書き出した整列済みのリストを書き戻す for i := 0 to High(l_Index) do begin Self.Strings[i + iStart] := lsl_List.Strings[i]; Self.Objects[i + iStart] := lsl_List.Objects[i]; end; finally lsl_List.Free; end; end; procedure TMyWStrings.MergeSort(iStart, iEnd : Integer); begin MergeSort(iStart, iEnd, lfni_SortFunc); end; procedure TMyWStrings.MergeSort(fniCompare: TMyWStringsSortCompare); //インデックスの配列を使った更にもうちょっとだけ速いマージソート { procedure lpc_MergeSort(AList: TMyWStrings; var Index: array of Integer; fniCompare: TMyWStringsSortCompare); //http://www.ics.kagoshima-u.ac.jp/~fuchida/edu/algorithm/sort-algorithm/merge-sort.html var i, k: Integer; li_Count, li_Count1, li_Count2: Integer; l_Index1, l_Index2: array of Integer; begin li_Count := Length(Index); if (li_Count > 1) then begin li_Count1 := li_Count div 2; li_Count2 := li_Count - li_Count1; SetLength(l_Index1, li_Count1); //前半のインデックス SetLength(l_Index2, li_Count2); //後半のインデックス for i := 0 to li_Count1-1 do begin //前半のインデックスをコピー l_Index1[i] := Index[i]; end; for i := 0 to li_Count2-1 do begin //後半のインデックスをコピー l_Index2[i] := Index[li_Count1+i]; end; lpc_MergeSort(AList, l_Index1, fniCompare); //この中で順番が変わっている lpc_MergeSort(AList, l_Index2, fniCompare); //この中で順番が変わっている i := 0; k := 0; while (i < li_Count1) or (k < li_Count2) do begin if (i >= li_Count1) or ((k < li_Count2) and (fniCompare(AList, l_Index1[i], l_Index2[k]) > 0)) then begin Index[i+k] := l_Index2[k]; Inc(k); end else begin Index[i+k] := l_Index1[i]; Inc(i); end; end; end; end; var i : Integer; l_Index : array of Integer; lsl_List : TMyWStrings; } begin MergeSort(0, GetCount-1, fniCompare); { Exit; SetLength(l_Index, Self.GetCount); for i := 0 to High(l_Index) do begin l_Index[i] := i; end; //この中で並べ替えられるのはリスト本体ではなくインデックスのリスト(l_Index)の方 lpc_MergeSort(Self, l_Index, fniCompare); lsl_List := TMyWStrings.Create; try for i := 0 to High(l_Index) do begin //並べ替えられたインデックスを基にバッファへリストを書き出す lsl_List.AddObject(Self.Strings[l_Index[i]], Self.Objects[l_Index[i]]); end; //バッファに書き出した整列済みのリストを書き戻す Self.Assign(lsl_List); finally lsl_List.Free; end; } end; procedure TMyWStrings.MergeSort; begin MergeSort(0, GetCount-1, lfni_SortFunc); end; //挿入ソート procedure TMyWStrings.InsertionSort(const bUnique: Boolean); begin InsertionSort(lfni_SortFunc, bUnique); end; procedure TMyWStrings.InsertionSort(fniCompare: TMyWStringsSortCompare); {2008-06-01: } begin // InsertionSort(fniCompare, (Sorted and (Duplicates = dupIgnore)); InsertionSort(fniCompare, False); end; procedure TMyWStrings.InsertionSort(fniCompare: TMyWStringsSortCompare; const bUnique: Boolean); {2008-02-12,06-01: 挿入ソート http://ja.wikipedia.org/wiki/挿入ソート bUniqueがTrueなら同じデータを許可しない（重複行は削除） 以外に速い… ほぼ整列されているリストならクイックソートより速い 2008-06-01:TMyWStrings用に一部書き換え } var i, k, li_Comp: Integer; begin //一個っきゃデータがない時はソートする必要はないので2以上 if (FList.Count >= 2) then begin FList.BeginUpdate; try i := 1; repeat for k := i downto 1 do begin //前の行と比べている li_Comp := fniCompare(Self, k-1, k); if (li_Comp < 0) then begin //前の方が小さい→ループを一段抜ける Break; end else if (li_Comp > 0) then begin //前の方が大きい→入れ替え Exchange(k-1, k); end else if (bUnique) then begin //同じ→同じデータを許さないなら削除 Delete(k); Dec(i); Break; end; Application.ProcessMessages; end; Inc(i); until (i > FList.Count-1); finally FList.EndUpdate; end; end; end; function _fniSortFuncFileList(slList: TMyWStrings; iIndex1, iIndex2: Integer): Integer; {2007-09-18: CustomSort用下請け関数 http://www.geocities.jp/fjtkt/program/2004_0001.html ファイルのリストを取得してTStringListのSortを行うとファイルとサブフォルダが混在し てしまうのでサブディレクトリは後ろにまとめてソートしたい場合にこの関数をCustomSort に渡して使う 例) //------------- Stay In Loveサブディレクトリがファイルの途中にきてしまう e:\mp3\MySharona.mp3 e:\mp3\StayInLove\CouldItBeI'mInLove.mp3 e:\mp3\TakeAChanceOnMe.mp3 ↓ e:\mp3\MySharona.mp3 e:\mp3\TakeAChanceOnMe.mp3 e:\mp3\StayInLove\CouldItBeI'mInLove.mp3 //------------- サブディレクトリを頭にもっていくのは面倒なので後ろへ } begin Result := gfniCompareFileName(slList[iIndex1], slList[iIndex2]); end; procedure TMyWStrings.FileSort; begin // FileSort(Sorted and (Duplicates = dupIgnore)); FileSort(False); end; procedure TMyWStrings.FileSort(bUnique: Boolean); //重複削除オプションあり begin MergeSort(_fniSortFuncFileList, True); // QuickSort(_fniSortFuncFileList); // if (bUnique) then begin // SortDupDelete; // end; end; procedure TMyWStrings.FileSort(iStart, iEnd : Integer); begin MergeSort(iStart, iEnd, _fniSortFuncFileList); end; procedure TMyWStrings.FileInsertionSort; //挿入ソート begin InsertionSort(_fniSortFuncFileList, False); end; procedure TMyWStrings.FileInsertionSort(bUnique: Boolean); //挿入ソート・重複削除オプションあり begin InsertionSort(_fniSortFuncFileList, bUnique); end; procedure TMyWStrings.FSetSorted(bValue: Boolean); begin FbSorted := bValue; if (FbSorted) then begin MergeSort; if (Duplicates <> dupAccept) then begin //重複行を許可しないならば重複を削除 SortDupDelete; end; end; end; //LoadFromFile SaveToFile ------------------------------------------------------ procedure TMyWStrings.LoadFromFile(sFile: String); {2008-06-01: } begin // F_cdCharCode := cdAuto; LoadFromFile(sFile, FcdCharCode); end; procedure TMyWStrings.LoadFromFile(sFile: String; var cdCode: TMyCharCode); var ls_Text: String; begin ls_Text := gfnsFileReadText(sFile, cdCode); SetTextStr(ls_Text); end; procedure TMyWStrings.LoadFromFile(sFile: String; var cdCode: TMyCharCode; iByte: DWORD); begin SetTextStr(gfnsFileReadText(sFile, cdCode, iByte)); end; function TMyWStrings.SaveToFile(sFile: String): Boolean; //デフォルトはUnicode文字があればUTF-8、なければShift_JIS begin // SaveToFile(sFile, cdAuto); Result := SaveToFile(sFile, FcdCharCode); end; function TMyWStrings.SaveToFile(sFile: String; cdCode: TMyCharCode; nlNewLine: TMyNewLine): Boolean; begin FnlNewLine := nlNewLine; Result := SaveToFile(sFile, cdCode); end; function TMyWStrings.SaveToFile(sFile: String; cdCode: TMyCharCode): Boolean; begin Result := gfnbFileWriteText(sFile, GetTextStr, cdCode); end; procedure TMyWStrings.BeginUpdate; begin FList.BeginUpdate; end; procedure TMyWStrings.EndUpdate; begin FList.EndUpdate; end; end.