unit_public_1.pas

一个不错的源程序DELPHI开发的,功能比较好的客户管理系统

    1:
    begin
      with Tbarseries.Create(Aparent) do  //直方图
      begin
        ParentChart:=Achart;

        OldTimeSepa := TimeSeparator;
        TimeSeparator := '_';
        name:='series'+TimeToStr(time);
        TimeSeparator := OldTimeSepa ;

        title:=Atitle;
        DataSource:=Atable;
        XLabelsSource:=x;
        YValues.ValueSource:=y;
        CheckDatasource;
        Marks.Style:=smsValue;
      end;
    end;
    2:
    begin
      with Tpieseries.Create(Aparent) do  //圆饼图
      begin
        ParentChart:=Achart;

        OldTimeSepa := TimeSeparator;
        TimeSeparator := '_';
        name:='series'+TimeToStr(time);
        TimeSeparator := OldTimeSepa ;

        title:=Atitle;
        DataSource:=Atable;
        XLabelsSource:=x;
        YValues.ValueSource:=y;
        CheckDatasource;
        Marks.Style:=smsLabelValue;
      end;
    end;
  end;
end;

{
*******************************************************************
* 作者：陈庭昀        编写日期：2001-08-12                        *
*                                                                 *
* 函数：GF_ImportData                                               *
* 功能：将StringGrid、DBGrid组合中的值传至Excel文件中             *
* 参数：FileName      导出至Excel的文件名                         *
*       ReportTitle   报表标题名                                  *
* 返回值：无                                                      *
*                                                                 *
* 基本要求：系统必须按装Excel应用软件                             *
*                                                                 *
* 可导出文件：DBF、TXT、XLS                                       *
*                                                                 *
*修改历史：                                                       *
   2002.01.22日 把函数名称修改为现在名称，原来的名称为ExportExcel *

*******************************************************************
}
Function GF_ExportData(FileName     : String ; //数据导出的文件名，
                      ReportTitle  : String ; //到处报表的标题
                      ObjectSource : TObject  //导出的数据源的存放地
                      ):Boolean;              //导出成功 - true 导出错误 - false
Var
   ExcelSaveDialog:TSaveDialog;
   eclApp,WorkBook:Variant;
   xlsFileName:String;
   ColNumber,RowNumber:Integer;
   Msg:String;
   tmptable : TTable;
   OutDir :string;
   OutFileName :TFileName;
   tmpfieldname : string;
begin

  Application.CreateForm(TSaveDialog,ExcelSaveDialog);

  ExcelSaveDialog.Filter:='Microsoft Excel 工作簿|*.xls|DBF文件格式|*.dbf|文本文件格式|*.txt';
  ExcelSaveDialog.FileName:=FileName;

  Result := False ; //加入返回默认的值，防止出现警告，add by zengzc 2002.01.21

  If Not ExcelSaveDialog.Execute Then
    Exit ;

  case ExcelSaveDialog.FilterIndex of
  1://xls
  begin
      If Pos('.xls',LowerCase(ExcelSaveDialog.FileName))=0 Then
        xlsFileName:=ExcelSaveDialog.FileName+'.xls'
      Else
        xlsFileName:=ExcelSaveDialog.FileName;
  If FileExists(xlsFileName) Then
    Begin
      Msg:=xlsFileName+'已经存在，您确定替换原来的文件吗？';
      If Application.MessageBox(Pchar(Msg),'确认文件替换',MB_ICONINFORMATION+MB_YESNO)=IDNO Then
        Exit
      Else
        If Not DeleteFile(xlsFileName) Then
          Application.MessageBox('不能正确操作该文件。可能是该文件已被其他程序打开, 或系统错误','提示',MB_ICONINFORMATION);
    End;

    Try
      eclApp:=CreateOleObject('Excel.Application');
      WorkBook:=CreateOleobject('Excel.Sheet');
    Except
      Application.MessageBox('您的机器里未安装Microsoft Excel。','提示',MB_ICONINFORMATION);
      Exit;
    End;
    Try
      WorkBook:=eclApp.workBooks.Add;
      eclApp.Cells(1,1):=ReportTitle;
      If ObjectSource is TStringGrid Then
        For ColNumber:=0 To TStringGrid(ObjectSource).ColCount-1 Do
          For RowNumber:=0 To TStringGrid(ObjectSource).RowCount-1 Do
            eclApp.Cells(RowNumber+2,ColNumber+1):=TStringGrid(ObjectSource).Cells[ColNumber,RowNumber];
            If ObjectSource Is TDBGrid Then
              Begin
                {将DBGrid列标题名写入Excel文件中}
                For ColNumber:=0 To TDBGrid(ObjectSource).Columns.Count-1 Do
                  eclApp.Cells(2,ColNumber+1):=TDBGrid(ObjectSource).Columns.Items[ColNumber].Title.Caption;
                {将DBGrid中的记录写入Excel文件中}
                RowNumber:=3;
                If Not ((TDBGrid(ObjectSource).DataSource.DataSet.Eof) And (TDBGrid(ObjectSource).DataSource.DataSet.Bof)) Then
                  Begin
                    TDBGrid(ObjectSource).DataSource.DataSet.First;
                    While Not TDBGrid(ObjectSource).DataSource.DataSet.Eof Do
                      Begin
                        For ColNumber:=0 To TDBGrid(ObjectSource).Columns.Count-1 Do
                          eclApp.Cells(RowNumber,ColNumber+1):=TDBGrid(ObjectSource).DataSource.DataSet.FieldByName(TDBGrid(ObjectSource).Columns.Items[ColNumber].FieldName).AsString;
                        RowNumber:=RowNumber+1;
                        TDBGrid(ObjectSource).DataSource.DataSet.Next;
                      End;
                   End;
              end;
          WorkBook.saveas(xlsFileName);
          WorkBook.close;
          eclApp.Quit;
          eclApp:=Unassigned;
          Msg:='数据导出成功，存放在'+xlsFileName;
          Application.MessageBox(Pchar(Msg),'提示',MB_ICONINFORMATION);
          Result:=True;
       except
          Msg:='不能正确操作Excel文件。可能是该文件已被其他程序打开, 或系统错误。';
          Application.MessageBox(Pchar(Msg),'提示',MB_ICONINFORMATION);
          WorkBook.close;
          eclApp.Quit;
          eclApp:=Unassigned;
          Result:=False;
       end;
       ExcelSaveDialog.free;
     end;
   2://dbf;
     begin
      If Pos('.dbf',LowerCase(ExcelSaveDialog.FileName))=0 Then
        xlsFileName:=ExcelSaveDialog.FileName+'.dbf'
      Else
        xlsFileName:=ExcelSaveDialog.FileName;
  If FileExists(xlsFileName) Then
    Begin
      Msg:=xlsFileName+'已经存在，您确定替换原来的文件吗？';
      If Application.MessageBox(Pchar(Msg),'确认文件替换',MB_ICONINFORMATION+MB_YESNO)=IDNO Then
        Exit
      Else
        If Not DeleteFile(xlsFileName) Then
          Application.MessageBox('不能正确操作该文件。可能是该文件已被其他程序打开, 或系统错误','提示',MB_ICONINFORMATION);
    End;
         OutDir := '';
      OutFileName := xlsFileName;
       while pos('\',OutFileName)<>0 do
       begin
        OutDir := OutDir + Copy(OutFileName,1,pos('\',OutFileName));
        OutFileName := Copy(OutFileName,pos('\',OutFileName)+1,Length(OutFileName));
      end;

       tmptable := TTable.Create(application);
       with tmptable DO
         begin
           DatabaseName := OutDir;
           TableType :=  ttFoxPro;
           TableName := OutFileName;
         end;
       Try
         If ObjectSource is TStringGrid Then
           begin
             with tmptable do
               begin
                 For ColNumber:=0 To TStringGrid(ObjectSource).ColCount-1 Do
                   begin
                     //clear;
                     with FieldDefs.AddFieldDef do
                       begin
                         Name := 'Field'+inttostr(ColNumber);
                         Size := 250;
                         DataType := ftString;
                       end;
                   end;
                 CreateTable;
               end;
              tmptable.open;
             for RowNumber:=0 to TStringGrid(ObjectSource).RowCount-1 do
               begin
                 tmptable.Insert;
                 For ColNumber:=0 To TStringGrid(ObjectSource).ColCount-1 Do
                   tmptable.FieldByName('field'+inttostr(colnumber)).asstring := TStringGrid(ObjectSource).Cells[ColNumber,RowNumber];
                 tmptable.post;
               end;
           end;
          If ObjectSource Is TDBGrid Then
             Begin
               with tmptable do
                 begin
                   //clear;
                   For ColNumber:=0 To TDBGrid(ObjectSource).Columns.Count - 1 Do
                     begin
                       with FieldDefs.AddFieldDef do
                         begin
                           Name := 'Field'+inttostr(ColNumber);
                           Size := 250;
                           DataType := ftString;
                         end;
                     end;
                  createtable;
                 end;
               tmptable.open;
               {将DBGrid中的记录写入Dbf文件中}
               If Not ((TDBGrid(ObjectSource).DataSource.DataSet.Eof) And (TDBGrid(ObjectSource).DataSource.DataSet.Bof)) Then
                 Begin
                   TDBGrid(ObjectSource).DataSource.DataSet.First;
                   While Not TDBGrid(ObjectSource).DataSource.DataSet.Eof Do
                     Begin
                       tmptable.Insert;
                       For ColNumber:=0 To TDBGrid(ObjectSource).Columns.Count - 1 Do
                         begin
                         tmpfieldname := 'field'+inttostr(colnumber);
                         tmptable.FieldByName(tmpfieldname).asstring := TDBGrid(ObjectSource).DataSource.DataSet.FieldByName(TDBGrid(ObjectSource).Columns.Items[ColNumber].FieldName).AsString;
                         end;
                       tmptable.post;
                       RowNumber:=RowNumber+1;
                       TDBGrid(ObjectSource).DataSource.DataSet.Next;
                     End;
                 End;
             End;
          Msg := '数据导出成功，存放在'+xlsFileName;
          Application.MessageBox(Pchar(Msg), '提示', MB_ICONINFORMATION);
          tmptable.Free;
          Result := True;
       except
          Msg := '不能正确操作DBF文件。可能是该文件已被其他程序打开, 或系统错误。';
          Application.MessageBox(Pchar(Msg), '提示', MB_ICONINFORMATION);
          Result:=False;
       end;
       ExcelSaveDialog.free;
     end;
   3://.txt;
     begin
       If Pos('.txt',LowerCase(ExcelSaveDialog.FileName))=0 Then
         xlsFileName:=ExcelSaveDialog.FileName+'.txt'
       Else
         xlsFileName:=ExcelSaveDialog.FileName;
       If FileExists(xlsFileName) Then
         Begin
           Msg:=xlsFileName+'已经存在，您确定替换原来的文件吗？';
           If Application.MessageBox(Pchar(Msg),'确认文件替换',MB_ICONINFORMATION+MB_YESNO)=IDNO Then
             Exit
           Else
             If Not DeleteFile(xlsFileName) Then
               Application.MessageBox('不能正确操作该文件。可能是该文件已被其他程序打开, 或系统错误','提示',MB_ICONINFORMATION);
         End;
       OutDir := '';
       OutFileName := xlsFileName;
       while pos('\',OutFileName)<>0 do
         begin
           OutDir := OutDir + Copy(OutFileName,1,pos('\',OutFileName));
           OutFileName := Copy(OutFileName,pos('\',OutFileName)+1,Length(OutFileName));
         end;
       try
         AssignFile(Output,OutFileName);
         Rewrite(Output);
         Writeln(ReportTitle);
         Writeln('');
         If ObjectSource is TStringGrid Then
         For RowNumber:=0 To TStringGrid(ObjectSource).RowCount-1 Do
           begin
             For ColNumber:=0 To TStringGrid(ObjectSource).ColCount-1 Do
               begin
                 Write(TStringGrid(ObjectSource).Cells[ColNumber,RowNumber]+'        ');
               end;
             WriteLn('                  ');
           end;
         If ObjectSource Is TDBGrid Then
           Begin
             //将DBGrid列标题名写入Excel文件中}
             For ColNumber:=0 To TDBGrid(ObjectSource).Columns.Count-1 Do
               begin
                 write(TDBGrid(ObjectSource).Columns.Items[ColNumber].Title.Caption+'        ');
                 {将DBGrid中的记录写入Excel文件中}
               end;
             Writeln('               ');
             If Not ((TDBGrid(ObjectSource).DataSource.DataSet.Eof) And (TDBGrid(ObjectSource).DataSource.DataSet.Bof)) Then
               Begin
                 TDBGrid(ObjectSource).DataSource.DataSet.First;
                 While Not TDBGrid(ObjectSource).DataSource.DataSet.Eof Do
                   Begin
                     For ColNumber:=0 To TDBGrid(ObjectSource).Columns.Count-1 Do
                       write(TDBGrid(ObjectSource).DataSource.DataSet.FieldByName(TDBGrid(ObjectSource).Columns.Items[ColNumber].FieldName).AsString+'                ');
                     writeln('           ');
                     RowNumber:=RowNumber+1;
                     TDBGrid(ObjectSource).DataSource.DataSet.Next;
                   End;
               End;
           End;
         CloseFile(Output);
         Msg := '数据导出成功，存放在' + xlsFileName;
         Application.MessageBox(Pchar(Msg), '提示', MB_ICONINFORMATION);
         Result := True;
         except
           Msg := '不能正确操作Txt文件。可能是该文件已被其他程序打开, 或系统错误。';
           Application.MessageBox(Pchar(Msg), '提示', MB_ICONINFORMATION);
           Result:=False;
         end;
         ExcelSaveDialog.free;
        end;
   end;
end;


Function GF_ConnectDB( PS_ConnectUserName : String ) : TDatabase ;
//------------------------------------------------------------------------
//设计时间      : 2002.1.22