untglobalfun.pas

简要说明:对医院幼儿心理情况做的一个调查,统计系统.

unit untGlobalFun;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  DB, Variants, DBGrids, ADODB, ComObj, untGlobalVar, Excel97,
  ComCtrls;

  function MsgQuestion(pInfo: string; pTiTleInfo: string = ''; pDefaultAnswer: string = 'Yes'): Boolean;
  procedure MsgOK(pInfo: string; pTiTleInfo: string = '');
  procedure TranDBGridToExcel(DBGrid: TDBGrid); //将DBGrid数据集转换为Excel
  function ReplaceADOConnection(pSrcStr: AnsiString; pSubStr: string; pValue: string): AnsiString;
  function GetMaxID(AConn: TADOConnection; TableName,FieldName: string): Integer; overload;
  function GetMaxID(TableName,FieldName: string; AConn: TADOConnection; Len: Integer=10): string; overload;
  function GetMaxPatientID(AConn: TADOConnection): string;
  function GetPYCode(HanStr: String) : String;//提取汉字的汉语拼音首字母函数。
  function HasChildren(AConn: TADOConnection; PartID: Integer): Boolean;
  function GetDataSet(AConn: TADOConnection; strSQL: string; AOwner: TComponent = nil): TADODataSet;
  function GetDBValue(AConn: TADOConnection; strSQL: string): Variant;
  procedure OpenDataSet(DataSet: TCustomADODataSet; AConn: TADOConnection; strSQLOrTableName: string);
  procedure ExecDBCommand(AConn: TADOConnection; strSQL: string);
  function GetDataType(AFieldType: TFieldType): TFieldDataType;
  procedure PgcDrawTab(Control: TCustomTabControl;
    TabIndex: Integer; const Rect: TRect; Active: Boolean);
  function PubGetNextLsh(pCode: Integer): String;
  function CheckUserRight(UserID: Integer; FunCode: string): Boolean;
  procedure AddDignoseRecord(AConn: TADOConnection; PatientID: Integer);
  procedure SavePatientResult(PatientID: Integer; adsResult: TADODataSet);
  procedure GetYearMonth(dtBirth: TDate; var BirthYear,BirthMonth: string);

implementation

uses untDM, untSelectRecord;

function MsgQuestion(pInfo: string; pTiTleInfo: string = ''; pDefaultAnswer: string = 'Yes'): Boolean;
begin
  if pTiTleInfo = '' then pTitleInfo := Application.Title;
  if Pos(UpperCase(pDefaultAnswer), 'YES|TRUE') > 0 then
    Result := Application.MessageBox(PChar(pInfo), PChar(pTiTleInfo), MB_YesNo + MB_ICONQuestion +
              MB_DEFBUTTON1) = ID_Yes
  else
    Result := Application.MessageBox(PChar(pInfo), PChar(pTiTleInfo), MB_YesNo + MB_ICONQuestion +
              MB_DEFBUTTON2) = ID_Yes;
end;

procedure MsgOK(pInfo: string; pTiTleInfo: string = '');
begin
  if pTiTleInfo = '' then pTitleInfo := Application.Title;
  Application.MessageBox(PChar(pInfo), PChar(pTiTleInfo), MB_OK+MB_ICONINFORMATION);
end;

procedure TranDBGridToExcel(DBGrid: TDBGrid);
  var BkMk: TBookMarkStr;
      AScroll, BScroll: TDataSetNotifyEvent;
      K, I, Cnt: SmallInt;
      xlapp, Sheet, columnrange: Variant;
begin
  with DBGrid do
  begin
    if Not (Assigned(DataSource) and Assigned(DataSource.DataSet)) then Exit;
    if Not DataSource.DataSet.Active then Exit;
    AScroll := DataSource.DataSet.AfterScroll;
    BScroll := DataSource.DataSet.BeforeScroll;
    DataSource.DataSet.AfterScroll := Nil;
    DataSource.DataSet.BeforeScroll := Nil;
    BkMk := DataSource.DataSet.Bookmark;
    DataSource.DataSet.DisableControls;
    DataSource.DataSet.First;
    Screen.Cursor := crHourGlass;
    try
      xlapp := CreateOleObject('excel.application');
      xlapp.WorkBooks.Add(xlwbatworksheet);
      xlapp.workbooks[1].worksheets[1].Name := 'kw';
      Sheet := xlapp.workbooks[1].worksheets['kw'];
      Cnt := Columns.Count;
      Xlapp.Workbooks[1].worksheets[1].Rows.Font.Bold := True;
      for I := 1 to Cnt do
      begin
        if Not Columns[I - 1].Visible then Continue;
        columnrange := xlapp.workbooks[1].worksheets[1].Columns;
        if Columns[I - 1].Field.Size < 3 then
          columnrange.columns[1].columnwidth := 6
        else
          columnrange.columns[1].columnwidth := Columns[I - 1].Field.Size;
        sheet.cells[1, I] := Columns[I - 1].Title.Caption ;
      end;
      xlapp.workbooks[1].worksheets[1].Rows.Font.Bold := False;
      K := 1;
      while Not Datasource.Dataset.Eof do
      begin
        Inc(k);
        for I := 1 to Cnt do
        begin
          if Not Columns[I - 1].Visible then Continue;
          Sheet.Cells[K, I] := Columns[I - 1].Field.AsString;
        end;
        Datasource.Dataset.Next;
      end;
      Xlapp.Visible := True;
    finally
      DataSource.DataSet.Bookmark := BkMk;
      DataSource.DataSet.AfterScroll := AScroll;
      DataSource.DataSet.BeforeScroll := BScroll;
      DataSource.DataSet.EnableControls;
      Screen.Cursor := crDefault;
    end; // End Try
  end; //with
end;

function ReplaceADOConnection(pSrcStr: AnsiString; pSubStr: string; pValue: string): AnsiString;
  var  Pos1, Pos2: Integer;
begin
  Pos1 := Pos(pSubStr, pSrcStr);
  if Pos1 <= 0 then
  begin
    Result := pSrcStr;
    Exit;
  end;
  Pos2 := Pos(';', Copy(pSrcStr, Pos1, Length(pSrcStr)));
  if Pos2 <= 0 then
    Result := Copy(pSrcStr, 1, Pos1 + Length(pSubStr)) + pValue
  else
    Result := Copy(pSrcStr, 1, Pos1 + Length(pSubStr)) + pValue + Copy(pSrcStr, Pos1 + Pos2 - 1, Length(pSrcStr));
end;

function GetMaxID(AConn: TADOConnection; TableName,FieldName: string): Integer;
var
  varResult: Variant;
begin
  varResult := GetDBValue(AConn, 'select max('+FieldName+') from '+TableName);
  if VarIsNull(varResult) then Result := 1
  else Result := varResult + 1;
end;

function GetMaxPatientID(AConn: TADOConnection): string;
var
  varResult: Variant;
  iTmp: Integer;
begin
  varResult := GetDBValue(AConn, 'select max(code) from tPatient where code like '''+FormatDateTime('yyMMdd', Now)+'%''');
  if VarIsNull(varResult) then Result := FormatDateTime('yyMMdd', Now)+'001'
  else begin
    iTmp := StrToInt(Copy(varResult,7,Length(varResult)))+1;
    Result := Copy(varResult,1,6)+StringOfChar('0',3-Length(IntToStr(iTmp)))+IntToStr(iTmp);
  end;
end;

function GetMaxID(TableName,FieldName: string; AConn: TADOConnection; Len: Integer=10): string;
var
  varID: Integer;
begin
  varID := GetMaxID(AConn, TableName, FieldName);
  Result := StringOfChar('0', Len-Length(IntToStr(varID)))+IntToStr(varID);
end;

function GetPYCode(HanStr: String) : String;//提取汉字的汉语拼音首字母函数。
const
  PRCCodePage=936;
  VowelPos: array['`'..'{'] of Integer = ($0000,$B0A1,$b0c5,$b2c1,$b4ee,
    $b6ea,$b7a2,$b8c1,$b9fe,$0000,$bbf7,$bfa8,
    $c0ac,$c2e8,$c4c3,$c5b6,$c5be,$c6da,$c8bb,
    $c8f6,$cbfa,$0000,$0000,$cdda,$cef4,$d1b9,
    $d4d1,$FFFF);
var
  sVol : string;
  Vowels : String;
  i:Char;
  HanziCode:Word;
  lps,p1,p2:Pointer;
begin
  sVol := HanStr;
  GetMem(lps,Length(sVol)+1);
  StrPCopy(lps,sVol);
  p1:=lps;
  p2:=CharNextEx(PRCCodePage,p1,0);
  Repeat
    if Abs(Longint(p2)-Longint(p1))=2 then
    begin
      HanziCode:=Word(p1^);
      HanziCode:=swap(HanziCode);
      for i:='`' to '{' do
      begin
        if VowelPos[i]>HanziCode then
        begin
          if i='a' then
            Vowels:=Vowels+i
          else if i='j' then //因为汉语内没有以“I”开头的拼音，遇到这种情况就是遇到了“H”
            Vowels:=Vowels+'h'
          else if i='w' then // 没有以“U、V”开头的拼音，遇到这种情况就是遇到了“T”
            Vowels:=Vowels+'t'
          else
          Vowels:=Vowels+Chr(Ord(i)-1);
          break;
        end;
      end;
    end
    else begin
     Vowels:=Vowels+PChar(p1)^; //非汉字不转换
    end;
    p1:=p2;
    p2:=CharNextEx(PRCCodePage,p1,0);
  Until p1=p2;
  Result:=Vowels;
  FreeMem(lps);
end;

function HasChildren(AConn: TADOConnection; PartID: Integer): Boolean;
begin
  with TADODataSet.Create(nil) do begin
    Connection := AConn;
    CommandText := 'select * from tBodyPart where ParentPartID = '+IntToStr(PartID);
    Active := true;
    Result := RecordCount > 0;
    Free;
  end;
end;

function GetDataSet(AConn: TADOConnection; strSQL: string; AOwner: TComponent = nil): TADODataSet;
begin
  Result := TADODataSet.Create(AOwner);
  with Result do begin
    Connection := AConn;
    CommandText := strSQL;
    Active := true;
  end;
end;

function GetDBValue(AConn: TADOConnection; strSQL: string): Variant;
begin
  with TADODataSet.Create(nil) do begin
    Connection := AConn;
    CommandText := strSQL;
    Active := true;
    Result := Fields[0].Value;
    Active := false;
    Free;
  end;
end;

procedure OpenDataSet(DataSet: TCustomADODataSet; AConn: TADOConnection; strSQLOrTableName: string);
begin
  with DataSet do begin
    if Active then Active := false;
    Connection := AConn;
    if DataSet is TADODataSet then
      TADODataSet(DataSet).CommandText := strSQLOrTableName
    else if DataSet is TADOQuery then
      TADOQuery(DataSet).SQL.Text := strSQLOrTableName
    else if DataSet is TADOTable then
      TADOTable(DataSet).TableName := strSQLOrTableName;
    Active := true;
  end;
end;

procedure ExecDBCommand(AConn: TADOConnection; strSQL: string);
begin
  with TADOCommand.Create(nil) do begin
    Connection := AConn;
    CommandText := strSQL;
    Execute;
    Free;
  end;
end;

function GetDataType(AFieldType: TFieldType): TFieldDataType;
begin
  case AFieldType of
    ftString, ftWideString:  Result := dtString;
    ftSmallint, ftInteger, ftWord, ftBoolean, ftFloat,
    ftCurrency, ftBCD, ftBytes, ftVarBytes, ftAutoInc,
    ftTypedBinary, ftLargeint, ftFMTBcd: Result := dtNumeric;
    ftDate, ftDateTime,ftTime, ftTimeStamp: Result := dtDateTime;
    ftBlob, ftMemo, ftOraBlob: Result := dtBlob;
    else
      Result := dtUnknow;
  end;
end;

procedure PgcDrawTab(Control: TCustomTabControl;
  TabIndex: Integer; const Rect: TRect; Active: Boolean);
var
  rgbStart, rgbEnd, Added, j: Integer;
  sr, sg, sb, er, eg, eb: Byte;
  ARect: TRect;
  CaptionX, CaptionY: Integer;
begin
  rgbStart := ColorToRGB(StartColor);
  rgbEnd   := ColorToRGB(EndColor);
  sr := rgbStart;
  sg := rgbStart shr 8;
  sb := rgbStart shr 16;
  er := rgbEnd;
  eg := rgbEnd shr 8;
  eb := rgbEnd shr 16;
  with Control.Canvas do begin
    Brush.Color := StartColor;
    ARect.Left := Rect.Left;
    ARect.Top  := Rect.Top +1;
    ARect.Right:= Rect.Right;
    ARect.Bottom := Rect.Top + 2;
    FillRect(ARect);
    Added := Rect.Bottom-Rect.Top-2;
    for j:=1 to Added do begin
      ARect.Left := Rect.Left;
      ARect.Top  := Rect.Top +1+j;
      ARect.Right:= Rect.Right;
      ARect.Bottom := Rect.Top + 2+j;
      Brush.Color := RGB((sr+(er-sr)*j div Added),(sg+(eg-sg)*j div Added),(sb+(eb-sb)*j div Added));
      FillRect(ARect);
    end;
  end;

  with Control.Canvas do begin
    Font.Color := CaptionColor;
    Brush.Style := bsClear;
//    if Active then
//      Font.Style := Font.Style+[fsBold];
    CaptionX := Rect.Left
      +((Rect.Right-Rect.Left)-TextWidth(TPageControl(Control).Pages[TabIndex].Caption)) div 2;
    CaptionY := Rect.Top
      +((Rect.Bottom-Rect.Top)-TextHeight(TPageControl(Control).Pages[TabIndex].Caption)) div 2;
    TextOut(CaptionX, CaptionY, TPageControl(Control).Pages[TabIndex].Caption);
    if Active then begin
      Brush.Color := ActiveColor;
      ARect.Left := Rect.Left+2;
      ARect.Top  := Rect.Top+1;
      ARect.Right:= Rect.Right-2;
      ARect.Bottom := Rect.Top+4;
      FillRect(ARect);
    end;
  end;
end;

function PubGetNextLsh(pCode: Integer): String;
begin
  Result := '';
  with TADOStoredProc.Create(nil) do begin;
    Connection := DM.cnn;
    ProcedureName := 'pGetNextVoucher';
    Prepared := true;
    Prepared := false;
    Parameters.ParamByName('@iFlag').Value := pCode;
    try
      ExecProc;
      Result := Parameters.ParamByName('@cTyBh').Value;
    except
      on E: Exception do MsgOk('取下一号时出错：'#13 + E.Message);
    end;
  end;
end;

function CheckUserRight(UserID: Integer; FunCode: string): Boolean;
var
  strSQL: string;
begin
  strSQL := 'select count(*) from tDoctorPower where doctorID='+IntToStr(UserID)
    + ' and PowerID in (select iAutoID from tFuncPower where code='+QuotedStr(FunCode)+')';
  result := GetDBValue(DM.cnn, strSQL)>0;
end;

procedure AddDignoseRecord(AConn: TADOConnection; PatientID: Integer);
var
  strSQL, strRAge: string;
  dtBirth: TDateTime;
  lessDay, iFirst, iSecond: Integer;
begin
  dtBirth := GetDBValue(AConn, 'select birth from tPatient where iAutoID='+IntToStr(PatientID));
  if dtBirth < Now then begin
    lessDay := Round(Now-dtBirth);
    if lessDay > 365 then begin
      iFirst := lessDay div 365;
      iSecond := (lessDay mod 365) div 30;
      strRAge := IntToStr(iFirst)+'岁'+IntToStr(iSecond)+'个月';
    end else if lessDay > 30 then begin
      iFirst := lessDay div 30;
      iSecond := lessDay mod 30;
      strRAge := IntToStr(iFirst)+'个月'+IntToStr(iSecond)+'天';
    end else
      strRAge := IntToStr(lessDay)+'天';
  end;


  strSQL := 'Insert into tPatientRecord(PatientID, RecordDate, RAge) '
    + ' values('+IntToStr(PatientID)+',GetDate(), '+QuotedStr(strRAge)+')';
  ExecDBCommand(AConn, strSQL);
end;

procedure SavePatientResult(PatientID: Integer; adsResult: TADODataSet);
var
  strSQL: string;
begin
  //code, score
  with adsResult do begin
    DisableControls;
    First;
    while not Eof do begin
      strSQL := 'insert into tPatientResult(PatientID, CalcDate, MeasureItem, Result) '
        +' values ('+IntToStr(PatientID)+',GetDate(),'+QuotedStr(adsResult.FieldByName('Code').AsString)
        +' , '+adsResult.FieldByName('Score').AsString+')';
      ExecDBCommand(DM.cnn, strSQL);
      Next;
    end;
    EnableControls;
  end;
end;

procedure GetYearMonth(dtBirth: TDate; var BirthYear,BirthMonth: string);
var
  iNowMonth, iBirthMonth: Integer;
begin
  iNowMonth := StrToInt(FormatDateTime('MM', Now));
  iBirthMonth := StrToInt(FormatDateTime('MM', dtBirth));
  if iNowMonth < iBirthMonth then begin
    BirthMonth := IntToStr(iNowMonth + 12 - iBirthMonth);
    BirthYear  := IntToStr(StrToInt(FormatDateTime('yyyy', Now))-StrToInt(FormatDateTime('yyyy', dtBirth)) - 1);
  end else begin
    BirthMonth := IntToStr(iNowMonth - iBirthMonth);
    BirthYear  := IntToStr(StrToInt(FormatDateTime('yyyy', Now))-StrToInt(FormatDateTime('yyyy', dtBirth)));
  end;
end;

end.