Measure/Units/UtilMethods.pas

unit UtilMethods;

interface

uses
  Controls, ZhAPI, ActnList, ZjIDTree, DB, ZjGridDBA, ZjGrid, Windows, Messages,
  sdDB, VCLZip, VCLUnZip, Dialogs, Forms, ShlObj, Classes, StrUtils, Math, ADODB,
  IdGlobal;

type 
  TRoundMode = (rmNearest, rmUp, rmDown);
  TBookmarkRefreshEvent = procedure (AExpandFrame: Boolean) of object;

  {RoundTo}
  function QuantityRoundTo(AValue: Double): Double;
  function PriceRoundTo(AValue: Double): Double;
  function TotalPriceRoundTo(AValue: Double): Double;
  function CommonRoundTo(AValue: Double; ADigit: Integer; RoundMode: TRoundMode = rmNearest): Double;

  {Interface Control}
  procedure AlignControl(AControl, AParent: TWinControl; AAlign: TAlign);
  procedure SetDxBtnAction(AAction: TAction; ADxBtn: TObject);

  {DataBase Rela}
  function GetsdDataSetNewID(ADataSet: TsdDataSet; const AIndex: string): Integer;
  procedure ExecuteSql(AConnection: TADOConnection; const ASql: string);
  function QueryData(AConnection: TADOConnection; const ASql: string): TADOQuery;

  {Message}
  procedure WarningMessage(const AMsg: string; AHandle: THandle = 0);
  procedure ErrorMessage(const AMsg: string; AHandle: THandle = 0);
  function QuestMessage(const AMsg: string; AHandle: THandle = 0): Boolean;
  function QuestMessageYesNo(const AMsg: string; AHandle: THandle = 0): Boolean;
  procedure TipMessage(const AMsg: string; AHandle: THandle = 0);
  procedure DataSetErrorMessage(var Allow: Boolean; const AMsg: string);

  {Get Common Path}
  function GetAppFilePath: string;
  function GetMyProjectsFilePath: string;
  function GetEmptyDataBaseFileName: string;
  function GetTemplateBillsFileName: string;
  function GetTemplateXlsFileName: string;
  function GetBackupFilePath: string;
  function GetReportTemplatePath: string;

  {Select & Save File Choose}
  function GetFilter(AExt: string): string;
  function SelectFile(var AFileName: string; const AExt: string): Boolean;
  function SelectFiles(AFiles: TStrings; const AExt: string): Boolean;
  function SaveFile(var FileName: string; const AExt: string): Boolean;
  function SelectOutputDirectory(const ATitle: string; var ADirectory: string;
    AParentHandle: THandle = 0; AHasNewFolderBtn: Boolean = True): Boolean;
  function FixPathByAppPath(AFileName: string): string;
  function BrowseFolder(var APath: string; const ATitle: string;
    AParentHandle: THandle; AHasNewFolderBtn: Boolean = True): Boolean;

  {CheckStrings}
  function CheckPeg(const AStr: string): Boolean;
  function CheckValidPassword(APassword: string): Boolean;
  function ValidInteger(var AKey: Char): Boolean;

  {MergeStrings}
  function MergeRelaBGL(const ABGLCode1, ABGLCode2: string): string;
  procedure MergeRelaBGLAndNum(var ABGLCode1, ABGLNum1: string; const ABGLCode2, ABGLNum2: string);

  {CodeTransform}
  function B_CodeToIndexCode(const AB_Code: string): string;
  function ChinessNum(const ADigitNum: Integer): string;
  function Num2Peg(ANum: Double): string;

  {Compare Code}
  //function CompareCodeWithChar(const ACode1, ACode2: string): Integer;

  {Tree Relative}
  function CreateTree: TZjIDTree;
  procedure DisConnectTree(ATree: TZjIDTree);
  procedure ConnectTree(ATree: TZjIDTree; ADataset: TDataSet);
  procedure InitGridHead(AGridDBA: TZjGridDBA; AGrid: TZJGrid);

  {Generate Name/Directory/Path}
  function GetTempFileDir: string;
  function GetTempFilePath: string;
  function GetTempName(ALength: Integer = 8): string;
  function GetTempFileName: string;
  function GenerateTempFolder(AGeneratePath: string): string;
  function GetNewGUIDFileName(const AGeneratePath: string): string;

  {Progress bar Control}
  procedure UpdateSysProgress(APosition: Integer; const AHint: string);
  procedure UpdateProgress(APosition: Integer; const AHint: string);
  procedure DisableSysProgress;
  procedure EnableSysProgress;

  {Interface RePaint Control}
  procedure BeginUpdateWindow(AHandle: THandle);
  procedure EndUpdateWindow(AHandle: THandle);

  {Zip}
  procedure ZipFolder(AFileFolder, AFileName: string);
  function UnZipFile(AFileName, AFileFolder: string): Boolean;

  {Copy By Stream}
  procedure CopyFileByStream(const ASourceFile, ADestFile: string);

  // Add by chenshilong, 2014-04-11
  function GetVersion(APartCount: Integer = 4): string;
  function ExtractFileNameWithoutExt(const AFileName: string): string;
  function ShortText(AText: string; AWidth: Integer): string;                     // 文本缩略显示
  function CustomWidthText(AText: string; AWidth: Integer): string;
  function ReplaceCharsForJson(AText: string): string;                                  // 替换Json文本中的特殊字符
  function RecoverCharsFromJson(AText: string): string;                             // 下载得到的Json文本恢复成用户需要的文本
  procedure FindFiles(APath, AExtName: string; AFileList: TStrings);
  function DeleteFolder(const FolderStr: string): Boolean;
  function HasExt(const AFileName: string): Boolean;
  function CopyFolder(const SrcFolder, DstFolder: string): Boolean;
  function FileCount(APath: string): Integer;

implementation

uses
  SysUtils, dxBar, MainFrm, ConstUnit, Globals, StdCtrls, ShellAPI;

var
  SysProgressDisabled: Boolean;

{RoundTo}
function InnerRoundTo(const AValue: Extended; const ADigit: Integer; RoundMode: TRoundMode): Extended;
var
  LFactor, Offset: Extended;
  HFactor: Integer;
begin
  LFactor := IntPower(10, ADigit);
  HFactor := Trunc(IntPower(10, abs(ADigit)));
  Result := AValue;
  case RoundMode of
    rmNearest:
    begin
      if AValue >= 0 then
        Offset := 0.5
      else
        Offset := -0.5;
      Result := Trunc((AValue * HFactor) + Offset) * LFactor;
    end;
    rmUP:
    begin
      if Frac(AValue / LFactor) > 0 then
        Result := Trunc(AValue * HFactor + 1) * LFactor
      else
        Result := Trunc(AValue * HFactor) * LFactor;
    end;
    rmDown:
    begin
      Result := Trunc(AValue * HFactor) * LFactor;
    end;
  end;
end;

function QuantityRoundTo(AValue: Double): Double;
begin
  if Assigned(OpenProjectManager.CurProjectData) then
    Result := CommonRoundTo(AValue, -OpenProjectManager.CurProjectData.ProjProperties.QuantityDigit)
  else
    Result := CommonRoundTo(AValue, iQuantityDigit);
end;

function PriceRoundTo(AValue: Double): Double;
begin
  if Assigned(OpenProjectManager.CurProjectData) then
    Result := CommonRoundTo(AValue, -OpenProjectManager.CurProjectData.ProjProperties.PriceDigit)
  else
    Result := CommonRoundTo(AValue, iPriceDigit);
end;

function TotalPriceRoundTo(AValue: Double): Double;
begin
  if Assigned(OpenProjectManager.CurProjectData) then
    Result := CommonRoundTo(AValue, -OpenProjectManager.CurProjectData.ProjProperties.TotalPriceDigit)
  else
    Result := CommonRoundTo(AValue, iTotalPriceDigit);
end;

function CommonRoundTo(AValue: Double; ADigit: Integer; RoundMode: TRoundMode = rmNearest): Double;
var
  X: Double;
  P: Pointer;
  I: Integer;
  Buf: array [0..7] of Byte;
begin
  P := @AValue;
  CopyMemory(@Buf[0], P, SizeOf(AValue));
  // 进位处理，从后往前，如果当前byte为$FF，则往前一byte进1
  // 注意到尾数开始的位置停止
  // 这里说的前后是二进制串，实际存储前后相反
  for I := 0 to 6 do
    if (I < 6) and (Buf[I] = $FF) then
      Buf[I] := 0
    else
    begin
      Buf[I] := Buf[I] + 1;
      Break;
    end;
  P := @X;
  CopyMemory(P, @Buf[0], SizeOf(X));
  Result := InnerRoundTo(X, ADigit, RoundMode);
end;

{Interface Control}
procedure AlignControl(AControl, AParent: TWinControl; AAlign: TAlign);
begin
  if Assigned(AControl) then
  begin
    if Assigned(AControl.Parent) then
      AControl.Parent.RemoveControl(AControl);
    AControl.Parent := AParent;
    AControl.Align := AAlign;
  end;
end;

procedure SetDxBtnAction(AAction: TAction; ADxBtn: TObject);
begin
  if Assigned(ADxBtn) then
    if ADxBtn is TdxBarButton then
      TdxBarButton(ADxBtn).Action := AAction;
end;

{DataBase Rela}
function GetsdDataSetNewID(ADataSet: TsdDataSet; const AIndex: string): Integer;
var
  idx: TsdIndex;
begin
  idx := ADataSet.FindIndex(AIndex);
  if idx.RecordCount > 0 then
    Result := idx.Records[idx.RecordCount - 1].ValueByName('ID').AsInteger + 1
  else
    Result := 1;
end;

procedure ExecuteSql(AConnection: TADOConnection; const ASql: string);
var
  vQuery: TADOQuery;
begin
  vQuery := TADOQuery.Create(nil);
  try
    vQuery.Connection := AConnection;
    vQuery.SQL.Add(ASql);
    vQuery.ExecSQL;
  finally
    vQuery.Free;
  end;
end;

function QueryData(AConnection: TADOConnection; const ASql: string): TADOQuery;
begin
  Result := TADOQuery.Create(nil);
  Result.Connection := AConnection;
  Result.SQL.Clear;
  Result.SQL.Add(ASql);
  Result.Open;
end;

{Message}

function GetValidHandle(AHandle: THandle = 0): THandle;
begin
  if AHandle = 0 then
  begin
    if (Screen.ActiveForm <> nil) and (Screen.ActiveForm.HandleAllocated) then
      Result := Screen.ActiveForm.Handle
    else
      Result := Application.Handle;
  end
  else
    Result := AHandle;
end;

procedure WarningMessage(const AMsg: string; AHandle: THandle = 0);
begin
  MessageBox(GetValidHandle(AHandle), PChar(AMsg), PChar('警告'), MB_OK or MB_ICONWARNING);
end;

procedure ErrorMessage(const AMsg: string; AHandle: THandle = 0);
begin
  MessageBox(GetValidHandle(AHandle), PChar(AMsg), PChar('错误'), MB_OK or MB_ICONERROR);
end;

function QuestMessage(const AMsg: string; AHandle: THandle = 0): Boolean;
begin
  Result := MessageBox(GetValidHandle(AHandle), PChar(AMsg), PChar('询问'), MB_OKCANCEL or MB_ICONQUESTION) = IDOK;
end;

function QuestMessageYesNo(const AMsg: string; AHandle: THandle = 0): Boolean;
begin
  Result := MessageBox(GetValidHandle(AHandle), PChar(AMsg), PChar('询问'), MB_YESNO or MB_ICONQUESTION) = IDYes;
end;

procedure TipMessage(const AMsg: string; AHandle: THandle = 0);
begin
  MessageBox(GetValidHandle(AHandle), PChar(AMsg), PChar('提示'), MB_OK or MB_ICONINFORMATION);
end;

procedure DataSetErrorMessage(var Allow: Boolean; const AMsg: string);
begin
  Allow := False;
  ErrorMessage(AMsg);
end;

{Get Common Path}
function GetAppFilePath: string;
begin
  Result := ExtractFilePath(ParamStr(0));
end;

function GetMyProjectsFilePath: string;
begin
  Result := GetAppFilePath + '我的项目\';
end;

function GetEmptyDataBaseFileName: string;
begin
  Result := GetAppFilePath + 'Data\Base.dat';
end;

function GetTemplateBillsFileName: string;
begin
  Result := GetAppFilePath + 'Data\Template.xls';
end;

function GetTemplateXlsFileName: string;
begin
  Result := GetAppFilePath + 'Data\Basic.xls';
end;

function GetBackupFilePath: string;
begin
  Result := GetAppFilePath + 'TenderBackup\';
end;

function GetReportTemplatePath: string;
begin
  Result := GetAppFilePath + 'ReportTemplates\';
end;

{Select & Save File Choose}

function GetFilter(AExt: string): string;
begin
  if AExt = '' then
    Result := '所有文件(*.*)|*.*'
  else
  begin
    if AExt[1] <> '.' then
      AExt := '.' + AExt;
    Result := Format('(*%s)|*%s', [AExt, AExt]);
  end;
end;

function SelectFile(var AFileName: string; const AExt: string): Boolean;
var
  odFile: TOpenDialog;
begin
  odFile := TOpenDialog.Create(nil);
  try
    odFile.Filter := GetFilter(AExt);
    if odFile.Execute then
    begin
      Application.ProcessMessages;
      AFileName := odFile.FileName;
      Result := True;
    end
    else
      Result := False;
  finally
    odFile.Free;
  end;
end;

function SelectFiles(AFiles: TStrings; const AExt: string): Boolean;
var
  odFile: TOpenDialog;
begin
  odFile := TOpenDialog.Create(nil);
  try
    odFile.Options := odFile.Options + [ofAllowMultiSelect];
    odFile.Filter := GetFilter(AExt);
    if odFile.Execute then
    begin
      Application.ProcessMessages;
      AFiles.Assign(odFile.Files);
      Result := True;
    end
    else
      Result := False;
  finally
    odFile.Free;
  end;
end;

function SaveFile(var FileName: string; const AExt: string): Boolean;
var
  sdFile: TSaveDialog;
begin
  sdFile := TSaveDialog.Create(nil);
  try
    sdFile.FileName := FileName;
    sdFile.DefaultExt := AExt;
    sdFile.Filter := GetFilter(AExt);
    Result := sdFile.Execute;
    if Result then
      FileName := sdFile.FileName;
    Application.ProcessMessages;
  finally
    sdFile.Free;
  end;
end;

function SelectOutputDirectory(const ATitle: string; var ADirectory: string;
  AParentHandle: THandle; AHasNewFolderBtn: Boolean): Boolean;
var
  pID: PItemIDList;
  bInfo: TBrowseInfo;
  AHandle: THandle;
  PStr: array[0..1023] of Char;
  sPath: string;

  function BFCallBack(Hwnd: HWND; uMsg: UINT; lParam, lpData: LPARAM): Integer; stdcall;
  begin
    if uMsg = BFFM_INITIALIZED then
    begin
      SendMessage(Hwnd, BFFM_SETSELECTION, 1, lpData);
    end;
    Result := 0;
  end;

begin
  Result := False;
  if AParentHandle = 0 then
    AHandle := Screen.ActiveForm.Handle
  else
    AHandle := AParentHandle;
  if ADirectory = '' then
    sPath := GetAppFilePath
  else
    sPath := ADirectory;

  with bInfo do
  begin
    hwndOwner := AParentHandle;
    iImage := 0;
    lParam := Integer(PChar(sPath));
    lpszTitle := PChar(ATitle);
    pidlRoot := nil;
    pszDisplayName := nil;
    if AHasNewFolderBtn then
      ulFlags := BIF_RETURNONLYFSDIRS or BIF_USENEWUI
    else
      ulFlags := BIF_RETURNONLYFSDIRS;
    lpfn := @BFCallBack;
  end;
  pID := SHBrowseForFolder(bInfo);

  if pID <> nil then
  begin
    SHGetPathFromIDList(pID, PStr);
    ADirectory := StrPas(PStr);
    if (ADirectory <> '') and (ADirectory[Length(ADirectory)] <> '\') then
      ADirectory := ADirectory + '\';
    Result := True;
  end;
end;

function FixPathByAppPath(AFileName: string): string;
begin
  Result := AFileName;
  if AnsiPos(':\', Result) = 0 then
  begin
    if (Result <> '') and (Result[1] = '\') then
      Delete(Result, 1, 1);
    Result := ExtractFilePath(Application.ExeName) + Result;
  end;
end;

var
  PathStr: string;

function BrowseFolder(var APath: string; const ATitle: string; AParentHandle: THandle;
    AHasNewFolderBtn: Boolean): Boolean;

  function BFCallBackFunc(hwnd: HWND; uMsg: UINT; lParam: LPARAM; lpData: LPARAM): Integer; stdcall;
  begin
    Result := 0;

    case uMsg of
      BFFM_INITIALIZED :  // 初始化设置目录。
        begin
          SendMessage(Hwnd,BFFM_SETSELECTION,-1,Integer(PathStr));
        end;
    end;
  end;

var
  pID: PItemIDList;
  bInfo: TBrowseInfo;
  PStr: array[0..1023] of Char;
  sPath: string;
  Hdl: THandle;
begin
  Result := False;
  PathStr := '';
  if AParentHandle = 0 then
    Hdl := Screen.ActiveForm.Handle
  else
    Hdl := AParentHandle;
  sPath := FixPathByAppPath(APath);
  if DirectoryExists(sPath) then
    PathStr := sPath;
  bInfo.hwndOwner := Hdl;
  bInfo.iImage := 0;
  bInfo.lParam := 0;
  bInfo.lpszTitle := PChar(ATitle);
  bInfo.pidlRoot := nil;
  bInfo.pszDisplayName := nil;
  if (not AHasNewFolderBtn) then
    bInfo.ulFlags := BIF_RETURNONLYFSDIRS
  else
    bInfo.ulFlags := BIF_RETURNONLYFSDIRS or BIF_USENEWUI;
  bInfo.lpfn := @BFCallBackFunc;
  pID := SHBrowseForFolder(bInfo);

  if pID <> nil then
  begin
    SHGetPathFromIDList(pID,pStr);
    APath := StrPas(pStr);
    if (APath <> '') and (APath[Length(APath)] <> '\') then
      APath := APath + '\';
    Result := True;
  end;
end;

{CheckStrings}
function CheckPeg(const AStr: string): Boolean;

  function GetPosition(const AName, AStr, AStrSpare: string): Integer;
  begin
    Result := Pos(AStr, AName);
    if Result = 0 then
      Result := Pos(AStrSpare, AName);
  end;

var
  iPosK, iPosPlus: Integer;
  fNum: Double;
begin
  Result := False;
  iPosK := GetPosition(AStr, 'K', 'k');
  iPosPlus := GetPosition(AStr, '+', '＋');
  if (iPosK = 0) or (iPosPlus = 0) or (iPosPlus < iPosK) then Exit;
  Result := TryStrToFloat(Copy(AStr, iPosK + 1, iPosPlus - iPosK - 1), fNum);
end;

function CheckValidPassword(APassword: string): Boolean;
var
  iIndex, iLength: Integer;
begin
  Result := True;
  if APassword = '' then Exit;
  iIndex := 1;
  iLength := Length(APassword);
  Result := (iLength >= 6) and (iLength <= 16);
  while Result and (iIndex < iLength) do
  begin
    Result := APassword[iIndex] in ['A'..'Z', 'a'..'z', '0'..'9'];
    Inc(iIndex);
  end;
end;

function ValidInteger(var AKey: Char): Boolean;
begin
  if AKey in ['+', '-', '0'..'9', #8, #13, #35, #36,
      #37, #38, #39, #40, #46] then
  begin
    Result := True;
  end
  else
  begin
    AKey := #0;
    Result := False;
  end;
end;

{MergeStrings}
function MergeRelaBGL(const ABGLCode1, ABGLCode2: string): string;
var
  sgs1, sgs2: TStrings;
  i1, i2: Integer;
  bExist: Boolean;
begin
  Result := ABGLCode1;
  sgs1 := TStringList.Create;
  sgs2 := TStringList.Create;
  try
    sgs1.Delimiter := ';';
    sgs2.Delimiter := ';';
    sgs1.DelimitedText := ABGLCode1;
    sgs2.DelimitedText := ABGLCode2;
    for i2 := 0 to sgs2.Count - 1 do
    begin
      bExist := False;
      for i1 := 0 to sgs1.Count - 1 do
        if SameText(sgs2[i2], sgs1[i1]) then
        begin
          bExist := True;
          Break;
        end;
      if not bExist then
        sgs1.Add(sgs2[i2]);
    end;
    Result := sgs1.DelimitedText;
  finally
    sgs1.Free;
    sgs2.Free;
  end;
end;

procedure MergeRelaBGLAndNum(var ABGLCode1, ABGLNum1: string; const ABGLCode2, ABGLNum2: string);
var
  sgsC1, sgsC2, sgsN1, sgsN2: TStrings;
  i1, i2: Integer;
  bExist: Boolean;
begin
  sgsC1 := TStringList.Create;
  sgsC2 := TStringList.Create;
  sgsN1 := TStringList.Create;
  sgsN2 := TStringList.Create;
  try
    sgsC1.Delimiter := ';';
    sgsC2.Delimiter := ';';
    sgsC1.DelimitedText := ABGLCode1;
    sgsC2.DelimitedText := ABGLCode2;
    sgsN1.Delimiter := ';';
    sgsN2.Delimiter := ';';
    sgsN1.DelimitedText := ABGLNum1;
    sgsN2.DelimitedText := ABGLNum2;
    for i2 := 0 to sgsC2.Count - 1 do
    begin
      bExist := False;
      for i1 := 0 to sgsC1.Count - 1 do
        if SameText(sgsC2[i2], sgsC1[i1]) then
        begin
          bExist := True;
          Break;
        end;
      if bExist then
      begin
        sgsN1[i1] := FloatToStr(StrToFloatDef(sgsN1[i1], 0) + StrToFloatDef(sgsN2[i2], 0))
      end
      else
      begin
        sgsC1.Add(sgsC2[i2]);
        sgsN1.Add(sgsN2[i2]);
      end;
    end;
    ABGLCode1 := sgsC1.DelimitedText;
    ABGLNum1 := sgsN1.DelimitedText;
  finally
    sgsC1.Free;
    sgsC2.Free;
    sgsN1.Free;
    sgsN2.Free;
  end;
end;

function B_CodeToIndexCode(const AB_Code: string): string;
var
  sgs: TStrings;
  i, iNum, iError: Integer;
  sError: string;
begin
  sgs := TStringList.Create;
  try
    Result := '';
    sgs.Delimiter := '-';
    sgs.DelimitedText := AB_Code;
    for i := 0 to sgs.Count - 1 do
    begin
      Val(sgs[i], iNum, iError);
      if iError = 0 then
        sError := ''
      else
        sError := Copy(sgs[i], iError, Length(sgs[i])-iError+1);
      if iError = 0 then
        Result := Result + Format('%4d', [iNum]) + Format('%-4s', [sError])
      else if iNum = 0 then
        Result := Result + '9999' + Format('%-4s', [sError])
      else
        Result := Result + Format('%4d', [iNum]) + Format('%-4s', [sError]);
    end;
  finally
    sgs.Free;
  end;
end;

function ChinessNum(const ADigitNum: Integer): string;

  function TransChineseNum(const ANum, AZeroNum: Integer): string;
  begin
    Result := '';
    case ANum of
      1: if AZeroNum <> 1 then Result := '一';
      2: Result := '二';
      3: Result := '三';
      4: Result := '四';
      5: Result := '五';
      6: Result := '六';
      7: Result := '七';
      8: Result := '八';
      9: Result := '九';
    end;
    if (Result = '') and ((AZeroNum <> 1) or (ANum = 0)) then Exit;
    case AZeroNum of
      0: Result := Result;
      1: Result := Result + '十';
      2: Result := Result + '百';
      3: Result := Result + '千';
      4: Result := Result + '万';
    end;
  end;

var
  iBai, iShi, iGe: Integer;
begin
  Result := '';
  if (ADigitNum < 0) and (ADigitNum > 10000) then Exit;
  iBai := ADigitNum div 100;
  iShi := (ADigitNum mod 100) div 10;
  iGe := (ADigitNum mod 100) mod 10;
  Result := TransChineseNum(iBai, 2) + TransChineseNum(iShi, 1) + TransChineseNum(iGe, 0);
end;

function CheckDigit(ANum: Double): Integer;
begin
  if abs(ANum - advRoundTo(ANum, -2)) > 0.0001 then
    Result := 3
  else if abs(ANum - advRoundTo(ANum, -1)) > 0.001 then
    Result := 2
  else if abs(ANum - AdvRoundTo(ANum, 0)) > 0.01 then
    Result := 1
  else
    Result := 0; 
end;

function Num2Peg(ANum: Double): string;
var
  fMod: Double;
  iK, iDigit: Integer;
  sDigit: string;
begin
  iK := Trunc(ANum/1000);
  fMod := Frac(ANum/1000)*1000;
  iDigit := CheckDigit(fMod);
  case iDigit of
    3: sDigit := FormatFloat('000.000', AdvRoundTo(fMod, -3));
    2: sDigit := FormatFloat('000.00', AdvRoundTo(fMod, -2));
    1: sDigit := FormatFloat('000.0', AdvRoundTo(fMod, -1));
    0: sDigit := FormatFloat('000', Trunc(AdvRoundTo(fMod, 0)));
  end;
{  case iDigit of
    3: Result := Format('K%d+%3.3f', [iK, ]);
    2: Result := Format('K%d+%3.2f', [iK, AdvRoundTo(fMod, -2)]);
    1: Result := Format('K%d+%3.1f', [iK, AdvRoundTo(fMod, -1)]);
    0: Result := Format('K%d+%s', [iK, FormatFloat('000', [])]);
  end;                                                          }
  Result := Format('K%d+%s', [iK, sDigit]);
end;

{Tree Relative}

function CreateTree: TZjIDTree;
begin
  Result := TZjIDTree.Create;
  Result.KeyFieldName := 'ID';
  Result.ParentFieldName := 'ParentID';
  Result.NextSiblingFieldName := 'NextSiblingID';
  Result.AutoCreateKeyID := True;
  Result.AutoExpand := True;
end;

procedure DisConnectTree(ATree: TZjIDTree);
begin
  ATree.DataSet := nil;
  ATree.Active := False;
end;

procedure ConnectTree(ATree: TZjIDTree; ADataset: TDataSet);
begin
  ATree.DataSet := ADataset;
  ATree.Active := True;
end;

procedure InitGridHead(AGridDBA: TZjGridDBA; AGrid: TZJGrid);
var
  I: Integer;
begin
  for I := 0 to AGridDBA.Columns.Count - 1 do
    AGrid.Cells[I + 1, 0].Text := AGridDBA.Columns[I].Title.Caption;
end;

{Generate Name/Path}
function GetTempFileDir: string;
var
  TempPath: string;
begin
  TempPath := GetEnvironmentVariable('TMP');
  if TempPath = '' then
    TempPath := GetEnvironmentVariable('TEMP');
  if TempPath = '' then
  begin
    if not DirectoryExists(ExtractFileDir(ParamStr(0)) + '\Temp') then
      CreateDir(ExtractFileDir(ParamStr(0)) + '\Temp');
    TempPath := ExtractFileDir(ParamStr(0)) + '\Temp';
  end;
  Result := TempPath;
end;

function GetTempFilePath: string;
begin
  Result := GetTempFileDir + '\';
end;

function GetTempName(ALength: Integer): string;
const
  CodedBuf: array[0..35] of Char = ('0', '1', '2', '3', '4', '5',
  '6', '7', '8', '9', 'A', 'B', 'C', 'D', 'E', 'F', 'G', 'H', 'I',
  'J', 'K', 'L', 'M', 'N', 'O', 'P', 'Q', 'R', 'S', 'T', 'U', 'V',
  'W', 'X', 'Y', 'Z');
var
  Temp: string;
  Num: Integer;
begin
  Randomize;
  Temp := '';
  while Length(Temp) < ALength do
  begin
    Num := Random(37);
    If Num <> 36 Then
      Temp := Temp + CodedBuf[Num];  // 0..35
  end;
  Result := Temp;
end;

function GetTempFileName: string;
var
  TempExt: string;
begin
  Result := GetTempFilePath + GetTempName;
  TempExt := '.' + GetTempName(3);
  while SameText(TempExt, '.mdb') or SameText(TempExt, '.db') or
      SameText(TempExt, '.ldb') do
    TempExt := '.' + GetTempName(3);
  Result := Result + TempExt;

  while FileExists(Result) do
  begin
    Result := GetTempFilePath + GetTempName;
    TempExt := '.' + GetTempName(3);
    while SameText(TempExt, '.mdb') or SameText(TempExt, '.db') or
        SameText(TempExt, '.ldb') do
      TempExt := '.' + GetTempName(3);
    Result := Result + TempExt;
  end;
end;

function GenerateTempFolder(AGeneratePath: string): string;
begin
  Result := AGeneratePath + GetTempName;
  while DirectoryExists(Result) do
    Result := AGeneratePath + GetTempName;
  CreateDirectoryInDeep(Result);
end;

function GetNewGUIDFileName(const AGeneratePath: string): string;
var
  gFile: TGUID;
begin
  repeat
    CreateGUID(gFile);
    Result := AGeneratePath + GUIDToString(gFile);
  until not FileExists(Result);
end;

{Progress bar Control}
procedure UpdateSysProgress(APosition: Integer; const AHint: string);
begin
  if not SysProgressDisabled then
    UpdateProgress(APosition, AHint);
end;

procedure UpdateProgress(APosition: Integer; const AHint: string);
begin
  MainForm.UpdateProgress(APosition, AHint);
end;

procedure DisableSysProgress;
begin
  SysProgressDisabled := True;
end;

procedure EnableSysProgress;
begin
  SysProgressDisabled := False;
end;

{Interface RePaint Control}

procedure BeginUpdateWindow(AHandle: THandle);
begin
  SendMessage(AHandle, WM_SETREDRAW, 0, 0);
end;

procedure EndUpdateWindow(AHandle: THandle);
begin
  SendMessage(AHandle, WM_SETREDRAW, 1, 0);
end;

{Zip}
function ZipComplete(const AFileName: string): Boolean;
var
  iSize1, iSize2: Integer;
begin
  iSize1 := FileSizeByName(AFileName);
  Sleep(200);
  iSize2 := FileSizeByName(AFileName);
  Result := iSize1 = iSize2;
end;

procedure ZipFolder(AFileFolder, AFileName: string);
var
  sTempFile: string;
  vZip: TVCLZip;
  iCount: Integer;
begin
  sTempFile := GetTempFileName;
  vZip := TVCLZip.Create(nil);
  iCount := 0;
  try
    vZip.FilesList.Clear;
    vZip.ZipName := sTempFile;
    vzip.RootDir := AFileFolder;
    vZip.OverwriteMode := Always;
    //vZip.AddDirEntriesOnRecurse:=True;
    vZip.RelativePaths := True;
    //vZip.RecreateDirs := True;
    vZip.FilesList.Add(AFileFolder + '\*.*');
    vZip.Zip;
    while not ZipComplete(sTempFile) and (iCount < 10) do
    begin
      Sleep(200);
      Inc(iCount);
    end;
    CopyFileOrFolder(sTempFile, AFileName);
  finally
    vZip.Free;
    if FileExists(sTempFile) then
      DeleteFile(sTempFile);
  end;
end;

function UnZipFile(AFileName, AFileFolder: string): Boolean;
var
  vUnZip: TVCLZip;
begin
  Result := True;
  vUnZip := TVCLZip.Create(nil);
  try
    vUnZip.FilesList.Clear;
    vUnZip.ZipName := AFileName;
    vUnZip.ReadZip;
    vUnZip.DestDir := AFileFolder;
    vUnZip.OverwriteMode := Always;
    vUnZip.RecreateDirs := True;
    vUnZip.RelativePaths := True;
    vUnZip.DoAll := True;
    vUnZip.FilesList.Add('*.*');
    try
      vUnZip.UnZip;
    except
      Result := False;
    end;
  finally
    vUnZip.Free;
  end;
end;

{Copy By Stream}
procedure CopyFileByStream(const ASourceFile, ADestFile: string);
var
  MS: TMemoryStream;
begin
  MS := TMemoryStream.Create;
  try
    MS.LoadFromFile(ASourceFile);
    if FileExists(ADestFile) then
      DeleteFile(ADestFile);
    MS.SaveToFile(ADestFile);
  finally
    MS.Free;
  end;
end;

function GetVersion(APartCount: Integer = 4): string;
var
  V1, V2, V3, V4: Word;
  FInfoSize, FF: Cardinal;
  FInfo: Pointer;
  FFixed: PVSFIXEDFILEINFO;
begin
  FInfoSize := GetFileVersionInfoSize(PChar(Application.ExeName), FF);
  FInfo := AllocMem(FInfoSize);
  try
    GetFileVersionInfo(PChar(Application.ExeName), FF, FInfoSize, FInfo);
    VerQueryValue(FInfo, '\', Pointer(FFixed), FInfoSize);
    V1 := FFixed.dwFileVersionMS shr 16;
    V2 := FFixed.dwFileVersionMS and $FFFF;
    V3 := FFixed.dwFileVersionLS shr 16;
    V4 := FFixed.dwFileVersionLS and $FFFF;
  finally
    Dispose(FInfo);
  end;
  Result := '';
  case APartCount of
    1:
      Result := Format('%d', [V1]);
    2:
      Result := Format('%d.%d', [V1, V2]);
    3:
      Result := Format('%d.%d.%d', [V1, V2, V3]);
    4:
      Result := Format('%d.%d.%d.%d', [V1, V2, V3, V4]);
  end;
end;


function ExtractFileNameWithoutExt(const AFileName: string): string;
var
  sFileName, Ext: string;
begin
  Result := '';
  if AFileName = '' then
    Exit;
  sFileName := AFileName;
  if sFileName[Length(sFileName)] = '\' then
    Delete(sFileName, Length(sFileName), 1);
  Result := ExtractFileName(sFileName);
  Ext := ExtractFileExt(sFileName);
  Delete(Result, Length(Result) - Length(Ext) + 1, Length(Ext));
end;

function ShortText(AText: string; AWidth: Integer): string;
var vMM: TMemo;
begin
  if Trim(AText) = '' then
  begin
    Result := '';
    Exit;
  end;

  vMM := TMemo.Create(nil);
  try
    vMM.Visible := False;
    vMM.WordWrap := True;
    vMM.parent := Application.MainForm;
    vMM.Width := AWidth - 10;   // 10像素留给3个小点
    vMM.Text := AText;
    if vMM.Lines.Count > 1 then
      Result := vMM.Lines[0] + '...'
    else
      Result := AText;
  finally
    vMM.Free;
  end;
end;

function CustomWidthText(AText: string; AWidth: Integer): string;
var vMM: TMemo;
  i: Integer;
begin
  if Trim(AText) = '' then
  begin
    Result := '';
    Exit;
  end;
  
  vMM := TMemo.Create(nil);
  try
    vMM.Visible := False;
    vMM.WordWrap := True;
    vMM.parent := Application.MainForm;
    vMM.Width := AWidth;
    vMM.Text := AText;

    for i := 0 to vMM.Lines.Count - 1 do
    begin
      if i = 0 then
        Result := vMM.Lines[i]
      else
        Result := Result + #10#13 + vMM.Lines[i];
    end;
  finally
    vMM.Free;
  end;
end;

function ReplaceCharsForJson(AText: string): string;
const
  BefChar: array [0..7] of Char = ('{', '}', ',', ':', '"', '[', ']', '%');
  AftChar: array [0..7] of string = ('｛', '｝', '，', '：', '＂', '【', '】', '♂');
var I: Integer;
begin
  AText := Trim(AText);
  Result := AText;

  if AText = '' then Exit;

  for I := low(BefChar) to High(BefChar) do
  begin
    if Pos(BefChar[I], AText) > 0 then
      AText := StringReplace(AText, BefChar[I], AftChar[I], [rfReplaceAll]);
  end;
  Result := AText;
end;

function RecoverCharsFromJson(AText: string): string;
const
  BefStr: array [0..3] of string = ('♂', '\r\n', '\r', '\n');
  AftStr: array [0..3] of string = ('%', '', '', '');
var I: Integer;
begin
  AText := Trim(AText);
  Result := AText;

  if AText = '' then Exit;

  for I := low(BefStr) to High(BefStr) do
  begin
    if Pos(BefStr[I], AText) > 0 then
      AText := StringReplace(AText, BefStr[I], AftStr[I], [rfReplaceAll]);
  end;
  Result := AText;
end;


procedure FindFiles(APath, AExtName: string; AFileList: TStrings);
var
  SRec: TSearchRec;
  retval: Integer; 
begin 
  AFileList.Clear; 
  retval := FindFirst(APath + AExtName, faAnyFile, sRec); 
  try 
    while retval = 0 do 
    begin 
      if (SRec.Attr and faDirectory) = 0 then 
        AFileList.Add(Srec.Name); 
      retval := FindNext(SRec); 
    end;
  finally 
    FindClose(SRec); 
  end; 
end;

function DeleteFolder(const FolderStr: string): Boolean;
var
  fos: SHFILEOPSTRUCT;
begin
  ZeroMemory(@fos, SizeOf(fos));
  fos.Wnd    := HWND_DESKTOP;
  fos.wFunc  := FO_DELETE;
  fos.fFlags := FOF_SILENT OR FOF_ALLOWUNDO OR FOF_NOCONFIRMATION;
  fos.pFrom  := PChar(FolderStr + #0);
  Result     := SHFileOperation(fos) <> 0;
end;

function HasExt(const AFileName: string): Boolean;
begin
  Result := ExtractFileExt(AFileName) <> '';
end;

function CopyFolder(const SrcFolder, DstFolder: string): Boolean;
var
  fos: SHFILEOPSTRUCT;
begin
  ZeroMemory(@fos, SizeOf(fos));
  fos.Wnd    := HWND_DESKTOP;
  fos.wFunc  := FO_COPY;
  fos.fFlags := FOF_SILENT OR FOF_ALLOWUNDO;  
  fos.pFrom  := PChar(SrcFolder + #0);
  fos.pTo    := PChar(DstFolder + #0);
  Result     := SHFileOperation(fos) <> 0;
end;

function FileCount(APath: string): Integer;
var
  vSR: TSearchRec;
  iRetval: Integer;
  vSL: TStringList;
begin
  vSL := TStringList.Create;
  iRetval := FindFirst(APath + '*.*', faAnyFile, vSR);
  try 
    while iRetval = 0 do
    begin
      if (vSR.Attr and faDirectory) = 0 then
        vSL.Add(vSR.Name);
      iRetval := FindNext(vSR);
    end;
    Result := vSL.Count;
  finally
    FindClose(vSR);
    vSL.Free;
  end;
end;

end.