u_globalproc.pas

一个简单的学籍管理软件

    if DbiGetFieldDescs(Table.Handle, pFields) <> DBIERR_NONE then
      Exit;
    Inc(pFields, Field.Index);
    if (Length(Rec.szName) > 0) then
      pFields^.szName := Rec.szName;
    if (Rec.iType > 0) then
      pFields^.iFldType := Rec.iType;
    if (Rec.iSubType > 0) then
      pFields^.iSubType := Rec.iSubType;
    if (Rec.iLength > 0) then
      pFields^.iUnits1 := Rec.iLength;
    if (Rec.iPrecision > 0) then
      pFields^.iUnits2 := Rec.iPrecision;
    Dec(pFields, Field.Index);
    for B := 1 to Table.FieldCount do
    begin
      pFields^.iFldNum := B;
      Inc(pFields, 1);
    end;
    Dec(pFields, Table.FieldCount);

    FillChar(TableDesc, sizeof(TableDesc), #0);
    if DbiGetObjFromObj(hDBIObj(Table.Handle), objDATABASE, hDBIObj(hDb)) <> DBIERR_NONE then
      Exit;

    StrPCopy(TableDesc.szTblName, Table.TableName);
    StrPCopy(TableDesc.szTblType, Props.szTableType);
    TableDesc.iFldCount := Table.FieldCount;

    TableDesc.pecrFldOp := pOp;
    TableDesc.pFldDesc := pFields;
    Table.Close;
    if DbiDoRestructure(hDb, 1, @TableDesc, nil, nil, nil, False) = DBIERR_NONE then
      Result := True;
  finally
    if (pFields <> nil) then
      FreeMem(pFields);
    if (pOp <> nil) then
      FreeMem(pOp);
  end;
end;

//删除字段

function DropField(Table: TTable; Field: TField): Boolean;
var
  Props: CURProps;
  hDb: hDBIDb;
  TableDesc: CRTblDesc;
  pFields: pFLDDesc;
  pOp: pCROpType;
  sFld, dFld: pFLDDesc;
  B: Byte;
begin
  Result := False;
  if not Table.Active then
    Exit;
  if not Table.Exclusive then
    Exit;

  if DbiSetProp(hDBIObj(Table.Handle), curxltMODE, Integer(xltNONE)) <> DBIERR_NONE then
    Exit;
  if DbiGetCursorProps(Table.Handle, Props) <> DBIERR_NONE then
    Exit;

  if (Props.szTableType <> szPARADOX) and (Props.szTableType <> szDBASE) then
    Exit;

  // 分配字段定义内存
  pFields := AllocMem(Table.FieldCount * sizeof(FLDDesc));
  sFld := pFields;
  dFld := pFields;
  Inc(sFld, Field.Index + 1);
  Inc(dFld, Field.Index);
  // 分配操作定义内存
  pOp := AllocMem(Table.FieldCount * sizeof(CROpType));
  try
    if DbiGetFieldDescs(Table.Handle, pFields) <> DBIERR_NONE then
      Exit;
    if Field.Index + 1 < Table.FieldCount then
      Move(sFld^, dFld^, (Table.FieldCount - Field.Index - 1) *
        Sizeof(FLDDesc));
    for B := 1 to Field.Index do
    begin
      pFields^.iFldNum := B;
      Inc(pFields, 1);
      Inc(pOp, 1);
    end;

    for B := Field.Index + 1 to Table.FieldCount - 1 do
    begin
      pFields^.iFldNum := B + 1;
      pOp^ := crCopy;
      Inc(pFields, 1);
      Inc(pOp, 1);
    end;
//    pFields^.iFldNum := 0;
    Dec(pFields, Table.FieldCount - 1);
    Dec(pOp, Table.FieldCount - 1);

    FillChar(TableDesc, sizeof(TableDesc), #0);
    if DbiGetObjFromObj(hDBIObj(Table.Handle), objDATABASE, hDBIObj(hDb)) <> DBIERR_NONE then
      Exit;

    StrPCopy(TableDesc.szTblName, Table.TableName);
    StrPCopy(TableDesc.szTblType, Props.szTableType);
    TableDesc.iFldCount := Table.FieldCount - 1;

    TableDesc.pecrFldOp := pOp;
    TableDesc.pFldDesc := pFields;
    Table.Close;
    if DbiDoRestructure(hDb, 1, @TableDesc, nil, nil, nil, False) = DBIERR_NONE then
      Result := True;
  finally
    if (pFields <> nil) then
      FreeMem(pFields);
    if (pOp <> nil) then
      FreeMem(pOp);
  end;
end;

function DelDirFile(DirName: string): Boolean; //删除目录中的文件
var
  SearchRec: TSearchRec;
  tmName: string;
begin
  FindFirst(DirName + '\*.*', faAnyFile, SearchRec);
  repeat
    tmName := SearchRec.Name;
    if not ((SearchRec.Name = '.') or (SearchRec.Name = '..')) then
    begin
      if (SearchRec.Attr and faDirectory) <> 0 then
        DelDirFile(DirName + '\' + tmName)
      else
        DeleteFile(PChar(DirName + '\' + SearchRec.Name));
    end;
    FindNext(SearchRec);
  until tmName = SearchRec.Name;
  SysUtils.FindClose(SearchRec);
  Result := RemoveDir(DirName);
end;

function MoveDirFile(SDir, DDir: string): Boolean;
var
  SearchRec: TSearchRec;
  tmName: string;
begin
  FindFirst(SDir + '\*.*', faAnyFile, SearchRec);
  CreateDir(DDir);
  repeat
    tmName := SearchRec.Name;
    if not ((SearchRec.Name = '.') or (SearchRec.Name = '..')) then
    begin
      if (SearchRec.Attr and faDirectory) <> 0 then
      begin
        MoveDirFile(SDir + '\' + tmName, DDir + '\' + tmName)
      end
      else
      begin
        CopyFile(PChar(SDir + '\' + SearchRec.Name),
          PChar(DDir + '\' + SearchRec.Name), False);
        DeleteFile(PChar(SDir + '\' + SearchRec.Name));
      end;
    end;
    FindNext(SearchRec);
  until tmName = SearchRec.Name;
  SysUtils.FindClose(SearchRec);
  Result := RemoveDir(SDir);
end;

procedure Show_InfoMess(Msg: string); //显示提示信息框
begin
  Application.MessageBox(PChar(Msg), '运行信息', MB_OK + MB_ICONINFORMATION);
end;

procedure Show_ErrorMess(Msg: string); //显示错误信息框
begin
  Application.MessageBox(PChar(Msg), '错误', MB_OK + MB_ICONERROR);
end;

procedure Show_WarningMess(Msg: string); //显示警告信息框
begin
  Application.MessageBox(PChar(Msg), '警告', MB_OK + MB_ICONWARNING);
end;

function Show_ConfirmMess(Msg: string): Boolean; //显示确认信息框
begin
  MessageBeep(0);
  Result := Application.MessageBox(PChar(Msg), '注意', MB_YESNO + MB_ICONQUESTION) = IDYES;
end;

function MaxDays(Year, Month: Word): Word;
begin
  case Month of
    4, 6, 9, 11: Result := 30; //小月
    2: //能被4整除、不能被100整除，但如果能被400整除也是闰月
      if ((Year mod 4 = 0) and (Year mod 100 <> 0)) or
        (Year mod 400 = 0) then
        Result := 29
      else
        Result := 28;
  else
    Result := 31; //大月
  end;
end;

function IntFormatStr(aValue: integer; aCount: integer): string;
begin
  Result := StringOfChar('0', aCount) + IntToStr(aValue);
  Result := Copy(Result, Length(Result) - aCount + 1, aCount);
end;

procedure GridInfoGetCaption(Sender: TObject; PgChapter,
  PageNumber: Integer; var Caption: string);
var
  tmS01: string;
  iBs: integer;
begin //  取表头、表尾附加信息数据
  iBs := Pos('(&单位)', Caption);
  if iBs > 0 then
  begin
    tmS01 := Copy(Caption, 1, iBs - 1);
    tmS01 := tmS01 + U_GlobalVar.S_SchoolName;
    tmS01 := tmS01 + Copy(Caption, iBs + 7, Length(Caption) - iBs - 6);
    Caption := tmS01;
  end;
  iBs := Pos('(&制表)', Caption);
  if iBs > 0 then
  begin
    tmS01 := Copy(Caption, 1, iBs - 1);
    tmS01 := tmS01 + U_GlobalVar.S_UserName;
    tmS01 := tmS01 + Copy(Caption, iBs + 7, Length(Caption) - iBs - 6);
    Caption := tmS01;
  end;
end;

type
  THGridCreak = class(THCustomDBGrid);

procedure RefreshGridStyle(Sender: TObject);
var
  aGrid: THGridCreak;
  i: integer;
begin
  aGrid := THGridCreak(Sender);
  with GridStyles do
  begin
    aGrid.Color := GroundColor; //  表格底色
    aGrid.Font.Color := FontColor; //  表格字体颜色
    aGrid.LineColor := LineColor; //  表格线颜色
    aGrid.LimitedColor := LmtColColor; //  固定列颜色
    aGrid.CurRowHighLight := CurRowHiLight; //  当前行高亮显示
    aGrid.CurRowColor := CurRowColor; //  当前行颜色
    aGrid.CurRowTextColor := CurFntColor; //  当前行字体颜色
    aGrid.RowAlternate := RowAlter; //  行颜色交错显示
    aGrid.RowAlternateColor := AlterColor; //  交错行颜色
    if ShowMoneyLine then
      aGrid.Options := aGrid.Options + [hgMoneyLine] //  显示金额线
    else
      aGrid.Options := aGrid.Options - [hgMoneyLine]; //  显示金额线
    for i := 0 to aGrid.Columns.Count - 1 do
    begin
      if aGrid.Columns[i].MoneyLine then
      begin
        aGrid.Columns[i].CommLineColor := CommLineColor; //  一般分隔线颜色
        aGrid.Columns[i].DecLineColor := DotLineColor; //  小数位分隔线颜色
        aGrid.Columns[i].KiloLineColor := KiloLineColor; //  千位分隔线颜色
        aGrid.Columns[i].LeftLineColor := LeftLineColor; //  左边线颜色
      end;
      if DblRightLine and (aGrid.LimitedCol > 0) and (i = aGrid.LimitedCol - 1) then
        aGrid.Columns[i].RightDouble := True
      else
        aGrid.Columns[i].RightDouble := False;
    end;
    aGrid.VertToBound := VertToBound; //  竖线显示到底
    aGrid.HorzToBound := HorzToBound; //  横线显示到边
  end;
end;

//  生成年级树 aMode -- 0 基本   1 -- 扩展  2 -- 年级  hasBase -- 有单位节点
procedure MakeGradeTree(aTreeView: TTreeView; aMode: integer; HasBase: Boolean);
var
  aQuery: TQuery;
  i: integer;
  GNodeNames: array of string;
  bsNode, upNode: TTreeNode;
  tmGradeStr: string;
begin
  aTreeView.Items.Clear;
  bsNode := nil;
  if HasBase then
    bsNode := aTreeView.Items.AddChildObject(nil, S_SchoolName, nil);
  aQuery := TQuery.Create(Application);
  with aQuery do
  begin
    DataBaseName := DataDBase;
    SQL.Text := 'SELECT s_bjhao, s_bjmcheng FROM bj WHERE s_bjhao LIKE :ps_bjhao';
  end;
  try
    SetLength(GNodeNames, SI_GradeCount);
    for i := 0 to SI_GradeCount - 1 do
    begin
      GNodeNames[i] := GradeNames[i] + '年级';
      upNode := aTreeView.Items.AddChildObject(bsNode, GNodeNames[i], Pointer(W_CurYear - i));
      if aMode <> 2 then
      begin
        tmGradeStr := S_SchoolCode + IntToStr(W_CurYear - i);
        with aQuery do
        try
          ParamByName('ps_bjhao').AsString := tmGradeStr + '%';
          Prepare;
          Open;
          while not Eof do
          begin
            aTreeView.Items.AddChildObject(upNode, FieldByName('s_bjmcheng').AsString,
              Pointer(FieldByName('s_bjhao').AsInteger));
            Next;
          end;
        finally
          Close;
        end;
      end;
    end;
    if aMode = 1 then
    begin
      SetLength(GNodeNames, SI_GradeCount + 3);
      for i := SI_GradeCount to SI_GradeCount + 2 do
      begin
        GNodeNames[i] := IntToStr(W_CurYear - i) + '级';
        upNode := aTreeView.Items.AddChildObject(bsNode, GNodeNames[i], Pointer(W_CurYear - i));
        tmGradeStr := S_SchoolCode + IntToStr(W_CurYear - i);
        with aQuery do
        try
          ParamByName('ps_bjhao').AsString := tmGradeStr + '%';
          Prepare;
          Open;
          while not Eof do
          begin
            aTreeView.Items.AddChildObject(upNode, FieldByName('s_bjhao').AsString + '班',
              Pointer(FieldByName('s_bjhao').AsInteger));
            Next;
          end;
        finally
          Close;
        end;
      end;
    end;
  finally
    aQuery.Close;
    aQuery.Free;
  end;
end;

procedure RefreshGridColumns(MGrid: THDBGrid; TableName: string;
  GetEvent: TFieldGetTextEvent; SetEvent: TFieldSetTextEvent);
var
  aColumn: THColumn;
  aField: TField;
  aDataSet: TDataSet;
  OldDS: TDataSource;
  DQuery, CQuery: TQuery;
  tmS: string;
  Meters, InType: integer;
  TM: TTextMetric;

  function FillGridColumns: integer;
  begin
    GetTextMetrics(MGrid.Canvas.Handle, TM);
    Meters := MGrid.Canvas.TextWidth('0') - TM.tmOverhang;
    Result := 0;

    with DQuery do
    try
      while not Eof do
      begin
        aField := aDataSet.FindField(FieldbyName('FieldName').AsString);
        if Assigned(aField) then
        begin
          aColumn := MGrid.Columns.Add;
          Inc(Result);
          with aColumn do
          begin
            Fieldname := Trim(FieldbyName('FieldName').AsString);
            Title.Caption := Trim(FieldbyName('DisplayLabel').AsString);
            Width := FieldbyName('DisplayWidth').AsInteger * Meters +
              TM.tmOverhang + 4;
          end;
          tmS := FieldbyName('FieldType').AsString;
          if tmS = 'D' then
            (aField as TDateField).DisplayFormat := 'yyyy-mm-dd'
          else if tmS = 'T' then
            (aField as TDateField).DisplayFormat := 't'
          else if (tmS = 'N') then
            (aField as TNumericField).DisplayFormat := '#,##0.00'
          else if (tmS = 'S') or (tmS = 'I') then
            aField.Tag := 0;
          //  对照字段
          InType := FieldbyName('InputType').AsInteger;
          if InType = 2 then
          begin
            aField.OnGetText := GetEvent;
            aField.OnSetText := SetEvent;