var Form1: TForm1; const MaxDigit =15; UnitList :Array[0..14] of string=('万亿','仟亿','佰亿','拾亿','亿','仟万','佰万','拾万','万','仟','佰','拾','元','角','分'); var DefLineWidth :Integer; function Lpad(const Str :string;Len :Integer;FillStr :Char) :string; function RoundtoExStr(const Value:Double;Digit:word=2; Format :Boolean= False):string; procedure ReplaceEx(var s:string;const SourceChar,RChar:PChar);
procedure DrawMoneyHeader(const Canvas :TCanvas;ARect :TRect;AWidth :Integer); var I,J :Integer; iStart :Integer; sText,S :string; rcText :TRect; OldBrushStyle :TBrushStyle; APt,BPt :TPoint; begin J :=0; iStart :=Length(UnitList)-MaxDigit; for I := iStart to High(UnitList) do begin sText :=UnitList[I]; S :=sText;
case Length(sText) of 1: begin rcText.Top := ARect.Top+2; rcText.Bottom := ARect.Bottom; rcText.Left := ARect.Left+J*AWidth+2; rcText.Right := rcText.Left + AWidth-1 ; Canvas.Brush.Style :=bsClear; Canvas.TextRect(rcText,S,[tfSingleLine,tfCenter,tfVerticalCenter]); Canvas.Brush.Style :=OldBrushStyle; end; 2: begin
//画框线 for I := 1 to MaxDigit-1 do begin APt.X :=ARect.Left+I*AWidth+1; APt.Y :=ARect.Top; BPt.X :=ARect.Left+I*AWidth+1; BPt.Y :=ARect.Bottom; DrawLine(Canvas,APt,BPt); end end;
S :=FloatToStr(Abs(AValue)); if S='0' then S :=''; intLen := Length(S);
if intLen<> 0 Then begin if Pos('.',S)>0 then begin if intLen>MaxDigit then begin //Application.MessageBox('数值超出范围!','错误',MB_ICONERROR+MB_OK); Exit; end; end; S :=RoundtoExStr(StrToFloat(S),2,True); if S='0.00' then S :='' else ReplaceEx(S,'.','');
S :=Lpad(S,-MaxDigit,'0'); intLen := Length(S); if IntLen>MaxDigit then begin //Application.MessageBox('数值超出范围!','错误',MB_ICONERROR+MB_OK); Exit end;
if AValue<0 then AFont.Color :=clRed else AFont.Color :=clBlue; OldFont :=Canvas.Font; Canvas.Font :=AFont;
for I := 1 to Length(S) do begin rcText.Left := ARect.Left + (MaxDigit-1 - intLen + i) * AWidth+1; rcText.Right := rcText.Left + AWidth-1; if rcText.Right>=ARect.Right-1 then rcText.Right :=rcText.Right-DefLineWidth; rcText.Bottom :=ARect.Bottom+DefLineWidth;
sText :=Copy(S,I,1);
if sText='0' then begin if iFlag then begin if Copy(S,I+1,1)<>'0' then begin if CurrencyFlag then begin sText :='¥'; Canvas.TextRect(rcText,sText,[tfSingleLine,tfCenter,tfVerticalCenter]); end; end;
end else begin Canvas.Brush.Style :=bsClear; Canvas.TextRect(rcText,sText,[tfSingleLine,tfCenter,tfVerticalCenter]); Canvas.Brush.Style :=OldBrushStyle; end; end else begin iFlag :=False; Canvas.Brush.Style :=bsClear; Canvas.TextRect(rcText,sText,[tfSingleLine,tfCenter,tfVerticalCenter]); Canvas.Brush.Style :=OldBrushStyle; end; end; finally Canvas.Font :=OldFont; Canvas.Brush.Style :=OldBrushStyle; end; end; for I := 1 to MaxDigit-1 do begin APt.X :=ARect.Left+I*AWidth; APt.Y :=ARect.Top-1; BPt.X :=ARect.Left+I*AWidth; BPt.Y :=ARect.Bottom; if I =MaxDigit-2 then DrawLine(Canvas,APt,BPt,clred,2) else if ((MaxDigit-2-I) mod 3)=0 then DrawLine(Canvas,APt,BPt,clBlue,2) else DrawLine(Canvas,APt,BPt,clGreen) end; APt.X :=ARect.Right; APt.Y :=ARect.Top-1; BPt.X :=ARect.Right; BPt.Y :=ARect.Bottom; DrawLine(Canvas,APt,BPt,clWhite,1); APt.X :=ARect.Right-1; BPt.X :=ARect.Right-1; DrawLine(Canvas,APt,BPt,clBlack,2); APt.X :=ARect.Right+3; BPt.X :=ARect.Right+3; DrawLine(Canvas,APt,BPt,clBlack,1); end;
procedure ReplaceEx(var s:string;const SourceChar,RChar:PChar); //第一个参数是原串,第二个是模式串,第三个是替换串 var ta,i,j:integer; m,n,pn,sn:integer; SLen,SCLen,RCLen:integer;//SLen表示原串的长度,SCLen表示模式传的长度,RCLen表示替换串的长度 IsSame:integer; newp:array of char;//用来保存替换后的字符数组
begin SLen:=strlen(pchar(s));SCLen:=strlen(SourceChar);RCLen:=strlen(RChar); j:=pos(string(SourceChar),s); s:=s+chr(0);ta:=0;i:=j; while s[i]<>chr(0) do //这个循环用ta统计模式串在原串中出现的次数 begin n:=0;IsSame:=1; for m:=i to i+SCLen-1 do begin if m>SLen then begin IsSame:=0; break; end; if s[m]<>sourceChar[n] then begin IsSame:=0; break; end; n:=n+1; end; if IsSame=1 then begin ta:=ta+1; i:=m; end else i:=i+1; end; if j>0 then begin pn:=0;sn:=1; SetLength(newp,SLen-ta*SCLen+ta*RCLen+1);//分配newp的长度,+1表示后面还有一个#0结束符 while s[sn]<>chr(0) do //主要循环,开始替换 begin n:=0;IsSame:=1; for m:=sn to sn+SCLen-1 do //比较子串是否和模式串相同 begin if m>SLen then begin IsSame:=0; break; end; if s[m]<>sourceChar[n] then begin IsSame:=0;break; end; n:=n+1; end; if IsSame=1 then//相同 begin for m:=0 to RCLen-1 do begin newp[pn]:=RChar[m]; pn:=pn+1; end; sn:=sn+SCLen; end else begin //不同 newp[pn]:=s[sn]; pn:=pn+1;sn:=sn+1; end; end;
s:=string(newp); //重置s,替换完成! sLen :=Length(s); S :=Copy(S,1,sLen-1); end; end;
function Lpad(const Str :string;Len :Integer;FillStr :Char) :string; var Str1 :string; Str2 :string; I :Integer; begin if Len=0 then begin Result :=''; Exit; end else if Length(Str)>=Abs(Len) then begin if Len>0 then begin Result :=Copy(Str,1,Abs(Len)); Exit; end else begin I :=Length(Str)-Abs(Len)+1; Result :=Copy(Str,I,Abs(Len)); Exit; end; end; if Len>0 then begin Str1 :=stringOfChar(FillStr,Abs(Len));
Str1 :=Str+Str1; Result :=Copy(Str1,1,Abs(Len)); Exit; end else begin Str1 :=stringOfChar(FillStr,Abs(Len)); Str1 :=Str1+Str; I :=Length(Str1)-Abs(Len)+1; Result :=Copy(Str1,I,Abs(Len)); Exit; end;
end;
function RoundtoExStr(const Value:Double;Digit:word=2; Format :Boolean= False):string; var Str :string; Ex :Extended; I :Integer; begin Str :='0.'+StringOfChar('0',Digit); Result :=Str;
Str :='#0.'+StringOfChar('0',Digit); Ex :=StrToFloat(FloatToStr(Value)); Str :=FloatToStr(StrToFloat(FormatFloat(Str,Ex))); if not Format then begin Result :=Str; Exit; end else begin I :=Pos('.',Str); if I=0 then Str :=Str+'.0'; Str :=Lpad(Str,20,'0'); I :=Pos('.',Str); Result :=Copy(Str,1,I+Digit); end; end;
procedure TForm1.Button1Click(Sender: TObject); var I,J :Integer; sValue:string; rcRect :TRect; APt,BPt :TPoint; begin CommitFlag :=True; end;
procedure TForm1.FormCreate(Sender: TObject); begin InitGrid; DefLineWidth :=Grid.GridLineWidth;
end;
procedure TForm1.GridCellsChanged(Sender: TObject; R: TRect); var I :Integer; sValue1,sValue2 :double; begin sValue1 :=0; sValue2 :=0; with Grid do begin for I :=FixedRows to RowCount-2 do begin sValue1 :=sValue1+Floats[3,I]; sValue2 :=sValue2+Floats[4,I]; end; if sValue1<>0 then Floats[3,Grid.RowCount-1] :=sValue1; if sValue2<>0 then Floats[4,Grid.RowCount-1] :=sValue2; end; end;
procedure TForm1.GridDrawCell(Sender: TObject; ACol, ARow: Integer; Rect: TRect; State: TGridDrawState); var I,J :Integer; SngWidth,iHeigth :Integer; rcText : TRect; S,sText :string; sValue,sValue1,sValue2 :Double; APt,BPt :TPoint; OldBrushStyle :TBrushStyle; begin with Grid do begin OldBrushStyle :=Canvas.Brush.Style; case ACol of 0: begin if ARow=0 then begin sText :='摘 要'; rcText :=Rect; rcText.Left :=rcText.Left; rcText.Top :=rcText.Top; rcText.Right :=Grid.Columns[Acol].Width; rcText.Bottom :=Grid.RowHeights[0]+Grid.RowHeights[1]-2*DefLineWidth;
Canvas.Brush.Style :=bsClear; Canvas.FillRect(rcText); Canvas.TextRect(rcText,sText,[tfSingleLine,tfCenter,tfVerticalCenter]); Canvas.Brush.Style :=OldBrushStyle; end; if ARow=RowCount-1 then begin sValue :=Ints[ACol,ARow]; if sValue =0 then S :=' ' else S :=IntToStr(Ints[ACol,ARow]); sText :='附件 '+S+' 张'; rcText :=Rect; rcText.Left :=rcText.Left; rcText.Top :=rcText.Top; rcText.Right :=rcText.Left+Grid.Columns[Acol].Width-2*DefLineWidth; rcText.Bottom :=rcText.Top+Grid.RowHeights[ARow]-2*DefLineWidth;
end; 1,2: begin if ARow=RowCount-1 then begin if ACol=1 then begin sText :='合 计'; rcText :=Rect; rcText.Left :=rcText.Left; rcText.Top :=rcText.Top; rcText.Right :=rcText.Left+Grid.Columns[1].Width+Grid.Columns[2].Width-2; rcText.Bottom :=rcText.Top+Grid.RowHeights[ARow]-2;
//Canvas.Brush.Style :=bsClear; Canvas.FillRect(rcText); Canvas.TextRect(rcText,sText,[tfSingleLine,tfCenter,tfVerticalCenter]); Canvas.Brush.Style :=OldBrushStyle; end; end else if ARow=0 then begin if ACol=1 then begin sText :='会计科目'; rcText :=Rect; rcText.Left :=rcText.Left; rcText.Top :=rcText.Top; rcText.Right :=rcText.Left+Grid.Columns[1].Width+Grid.Columns[2].Width; rcText.Bottom :=Grid.RowHeights[ARow];
Canvas.Brush.Style :=bsClear; Canvas.FillRect(rcText); Canvas.TextRect(rcText,sText,[tfSingleLine,tfCenter,tfVerticalCenter]); Canvas.Brush.Style :=OldBrushStyle; end; end else if ARow=1 then begin case ACol of 1: begin sText :='总帐科目'; rcText :=Rect; rcText.Left :=rcText.Left; rcText.Top :=rcText.Top; rcText.Right :=rcText.Left+Grid.Columns[ACol].Width; rcText.Bottom :=rcText.Top+Grid.RowHeights[ARow];
end; end; end end; 3,4: begin if ARow=0 then begin case ACol of 3: begin sText :='借方金额'; rcText :=Rect; rcText.Left :=rcText.Left; rcText.Top :=rcText.Top; rcText.Right :=rcText.Left+Grid.Columns[ACol].Width; rcText.Bottom :=rcText.Top+Grid.RowHeights[ARow];
Canvas.Brush.Style :=bsClear; Canvas.FillRect(rcText); Canvas.TextRect(rcText,sText,[tfSingleLine,tfCenter,tfVerticalCenter]); Canvas.Brush.Style :=OldBrushStyle; end; end; end else if ARow=1 then begin sngWidth := Grid.Columns[ACol].Width div MaxDigit; DrawMoneyHeader(Canvas,Rect,sngWidth); end else if ARow=RowCount-1 then begin sngWidth := Grid.Columns[ACol].Width div MaxDigit; sValue1 :=0; sValue2 :=0; for I := FixedRows to RowCount-2 do begin sValue1 :=sValue1+Floats[3,I]; sValue2 :=sValue2+Floats[4,I]; end; case ACol of 3: begin DrawMoneyValue(Canvas,Rect,sValue1,SngWidth,True); end; 4: begin DrawMoneyValue(Canvas,Rect,sValue2,SngWidth,True); end; end;
end else begin sngWidth := Grid.Columns[ACol].Width div MaxDigit; if ARow>=Grid.FixedRows then begin //S :=Grid.Cells[ACol,ARow]; sValue :=Grid.Floats[ACol,ARow]; DrawMoneyValue(Canvas,Rect,sValue,SngWidth); end; end; //==========提交========== if CommitFlag then begin J :=FixedRows; for I :=RowCount-2 downto FixedRows do begin sText :=Trim(Cells[3,I]+Cells[4,I]); if sText<>'' then begin J :=I+1; Break; end; end;
if J<>(Grid.RowCount-2) then begin rcText :=Grid.CellRect(3,Grid.RowCount-2); APt.X := rcText.Left; APt.Y := rcText.Bottom;
end; 5: begin if ARow=0 then begin rcText :=Rect; rcText.Left :=rcText.Left; rcText.Top :=rcText.Top; rcText.Right :=rcText.Left+Grid.Columns[Acol].Width-DefLineWidth; rcText.Bottom :=rcText.Top+Grid.RowHeights[0]+Grid.RowHeights[1]-2*DefLineWidth; iHeigth :=rcText.Bottom-rcText.Top; Canvas.Brush.Style :=bsClear; Canvas.FillRect(rcText); Canvas.Brush.Style :=OldBrushStyle; rcText :=Rect;
sText :='记账√'; for I := 1 to Length(sText) do begin S :=Copy(sText,I,1); rcText.Top :=Rect.Top; rcText.Top := rcText.Top+(I-1)*(iHeigth div 3); rcText.Bottom := rcText.Top + iHeigth div 3;
Canvas.Brush.Style :=bsClear; Canvas.TextRect(rcText,S,[tfSingleLine,tfCenter,tfVerticalCenter]); Canvas.Brush.Style :=OldBrushStyle; end; end else if ARow>=FixedRows then begin S :='√'; sValue :=Grid.Floats[ACol,ARow]; if sValue<>1 then begin S :=''; end; sText :=S; rcText :=Rect; rcText.Left :=rcText.Left+DefLineWidth; rcText.Top :=rcText.Top+DefLineWidth; rcText.Right :=rcText.Right-DefLineWidth; rcText.Bottom :=rcText.Bottom-DefLineWidth; Canvas.FillRect(rcText); Canvas.Brush.Style :=bsClear; Canvas.TextRect(rcText,sText,[tfSingleLine,tfCenter,tfVerticalCenter]); Canvas.Brush.Style :=OldBrushStyle; end; end; end; end; end;
procedure TForm1.GridGetCellBorder(Sender: TObject; ARow, ACol: Integer; APen: TPen; var Borders: TCellBorders); begin { if (ARow>=Grid.FixedRows) and (ACol>=Grid.FixedCols) then begin Borders := [cbLeft,cbRight]; APen.Width := 1; APen.Color := Grid.GridLineColor; end; } end;
procedure TForm1.InitGrid; var I :Integer; begin CommitFlag :=False; Grid.RowHeights[0] :=35; Grid.RowHeights[1] :=44; Grid.MergeCells(0,0,1,2); Grid.MergeCells(1,0,2,1); Grid.MergeCells(5,0,1,2); Grid.MergeCells(1,Grid.RowCount-1,2,1); Grid.Cells[0,0] :=''; for I := 1 to Grid.ColCount-1 do Grid.ReadOnly[I,Grid.RowCount-1] :=True; { Grid.Cells[1,0] :='会计科目';