inherit.~pas

用delphi实现的一个酒店管理系统框架

 Begin App.WorkSheets[1].Columns[i+1].numberformatlocal:='@';end;
 End;//若是字符型设置为文本格式，以显示类似'003'这样的数字字符
 for j:=1 to r do//数据导出
  begin
   for i:=0 to c-1 do
   Begin//if DBGrid1.Fields[j-1] is TBlobField then continue;//跳过图片字段
 if DBGrid.Fields[i].DataType=ftBlob then continue else//跳过图
 if DBGrid.Fields[i].DataType=ftMemo then
 begin Re.Text:=DBGrid.Fields[i].AsString;//Txt.Text:=DBGrid.Fields[i].AsString;
 app.cells(j+1,1+i):=Re.Text;continue end;
 {if DBGrid.Fields[i].DataType=ftWideString then //ftSmallint
 Begin app.Goto('R'+IntToStr(j+1)+'C'+IntToStr(i+1));//若是字符型设置为文本格式，
 App.ActiveCell.numberformatlocal:='@';end;}//以显示类似'003'这样的数字字符
 if (DBGrid.Fields[i].AsString<>null)and(DBGrid.Fields[i].AsString<>'') then
 app.cells(j+1,1+i):=DBGrid.Fields[i].AsString;
// if (DBGrid.Fields[i].AsString<>'0')and(DBGrid.Fields[i].AsString[1]='0') then
// app.cells(j+1,1+i):=''''+DBGrid.Fields[i].AsString else//以前缀单引号显示数字字符
//app.cells(j+1,1+i):=DBGrid.DataSource.DataSet.Fields[i].AsString;
   End;
   DBGrid.DataSource.DataSet.Next;
  end;
 if FileExists(TempFN) then DeleteFile(TempFN);//若存在则删除它
except;end;
 app.Activeworkbook.SaveAs(TempFN);app.Activeworkbook.close(false);
 app.quit;app:=unassigned;
 DBGrid.DataSource.DataSet.Bookmark:=BM;
 DBGrid.DataSource.DataSet.EnableControls;RE.Free;
end;

procedure TTInherit.ToolButton15Click(Sender: TObject);//导出Excel
begin
 SaveDialog1.Filter:='Excel工作薄(*.Xls)|*.Xls';
 SaveDialog1.DefaultExt:='xls';SaveDialog1.FileName:=Caption;
 if not SaveDialog1.Execute then Exit;//取消导出  
Screen.Cursor:=crHourGlass;//Screen.Cursor:=crDefault
try ExportDBGrid0(DBGrid1,(SaveDialog1.FileName));Except;end;
Screen.Cursor:=crDefault; // CallDllForm  ,application.Handle
end;

procedure TTInherit.ToolButton16Click(Sender: TObject);//Excel导入
var i,j,r,c,n:integer;ExcelApp,MyWorkBook:OLEVariant;s:string;//改成DLL
begin
 if not opendialog1.Execute then exit;s:='Excel第';n:=0;
 try
 ExcelApp:=CreateOleObject('Excel.Application');
 MyWorkBook:=CreateOleobject('Excel.Sheet');
 except
  Msg1('无法打开Xls文件,请确认已经安装EXCEL!');Exit;
 end;Screen.Cursor:=crHourGlass;Application.ProcessMessages;
 MyWorkBook:=ExcelApp.workBooks.Open(opendialog1.FileName);//打开文件后,对文件进行操作
 r:=2;c:=1;//求出要导入表的行数r(第一列连续非空行数)和列数c(第一行连续非空列数)
 while trim(MyWorkBook.WorkSheets[1].Cells.Item[r,1])<>'' do
 inc(r);dec(r);
 while trim(MyWorkBook.WorkSheets[1].Cells.Item[1,c])<>'' do
  inc(c);dec(c);
 For i:=2 to r do
 Begin
  DBGrid1.DataSource.DataSet.Append;
  For j:=1 to c do
  begin
   if DBGrid1.Fields[j-1].FieldKind<>fkData then continue;//跳过非数据字段
   if DBGrid1.Fields[j-1] is TAutoIncField then continue;//跳过自动增1字段
   if DBGrid1.Fields[j-1] is TBlobField then continue;//跳过图片字段
   try// if MyWorkBook.WorkSheets[1].Cells.Item[i,j]<>null then
   DBGrid1.Fields[j-1].AsString:=MyWorkBook.WorkSheets[1].Cells.Item[i,j];
   except;end;
   end;
  try DBGrid1.DataSource.DataSet.Post;n:=n+1;except
  s:=s+inttostr(i)+',';DBGrid1.DataSource.DataSet.Cancel;end;
 End;
 ExcelApp.Quit;ExcelApp:=UnAssigned;Screen.Cursor:=crDefault;
 s:=copy(s,1,length(s)-1)+'行记录的导入失败!实际导入'+inttostr(n)+'条记录。';
 if s<>'Excel第' then Msg1(s);
end;

procedure TTInherit.ToolButton17Click(Sender: TObject);
begin
ReplaceDialog1.Execute;FHandle1:=findwindow(nil,'替换');
SetWindowText(FHandle1,PChar('替换"'+DBGrid1.SelectedField.DisplayName+'"列的内容'));
end;

procedure TTInherit.ReplaceDialog1Find(Sender: TObject);
Label Nxt,Nxt2;Var KF,old,s:string;BM:TBookMarkStr;x,i:integer;
begin//查找操作
BM:=ADODataSet1.Bookmark;Old:=TReplaceDialog(Sender).FindText;
KF:=DBGrid1.Fields[DBGrid1.SelectedIndex].FieldName;
if frDown IN TReplaceDialog(Sender).Options then ADODataSet1.Next
 else ADODataSet1.Prior;i:=0;
Nxt:x:=0;
if ((old='null')and((ADODataSet1[KF]=null)or((ADODataSet1.FieldByName(KF).DataType=ftString)and(ADODataSet1[KF]=''))))or
 (old='%') then i:=1 else
begin
if ADODataSet1[KF]<>null then
if KF='题目' then begin RTF.Text:=ADODataSet1[KF];s:=RTF.Text;end else
s:=ADODataSet1[KF] else Goto Nxt2;
if frWholeWord IN TReplaceDialog(Sender).Options then x:=x+1;
if frMatchCase IN TReplaceDialog(Sender).Options then x:=x+2;i:=0;
case x of
0:i:=Pos(Lowercase(old),Lowercase(s));
1:i:=ifthen(Lowercase(old)=Lowercase(s),1,0);
2:i:=Pos(old,s);
3:i:=ifthen(old=s,1,0);
End;
NXT2:if (i<1)and(not ADODataSet1.Eof and not ADODataSet1.Bof)then
 Begin
  if frDown IN TReplaceDialog(Sender).Options then ADODataSet1.Next
   else ADODataSet1.Prior;
  Goto Nxt;
 End;
End;///////
if i<1 then Begin Msg1('没有找到:'+Old);ADODataSet1.Bookmark:=BM;End;
end;

procedure TTInherit.ReplaceDialog1Replace(Sender: TObject);
Label Nxt;Var Old,New,KF,s:String;x,i,n:integer;BM:TBookMarkStr;
begin
BM:=ADODataSet1.Bookmark;
Old:=ReplaceDialog1.FindText;New:=ReplaceDialog1.ReplaceText;
if Old=New then exit;n:=Length(Old);
if DBGrid1.SelectedIndex<0 then exit;
KF:=DBGrid1.Fields[DBGrid1.SelectedIndex].FieldName;
Nxt:x:=0;
if ((old='null')and((ADODataSet1[KF]=null)or((ADODataSet1.FieldByName(KF).DataType=ftString)and(ADODataSet1[KF]=''))))or
 (old='%') then i:=1 else  begin
if frWholeWord IN ReplaceDialog1.Options then x:=x+1;
if frMatchCase IN ReplaceDialog1.Options then x:=x+2;i:=0;
if ADODataSet1[KF]=null then s:='' else s:=ADODataSet1[KF];
case x of
0:i:=Pos(Lowercase(old),Lowercase(s));
1:i:=ifthen(Lowercase(old)=Lowercase(s),1,0);
2:i:=Pos(old,s);
3:i:=ifthen(old=s,1,0);
End;End;Application.ProcessMessages;
if (i<1)and not ADODataSet1.Eof then Begin ADODataSet1.Next;Goto Nxt;End;
if i<1 then Begin Msg1('没有找到:'+Old);ADODataSet1.Bookmark:=BM;exit;End;
ADODataSet1.Edit;
if old='%' then s:=new else
if (old='null')and((ADODataSet1[KF]=null)or((ADODataSet1.FieldByName(KF).DataType=ftString)and(ADODataSet1[KF]=''))) then
s:=new else s:=copy(s,1,i-1)+new+copy(s,i+n,length(s)-i-n+1);
Try if (s='')or(s='null') then ADODataSet1[KF]:=null else ADODataSet1[KF]:=s;except;
Msg1('不能将'''+Old+'''替换为'''+New+'''');ADODataSet1.Cancel;exit;end;
ADODataSet1.Post;if (old='%')or(old='null') then ADODataSet1.Next;
if (frReplaceAll IN ReplaceDialog1.Options)and not ADODataSet1.Eof then Goto Nxt;
End;
procedure TTInherit.FFn1Change(Sender: TObject);
begin
if (FFn1.Text<>'')and(FFv1.Text<>'') then
Begin
 try ADODataSet1.Filtered:=False;
 SB1.Panels[3].Text:='没有找到满足条件的记录。';
 ADODataSet1.Filter:=FFn1.Text+YSF.Text+''''+FFv1.Text+'''';
 ADODataSet1.Filtered:=True;
 SB1.Panels[3].Text:='成功过滤操作。';
 Except;SB1.Panels[3].Text:='过滤操作失败!取消过滤。';
 ADODataSet1.Filtered:=False;end;
End else Begin ADODataSet1.Filtered:=False;
SB1.Panels[3].Text:='取消过滤操作。';End;
end;

procedure TTInherit.ADODataSet1AfterOpen(DataSet: TDataSet);
var i:integer;
begin//FFn1.Items:=ADODataSet1.FieldList;
FFn1.Items.Clear;
for I := 0 to ADODataSet1.FieldList.Count - 1 do
Begin
 if (F1TP='')and(ADODataSet1.Fields[i].DataType=ftBlob) then
  F1TP:=ADODataSet1.Fields[i].DisplayName;
 FFn1.Items.Add(ADODataSet1.Fields[i].DisplayName);
End;
FFn1.ItemIndex:=0;
SB1.Panels[1].Text:=Format('%d/%d',[ADODataSet1.RecNo,ADODataSet1.RecordCount]);
end;

procedure TTInherit.DBGrid1DrawColumnCell(Sender: TObject;
  const Rect: TRect; DataCol: Integer; Column: TColumn;
  State: TGridDrawState);
 var OutRect:TRect;//j:tjpegimage;//bmp:TBitmap;
begin//网格中显示图形和备注型内容
 with DBGrid1 do
  begin
   Canvas.FillRect(Rect);OutRect:=Rect;
   InflateRect(OutRect,-2,-2);
   if Column.Field is TMemoField then//一定要先判断备注型再判断图
    begin
     RTF.Text:=Column.Field.AsString;
     DrawText(Canvas.Handle,Pchar(RTF.Text),
     Length(RTF.Text),OutRect,dt_WordBreak or dt_NoPrefix);
    end
    else 
   if Column.Field is TBlobField then
    begin
     if not Column.Field.IsNull then Begin
     if j<>nil then j:=tjpegimage.Create;
     try j.Assign(Column.Field);Canvas.StretchDraw(OutRect,j);finally end;
     End;
    end
   else DrawText(Canvas.Handle,Pchar(Column.Field.DisplayText),
     Length(Column.Field.DisplayText),
     OutRect,dt_WordBreak or dt_NoPrefix);
  end;
end;


procedure TTInherit.Image1DblClick(Sender: TObject);
var ext,FLNm:string;
begin
if (Sender Is TImage)or(ToolButton14.Caption='加图') then
Begin
if not OpenPictureDialog1.Execute then exit;//打开文件成功进入编辑
FLNm:=OpenPictureDialog1.FileName;ext:=LowerCase(ExtractFileExt(FLNm));
ADODataSet1.Edit;ToolButton14.Caption:='清除';
if ext='.bmp' then// edit1.Text:=format('%d,%d',[b.Width,b.Height]);
 Begin b.LoadFromFile(FLNm);j.Assign(b);end else//加载图片到Tbitmap对象
 if ext='.jpg' then j.LoadFromFile(FLNm) else//加载图片到tjpegimage对象edit1.Text:=format('%d,%d',[j.Width,j.Height]);
  TBlobField(ADODataSet1.FieldByName(F1TP)).LoadFromFile(FLNm);
if pos(ext,'.bmp.jpg')>0 then Begin Image1.Picture.Graphic:=j; //将图片内容送Image1组件显示
ADODataSet1.FieldByName(F1TP).Assign(j);ToolButton14.Caption:='清图';End;//将JPG图片写数据库"图"字段
ADODataSet1.Post;//保存提交
End
Else Begin Image1.Picture.Graphic:=nil;ADODataSet1.Edit;
ADODataSet1[F1TP]:='';ADODataSet1.Post;
ToolButton14.Caption:='加图';
End;
end;

procedure TTInherit.Timer1Timer(Sender: TObject);
var i:integer;
begin
Timer1.Interval:=5;Timer1.Enabled:=false;
if high(vsb)>-1 then begin
for i:=0 to high(vsb) do Begin DBGrid1.Columns[i].Visible:=vsb[i];
DBGrid1.Columns[i].Width:=ColW[i];End;exit;End;
setLength(vsb,DBGrid1.Columns.Count);setLength(ColW,DBGrid1.Columns.Count);
for i:=0 to DBGrid1.Columns.Count-1 do Begin
vsb[i]:=DBGrid1.Columns[i].Visible;ColW[i]:=DBGrid1.Columns[i].Width;end;
end;

procedure TTInherit.ADODataSet1BeforeInsert(DataSet: TDataSet);
begin
if (ADODataSet1.FieldList.IndexOf('分类')>=0)and(ADODataSet1.FieldList.Count<5)
 then if ADODataSet1['分类']<>null then SRBFL:=ADODataSet1['分类'];
end;

procedure TTInherit.ADODataSet1AfterInsert(DataSet: TDataSet);
begin
 if Form3.dj>='R' then begin ADODataSet1.Cancel;Exit;end;
if (ADODataSet1.FieldList.IndexOf('分类')>=0)and(ADODataSet1.FieldList.Count<5)
 then ADODataSet1['分类']:=SRBFL;
end;

procedure TTInherit.ADODataSet1AfterEdit(DataSet: TDataSet);
begin
 if Form3.dj>='R' then  ADODataSet1.Cancel;
end;

procedure TTInherit.FormActivate(Sender: TObject);
begin
Screen.Cursor:=crDefault;
end;

procedure TTInherit.BBCreate(Sender: TObject);
begin
// NDCsJPEG.RaveRegister; //****Rave报表注册Jpeg组件****
end;
procedure TTInherit.N1Click(Sender: TObject);
begin
Image1DblClick(Image1);//加载图
end;

procedure TTInherit.N3Click(Sender: TObject);
begin
if Msg1('真清除图片吗?','警告',MB_OKCANCEL)<>MrOk then exit;
Image1DblClick(ToolButton14);//清除图
end;

procedure TTInherit.N2Click(Sender: TObject);
begin
if not SavePictureDialog1.Execute then exit;
if LowerCase(ExtractFileExt(SavePictureDialog1.FileName))='.bmp' then begin
b.Assign(Image1.Picture.Graphic);
b.SaveToFile(SavePictureDialog1.FileName);
end else begin
j.Assign(Image1.Picture.Graphic);
j.SaveToFile(SavePictureDialog1.FileName);
end;
end;

procedure TTInherit.DBGrid1Exit(Sender: TObject);
begin
if not IMEOPen then exit;
keybd_event(VK_Control,0,0,0);
keybd_event(ord(' '),0,0,0);
keybd_event(ord(' '),0,KEYEVENTF_KEYUP,0);
keybd_event(VK_Control,0,KEYEVENTF_KEYUP,0);
end;

procedure TTInherit.DBGrid1KeyUp(Sender: TObject; var Key: Word;
  Shift: TShiftState);
begin
MyHKL:=GetKeyboardLayout(0);IMEopen:=ImmIsIme(MyHKL);//要引用打开状态
end;

end.