main.pas

适合Delphi初学者使用。其中涉及XML文件导入

unit Main;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, GridsEh, DBGridEh, ExtCtrls, StdCtrls, DB, ADODB, Menus,
  ExcelXP, OleServer, xmldom, XMLIntf, msxmldom, XMLDoc;

type
  TfrmMain = class(TForm)
    Panel1: TPanel;
    Panel2: TPanel;
    gridCustomer: TDBGridEh;
    Label1: TLabel;
    comFind: TComboBox;
    Label2: TLabel;
    edtValue: TEdit;
    btnLocate: TButton;
    btnFilter: TButton;
    btnShowAll: TButton;
    btnImport: TButton;
    btnExport: TButton;
    btnAdd: TButton;
    btnDel: TButton;
    btnSave: TButton;
    btnPrint: TButton;
    btnSet: TButton;
    PopupMenu1: TPopupMenu;
    PopupMenu2: TPopupMenu;
    PopupMenu3: TPopupMenu;
    btnClear: TButton;
    pmFontSet: TMenuItem;
    pmGridWidth: TMenuItem;
    pmPrintSet: TMenuItem;
    pmImportExecl1: TMenuItem;
    pmImportOldDoc: TMenuItem;
    pmImportFile: TMenuItem;
    ExcelApplication1: TExcelApplication;
    ExcelWorksheet1: TExcelWorksheet;
    ExcelWorkbook1: TExcelWorkbook;
    InXMLDoc: TXMLDocument;
    btnShopAdmin: TButton;
    btnFirst: TButton;
    btnLast: TButton;
    pmFirstColor: TMenuItem;
    pmSecondColor: TMenuItem;
    pmExportExcel: TMenuItem;
    pmExportFile: TMenuItem;
    btnReLogin: TButton;
    btnTurnShop: TButton;
    laShop: TLabel;
    pmExcelSet: TMenuItem;
    pmDelSpace: TMenuItem;
    procedure gridCustomerGetCellParams(Sender: TObject; Column: TColumnEh;
      AFont: TFont; var Background: TColor; State: TGridDrawState);
    procedure btnLocateClick(Sender: TObject);
    procedure btnFilterClick(Sender: TObject);
    procedure btnShowAllClick(Sender: TObject);
    procedure gridCustomerTitleClick(Column: TColumnEh);
    procedure FormCreate(Sender: TObject);
    procedure btnDelClick(Sender: TObject);
    procedure btnClearClick(Sender: TObject);
    procedure btnSaveClick(Sender: TObject);
    procedure btnPrintClick(Sender: TObject);
    procedure btnImportClick(Sender: TObject);
    procedure btnExportClick(Sender: TObject);
    procedure btnSetClick(Sender: TObject);
    procedure pmFontSetClick(Sender: TObject);
    procedure pmGridWidthClick(Sender: TObject);
    procedure pmPrintSetClick(Sender: TObject);
    procedure pmImportExecl1Click(Sender: TObject);
    procedure pmImportOldDocClick(Sender: TObject);
    procedure btnAddClick(Sender: TObject);
    procedure btnFirstClick(Sender: TObject);
    procedure btnLastClick(Sender: TObject);
    procedure pmFirstColorClick(Sender: TObject);
    procedure pmSecondColorClick(Sender: TObject);
    procedure pmExportExcelClick(Sender: TObject);
    procedure pmExportFileClick(Sender: TObject);
    procedure pmImportFileClick(Sender: TObject);
    procedure btnReLoginClick(Sender: TObject);
    procedure btnShopAdminClick(Sender: TObject);
    procedure btnTurnShopClick(Sender: TObject);
    procedure pmExcelSetClick(Sender: TObject);
    procedure pmDelSpaceClick(Sender: TObject);
  private
    { Private declarations }
    procedure init;
    procedure InitData;
    procedure InitGrid;
    procedure InitButton;
  public
    { Public declarations }
  end;

var
  frmMain: TfrmMain;

implementation

uses gendm, genFunc, IniFiles, RegExpr, RM_Class, ExcelMessage, Login,
  InfoShop, TurnShop, ExcelImportColSet;

{$R *.dfm}

procedure TfrmMain.gridCustomerGetCellParams(Sender: TObject;
  Column: TColumnEh; AFont: TFont; var Background: TColor;
  State: TGridDrawState);
begin
  if gridCustomer.SumList.RecNo mod 2 = 1 then
  begin
    Background := FIRSTCOLOR;
//    sncDBCurrencyInplaceEdit.Color := FIRSTCOLOR;
  end
  else
  begin
    Background := SECOUNDCOLOR;
//    sncDBCurrencyInplaceEdit.Color := SECOUNDCOLOR;
  end;
end;

procedure TfrmMain.btnLocateClick(Sender: TObject);
const
  sFieldName: array[0..3] of string = ('Name', 'VIP', 'Tel', 'Remark');
var
  str: string;
begin

  str := Trim(edtValue.Text);
  if str = '' then
  begin
    Exit;
  end;
  DM.QueCustomer.Locate(sFieldName[comFind.ItemIndex], str, [loCaseInsensitive, loPartialKey]);
end;

procedure TfrmMain.btnFilterClick(Sender: TObject);
const
  sFieldName: array[0..3] of string = ('Name', 'VIP', 'Tel', 'Remark');
var
  str: string;
  iID: Integer;
begin
  iID := -1;
  str := Trim(edtValue.Text);
  if str = '' then
  begin
    Exit;
  end;
  if DM.QueCustomer.RecordCount > 0 then
  begin
    iID := DM.QueCustomer.FieldByName('ID').AsInteger;
  end;
  DM.QueCustomer.Filter := sFieldName[comFind.ItemIndex] + ' like ' + QuotedStr('%' + str + '%');
  DM.QueCustomer.Filtered := True;
  if iID > 0 then
  begin
    DM.QueCustomer.Locate('ID', iID, [loCaseInsensitive]);
  end;
end;

procedure TfrmMain.btnShowAllClick(Sender: TObject);
var
  iID: Integer;
begin
  iID := -1;
  if DM.QueCustomer.RecordCount > 0 then
  begin
    iID := DM.QueCustomer.FieldByName('ID').AsInteger;
  end;
  DM.QueCustomer.Filtered := False;
  if iID > 0 then
  begin
    DM.QueCustomer.Locate('ID', iID, [loCaseInsensitive]);
  end;
end;

procedure TfrmMain.gridCustomerTitleClick(Column: TColumnEh);
var
  ii: integer;
  bUp: boolean;
  strFieldName: string;
  iID: Integer;
begin
  if DM.QueCustomer.RecordCount = 0 then
  begin
    Exit;
  end;
  iID := DM.QueCustomer.FieldByName('ID').AsInteger;
  strFieldName := Column.FieldName;
  if UpperCase(strFieldName) = 'VIP' then
  begin
    strFieldName := 'RealVIP';
  end;
  if DM.QueCustomer.FieldByName(strFieldName).FieldKind = fkData then
  begin
    if Column.Title.SortMarker = smUpEh then bUp := true else bUp := false;
    for ii := 0 to gridCustomer.Columns.Count - 1 do
    begin
      gridCustomer.Columns[ii].Title.SortMarker := smNoneEh;
    end;

    if bUp then
    begin
      Column.Title.SortMarker := smDownEh;
      DM.QueCustomer.Sort := strFieldName + ' DESC';
    end
    else
    begin
      Column.Title.SortMarker := smUpEh;
      DM.QueCustomer.Sort := strFieldName + ' ASC';
    end;
  end;
  DM.QueCustomer.Locate('ID', iID, [loCaseInsensitive]);
end;

procedure TfrmMain.init;
begin
  InitData;
  InitGrid;
  InitButton;
end;

procedure TfrmMain.InitData;
var
  sSQL: string;
begin
  laShop.Caption := gUserInfo.sCustomer;
  if gUserInfo.sCustomer = '全部客户' then
  begin
    sSQL := 'select * from Customer order by RealVIP';
  end
  else
  begin
    sSQL := 'select * from Customer where Shop = ' + QuotedStr(gUserInfo.sCustomer) + ' order by RealVIP';
  end;
  SetAdoQue(DM.QueCustomer, sSQL);
  gridCustomer.Columns[2].Title.SortMarker := smUpEh;
  //gridCustomer.Columns.
end;

procedure TfrmMain.InitGrid;
var
  ini: TIniFile;
  strWidth: string;
  arrWidth: TStrings;
  i: Integer;
  reg: TRegExpr;
  strFont: string;
begin
  ini := TIniFile.Create(gUserInfo.sAppPath + 'config.ini');
  if ini.ValueExists(gUserInfo.sTitle, 'FIRSTCOLOR') then
  begin
    FIRSTCOLOR := TColor(ini.ReadInteger(gUserInfo.sTitle, 'FIRSTCOLOR', $00B5E8E8));
  end;
  if ini.ValueExists(gUserInfo.sTitle, 'SECOUNDCOLOR') then
  begin
    SECOUNDCOLOR := TColor(ini.ReadInteger(gUserInfo.sTitle, 'SECOUNDCOLOR', $00B9E3D7));
  end;
  if ini.ValueExists(gUserInfo.sTitle, 'GridWidth') then
  begin
    strWidth := ini.ReadString(gUserInfo.sTitle, 'GridWidth', '89;236;139;264;153');
    arrWidth := TStringList.Create;
    reg := TRegExpr.Create;
    reg.Expression := ';';
    reg.Split(strWidth, arrWidth);
    for i := 0 to arrWidth.Count - 1 do
    begin
      if i >= gridCustomer.Columns.Count then
      begin
        Break;
      end;
      gridCustomer.Columns[i].Width := StrToIntEx(arrWidth[i]);
    end;
    arrWidth.Free;
    reg.Free;
  end;
  if ini.ValueExists(gUserInfo.sTitle, 'GridFont') then
  begin
    strFont := ini.ReadString(gUserInfo.sTitle, 'GridFont', '"新宋体",15,[],-16777208,134');
    StringToFont(strFont, gridCustomer.Font);
  end;
  ini.Free;
end;

procedure TfrmMain.FormCreate(Sender: TObject);
begin
  init;
end;

procedure TfrmMain.InitButton;
begin

  btnAdd.Enabled := False;
  btnImport.Enabled := False;
  btnSave.Enabled := False;
  btnDel.Enabled := False;
  btnClear.Enabled := False;
  btnShopAdmin.Enabled := False;
  btnTurnShop.Enabled := False;
  gridCustomer.Options := gridCustomer.Options - [dgEditing];
  gridCustomer.Columns[0].Visible := False;
  pmDelSpace.Enabled := False;
  pmExcelSet.Enabled := False;
  if gUserInfo.sCustomer = '全部客户' then
  begin
    gridCustomer.Columns[0].Visible := True;
    if gUserInfo.iLoginRole > 1 then
    begin
      btnSave.Enabled := True;
      btnTurnShop.Enabled := True;
    end;
    Exit;
  end;
  if gUserInfo.iLoginRole > 0 then
  begin
    btnAdd.Enabled := True;
    btnImport.Enabled := True;
    btnSave.Enabled := True;
    gridCustomer.Options := gridCustomer.Options + [dgEditing];
    pmDelSpace.Enabled := True;
    pmExcelSet.Enabled := True;
  end;
  if gUserInfo.iLoginRole > 1 then
  begin
    btnDel.Enabled := True;
    btnClear.Enabled := True;
    btnShopAdmin.Enabled := True;
    btnTurnShop.Enabled := True;

  end;

end;

procedure TfrmMain.btnDelClick(Sender: TObject);
begin
  DeleteOneADORecord(DM.QueCustomer);
end;

procedure TfrmMain.btnClearClick(Sender: TObject);
begin
  if Application.MessageBox(PChar('真的要全部删除资料？'), PChar('询问'), MB_YESNO) = IDNo then
  begin
    Exit;
  end;
  DeleteAllADORecord(DM.QueCustomer);
end;

procedure TfrmMain.btnSaveClick(Sender: TObject);
begin
  DoAdoqueryPost(DM.QueCustomer);
end;

procedure TfrmMain.btnPrintClick(Sender: TObject);
begin
  DM.RMGridReport1.LoadFromFile(gUserInfo.sAppPath + 'rep.rls');
  DM.RMGridReport1.PrepareReport;
  DM.RMGridReport1.PrintPreparedReport('', 1, true, rmppAll);
end;

procedure TfrmMain.btnImportClick(Sender: TObject);
var
  iPoint: TPoint;
begin
  if GetCursorPos(iPoint) then
  begin
    PopupMenu1.Popup(iPoint.X, iPoint.Y);
  end;
end;

procedure TfrmMain.btnExportClick(Sender: TObject);
var
  iPoint: TPoint;
begin
  if GetCursorPos(iPoint) then
  begin
    PopupMenu2.Popup(iPoint.X, iPoint.Y);
  end;
end;

procedure TfrmMain.btnSetClick(Sender: TObject);
var
  iPoint: TPoint;
begin
  if GetCursorPos(iPoint) then
  begin
    PopupMenu3.Popup(iPoint.X, iPoint.Y);
  end;
end;

procedure TfrmMain.pmFontSetClick(Sender: TObject);
begin
  with TFontDialog.Create(Self) do
  begin
    Font := gridCustomer.Font;
    if Execute then
    begin
      gridCustomer.Font := Font;
      ReadInifileString('GridFont', FontToString(Font), 2);
    end;
  end;
end;

procedure TfrmMain.pmGridWidthClick(Sender: TObject);
var
  i, iCount: Integer;
  strWidth: string;

begin
  iCount := gridCustomer.Columns.Count;
  strWidth := IntToStr(gridCustomer.Columns[0].Width);
  for i := 1 to iCount - 1 do
  begin
    strWidth := strWidth + ';' + IntToStr(gridCustomer.Columns[i].Width);
  end;
  ReadInifileString('GridWidth', strWidth, 2);
end;

procedure TfrmMain.pmPrintSetClick(Sender: TObject);
begin
  DM.RMGridReport1.DesignReport;
end;

procedure TfrmMain.pmImportExecl1Click(Sender: TObject);
var

  sFileName, sTemp, sSQL: string;
  iCount, iNo, iRow, i: Integer;
  bTel, bRemark: Boolean;
  iVip, iName, iTel, iRemark: Integer;
  iniFile: TIniFile;
begin
  if not ShowExcelMessage(sFileName, iNo, iRow) then
  begin
    Exit;
  end;
  try
    Screen.Cursor := crHourGlass;
    iniFile := TIniFile.Create(gUserInfo.sAppPath + 'config.ini');
    bTel := iniFile.ReadBool(gUserInfo.sTitle, 'ExcelTel', False);