func~1.~pa

软件类别: 数据库 软件大小: 2.60M 运行环境: Win9xNT/2000/XP 一套车辆管理系统,此版本为商业版,大家一定用的着。

unit func;

interface
uses
  Windows,DB,SysUtils,dbtables,Dialogs,registry,menus,Forms,jpeg,
  graphics,classes,DBGrids;

Function WriteRegFile(menth:integer;keyname:String;Regkey:variant):variant;
Function ReadRegFile(menth:integer;keyname:String):variant;
Function ExistsRegKey(keyname:string):boolean;
Function DeleteRegKey(keyname:string):boolean;
Function GetFontStyle(FontNo:integer):TFontStyles;
Function Encrypt(EncryptStr,EncryptKey:string):string;
Function Decrypt(DecryptStr,EncryptKey:string):string;

var
  Font_Style:array[0..4] of TFontStyles;
  Total_Do,Total_Do_Result:String;
  System_Flag:String;//定义一个标志位用于系统设置的操作对象；
  String_Col:Integer;  //Stringrid  的第几行
    Pub_Right:String;//权限的定义
    Login_Name:String;//登陆人员名称定义
    Car_Select:String;//车辆选择的全局定义
    Car_Select_Result:String;//车辆选择的结果的全局定义

    Drive_Card_Select:String;//驾驶证选择的全局定义
    Drive_Card_Select_Result:String;//驾驶证选择的结果的全局定义
    //
    Use_mond:string;//使用软件单位的名称的定义
    Mond_Address:String;//使用软件单位的地址的定义
    Link_Tel:String;//使用软件单位的联系电话的定义
    Link_Man:String;//使用软件单位的联系人员的定义
    Mond_Select:String;
    Mond_Select_Result:String;
    //
    //-----
    Charge_Type_Str   :String;//收费类别的选择
    Charge_Type_result:String;//收费类别的选择的结果
    Charge_Name_Str   :String;//收费名称的选择
    Charge_Name_result:String;//收费名称的选择的结果
    //-----
implementation

uses  main, Data;



Function GetCurImage(CurStr:string):integer;
var
    len:integer;
    tempstr:string;
begin
    tempstr:=trim(CurStr);
    len:=length(tempstr);
    if (len mod 2)=0 then
    begin
        tempstr:=copy(tempstr,length(tempstr)-1,2);
    end
    else
    begin
        tempstr:=copy(tempstr,length(tempstr),1);
        Result:=strtoint(tempstr);
    end;
end;

Function strtohex(instr:string):string;
var
   i:integer;
   asc:integer;
   hexstr:string;
begin
    Result:='';
    for i:=1 to length(instr) do
    begin
        asc:=ord(instr[i]);
        hexstr:=inttohex(asc,2);
        Result:=Result+hexstr;
    end;
end;

Function hexstrtodecstr(instr:string):string;
var
    hexstr1,hexstr2:string;
    decint,i:integer;
begin
    try
    Result:='';
    i:=1;
    while not (i>length(instr)) do
    begin
        hexstr1:=copy(instr,i,1);
        if hexstr1='A' then hexstr1:='10';
        if hexstr1='B' then hexstr1:='11';
        if hexstr1='C' then hexstr1:='12';
        if hexstr1='D' then hexstr1:='13';
        if hexstr1='E' then hexstr1:='14';
        if hexstr1='F' then hexstr1:='15';

        hexstr2:=copy(instr,i+1,1);
        if hexstr2='A' then hexstr2:='10';
        if hexstr2='B' then hexstr2:='11';
        if hexstr2='C' then hexstr2:='12';
        if hexstr2='D' then hexstr2:='13';
        if hexstr2='E' then hexstr2:='14';
        if hexstr2='F' then hexstr2:='15';

        decint:=strtoint(hexstr1)*16+strtoint(hexstr2);
        Result:=Result+chr(decint);
        i:=i+2;
    end;
    except
        Result:='False';
    end;
end;

Function Encrypt(EncryptStr,EncryptKey:string):string;
var
    i,j,icount:integer;
    s1,s2,tempstr:string;
    asc1,asc2,asc3:integer;
begin
    Result:='';
    s1:=EncryptStr;
    s2:=EncryptKey;
    icount:=length(s1) div 3;
    j:=1;

    for i:=1 to icount do
    begin
        tempstr:=copy(s1,(i-1)*3+1,3);
        asc1:=strtoint(tempstr);
        asc2:=ord(s2[j]);
        j:=j+1;
        if j>length(s2) then
        j:=1;

        asc3:=asc1 xor asc2;
        Result:=Result+chr(asc3);
    end;
end;

Function Decrypt(DecryptStr,EncryptKey:string):string;
var
    i,j:integer;
    str:char;
    s1,s2:string;
    asc1,asc2,asc3:integer;
begin
    Result:='';
    s1:=DecryptStr;
    s2:=EncryptKey;
    j:=1;

    for i:=1 to length(s1) do
    begin
        str:=s1[i];
        asc1:=ord(str);
        asc2:=ord(s2[j]);
        j:=j+1;
        if j>length(s2) then
            j:=1;
        asc3:=asc1 xor asc2;
        Result:=Result+formatfloat('000',asc3);
    end;
    Result:=trim(Result);
end;

function GetFontStyle(FontNo:Integer):TFontStyles;
begin
    Result:=[];
    case FontNo of
        3: Result:=[fsBold,fsItalic];
        2: Result:=[fsItalic];
        1: Result:=[fsBold];
        else Result:=[];
    end;
end;


Function writeselfdog(var selfstr:string;port:integer):integer;
type
    TDataProc=Function(num: Integer; data: Pchar):integer;cdecl;//stdcall;
var
    re      :integer;
    hLib      :Thandle;
    DataProc  :TDataProc;
begin
    hLib:=LoadLibrary('Dec.dll');
    if hLib<32 then
    begin
        result:=-2;
        exit;
    end;
    DataProc:=TDataProc(GetProcAddress(hLib,'SetData'));
    re:=DataProc(port,@selfstr[1]);
    FreeLibrary(hLib);
    result:=re;
end;

Function WriteRegFile(menth:integer;keyname:String;Regkey:variant):variant;
var
    tempkey :string;
    tempregkey :Tregistry;
begin
    tempregkey:=TRegistry.create;
    try
        tempkey:='\SOFTWARE\minipacs';
        tempregkey.RootKey := HKEY_LOCAL_MACHINE;
        tempregkey.OpenKey(tempkey,TRUE);

        case menth of
            1:
            begin
                tempregkey.WriteInteger(keyname,Regkey);
                result :=tempregkey.ReadInteger(keyname);
            end;

            2:
            begin
                tempregkey.WriteString(keyname,Regkey);
                result:=tempregkey.ReadString(keyname);
            end;

            3:
            begin
                tempregkey.WriteBool(keyname,Regkey);
                result:= tempregkey.ReadBool(keyname);
            end;
        end;
    finally
        tempregkey.closekey;
        tempregkey.destroy;
    end;
end;

Function ReadRegFile(menth:integer;keyname:String):variant;
var
    tempkey :string;
    tempregkey :Tregistry;
begin
    tempregkey:=TRegistry.create;
    try
        tempkey:='\SOFTWARE\minipacs';
        tempregkey.RootKey := HKEY_LOCAL_MACHINE;
        tempregkey.OpenKey(tempkey,TRUE);
        case menth of
            1:  Result:=tempregkey.ReadInteger(keyname);
            2:  Result:=tempregkey.ReadString(keyname);
            3:  Result:=tempregkey.ReadBool(keyname);
        end;
    finally
        tempregkey.closekey;
        tempregkey.destroy;
    end;
end;

Function ExistsRegKey(keyname:string):boolean;
var
    tempkey       :string;
    tempregkey    :Tregistry;
begin
    tempregkey:=TRegistry.create;
    try
        tempkey:='\SOFTWARE\minipacs';
        tempregkey.RootKey := HKEY_LOCAL_MACHINE;
        tempregkey.OpenKey(tempkey,TRUE);
        if tempregkey.valueexists(keyname) then
            result:= true
        else
            result:= false;
    finally
        tempregkey.closekey;
        tempregkey.destroy;
    end;
end;

Function DeleteRegKey(keyname:string):boolean;
var
    tempkey:string;
    tempregkey:Tregistry;
begin
    tempregkey:=TRegistry.create;
    try
        tempkey:='\SOFTWARE\minipacs';
        tempregkey.RootKey := HKEY_LOCAL_MACHINE;
        tempregkey.OpenKey(tempkey,TRUE);
        if tempregkey.valueexists(keyname) then
        begin
            tempregkey.DeleteKey(keyname);
            result:= true
        end
        else
            result:= false;
    finally
        tempregkey.closekey;
        tempregkey.destroy;
    end;
end;

Procedure Change_Bmp_To_Jpeg(var bmpfile,jpgFile:String; compressquality:integer);
var
    jpegimg :Tjpegimage;
    bmpimg:TBitMap;
begin
    jpegimg:=nil;
    bmpimg:=nil;
    try
        try
            jpegimg :=Tjpegimage.create;
            bmpimg  :=TBitMap.create;
            bmpimg.loadfromfile(bmpfile);
            Jpegimg.compressionQuality:=compressquality;
            Jpegimg.Assign(bmpimg);
            Jpegimg.Compress ;
            Jpegimg.SaveToFile(jpgFile);
            deletefile(bmpfile);
        except
            MessageBeep(0);
            Application.MessageBox('当前图象转换错误!','警告!',0);
            exit;
        end;
    finally
        if jpegimg<>nil then
            jpegimg.free;
        if bmpimg<>nil then
            bmpimg.free;
    end;
end;

Function Get_Part_Path(filename :string):string;
var
    len,i :integer;
begin
    len :=length(filename);
    for i:=len downto 1 do
    begin
        if filename[i]='\' then
            break;
    end;
    result :=copy(filename,1,i-1)
end;

Procedure InitFontArray;
begin
  Font_Style[0] :=[fsBold];
  Font_Style[1] :=[fsBold];
  Font_Style[2] :=[fsItalic];
  Font_Style[3] :=[fsUnderline];
  Font_Style[4] :=[fsStrikeOut];
end;
end.