myvar.pas

图书馆管理系统设计详细资料

unit myvar;
interface
uses Windows, Messages, SysUtils,Dialogs,Classes,Controls,StdCtrls,
     Db,DBTables,DBCtrls,Registry,Graphics,Forms,Grids,OleCtnrs,ComObj,
     DBGrids,ComCtrls,ExtCtrls,Buttons,MMSystem,FileCtrl,allvar,Variants,
     ShellAPI,Excel97, OleServer;
var tsbar1,tsbar2,tsbar3,tsbar4: TStatusPanel;
    ProBar : TProgressBar ;
var gcjbgkjlh,gcsjspjlh,gcsggljlh,gcjaogjlh,gcjungjlh,gcsgjdjlh,gcjdtbjlh,
    bzbmpjlh,bztxtjlh,bzwordjlh ,bzdwxxjlh ,rydajlh,ryjlxxjlh: integer;
    lj,XTdwmc,XTmm,srf,dbgridtitle,bzdw_head:string;
    sys_rep: array[0..10] of string;
var checkmm:boolean;
    getDBgradindex:integer;
    formname,getdate:string;
    myhint : THintWindow;
var bhnr:string;              //selectfm
    comzd,comnr:string;
    pdbh:integer;
const vchln  = 50;  //查询选择数组预定义长度
type Tchartvalue = record
                 caption : array[0..vchln] of string;
                 value   : array[0..vchln] of integer;
                    end;
var chartvalue : Tchartvalue;

    myExcelApplication: TExcelApplication;
    myExcelWorkbook: TExcelWorkbook;
    myExcelWorksheet: TExcelWorksheet;

const sosdire = 'C:\zbsoft\glgcgl\sos\';
      CurrentDir = 'C:\zbsoft\glgcgl\';
const olMailItem=0;
      olTo=1;olCC=2;olBCC=3;
// AOD
//'Provider=MSDASQL.1;Extended Properties="DBQ=E:\外科病例管理系统\surgery.mdb;Driver={Microsoft Access Driver (*.mdb)};DriverId=25;FIL=MS Access;MaxBufferSize=2048;MaxScanRows=8;PageTimeout=5;SafeTransactions=0;Threads=3;UID=admin;UserCommitSync=Yes;"'

//输入检测——与dbgrid连的
function  myjctxtvalue(DBGrid:TDBGrid;s:string;i:integer):integer;
//备入备出——显示条，进度条   fname2:备份文件名
procedure mysavejlpd(quy:tquery;fname:string);

procedure mysavequyfilepd(StatusBar:TStatusPanel;ProBar: TProgressBar;quy:tquery;fname:string);
procedure myopenquyfilepd(StatusBar:TStatusPanel;ProBar: TProgressBar;quy:tquery;SQL:TUpdateSQL;
                          quyname,fname,fname2:string;var vjlh:integer);
procedure mysavequyfilepicpd(StatusBar:TStatusPanel;ProBar: TProgressBar;quy:tquery;fname,zdm,zdsvm:string);
procedure myopenquyfilepicpd(StatusBar:TStatusPanel;ProBar: TProgressBar;quy:tquery;SQL:TUpdateSQL;
                          DBN:tDBNavigator;quyname,fname,fname2,zdm,zdsvm:string;var vjlh:integer);
procedure mysavequyfiletxtpd(StatusBar:TStatusPanel;ProBar: TProgressBar;quy:tquery;fname,zdm,zdsvm:string);
procedure myopenquyfiletxtpd(StatusBar:TStatusPanel;ProBar: TProgressBar;quy:tquery;SQL:TUpdateSQL;
                          DBN:tDBNavigator;quyname,fname,fname2,zdm,zdsvm:string;var vjlh:integer);
{清屏}
procedure mydelpmjlpd(StatusBar:TStatusPanel;ProBar: TProgressBar;
                      quy : TQuery;sql : TUpdateSQL;fname:string);
procedure mydelpmjlpicpd(StatusBar:TStatusPanel;ProBar: TProgressBar;
                      quy : TQuery;sql : TUpdateSQL;fname,zdm,zdsvm:string);
procedure mydelpmjltxtpd(StatusBar:TStatusPanel;ProBar: TProgressBar;
                      quy : TQuery;sql : TUpdateSQL;fname,zdm,zdsvm:string);
//追加，带一张图片（用的导航器）
function  insertjlpcfu(st:string;var vjlh:integer;mydbgrid:Tdbgrid;
                 DBN:tDBNavigator;zdm:string):integer;
 //追加，
function myinsertjlfu(dbgrid:Tdbgrid;DBNavigator:TDBNavigator;st:string):integer;
//修改
function mymodifyjlfu(dbgrid:Tdbgrid;DBNavigator:TDBNavigator;st:string):integer;
//查询
function selectlikefu(Quy:TQuery;sn,zdm,zdv,tj : string):integer;
//清文件夹文件
procedure myclearrub(fname:string);
procedure myclearrubempty(fname:string);  
//替换字符
function  mychgstrfu( s : string; fch1,fch2 : string):string;
//用空格填充字符
function  fill_lengthfu( s,subs : string; n:integer):string;
//得到字符的一部分
//function  get_string( s: string; n1,n2:integer):string;
//保留2位小数
function  myFloatToStrF(a:extended) : string;
function  myfloattof( s : extended) : extended;
//得时间
function mygetdatefu : string;
function mygetdate2fu : string;   //带汉字
function mygettimefu : string;
function mygettime2fu : string;   //带汉字
function mygetonlydatefu : string;  //得唯一数（图片文字保存是使用）
//调整窗口,进度条大小，位置
procedure mysetform(form:TForm);
procedure mysetProBar(mProBar:TProgressBar;mStB:TStatusBar);
//根据记录号跳转
function  mygotojlhfu(quy:TQuery;vjlh:integer): boolean;
//设置默认路径
procedure myCurrentDirpd;
//重复项删除,提树
function  myrepeatdefu(StatusBar:TStatusPanel;ProBar: TProgressBar;
                       quy:TQuery;sql:Tupdatesql;sn:string;fname:string): boolean;
function  myrepeatgetfu(StatusBar:TStatusPanel;ProBar: TProgressBar;var altertv: string;
                       quy:TQuery;dbgrid:Tdbgrid;sn,zdm:string): boolean;
//删除 一条记录（没有提示）
procedure deldatenoaskpd(quy : TQuery; sn , s1,s2:string);
procedure deljlh_noaskpd(quy:Tquery;sql:Tupdatesql);
procedure deljlhnoaskpd(quy:Tquery;sql:Tupdatesql;vjlh:integer);
procedure changtree(var st:string;var TreeV: TTreeView);
//得到combox
procedure myGETcboxp(CBbar:TPanel;ls:integer);
//得到dbgrid表头
procedure mysetdbgrid(st:string;dbgrid:Tdbgrid);
//得到选择字段 /自己作的hint用
function getselectfu:string;
//outlook
procedure outlookfu(address,title,body:string;filenamelist:TListBox);
procedure outlooknsfu(address,title,body:string;filenamelist:TListBox);
//Excel
procedure Excelgetvaluepd(quy:Tquery;dbgrid:Tdbgrid;ProBar: TProgressBar);
procedure ExcelPreviewpd;
procedure ExcelPrintOutpd;
procedure ExcelQuitpd;
function  tabinstab(Quy:TQuery;sn1,sn2:string):integer;
//////////////////////////////////////////////////////////////////
//or查询
function  selectcombhfu(Quy:TQuery;sn,mzd,mval,zd,val:string;ln:integer;tj:string):integer;
function  selectonlybhfu(Quy:TQuery;sn,mzd,mval:string;ln:integer;tj:string):integer;
function  selectrangfu(Quy:TQuery;sn,Mzd,Mval,ZD,vmil,vmax:string;ln:integer;tj:string):integer;
////////

//////////////////////////////////////////////////////
function  sltmefu(var s : string) : string;      //-->"/"  工程量
function  datetodatefu(var s : string) : string;  //2001年11月13日--》011113
procedure myopenquyfilejdpd(StatusBar:TStatusPanel;ProBar: TProgressBar;quy:tquery;SQL:TUpdateSQL;
                          quyname,fname,fname2:string;var vjlh:integer);
function getcityno(s:string): string;
function getgclbno(s:string): string;
//////////////////////////////////////////////////////////////////

implementation

   //不许带图片BLOB字段
procedure Excelgetvaluepd(quy:Tquery;dbgrid:Tdbgrid;ProBar: TProgressBar);
var
i,row,column:integer;
begin
Try
myExcelApplication.Connect;
Except
MessageDlg('Excel 可能没有被安装。',
mtError, [mbOk], 0);
Abort;
End;
ProBar.Visible:=true;
ProBar.Max:= (quy.RecordCount+1)*(dbgrid.FieldCount);
ProBar.Position:=0;
myExcelApplication.Caption:='数据导入<Excel>应用';
if myExcelApplication.Workbooks.Count =0 then
myExcelApplication.Workbooks.Add(Null,0);
myExcelWorkbook.ConnectTo
(myExcelApplication.Workbooks[1]);
myExcelWorksheet.ConnectTo
(myExcelWorkbook.Worksheets[1] as _Worksheet);
row:=1;
column:=1;
for i:=1 to dbgrid.FieldCount do
begin
myExcelWorksheet.Cells.Item[row,column]:=dbgrid.Columns[i-1].Title.Caption;
if myExcelWorksheet.Cells.Item[row,column].columnwidth< length(dbgrid.Columns[i-1].Title.Caption)
then myExcelWorksheet.Cells.Item[row,column].columnwidth:=length(dbgrid.Columns[i-1].Title.Caption);
column:=column+1;
ProBar.Position:=ProBar.Position+1;
end;
row:=row+1; 

quy.DisableConstraints;
quy.First;
While Not(quy.Eof) do
begin
column:=1;
for i:=1 to dbgrid.FieldCount do
 begin
  myExcelWorksheet.Cells.Item[row,column]:=dbgrid.fields[i-1].AsString;
  if myExcelWorksheet.Cells.Item[row,column].columnwidth< length(dbgrid.fields[i-1].AsString)
  then myExcelWorksheet.Cells.Item[row,column].columnwidth:=length(dbgrid.fields[i-1].AsString);
  column:=column+1;
  ProBar.Position:=ProBar.Position+1;
 end;
quy.Next;
row:=row+1;
end;
quy.EnableConstraints;
ProBar.Position:= ProBar.Max;
myExcelApplication.Visible[0]:=True;   //将Excel放到前台 
end;

procedure ExcelPreviewpd;
begin
myExcelWorksheet.PrintPreview;
end;

procedure ExcelPrintOutpd;
begin
myExcelWorksheet.PrintOut;
end;

procedure ExcelQuitpd;
begin
myExcelWorksheet.Disconnect;
myExcelWorkbook.Disconnect;
myExcelApplication.Disconnect;

myExcelApplication.Quit;
end;



procedure outlookfu(address,title,body:string;filenamelist:TListBox);
var Outlook: Variant;
    Mail: Variant;
    Var Recipient: Variant;
    i:integer;
begin
Outlook:= CreateOleObject ('Outlook.Application');
if VarIsEmpty(Outlook) then
begin
showmessage('Outlook自动化对象创建失败!');
Exit;
end;
Mail:=Outlook.CreateItem(olMailItem);
Recipient:=Mail.Recipients.Add(address);
Recipient.Type:=olTo;
if filenamelist.Items.Count>0
then begin
for i:=0 to filenamelist.Items.Count-1 do
Mail.Attachments.Add(filenamelist.Items[i]  );
end;
Mail.Subject:= title;
Mail.Body:=body;
try
Mail.Send;
except
showmessage('邮件发送失败！');
Outlook:=Unassigned;
end;
end;

procedure outlooknsfu(address,title,body:string;filenamelist:TListBox);
var Outlook: Variant;
    Mail: Variant;
    Var Recipient: Variant;
    i:integer;
begin
Outlook:= CreateOleObject ('Outlook.Application');
if VarIsEmpty(Outlook) then
begin
showmessage('Outlook自动化对象创建失败!');
Exit;
end;
Mail:=Outlook.CreateItem(olMailItem);
Recipient:=Mail.Recipients.Add(address);
Recipient.Type:=olTo;
if filenamelist.Items.Count>0
then begin
for i:=0 to filenamelist.Items.Count-1 do
Mail.Attachments.Add(filenamelist.Items[i]  );
end;
Mail.Subject:= title;
Mail.Body:=body;
Mail.display;
end;



function getselectfu:string;
var i:integer;
begin
 i := 1;
  repeat
    if sltvar.name[i] <> ''
    then  result:= result +sltvar.caption[i]+':'+#13+#10+
                           ' →'+sltvar.value[i]+#13+#10 ;
    inc(i);
  until (i > 7)or( sltvar.name[i] = '') ;
  if result=''then result:='没有选择字段！'

end;


procedure mysetdbgrid(st:string;dbgrid:Tdbgrid);
var i:integer;
    s:string;
begin
i:=0;
 while i <= (dbgrid.FieldCount-1) do
  begin
    s := sltfu(st);
    dbgrid.Columns[i].Title.Caption:=s ;
    inc(i);
    end;
end;



procedure myCurrentDirpd;
begin
  if not SetCurrentDir(CurrentDir)
  then messagedlg('磁盘文件目录出错',mtinformation,[mbok],0);
end;



procedure myGETcboxp(CBbar:TPanel;ls:integer);
var i,j : integer;
    s   : string;
begin
  for j := 0 to CBbar.ControlCount-1 do
  begin
    s := CBbar.Controls[j].GetNamePath;
    i := 1;
    repeat
      if (s = 'cb' + inttostr(i))or (s = 'CB' + inttostr(i))
      then CBboxary[i] := CBbar.Controls[j] as TComboBox;
      inc(i);
    until (s = 'cb' + inttostr(i-1))or(s = 'CB' + inttostr(i-1)) or (i > ls);
  end;
end;


procedure mysetProBar(mProBar:TProgressBar;mStB:TStatusBar);
begin
mProBar.Left:=3;
mProBar.Top :=4;
mProBar.Height:=22;
mProBar.Width:=294;
mProBar.Visible:=false;
mProBar.Parent:=mStB;
end;

procedure mysetform(form:TForm);
begin
form.Left:=0;
form.Top :=0;
form.Height:=600;
form.Width:=800;
end;

function myFloatToStrF(a:extended) : string;
begin
  result:=FloatToStrF(a,ffFixed,10,2)
end;

function myfloattof( s : extended) : extended;        //保留2位小数
begin
  s:=s*100;
  s:=int(s);
  s:=s/100  ;
  result := s;
end;

procedure myclearrub(fname:string);    //fname:路径名，/结尾
var   sr: TSearchRec;
      FileAttrs: Integer;
begin
    if not (messagedlg('确定要删除文件夹所有备份文件吗？',mtconfirmation,[mbyes,mbno],0) = mryes)
     then Exit;

    FileAttrs := faAnyFile;
    fname:=fname+'*.*' ;
  if FindFirst(fname, FileAttrs, sr) = 0 then
  begin
      if (sr.Attr and FileAttrs) = sr.Attr then
      begin
         DeleteFile(sr.Name);
      end;
      while FindNext(sr) = 0 do
      begin
        if (sr.Attr and FileAttrs) = sr.Attr then
        begin
          DeleteFile(sr.Name);
        end;
      end;
      FindClose(sr);
    end;
end;


procedure myclearrubempty(fname:string);    //fname:路径名，/结尾
var   sr: TSearchRec;
      FileAttrs: Integer;
begin
    FileAttrs := faAnyFile;
    fname:=fname+'*.*' ;
  if FindFirst(fname, FileAttrs, sr) = 0 then
  begin
      if ((sr.Attr and FileAttrs) = sr.Attr) and (sr.Size=0)then
          DeleteFile(sr.Name);
            while FindNext(sr) = 0 do
      begin
      if ((sr.Attr and FileAttrs) = sr.Attr) and (sr.Size=0)then
          DeleteFile(sr.Name); 
      end;
      FindClose(sr);
    end;
end;


function  mychgstrfu( s : string; fch1,fch2 : string):string;  //替换字符
var i : integer;
    st: string;
begin
  st := s ;
  repeat
  i := pos (fch1,st);
  if i > 0
  then begin
         delete(st,i,length(fch1));
         insert(fch2,st,i);
       end;
   until i = 0 ;
  result :=  st;
end;

function  fill_lengthfu( s,subs : string; n:integer):string;
begin
   result:=s;
   if length(result)<n  then
   repeat  result:=result+subs
   until   length(result)>=n

end;


function mygetdatefu : string;
var year,month,day:word;
    mon,da:string   ;
begin
   decodedate(date,year,month,day)  ;
    mon:=inttostr(month);
    da:=inttostr(day);
   if length(mon)<2 then mon:='0'+mon    ;
   if length(da)<2 then da:='0'+da       ;
   result := (inttostr(year)+'-'+mon+'-'+da);
end;

function mygetdate2fu : string;
var year,month,day:word;
    mon,da:string   ;
begin
   decodedate(date,year,month,day)  ;
    mon:=inttostr(month);
    da:=inttostr(day);
   if length(mon)<2 then mon:='0'+mon    ;
   if length(da)<2 then da:='0'+da       ;
   result := inttostr(year)+'年'+mon+'月'+da+'日';
end;

function mygettimefu : string;
var hour,min,sec,msec:word;
    shour,smin,ssec:string   ;
begin
   decodetime(now,hour,min,sec,msec)  ;