frame_utilfunc.pas

企业信息管理系统程序框架

function EncrypStr(Src, Key: string): string;
  //对字符串加密(Src:源 Key:密匙)
var
  KeyLen: integer;
  KeyPos: integer;
  offset: integer;
  dest: string;
  SrcPos: integer;
  SrcAsc: integer;
  Range: integer;
begin
  KeyLen := Length(Key);
  if KeyLen = 0 then
  begin
    key := 'delphi'
  end;
  KeyPos := 0;
  Range := 256;
  Randomize;
  offset := Random(Range);
  dest := format('%1.2x', [offset]);
  for SrcPos := 1 to Length(Src) do
  begin
    SrcAsc := (Ord(Src[SrcPos]) + offset) mod 255;
    if KeyPos < KeyLen then
    begin
      KeyPos := KeyPos + 1
    end
    else begin
      KeyPos := 1
    end;
    SrcAsc := SrcAsc xor Ord(Key[KeyPos]);
    dest := dest + format('%1.2x', [SrcAsc]);
    offset := SrcAsc;
  end;
  Result := Dest;
end;

function EncrypStr(Src: string): string;
begin
  Result := EncrypStr(Src, AppConfigFileName);
end;


//对字符串解密(Src:源 Key:密匙)

function UncrypStr(Src, Key: string): string;
var
  KeyLen: integer;
  KeyPos: integer;
  offset: integer;
  dest: string;
  SrcPos: integer;
  SrcAsc: integer;
  TmpSrcAsc: integer;
begin
  KeyLen := Length(Key);
  if KeyLen = 0 then
  begin
    key := 'delphi'
  end;
  KeyPos := 0;
  offset := StrToIntDef('$' + copy(src, 1, 2),0);
  SrcPos := 3;
  repeat
    SrcAsc := StrToIntDef('$' + copy(src, SrcPos, 2),0);
    if KeyPos < KeyLen then
    begin
      KeyPos := KeyPos + 1
    end
    else begin
      KeyPos := 1
    end;
    TmpSrcAsc := SrcAsc xor Ord(Key[KeyPos]);
    if TmpSrcAsc <= offset then
    begin
      TmpSrcAsc := 255 + TmpSrcAsc - offset
    end
    else begin
      TmpSrcAsc := TmpSrcAsc - offset
    end;
    dest := dest + chr(TmpSrcAsc);
    offset := srcAsc;
    SrcPos := SrcPos + 2;
  until SrcPos >= Length(Src);
  Result := Dest;
end;

function UncrypStr(Src: string): string;
begin
  if (Src = '') then
  begin
    Result := ''
  end
  else begin
    Result := UncrypStr(Src, AppConfigFileName)
  end;
end;
// 增加sql条件
procedure addSQLCondition(var wheresql: string; condition: string);
begin
  if wheresql='' then
  begin
    wheresql := ' where ('+condition+')';
  end
  else
  begin
    wheresql := wheresql+' and ('+condition+')';
  end;
end;
//------------------------------------------------------------------------------
// 显示询问窗口
//------------------------------------------------------------------------------

function QueryDlg(Mess: string; DefaultNo: Boolean; Caption: string): Boolean;
const
  Defaults: array[Boolean] of DWORD = (0, MB_DEFBUTTON2);
begin
  Result := Application.MessageBox(PChar(Mess), PChar(Caption),
    MB_YESNO + MB_ICONQUESTION + Defaults[DefaultNo]) = IDYES;
end;

//------------------------------------------------------------------------------
// 显示询问窗口
//------------------------------------------------------------------------------

function QueryDlg(Mess: string; DefaultNo: Boolean): Boolean;
const
  Defaults: array[Boolean] of DWORD = (0, MB_DEFBUTTON2);
begin
  Result := Application.MessageBox(PChar(Mess), PChar(Application.Title),
    MB_YESNO + MB_ICONQUESTION + Defaults[DefaultNo]) = IDYES;
end;


function FontStylesToString(Styles: TFontStyles): string;
begin
  Result := '';
  if fsBold in Styles then Result := Result + 'B';
  if fsItalic in Styles then Result := Result + 'I';
  if fsUnderline in Styles then Result := Result + 'U';
  if fsStrikeOut in Styles then Result := Result + 'S';
end;

function FontToString(Font: TFont): string;
var
  S: string;
begin
  with Font do
  begin
    if not CharsetToIdent(Charset, S) then
      S := IntToStr(Charset);
    Result := Format('%s,%d,%s,%d,%s,%s', [Name, Size,
      FontStylesToString(Style), Ord(Pitch), ColorToString(Color), S]);
  end;
end;

function IsInt(const s: string): Boolean;
var
  i, E: integer;
begin
  Result := True;
  Val(S, i, E);
  if E <> 0 then Result := False;

end;



// 设置级联属性值

function SetPropValueIncludeSub(Instance: TObject; const PropName: string;
  const Value: Variant): Boolean;

  procedure DoSetPropValueIncludeSub(Instance: TObject; const PropName: string;
    const Value: Variant);
  var
    AObject: TObject;
    Dot, IntValue: Integer;
    RestProp: string;
    PropInfo: PPropInfo;
    IdToInt: TIdentToInt;
  begin
    Dot := Pos('.', PropName);
    if Dot = 0 then
    begin
      PropInfo := GetPropInfo(Instance, PropName);
      if PropInfo^.PropType^.Kind = tkInteger then
      begin
        IdToInt := FindIdentToInt(PPropInfo(PropInfo)^.PropType^);
        if Assigned(IdToInt) and IdToInt(Value, IntValue) then
          SetPropValue(Instance, PropName, IntValue)
        else
          SetPropValue(Instance, PropName, Value)
      end
      else
        SetPropValue(Instance, PropName, Value)
    end
    else
    begin
      // 递归设置
      AObject := GetObjectProp(Instance, Copy(PropName, 1, Dot - 1));
      RestProp := Copy(PropName, Dot + 1, Length(PropName) - Dot);
      DoSetPropValueIncludeSub(AObject, RestProp, Value);
    end;
  end;

begin
  try
    DoSetPropValueIncludeSub(Instance, PropName, Value);
    Result := True;
  except
    Result := False;
  end;
end;

function GetPropValueIncludeSub(Instance: TObject; PropName: string;
  PreferStrings: Boolean = True): Variant;
var
  AObject: TObject;
  Dot: Integer;
  RestProp: string;
  IntToId: TIntToIdent;
  IdValue: string;
  PropInfo: PPropInfo;
begin
  Result := Null;
  if Instance = nil then Exit;

  Dot := Pos('.', PropName);
  if Dot = 0 then
  begin
    if (Instance is TStrings) and (PropName = 'Text') then
    begin
      Result := (Instance as TStrings).Text;
      Exit;
    end
    else if (Instance is TListItem) and (PropName = 'Caption') then
    begin
      Result := (Instance as TListItem).Caption;
      Exit;
    end
    else if (Instance is TTreeNode) and (PropName = 'Text') then
    begin
      Result := (Instance as TTreeNode).Text;
      Exit;
    end
    else if PropName = '!Font' then // 在此内部处理 !Font 的情况
    begin
      PropName := 'Font';
      PropInfo := GetPropInfo(Instance, PropName);
      if PropInfo = nil then
        Exit;

      if PropInfo^.PropType^.Kind = tkClass then
      begin
        try
          Result := FontToString(TFont(GetObjectProp(Instance, PropName)));
        except
          ;
        end;
        Exit;
      end;
    end;

    PropInfo := GetPropInfo(Instance, PropName);
    if PropInfo = nil then
      Exit;

    if PropInfo^.PropType^.Kind = tkClass then
    begin
      Result := Integer(GetObjectProp(Instance, PropName));
      Exit;
    end;

    Result := GetPropValue(Instance, PropName, PreferStrings);
    if (Result <> Null) and IsInt(Result) then // 如果返回整数，尝试将其转换成常量。
    begin
      if PropInfo^.PropType^.Kind = tkInteger then
      begin
        IntToId := FindIntToIdent(PPropInfo(PropInfo)^.PropType^);
        if Assigned(IntToId) and IntToId(Result, IdValue) then
          Result := IdValue;
      end
    end
  end
  else
  begin
    // 递归寻找
    AObject := nil;
    if GetPropInfo(Instance, Copy(PropName, 1, Dot - 1)) <> nil then
      AObject := GetObjectProp(Instance, Copy(PropName, 1, Dot - 1));

    if AObject = nil then
      Result := Null
    else
    begin
      RestProp := Copy(PropName, Dot + 1, Length(PropName) - Dot);
      Result := GetPropValueIncludeSub(AObject, RestProp);
    end;
  end;
end;

 //******************************************************************************
 // 单元初始化
 //******************************************************************************
initialization
  GV_Con := nil;
  GV_Qry := nil;

end.