dbfuncs.~pas

群星医药系统源码

unit DbFuncs;

interface

uses Windows, SysUtils, DB, DBClient, Variants, DBGrids, Controls, Forms,MConnect,iMainFrm,
    uGlobal,Classes,Dialogs,ckDBClient;

function GetFieldMaxInt(DataSet: TDataSet; sField: String): Integer;
Function CopyRecSelf(DataSet: TDataSet; IgnoreFields: String; bPost: Boolean): Boolean;
//IgnoreFields：要忽略的字段，在多个字段名之间用";"号分隔
procedure ViewDataSet(DataSet: TDataSet);
Function GetGoodsInfo(DataSet:TDataSet;sPriceFld,sGoodsID,sSetFields:String;
  sCustNo:String='';sType:String=''; Flag: ShortInt=0):String;
function GetGoodsPrice(DataSet: TDataSet; sPriceFld, sType, sCustNo, sGoodsID, sUnit: String): Boolean;
Procedure SysFieldXml(FieldsData:TClientDataSet;FiltStr:String;FileName:String);   //下载XML文件;
//获取某常用参考资料
procedure GetInfoValues(DataSet: TckClientDataSet; InfoType: String; Values: TStrings);
procedure GetValueList(DataSet: TDataSet; sField: String; Values: TStrings; bAutoClear: Boolean=true);
Procedure SetFieldProperty(CdsFields,CdsCust:TDataSet;sTableNames:String; bSetAllProperty: Boolean=true);      //显示字段的DispLabel;
Function IsFieldPass(CdsFields,CdsCust:TClientDataSet;sTableName:String;sTitle:String=''):Boolean;          //检查字段的合法性


implementation

function GetFieldMaxInt(DataSet: TDataSet; sField: String): Integer;
const
  sErr_FieldNotFound = '找不到指定的字段';
	sErr_FieldNotIsNumField = '指定的字段不是数值型字段：';
var Field: TField;
    iMax, i: Integer;
    sIdxFld: String;
begin
  with DataSet do begin
    Field := FindField(sField);
    if Field=nil then
      raise Exception.Create(sErr_FieldNotFound);
    if not (Field is TNumericField) then
      raise Exception.Create(sErr_FieldNotIsNumField);
    iMax := -1;
    DisableControls;
    if DataSet is TClientDataSet then begin
      sIdxFld := (DataSet as TClientDataSet).IndexFieldNames;
      if (sIdxFld=sField)or(AnsiPos(sField+';', sIdxFld)=1) then begin
        Last;
        iMax := Field.AsInteger;
      end;
    end;
    if iMax=-1 then begin
      First;
      iMax := 0;
      while not Eof do begin
        i := Field.AsInteger;
        If iMax<i Then
          iMax := Field.AsInteger;
        Next;
      End;
    end;
    EnableControls;
  end;
  Result := iMax;
end;

Function CopyRecSelf(DataSet: TDataSet; IgnoreFields: String; bPost: Boolean): Boolean;
var Values: Variant;
    i, k: Integer;
    IgnFieldIdx: set of byte;
begin
  Result := false;
  if (DataSet=nil)or not DataSet.Active then
    Exit;
  if DataSet.State in dsEditModes then begin
	  MessageBox(0, 'The dataset is in EditModes!', '消息', 64);
    Exit;
  end;
  IgnoreFields := IgnoreFields+';';
  with DataSet do begin
    k := FieldCount-1;
    Values := VarArrayCreate([0, k], varVariant);
    for i:=0 to k do begin
      if AnsiPos(Fields[i].FieldName+';', IgnoreFields)>0 then
        Include(IgnFieldIdx, i)
      else
        Values[i] := Fields[i].Value;
    end;
    Insert;
    for i:=0 to k do begin
      if not(i in IgnFieldIdx) then
        Fields[i].Value := Values[i];
    end;
    if bPost then
      DataSet.Post;
    Result := true;
  end;
end;

procedure ViewDataSet(DataSet: TDataSet);
var Form: TForm;
    Ds: TDataSource;
    Grid: TDBGrid;
begin
  Form := TForm.Create(nil);
  Ds := TDataSource.Create(Form);
  Ds.DataSet := DataSet;
  Grid := TDBGrid.Create(form);
  Grid.Parent := Form;
  Grid.Align := alClient;
  Grid.DataSource := ds;
  Form.ShowModal;
  Form.Free;
end;

{参数说明：
sPriceFld：要设置单价的字段，一般是一个字段，当Flag参数为负数时要传入两个字段名并用';'号分隔
Flag：-1:返回两个单位与sType对应的单价信息，0:不返回价格信息，
      大于0时由输入的商品代码的第一位是否为'-'号来决定返回主/辅单位的价格信息
}
Function GetGoodsInfo(DataSet:TDataSet;sPriceFld,sGoodsID,sSetFields:String;
  sCustNo,sType:string; Flag: ShortInt):String;
var vField:TField;
    iClientID, iLow, iHigh, i, j, iFieldCount:Integer;
    SvrGoods:TDispatchConnection;
    IFmMain: IMainForm;
    sFieldList:TStrings;
    NeedValue: Variant;
    GoodsID:String;
begin
   Try
    Result:='';
    sFieldList:=TStringList.Create;
    xStrSplit(sSetFields, [','],sFieldList);
    iFieldCount:=sFieldList.Count;
    IFmMain := (Application.MainForm As IMainForm);
    IClientID:=IFmMain.IFmMainEx.ClientID;
    GoodsID:=sGoodsID;
    SvrGoods := IFmMain.GetConnection(Application.MainForm.Handle, '', 'CommonSvr.CommonRDM');
    NeedValue:=SvrGoods.AppServer.GetGoodsInfo(IClientID, sType, sCustNo, sSetFields, GoodsID, Flag);
    If GoodsID='' then
      Exit
    else begin
      with DataSet do
      begin
        iLow := VarArrayLowBound(NeedValue,1);
        iHigh := VarArrayHighBound(NeedValue,1);
        j := iLow+iFieldCount-1;
        for i:=iLow to j do begin
          vField := DataSet.FindField(sFieldList[i]);
          if vField<>nil then begin
            vField.AsVariant := NeedValue[i];
          end;
        end;
        if (iHigh<>j)and(sPriceFld<>'') then
        begin
          i := AnsiPos(';', sPriceFld);
          if i=0 then
          begin
            vField := DataSet.FindField(sPriceFld);
            if vField<>nil then
              vField.AsVariant:=NeedValue[j+1];
          end
          else
          begin
            vField := DataSet.FindField(Copy(sPriceFld, 1, i-1));
            if vField<>nil then
              vField.AsVariant := NeedValue[j+1];
            system.Delete(sPriceFld, 1, i);
            vField := DataSet.FindField(sPriceFld);
            if vField<>nil then
              vField.AsVariant := NeedValue[j+2];
          end;
        end;
      end;
      Result := GoodsID;
    end;
  Except
    On E:Exception Do ;
  end;
end;

function GetGoodsPrice(DataSet: TDataSet; sPriceFld, sType, sCustNo, sGoodsID, sUnit: String): Boolean;
var SvrComm: TDispatchConnection;
    IFmMain: IMainForm;
    iClientID, i: Integer;
    vField: TField;
    dPrice: Double;
begin
  IFmMain := (Application.MainForm As IMainForm);
  IClientID:=IFmMain.IFmMainEx.ClientID;
  SvrComm := IFmMain.GetConnection(Application.MainForm.Handle, '', 'CommonSvr.CommonRDM');
  dPrice  := SvrComm.AppServer.GetGoodsPrice(IClientID, sType, sCustNo, sGoodsID, sUnit);
  i := AnsiPos(';', sPriceFld);
  if i=0 then
  begin
    vField := DataSet.FindField(sPriceFld);
    if vField<>nil then
      vField.AsVariant := dPrice;
  end else
  begin
    vField := DataSet.FindField(Copy(sPriceFld, 1, i-1));
    if vField<>nil then
      vField.AsVariant := dPrice;
    system.Delete(sPriceFld, 1, i);
    vField := DataSet.FindField(sPriceFld);
    if vField<>nil then
      if sUnit='' then
        vField.AsVariant := null
      else
        vField.AsVariant := sUnit;
  end;
  Result := true;
end;

procedure GetValueList(DataSet: TDataSet; sField: String; Values: TStrings; bAutoClear: Boolean);
var Field: TField;
    str: String;
begin
  if sField='' then Exit;
  if bAutoClear then Values.Clear;
  with DataSet do
  begin
    if (not Active) or IsEmpty then Exit;
    Field := DataSet.FindField(sField);
    if Field=nil then Exit;
    First;
    while not Eof do
    begin
      str := Field.AsString;
      if Values.IndexOf(str)<0 then
        Values.Add(str);
      Next;
    end;
  end;
end;

procedure GetInfoValues(DataSet: TckClientDataSet; InfoType: String; Values: TStrings);
const
  sTypes = 'HypoKind'#13'Departs'#13'Dosetype'#13'Dutys'#13'Trades'#13'Units'#13'Words';
  sTables= 'HypoKinds'#13'Info_Departs'#13'Info_DoseType'#13'Info_Dutys'#13'Info_Trades'#13'Info_Units'#13'Info_Words';
  sqStr = 'select Value from %s';
var sList1, sList2: TStrings;
    sTable, xmlPath, str: String;
    i: integer;
begin
  sList1 := TStringList.Create;
  sList1.Text := sTypes;
  i := sList1.IndexOf(InfoType);
  sList1.Free;
  if i>=0 then
  begin
    sList2 := TStringList.Create;
    sList2.Text := sTables;
    sTable := sList2[i];
    sList2.Free;
  end
  else Exit;
  xmlPath := ExtractFilePath(Application.ExeName)+'XML\';
  str := xmlPath+sTable+'.xml';
  if FileExists(str) then
  begin
    try
      DataSet.LoadFromFile(str);
    Except
      DeleteFile(PChar(str));
      Raise;
    end;
  end
  else
  begin
    DataSet.Close;
    DataSet.CommandText := Format(sqStr, [sTable]);
    DataSet.Open;
    if i>0 then//第一项普通分类不要保存到本地文件，因为它被修改的可能性相对要高
      DataSet.SaveToFile(str, dfXMLUTF8);
  end;
  GetValueList(DataSet, 'Value', Values);
end;

procedure SysFieldXml(FieldsData: TClientDataSet;
  FiltStr, FileName: String);
Var
  FilePath,sFileNames:String;
Begin
  FilePath:=ExtractFilePath(ParamStr(0))+'Xml\';
  if not DirectoryExists(FilePath) then
    CreateDir(FilePath);
  sFileNames:=FilePath+FileName;
  If FileExists(sFileNames) Then Begin
    FieldsData.LoadFromFile(sFileNames);
    FieldsData.Open;
  End Else
  Begin
    FieldsData.Close;
    FieldsData.CommandText:=FiltStr;
    FieldsData.Open;
    FieldsData.SaveToFile(sFileNames,dfXMLUTF8);
  End;
end;

{参数说明：
cdsFields: 字段属性字典数据集
cdsCust: 要进行字段属性设置的数据集
sTableNames: 从CdsFields表中查找字段属性的表名，多表名之间用','号分隔
bSetAllProperty:是否设置所有属性(包括Required属性及)，而且即使为true也只有
　　　　　　　　sTableNames中的第一个表匹配的字段Required等约束属性应用到目的表字段
}
procedure SetFieldProperty(cdsFields, cdsCust: TDataSet; sTableNames: String;
  bSetAllProperty: Boolean);
var sFirstTable, sFilter, sFieldName, sDispLabel, str: String;
    Field, LabField, ReqField, ConField, MsgField: TField;
    b1, b2: Boolean;
    i: integer;
Begin
  sTableNames := LowerCase(sTableNames);
  i := AnsiPos(',', sTableNames);
  if i=0 then
  begin
    sFirstTable := sTableNames;
    sFilter := ' Lower(TableName) = '''+sTableNames+'''';
  end else begin
    sFirstTable := Copy(sTableNames, 1, i-1);
    str := StringReplace(sTableNames, ',', ''',''', [rfReplaceAll]);
    sFilter := ' Lower(TableName) in ('''+str+''')';
  end;
  with cdsFields do
  begin
    LabField := FindField('DispLabel');
    ReqField := FindField('Requisite');
    ConField := FindField('CustConstraint');
    MsgField := FindField('CustErrorMsg');
    Filtered := False;
    FilterOptions := [foCaseInsensitive];
    Filter := sFilter;
    Filtered := True;
  end;
  with cdsCust do
  begin
    for i:=0 to FieldCount-1 do
    begin
      Field := Fields[i];
      sFieldName := Field.FieldName;
      b2 := true;
      b1 := cdsFields.Locate('TableName;FieldName', VarArrayOf([sFirstTable, sFieldName]), [loCaseInsensitive]);
      if not b1 then
        b2 := cdsFields.Locate('FieldName', sFieldName, [loCaseInsensitive]);
      if b2 then
      begin
        sDispLabel:= LabField.AsString;
        if sDisplabel<>'' then
          Field.DisplayLabel:=sDispLabel;
        if bSetAllProperty and b1 then
        begin
          Field.Required := ReqField.AsBoolean;
          if ConField<>nil then
          begin
            str := ConField.AsString;
            if str<>'' then
            begin
              if str[1]=';' then
              begin//需要将''值(非null)转换为null
                Field.Origin := ';';
                system.Delete(str, 1, 1);
              end;
              if str<>'' then
              begin
                Field.CustomConstraint := str;
                Field.ConstraintErrorMessage := MsgField.AsString;
              end;
            end;
          end;
        end;
      end;
    end;
  end;
End;

Function IsFieldPass(CdsFields,CdsCust:TClientDataSet;sTableName:String;sTitle:String): Boolean;
Const
  sFilter=' TableName =''%s'' and Requisite ';
Var I:Integer;
    sDispFormat,sFieldName,sMainLabel,sDispLabel,sText:String;
    Field: TField;
    bRequisite:Boolean;
begin
   Result:=True;
   sMainLabel:=sTitle;
  With CdsFields Do Begin
    Filtered:=False;
    sText:=Format(sFilter,[sTableName]);
    Filter:=sText;
    Filtered:=True;
    First;
    For I:=0 To RecordCount-1 Do
    Begin
      sDispFormat := FieldByName('DispFormat').AsString;
      sFieldName  := FieldByName('FieldName').AsString;
      sDispLabel  := FieldByName('DispLabel').AsString;
      bRequisite  := FieldByName('Requisite').AsBoolean;
      If sDispFormat='TITLE' Then
        sMainLabel:=sDispLabel    //判断是否为表标题
      Else If bRequisite Then
      Begin
        Field := cdsCust.FindField(sFieldName);
        If (Field<>nil)and(Field.IsNull) Then Begin
          if sMainLabel='' then sMainLabel := sTableName;
          Application.MessageBox(Pchar(sMainLabel+'的['+sDispLabel+']不能为空!'),'错误：',16);
          Result:=False;
          Exit;
        End;
      End;
      Next;
    End;
  End;
End;

end.