functionunit.pas

简单的进销存系统,包含登陆等界面,内容丰富,各种技巧,适合初学者

unit FunctionUnit;

interface
uses Windows, Messages, SysUtils, Classes, Controls, Forms, Dialogs,
  ComCtrls, ToolWin, Buttons, ExtCtrls,DBTables , StdCtrls,ShellAPI,DBGrids,Registry, ADODB;

function Msgbox(Handle: integer; Text, Caption: string; flag: integer): integer;
function Checkrights(S_sourcerights:string; S_checkrights: string): boolean; //权限检测
function Nowindex: string;
function DaysInMonth(MYdate: TDate): Integer; //统计任意月份的天数
function GetHDSerialNumber(Drv : String): String;//提取硬盘号
function outCheckSum(outstr:string):string;//对硬盘号运算
function Checkregistry:boolean;//打开程序时自检，看是否已注册
function GetPY( hzchar:string):char;

procedure  LocatebyPY(t1:TADOQuery;Fieldname:string;PYstr:string);//拼音查询
procedure  checkformactive;//检测窗口状态
function SearchByPYIndexStr( SourceStrs:TStrings;PYIndexStr:string):string;
procedure  SearchBill(t1:Tquery;dbgridstr:TDBGrid;str:string);
procedure MyWarning(MyMessage: string);
procedure MyError(MyMessage: string);
procedure MyInformation(MyMessage: string);
procedure NullWarning(MyMessage: string);
function  ScreenShow():integer;//定义分辨率
function getSeason(mm: integer):string;
procedure EditClear(form1:Tform);//清空所有edit记录
function replacing(S,source,target:string):string;//全角、半角转换
procedure SetmyIme(ImeName:string);

////////////////////////
const
  Infmsg0001 = '数据保存成功！';
  Infmsg0002 = '数据删除成功！';
  Infmsg0003 = '数据修改成功！';
  Infmsg0004 = '数据保存失败！请检查后重新保存。';
  Infmsg0005 = '检测到有数据窗口正外于打开状态！';

  Askmsg0001 = '数据已修改，是否保存？';
  Askmsg0002 = '确定要保存以上数据内容？';
  Askmsg0003 = '是否要继续？';

  Errormsg0001 = '数据库打开错误，请与系统管理员联系。';
  Errormsg0002 = '关键内容（字段）不能为空。' ;
  Errormsg0003 = '关键内容（字段）已存在。' ;
  Errormsg0004 = '数据库更新失败，请与系统管理员联系。' ;
  Errormsg0005 = '数据库删除错误，请与系统管理员联系。';
  Errormsg0006 = '你没有足够的权限使用本功能，请与系统管理员联系。' ;
  Errormsg0007 = '管理员信息不可删除。' ;
  Errormsg0008 = '没有输入有效的数据记录，请重新输入！';
  Errormsg0009 = '没有检测到商品的库存记录，请重新输入！';
  Errormsg0010 = '检测到商品的库存数量小于出货数量，请重新输入！';
  Errormsg0011 = '打印机打开错误，打印不能完成。请检查系统是否安装默认打印机！';
  Errormsg0012 = '日期输入错误，请重新输入！' + #13 + #13 + '错误代码：';
implementation

uses mainunit;
//自定义信息对话框

function Msgbox(Handle: integer; Text, Caption: string; flag: integer): integer;
var
  Msg: TMsgBoxParams;
begin
  Msg.cbSize := Sizeof(Msg);
  Msg.hwndOwner := Handle;
  Msg.hInstance := hinstance;
  Msg.lpszText := PChar(Text);
  Msg.lpszCaption := PChar(Caption);
  Msg.dwStyle := flag + MB_USERICON;
  Msg.lpszIcon := 'MAINICON';
  Msg.dwContextHelpId := 1;
  Msg.lpfnMsgBoxCallback := nil;
  Msg.dwLanguageId := LANG_NEUTRAL;
  Result := integer(MessageBoxIndirect(Msg));
end;

function Nowindex: string;
begin
  result := formatdatetime('yyyymmdd', date) + '-' + formatdatetime('hhmmss', time)
end;

function Checkrights(S_sourcerights: string; S_checkrights: string): boolean; //权限检测函数定义
begin
  S_checkrights := trim(S_checkrights);
  if length(S_sourcerights) <> 10 then
    S_sourcerights := '0000000000';
  if S_checkrights = '查看' then
  begin
    if S_sourcerights[1] = '1' then
      result := true
    else
      result := false;
  end
  else if S_checkrights = '增加' then
  begin
    if S_sourcerights[2] = '1' then
      result := true
    else
      result := false;
  end
  else if S_checkrights = '编辑' then
  begin
    if S_sourcerights[3] = '1' then
      result := true
    else
      result := false;
  end
  else if S_checkrights = '删除' then
  begin
    if S_sourcerights[4] = '1' then
      result := true
    else
      result := false;
  end
  else if S_checkrights = '高级' then
  begin
    if S_sourcerights[5] = '1' then
      result := true
    else
      result := false;
  end
  else if S_checkrights = '报表打印' then
  begin
    if S_sourcerights[6] = '1' then
      result := true
    else
      result := false;
  end
  else if S_checkrights = '打印预览' then
  begin
    if S_sourcerights[7] = '1' then
      result := true
    else
      result := false;
  end
  else if S_checkrights = '系统设置' then
  begin
    if S_sourcerights[8] = '1' then
      result := true
    else
      result := false;
  end
  else
    result := false;
end;

function DaysInMonth(MYdate: TDate): Integer;
var
  MyMonth, MyYear, MyDay: Word;
  MyDayTable: TDayTable;
  tmpBool: Boolean;
begin
  DecodeDate(MYdate, MyYear, MyMonth, MyDay);
  tmpBool := IsLeapYear(MyYear);
  MyDayTable := MonthDays[tmpBool];
  Result := MyDayTable[MyMonth];
end;


function GetPY( hzchar:string):char;
begin
  case WORD(hzchar[1]) shl 8 + WORD(hzchar[2]) of
    $B0A1..$B0C4 : result := 'A';
    $B0C5..$B2C0 : result := 'B';
    $B2C1..$B4ED : result := 'C';
    $B4EE..$B6E9 : result := 'D';
    $B6EA..$B7A1 : result := 'E';
    $B7A2..$B8C0 : result := 'F';
    $B8C1..$B9FD : result := 'G';
    $B9FE..$BBF6 : result := 'H';
    $BBF7..$BFA5 : result := 'J';
    $BFA6..$C0AB : result := 'K';
    $C0AC..$C2E7 : result := 'L';
    $C2E8..$C4C2 : result := 'M';
    $C4C3..$C5B5 : result := 'N';
    $C5B6..$C5BD : result := 'O';
    $C5BE..$C6D9 : result := 'P';
    $C6DA..$C8BA : result := 'Q';
    $C8BB..$C8F5 : result := 'R';
    $C8F6..$CBF9 : result := 'S';
    $CBFA..$CDD9 : result := 'T';
    $CDDA..$CEF3 : result := 'W';
    $CEF4..$D188 : result := 'X';
    $D1B9..$D4D0 : result := 'Y';
    $D4D1..$D7F9 : result := 'Z';
  else
    result := char(0);
  end;
end;

procedure  LocatebyPY(t1:TADOQuery;Fieldname:string;PYstr:string);
label NOtFound;
var
        i,j:integer;
        hzchar:string;
        hzstr:array[0..100] of char;
begin
        while not t1.Eof do
                begin
                        strcopy(hzstr,pchar(t1.FieldByName(Fieldname).AsString));
                        for j:=0 to length(PYstr)-1 do
                                begin
                                        hzchar:=hzstr[2*j]+hzstr[2*j+1];
                                        if (PYstr[j+1]<>'?')and(uppercase(PYstr[j+1])<>GetPY(hzchar)) then
                                                goto NotFound;
                                end;

        if messagedlg('已经找到，继续查找？',mtConfirmation,[mbYes,mbNo],0)<>mrYes then
                exit;

        NotFound:
          t1.Next;
        end;
        showmessage('查找结束，没有找到！');
end;

procedure  checkformactive;
var
        I_windows:integer;
begin
        with mainform do
        begin
                for I_Windows:=0 to Panel_main.DockClientCount-1 do
                begin
                        //Panel_main.DockClients[I_windows].Free;
                        (panel_main.DockClients[0] as Tform).Close;
                        (panel_main.DockClients[0] as Tform).Free;
                end;
        end; 
end;

function SearchByPYIndexStr( SourceStrs:TStrings;PYIndexStr:string):string;
label NotFound;
var
  i, j   :integer;
  hzchar :string;
begin
  for i:=0 to SourceStrs.Count-1 do
    begin
      for j:=1 to Length(PYIndexStr) do
        begin
          hzchar:=SourceStrs[i][2*j-1] 
+ SourceStrs[i][2*j];
          if (PYIndexStr[j]<>'?') and
(UpperCase(PYIndexStr[j]) <>
GetPY(hzchar)) then goto NotFound;
        end;
      if result='' then result := SourceStrs[i]
      else result := result + Char
(13) + SourceStrs[i];
NotFound:
    end;
end;

procedure  SearchBill(t1:Tquery;dbgridstr:TDBGrid;str:string);
var
        temp:boolean;
begin
      temp:=t1.Locate('帐单编号',str,[]);
      begin
          dbgridstr.SetFocus;
      end;
      if temp=false then
      begin
          showmessage('没有找到您所要查寻的帐单编号！'+#13+'注意区分大小写');
      end;
end;

function GetHDSerialNumber(Drv : String): String;
var
VolumeSerialNumber : DWORD;
MaximumComponentLength : DWORD;
FileSystemNameBuffer:DWORD;
FileSystemFlags : DWORD;

begin
	//if Drv[Length(Drv)] =':' then
	//Drv := Drv + '\';
        Drv:=ExtractFilePath(Application.ExeName);
	GetVolumeInformation(pChar(Drv),nil,0,@VolumeSerialNumber,MaximumComponentLength,FileSystemFlags,nil,0);
	Result := IntToHex(HiWord(VolumeSerialNumber), 4)+'0130'+IntToHex(LoWord(VolumeSerialNumber), 4);
end;
function outCheckSum(outstr:string):string;
var
        BufLen,i:integer;
        checkstr:string;
        j:integer;

begin
        buflen:=length(outstr);
        checkstr:='';
        for i:=1 to buflen do
        begin
        j:=(i mod (i+10))+(i mod (i+20));
        checkstr:=checkstr+chr(ord(outstr[i])+j);
        end;
        result:=checkstr;
end;

function Checkregistry:boolean;//验明注册信息
var
        str1,str2:string;
        reg:TRegistry;
        regpath:string;
begin
        str1:='';
        str2:='';
        //str1:=outCheckSum(mainform.HDstr);

        //从注册表中提取序列号
        regpath:='\Software\FarmSale\reg';
        reg:=TRegistry.Create;
        reg.RootKey:=HKEY_CURRENT_USER;
        try
                if(reg.OpenKey(regpath,false))=false then
                begin
                    showmessage('未注册！');
                    //验证时间是否到期
                    exit;
                end
                else
                begin
                //
                reg.OpenKey(regpath,true);
                str2:=reg.ReadString('regno');
                
                end;
        finally
        reg.CloseKey;
        reg.Free;

        if trim(str1)=trim(str2) then
           result:=true
        else
           result:=false;
end;
end;

procedure MyWarning(MyMessage: string);
begin
  MessageDlg(MyMessage, mtWarning, [mbOk], 0);
end;

procedure MyError(MyMessage: string);
begin
  MessageDlg(MyMessage, mtError, [mbOk], 0);
end;

procedure MyInformation(MyMessage: string);
begin
  MessageDlg(MyMessage, mtInformation, [mbOk], 0);
end;


procedure NullWarning(MyMessage: string);
begin
  MyWarning(MyMessage + '不可空白，请重新输入！');
end;


function  ScreenShow():integer;//定义分辨率
begin
        if screen.width=800  then
	begin
                Result:=0;
        end;

        if screen.width=1024  then
	begin
                Result:=1;
        end;
        
end;

function getSeason(mm: integer):string;//计算季度
begin
        case mm of
                10,11,12,1,2:Result:='春季';

                3,4,5,6,7,8,9:Result:='秋季';

        end;


end;

procedure EditClear(form1:Tform);//清空所有edit记录
var
        i:integer;

begin
        for i:=form1.ComponentCount-1 downto 0 do
        begin
                if (form1.Components[i] is TEdit) then
                   begin
                        TEdit(form1.Components[i]).Text:='';
                   end;
        end;
end;

function replacing(S,source,target:string):string;//全角、半角转换
var site,StrLen:integer;
begin
        {source在S中出现的位置}
        site:=pos(source,s);
        if site=0 then
        begin
                replacing:=S;
        end
        else
        begin
                {source的长度}
                StrLen:=length(source);
                {删除source字符串}
                delete(s,site,StrLen);
                {插入target字符串到S中}
                insert(target,s,site);
                {返回新串}
                replacing:=s;
        end;
end;

procedure SetmyIme(ImeName:string);
var
  I: Integer;
  HandleToSet: HKL;
begin
  if not SysLocale.FarEast then Exit;
  if ImeName <> '' then
  begin
    if (AnsiCompareText(ImeName, Screen.DefaultIme) <> 0)
        and (Screen.Imes.Count <> 0) then
    begin
      HandleToSet := Screen.DefaultKbLayout;
      I := Screen.Imes.IndexOf(ImeName);
      if I >= 0 then
        HandleToSet := HKL(Screen.Imes.Objects[I]);
      ActivateKeyboardLayout(HandleToSet, KLF_ACTIVATE);
    end;
  end;
end;



end.