ufunc.pas

delphi 源码 小型企业管理软件

end;

procedure RecalcHT(const HCCode:Integer);
begin
  DropTempTables;
  DropTempTables('#lj,#cp,#dh');
  ExecQuery(GetSQLText('RecalcHT.SQL','HT'),[HCCode,GDecimalQty,GDecimalPrice,GDecimalAmt]);
end;

//获得表中某列下一个可用ID，（取MAX）
function GetNextID(const tablename,colname:string;sWhereCond:string=''):Integer;
begin
  Result := GetQuery('select ISNULL(max(%1:s),0) from %0:s %2:s'
    ,[tablename,colname,sWhereCond])
    .Fields[0].AsInteger +1;
end;

procedure DoMutallyExclusiveWork(P:TMethod);
begin
  if GWorking then exit;
  GWorking := True;

  try
    P;
  finally
    GWorking := False;
  end;

end;


function GetGT(const name:string):string;
begin
  Result :=GetQuery('select value from gt where name=''%s''',[name]).Fields[0].AsString ;
end;

procedure PutGT(const name,value:string);
begin
  ExecQuery('delete from gt where name=%0:s'
    +#13#10+'insert into gt(name,value) values(%0:s,%1:s)'
    ,[QuotedStr(name),QuotedStr(value)]);
end;

procedure ReopenDataset(DS: TDataset);
var
  bm: string;
begin
  with DS do begin
    bm := Bookmark;
    Close;
    Open;

    try
      Bookmark := bm;
    except
    end;
  end;
end;

procedure LoadData2DB(DataLines:TStrings; usedColnos:string; LinesIgnored: integer=0);
var
  i,curColNo,nPos,MaxColno: integer;
  aLine,CurColData,mSQL,mSQLALL,mSQLHead,Tabs: string;
  usedCols: TStringList;
begin
  usedCols:= TStringList.Create ;
  usedCols.CommaText := usedColnos ;
  mSQLALL := 'truncate table dataio';
  mSQLHead := 'insert into dataio(id,';
  MaxColno := 0;

  for i:=0 to usedCols.Count-1 do begin
    mSQLHead := mSQLHead + Format('C%s,',[usedCols[i]]);
    if StrToInt(usedCols[i])> MaxColno then
       MaxColno := StrToInt(usedCols[i]);
  end;

  Tabs := '';
  for i:=0 to MaxColno do Tabs := Tabs +#9;

  mSQLHead := copy(mSQLHead,1,Length(mSQLHead)-1);   //去除最后的,
  mSQLHead := mSQLHead + ') values (';

  try
    for i:=LinesIgnored to DataLines.count-1 do begin
      aLine := DataLines[i] + Tabs; //每行多加#9,以便分析，且防止栏位不够
      curColNo := 1;
      mSQL := intToStr(i+1);   //行号
      nPos := pos(#9,aLine);
      while nPos>0 do begin
        CurColData := Trim(copy(aLine,1,nPos-1));
        aLine := copy(aLine,nPos+1,Length(aLine));

        //记录SQL语句
        if usedCols.IndexOf(IntToStr(curColNo))>=0 then begin
          if mSQL<>'' then mSQL := mSQL + ',';
          mSQL := mSQL + QuotedStr(CurColData);
        end;

        nPos := pos(#9,aLine);
        Inc(curColNo);
      end;

      mSQL := mSQLHead + mSQL + ')';
      mSQLALL := mSQLALL +#13#10+ mSQL ;
    end;

    //执行
    ExecQuery(mSQLALL);
  finally
    usedCols.Free ;
  end;
end;

var
  Excel: Variant;

function GetTabbedExcelData(const FileName:string;sheetno:integer=1;QuitExcel:Boolean=False):string;
var
//  Excel: Variant;
  WBk,WS : OleVariant;
//  WBk:_WorkBook;
//  WS: _Worksheet;
  i,j, rownum, colnum: integer;
  ALine: string;
begin
  Result := '';
  if VarType(Excel)=varEmpty	then
    Excel := CreateOleObject('Excel.Application');

  try
    WBk := Excel.WorkBooks.Open(FileName);
    WS := WBk.Worksheets[sheetno] ;

    //ClipBoard.Open ;
    try
    WS.UsedRange.Copy;
    Result := ClipBoard.AsText;
    ClipBoard.Clear ;
    finally
      //ClipBoard.Close;
    end;

  finally
    if QuitExcel then begin
      Excel.Quit;
      Excel := Unassigned;
    end;
  end;

end;

procedure TFakeForm.wwDBGridTitleButtonClick(Sender: TObject;
  AFieldName: String);
var
  adoDataset: TadoDataset;
begin
  adoDataset := TadoDataset(TwwDBGrid(Sender).Datasource.DataSet);
  if adoDataset.sort <> AFieldName+' ASC' then //判断原排序方式
    adoDataset.sort := AFieldName+' ASC'
  else
    adoDataset.sort := AFieldName+' DESC'
end;

procedure TFakeForm.wwDBGridCalcTitleImage(Sender: TObject;
  Field: TField; var TitleImageAttributes: TwwTitleImageAttributes);
var
  AFieldName: String;
  adoDataset: TadoDataset;
begin
  AFieldName := Field.FieldName ;
  adoDataset := TadoDataset(TwwDBGrid(Sender).Datasource.DataSet);

  if adoDataset.sort = AFieldName+' ASC' then //判断原排序方式
    TitleImageAttributes.imageIndex:= 3
  else if adoDataset.sort = AFieldName+' DESC' then //判断原排序方式
    TitleImageAttributes.imageIndex:= 4
  else
    TitleImageAttributes.imageIndex:= -1
end;

procedure TFakeForm.wwDBGridKeyDown(Sender: TObject; var Key: Word;
  Shift: TShiftState);
begin
  if ((Key=ord('F')) or (Key=ord('f'))) and (GetKeyState(VK_CONTROL)<0) then begin
    key :=0;
    DM.wwLocateDialog1.DataSource := TwwDBGrid(Sender).Datasource;
    DM.wwLocateDialog1.SearchField := TwwDBGrid(Sender).SelectedField.FieldName ;
    DM.wwLocateDialog1.Execute ;
  end
end;

procedure HookwwDBGrid(AComp:TwwDBGrid);
begin
  AComp.TitleButtons := True;
  AComp.OnTitleButtonClick := FakeForm.wwDBGridTitleButtonClick;
  AComp.OnCalcTitleImage:= FakeForm.wwDBGridCalcTitleImage;
  AComp.TitleImageList := DM.ImageList1 ;
  AComp.OnKeyDown := FakeForm.wwDBGridKeyDown ; //CTRL+F
end;

procedure HookMyControls(AForm:TForm);
var
  i: integer;
  AComp: TComponent;
begin
  for i:=0 to AForm.ComponentCount-1 do begin
    AComp := AForm.Components[i];
    if AComp is TwwDBGrid then HookwwDBGrid(TwwDBGrid(AComp));

    if AComp is TwwDBLookupCombo then
      TMywwDBLookupCombo.Create(TwwDBLookupCombo(AComp))
    else if AComp is TjvDBGrid then
      TMyjvDBGrid.Create(TjvDBGrid(AComp))
  end;
end;

function ShowFrm(FormClass: TFormClass; var Reference; bModal:Boolean=True):TModalResult;
begin
  Result := mrNone;
  Application.CreateForm(FormClass,Reference);
//  SetSkin(TForm(Reference));
  HookMyControls(TForm(Reference));

  with TForm(Reference) do
  if not bModal then Show
  else begin
    Result := ShowModal;
    FreeAndNil(Reference);
  end;
end;

procedure ShowMsg(const Mess:string);
begin
  Application.MessageBox(PAnsiChar(Mess),PAnsiChar(Application.Title)) ;
end;

function  Sure(const Mess:string):Boolean;
begin
  Result := MessageBox(Application.Handle,PAnsiChar(Mess),PAnsiChar(Application.Title)
    ,MB_YESNO) = idYes;
end;

procedure AbortMsg(const Mess:string);
begin
  ShowMsg(Mess);
  Abort;
end;

procedure ShowProgressBar(const OpType:integer;nPos:integer=0;
  AText:string='';ACaption:string='');
begin
  if not Assigned(JvProgressDialog1) then
    JvProgressDialog1 := TJvProgressDialog.Create(Application) ;

  with JvProgressDialog1 do begin
    if OpType=1 then begin //显示
      Position := nPos ;
      Text := AText;
      Show;
    end else
    if OpType=0 then begin //隐藏
      Hide;
    end else
    if OpType=-1 then begin //初始化
      InitValues(0,nPos,200,0,ACaption,AText);
    end
  end;

  Application.ProcessMessages ;
end;

function GetSQLSect(Lines:TStrings; Sectname:string): string;
var
  i, ps, pe: integer;
  ms, me: string;
begin                     
  Result := '';
  ms := '--BEGIN--' + Sectname;
  me := '--END--'   + Sectname;
  ps := Lines.Count;

  for i:= 0 to Lines.Count-1 do
    if Copy(Lines[i],1,Length(ms))=ms then begin
      ps := i;
      break;
    end;

  for i:= ps+1 to Lines.Count-1 do begin
    if Copy(Lines[i],1,Length(me))=me then exit;
    Result := Result +#13#10+ Lines[i];
  end;
end;

function GetSQLLines(const Sectname:string; SQLCategory:string=''): TStrings;
begin
  DM.SQLs.Text := GetSQLText(Sectname,SQLCategory);
  Result := DM.SQLs;
end;

function GetSQLText(const Sectname:string; SQLCategory:string=''): string;
var
  AMemo: TMemo;
begin
  if frmConstString=nil then
    Application.CreateForm(TfrmConstString,frmConstString);

  with frmConstString do begin
    if SQLCategory='' then
      AMemo := MemoDefault
    else
      AMemo := TMemo(FindComponent('memo'+SQLCategory));

    Result := GetSQLSect(AMemo.Lines,Sectname);
  end;
end;

procedure WriteErrorLog(const Mess:string;ReallyWrite:Boolean=False);
var                                           
  F:TextFile;
  ErrorLogFilename, MyMessage: string;
begin
  if not ReallyWrite then begin   //write to memory first
    MyMessage := Format('[%s]:'#13#10'%s'
          ,[FormatDateTime('YYYY-MM-DD HH:NN:SS',now),Mess]);
    DM.LOGs.Add(MyMessage);
  end;
  if not ReallyWrite and (DM.LOGs.Count <100) and (pos('-debug',CmdLine)=0)then exit;

  ErrorLogFilename := AppPath+'error.log' ;
  if not FileExists(ErrorLogFilename) then FileCreate(ErrorLogFilename);
  AssignFile(F,ErrorLogFilename);

  try
    try
      Append(f);
      Writeln(f, DM.LOGs.Text);
      Flush(f);
      DM.LOGs.Clear;
    except

    end;
  finally
    CloseFile(f);
    
  end;
end;

procedure DropTempTables(temptablenames:string='');
var
  sl:TStringList;
  i: integer;
  mSQL: string;
begin
  if temptablenames='' then
    ExecQuery('if object_id(''tempdb..#temp1'')>0 drop table #temp1'
      +#13#10+'if object_id(''tempdb..#temp2'')>0 drop table #temp2'
      +#13#10+'if object_id(''tempdb..#temp3'')>0 drop table #temp3'
    )
  else
  try
    sl := TStringList.Create ;
    sl.CommaText := temptablenames;
    mSQL := '';
    for i:=0 to sl.Count-1 do
      mSQL := mSQL+#13#10+
        Format('if object_id(''tempdb..%0:s'')>0 drop table %0:s',[sl[i]]);
    ExecQuery(mSQL);
  finally
    sl.Free; 
  end;
end;

procedure ExecQuery(msql: string; const Args: array of const);
begin
  ExecQuery(Format(msql,Args));
end;

procedure ExecQuery(msql: string);
var
  i: integer;
begin
  if trim(mSQL)='' then exit;
  DM.ADOConnection1.BeginTrans ;

  try
  with DM.Query1 do begin
    close;
    DM.SQLs.Text := msql;                    
    SQL.Clear;

    if Length(msql)<32000 then
      SQL.Text := msql

    else
    for i:=0 to DM.SQLs.Count-1 do begin
      SQL.Add(DM.SQLs[i]);
      if i mod 20=19 then begin
        if SQL.Text<>'' then ExecSQL;
        SQL.Clear;
      end;
    end;

    if SQL.Text<>'' then ExecSQL;
    DM.ADOConnection1.CommitTrans ;
    if pos('-log',CmdLine)>0 then WriteErrorLog('SQL:'#13#10+msql);
  end;

  except
    on E: Exception do begin
      DM.ADOConnection1.RollbackTrans ;
      WriteErrorLog(E.Message +#13#10+'SQL:'#13#10+msql);
      raise;
    end;
  end;
end;

function GetQuery(msql: string): TAdoQuery;
begin
  Result := DM.Query1;
  if trim(mSQL)='' then exit;

//  不加事务处理是为了节约资源，加快速度
//  DM.ADOConnection1.BeginTrans ;
//  try

   if pos('-log',CmdLine)>0 then WriteErrorLog('Query:'#13#10+msql);
    with DM.Query1 do begin
      close;
      sql.Text := msql; //showmessage(msql);
      open;
    end;

//    DM.ADOConnection1.CommitTrans ;
//  except
//    on E: Exception do begin
//      DM.ADOConnection1.RollbackTrans ;
//      WriteErrorLog(E.Message +#13#10+'SQL:'#13#10+msql);
//      raise;
//    end;
//  end;

end;

function GetQuery(msql: string; const Args: array of const): TAdoQuery;
begin
  Result := GetQuery(Format(msql,Args));
end;

//升级表结构
procedure UpdateTable(tabName:string);
  function GetUpTabSQL:string;
  var
    i,startLine,endLine: integer;
  begin
    Result := '';
    startLine := -1;
    endLine := -1;

    with GetSQLLines('CreateDB.SQL') do begin
      for i:=0 to Count-1 do begin
        if (startLine = -1) and sameText(Copy(Strings[i],1,15+Length(tabName))
          ,'CREATE TABLE ['+tabName+']')
        then startLine := i
        else if (startLine <> -1) and
          sameText(Copy(Strings[i],1,14),'CREATE TABLE [')
        then begin
          EndLine := i;
          break;
        end
      end;

      if (startLine <> -1) and (EndLine = -1) then EndLine := Count;

      if (startLine <> -1) and (EndLine <> -1) then
      for i:=startLine to EndLine-1 do
        Result := Result +#13#10+ Strings[i];
    end;
  end;

  function GetOrgFields: string;
  var
    i:integer;
  begin
    Result := '';