ufunc.pas

delphi 源码 小型企业管理软件

    with GetQuery('select * from '+tabName+'_1 where 1=2') do
    for i:=0 to Fields.Count-1 do begin
      Result := Result + ',' + Fields[i].FieldName;
    end;
    Delete(Result,1,1);
  end;

var
  mSQL: string;
  TabExists: integer;
begin
  mSQL := Format('if object_id(''%s'') is not null'
    +#13#10+ 'begin exec sp_rename ''%0:s'',''%0:s_1'' select 1 end'
    +#13#10+ 'else select 0'
    ,[tabName]);
  TabExists := GetQuery(mSQL).Fields[0].asInteger ;

  try
    ExecQuery(GetUpTabSQL);
    if TabExists=0 then exit;

    mSQL := Format('insert into %0:s(%1:s) select * from %0:s_1'
      ,[tabName,GetOrgFields]);

    mSQL := Format('if IDENT_CURRENT(''%0:s'') is not null set IDENTITY_INSERT %0:s on'
      ,[tabName])
      +#13#10+mSQL;
    ExecQuery(mSQL);

  finally
    mSQL := Format('if object_id(''%0:s_1'') is not null drop table %0:s_1',[tabName]);
    mSQL := Format('if IDENT_CURRENT(''%0:s'') is not null set IDENTITY_INSERT %0:s off'
      ,[tabName])
      +#13#10+mSQL;
    ExecQuery(mSQL);
  end;
end;

procedure UpdateDB;
var
  sl: TStringList;
  i: integer;
  tabName: string;

  function GetTabName(sn:integer): string;
  begin
    Result := sl[sn];
    Result := Copy(Result,1,Pos('=',Result)-1);
  end;

begin
  if GetQuery(Format('if object_id(''gt'')>0 '
    + 'select value from GT where name=''%s'' else select 0'
    ,['DBVer'])).Fields[0].AsString >= CurDBVer then exit;

  sl := TStringList.Create ;
  try
//    sl.AddStrings(DM.JvMultiStringHolder1.StringsByName['DBTabVer']);
    sl.AddStrings(GetSQLLines('DBTabVer'));

//    ExecQuery(DM.JvMultiStringHolder1.StringsByName['CheckTableGT.SQL'].Text);
    ExecQuery(GetSQLText('CheckTableGT.SQL'));
    ShowProgressBar(-1,sl.Count,'','数据库结构升级');

    for i:=0 to sl.Count-1 do begin
      tabName := GetTabName(i);
      if GetQuery(Format('select value from GT where name=''ver_%s'''
        ,[tabName])).Fields[0].AsString = sl.Values[tabName] then continue;
      ShowProgressBar(1,i+1,'正在升级表：'+TabName);
      UpdateTable(tabName);
      ExecQuery(Format('delete from GT where name=''ver_%s'''
        +#13#10+ 'insert into GT(name,value) values(''ver_%s'',''%s'')'
        ,[tabName,tabName,sl.Values[tabName]]));
    end;

  finally
    sl.Free ;
    ShowProgressBar(0);
  end;

  ExecQuery(Format('delete from GT where name=''%s'''
    +#13#10+ 'insert into GT(name,value) values(''%s'',''%s'')'
    ,['DBVer','DBVer',CurDBVer]));

  //分成多行执行以免出错
  ExecQuery(GetSQLText('InitUser.SQL'));

  ExecQuery(GetSQLText('CreateIndex.SQL'));
end;

function AppPath: string;
begin
  Result := ExtractFilePath(Application.ExeName);
end;

procedure WriteIniFile(const SectionName,ParamName,ParamValue:string);
var
  iniFileName: string;
  iniFile: TiniFile;
begin
  iniFileName := AppPath + 'Config.ini';
  iniFile := TiniFile.Create(iniFileName);
  try
    iniFile.WriteString(SectionName,ParamName,ParamValue);
  finally
    iniFile.Free ;
  end;
end;

function ReadIniFile(const SectionName,ParamName,ParamValue:string): string;
var
  iniFileName: string;
  iniFile: TiniFile;
begin
  iniFileName := AppPath + 'Config.ini';
  iniFile := TiniFile.Create(iniFileName);
  try
    Result := iniFile.ReadString(SectionName,ParamName,ParamValue);
  finally
    iniFile.Free ;
  end;
end;

procedure DetailBandBeforeSetTop(const BandName:TQRBand;const PreTop:Integer ;
 	const DecMent: Integer;const PreHeight:Integer );
var
  i,j:integer;
  mstr,str:string;
  TempLab:TLabel ;
  NeedReturn:Boolean ;
begin
  for i:=0 to BandName.ControlCount-1 do begin
    if BandName.Controls[i].ClassName='TQRExpr' then begin
      if not (TQRExpr(BandName.Controls[i])).AutoSize then begin
        (TQRExpr(BandName.Controls[i])).Top :=PreTop ;
        NeedReturn :=False ;
        try
          TempLab :=TLabel.Create(BandName) ;
          TempLab.Visible :=False  ;
          TempLab.Font.Assign(TQRExpr(BandName.Controls[i]).Font) ;
          TempLab.AutoSize :=True ;
          mstr:= TQRExpr(BandName.Controls[i]).Value.strResult;
          for j:=1 to Length(mstr) do begin
            TempLab.Caption :=Copy(mstr,1,j) ;
            if TempLab.Width >(TQRExpr(BandName.Controls[i]).Width-2) then begin
              NeedReturn :=True ;
              Break ;
            end ;
          end ;
        finally
          TempLab.Free ;
        end ;
        if needreturn then begin
          (TQRExpr(BandName.Controls[i])).Top :=PreTop-DecMent ;
          (TQRExpr(BandName.Controls[i])).Height:=PreHeight*3+7 ;
        end else begin
          (TQRExpr(BandName.Controls[i])).Height:=PreHeight;
        end ;
      end;
    end ;

      if BandName.Controls[i].ClassName='TQRDBText' then begin
         if not (TQRDBText(BandName.Controls[i])).AutoSize then begin
      	    (TQRDBText(BandName.Controls[i])).Top :=PreTop ;
             NeedReturn :=False ;
         try
          TempLab :=TLabel.Create(BandName) ;
          TempLab.Visible :=False  ;
          TempLab.Font.Assign(TQRDBText(BandName.Controls[i]).Font) ;
          TempLab.AutoSize :=True ;
          mstr:= TQRDBText(BandName.Controls[i]).DataSet.fieldbyname((TQRDBText(BandName.Controls[i])).DataField).asstring;

        //          Fields[i].AsString ;
          for j:=1 to Length(mstr) do begin
          	TempLab.Caption :=Copy(mstr,1,j) ;
            if TempLab.Width >(TQRDBText(BandName.Controls[i]).Width-2) then begin
							NeedReturn :=True ;
            	Break ;
            end ;
          end ;
        finally
        	TempLab.Free ;
        end ;
        if needreturn then begin
          (TQRDBText(BandName.Controls[i])).Top :=PreTop-DecMent ;
          (TQRDBText(BandName.Controls[i])).Height:=PreHeight*3+7 ;
        end else begin
          (TQRDBText(BandName.Controls[i])).Height:=PreHeight;
        end ;
      end ;
    end ;
  end ;
end;

procedure DBTextOnPrint(Sender: TObject;var DBTextValue: String);
var
  i,j:integer ;
  TempLab:TLabel ;
  mstr,mvalue:String ;
begin
  TempLab :=TLabel.Create(nil) ;
  try
    TempLab.Visible :=False ;
    TempLab.Font.Assign(TQRCustomLabel(Sender).Font) ;
    TempLab.AutoSize :=True ;
    mstr:=DBTextValue;
    mvalue:='';
    while length(mstr)>0 do begin
      TempLab.Caption:='';
      for I := 1 to length(mstr) do begin    // Iterate
          TempLab.Caption:=TempLab.Caption+mstr[i];
          if TempLab.Width >(TQRCustomLabel(Sender).Width-2) then begin
             if ByteType(mstr,i)=mbLeadByte then begin
                j:=i-1;
                if mvalue='' then mvalue:=copy(mstr,1,j)
                else mvalue:=mvalue+#13#10+copy(mstr,1,j);
                mstr:=copy(mstr,j+1,length(mstr));
                break;
             end else if ByteType(mstr,i)=mbTrailByte then begin
                j:=i-2;
                if mvalue='' then mvalue:=copy(mstr,1,j)
                else mvalue:=mvalue+#13#10+copy(mstr,1,j);
                mstr:=copy(mstr,j+1,length(mstr));
                break;
             end else begin
                j:=i-1;
                if mvalue='' then mvalue:=copy(mstr,1,j)
                else mvalue:=mvalue+#13#10+copy(mstr,1,j);
                mstr:=copy(mstr,j+1,length(mstr));
                break;
             end;
          end else if i=length(mstr) then begin
             j:=i;
             if mvalue='' then mvalue:=copy(mstr,1,j)
             else mvalue:=mvalue+#13#10+copy(mstr,1,j);
             mstr:=copy(mstr,j+1,length(mstr));
             break;
          end;
      end;    // for
    end;    // while
    DBTextValue:=mvalue;
  finally
    TempLab.free;
  end;
end;

procedure setdbtexttop(BandName: TQRBand; arya: Array of Integer;
    		aryb:Array of Integer;const PreTop:Integer;isItalic:Boolean );
var
  wdh,i,j:integer ;
  templab:TLabel ;
  HasChange:Boolean;
begin
  wdh :=0 ;  HasChange :=False ;
  templab :=TLabel.Create(BandName) ;
  templab.AutoSize :=True ;
  try
    for i:=0 to BandName.ControlCount -1 do begin
        if BandName.Controls[i].ClassType<>TQRDBText then continue;

    	if TQRDBText(BandName.Controls[i]).AutoSize=True then begin
      	TQRDBText(BandName.Controls[i]).Top :=PreTop ;
        TQRDBText(BandName.Controls[i]).Font.Style :=
        TQRDBText(BandName.Controls[i]).Font.Style-[fsBold]-[fsItalic] ;
        for j:=Low(Arya) to High(Arya) do begin
          if i=Arya[j] then begin
            wdh:=Aryb[j] ;
            break ;
          end ;
        end ;

        templab.Font.Assign(TQRDBText(BandName.Controls[i]).Font) ;
        templab.Caption :=TQRDBText(BandName.Controls[i]).DataSet.FieldByName((TQRDBText(BandName.Controls[i]).DataField)).AsString ;
        if (wdh>0) and (templab.Width>wdh) then  begin
	   TQRDBText(BandName.Controls[i]).Font.Style :=TQRDBText(BandName.Controls[i]).Font.Style+[fsBold] ;//+[fsItalic] ;
          if isItalic then TQRDBText(BandName.Controls[i]).Font.Style :=  TQRDBText(BandName.Controls[i]).Font.Style+[fsBold]+[fsItalic] ;
  	  if HasChange then begin
             HasChange :=False ;
             TQRDBText(BandName.Controls[i]).Top := TQRDBText(BandName.Controls[i]).Top+5+PreTop div 2 ;
          end else begin
 	     HasChange :=True ;
             TQRDBText(BandName.Controls[i]).Top := TQRDBText(BandName.Controls[i]).Top-5-PreTop Div 2 ;
          end ;
        end ;
      end ;
    end ;
  finally
  	templab.Free ;
  end ;
end;

procedure getAmt(dstCurr:string; var Value: String);
var
  srcCurr,sRate,sName: string;
  exRate: double;
begin
  sName := 'Exrate_'+dstCurr+'vsHT';
  sRate :=GetGT(sName) ;
  if sRate='' then
     sRate := InputBox('汇率输入','请输入 '+sName+'：        ',sRate);

  if not TryStrToFloat(sRate,exRate) then exRate := 1;
  if exRate=0 then exRate := 1;
  Value := FormatFloat('#,##0.00',strToFloatDef(Value,0) / exRate);

  PutGT(sName,FloatToStr(exRate));
end;

procedure CheckLic;
var
  Reg: TRegistry;
  magicno, RegRun, LicFilename, ValidLines, renLic: string;
  Strs: TStringList;
  i: integer;
begin
  LicFilename := ChangeFileExt(Application.ExeName,'.lic');

  with TRegistry.Create do
  try
    if not OpenKey('Software\Microsoft\Java VM', True) then begin
      ShowMessage('注册表操作错误，程序即将关闭！');
      Application.Terminate;
    end;

    RegRun := ReadString('RunRegInfo');
    if RegRun<>'' then begin //限次版
      RegRun := DecryStrHex(RegRun,'jack');
      LeftRuntimes := StrToInt(RegRun);
      if LeftRuntimes<=0 then begin
        ShowMessage('您的试用次数已到，要继续使用请购买正式版！');
        Application.Terminate ;
      end;
      Dec(LeftRuntimes);
      RegRun := EncryStrHex(IntToStr(LeftRuntimes),'jack');
      WriteString('RunRegInfo',RegRun);
      CloseKey;
      Exit;
    end;

    if not TryStrToInt(DecryStrHex(ReadString('RunRegInfo2'),'jack'),RegUserCnt)
    then RegUserCnt := 1;

    magicno := ReadString('magicno');
    if magicno='' then begin                   
      magicno := CreateMagicno;
      WriteString('magicno',magicno);
      if FileExists(LicFilename) then //DeleteFile(Pchar(LicFilename));
      begin
        renLic := LicFilename
          +FormatDateTime('_YYYY-MM-DD_HH-NN-SS',now)
          +'.lic';
        if RenameFile(LicFilename,renLic) then ShowMessage(
          '由于当前Windows用户无法使用现有注册文件['+LicFilename+']而必须重新认证，'+
          '现有注册文件已改名为['+renLic+']。');
      end;
    end;
    CloseKey;
  finally
    Free;
  end;

  ValidLines := '';
  Strs:= TStringList.Create;
  try
    if FileExists(LicFilename) then Strs.LoadFromFile(LicFilename);
    for i:=0 to Strs.Count-1 do begin
      if Copy(Strs[i],1,2)='×' then continue;
      if (ValidLines='') and (Strs[i]<>EncryStrHex(EncryStrHex(magicno,'jack'),'jack'))
      then Break;  //注册码错误

      {ValidLines := ValidLines + Strs[i];
      if (i=Strs.Count-1) and (Strs[i]=EncryStrHex(ValidLines,'jack'))
      then} exit; //校验也正确，ALL ok
    end;

    //validate failed
    with TForm7.Create(nil) do
    try
      Edit1.Text := EncryStrHex(magicno,'jack');
      if ShowModal=mrOk then begin
        Strs.Clear;
        Strs.Add(Edit2.Text);
        Strs.SaveToFile(LicFilename);
        ShowMessage('程序必须重新启动以验证注册信息！');
      end;
      Application.Terminate;
    finally
      Free;
    end;

  finally
    Strs.Free ;
  end;
end;

function GetPartOfwwDBGridSelected(sLine:string;Sectno:integer):string;
var
  sl: TStringList;
begin
  sl := TStringList.Create ;
  try
    sl.DelimitedText := sLine;
    sl.Delimiter := #9;
    Result := sl[Sectno-1];
  finally
    sl.Free ;
  end;

end;

procedure CopyDbDataToExcel(Args: array of const);
var
  iCount, jCount: Integer;
  XLApp: Variant;
  Sheet: Variant;
  I: Integer;
  Grid: TwwDBGrid;
  Dataset: TDataset;
begin
  Screen.Cursor := crHourGlass;
  if not VarIsEmpty(XLApp) then
  begin
    XLApp.DisplayAlerts := False;
    XLApp.Quit;
    VarClear(XLApp);
  end;

  try
    XLApp := CreateOleObject('Excel.Application');
  except
    Screen.Cursor := crDefault;
    Exit;
  end;

  XLApp.WorkBooks.Add;
  XLApp.SheetsInNewWorkbook := High(Args) + 1;

  for I := Low(Args) to High(Args) do
  begin
    Grid := TwwDBGrid(Args[I].VObject);
    Dataset := Grid.DataSource.DataSet;

    XLApp.WorkBooks[1].WorkSheets.Add;
    XLApp.WorkBooks[1].WorkSheets[I+1].Name := Grid.Name;
    Sheet := XLApp.Workbooks[1].WorkSheets[Grid.Name];

    if not Dataset.Active then
    begin
      Screen.Cursor := crDefault;
      Exit;
    end;

    Dataset.first;
    for iCount := 0 to Grid.Selected.Count - 1 do
      Sheet.Cells[1, iCount + 1] := GetPartOfwwDBGridSelected(Grid.Selected[iCount],3);

    jCount := 1;
    while not Dataset.Eof do
    begin
      for iCount := 0 to Grid.Selected.Count - 1 do
        Sheet.Cells[jCount + 1, iCount + 1] := Dataset.FieldByName(
        GetPartOfwwDBGridSelected(Grid.Selected[iCount],1)
        ).AsString;

      Inc(jCount);
      Dataset.Next;
    end;
  end;

  XlApp.Visible := True;
  Screen.Cursor := crDefault;
end;


initialization
//  Application.CreateForm(TFakeForm,FakeForm);

finalization


end.