test_edit_src.pas

来自「一个仓库管理中的子系统－－采购子系统」· PAS 代码 · 共 617 行 · 第 1/2 页

unit test_edit_src;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  Grids, ComCtrls, ExtCtrls, StdCtrls, Buttons;
  
const
  grid_headcolor=$00ACEEFF;
  grid_highcolor=$00F7FFFF;
  grid_lowcolor=$00CAFFFF;
  grid_selectedcolor=$0EFFAA00;

type
  TSomeInts = 1..12;
  TmonthSet = set of TSomeInts;

var dhsm_field_index:integer;
    bz_field_index:integer;
    sqbid_field_index:integer;
    cpbh_field_index:integer;
    MyRowCount:integer;
type
  TForm2 = class(TForm)
    StringGrid1: TStringGrid;
    DateTimePicker1: TDateTimePicker;
    BitBtn1: TBitBtn;
    ComboBox1: TComboBox;
    BitBtn2: TBitBtn;
    procedure StringGrid1DrawCell(Sender: TObject; ACol, ARow: Integer;
      Rect: TRect; State: TGridDrawState);
    procedure StringGrid1SelectCell(Sender: TObject; ACol, ARow: Integer;
      var CanSelect: Boolean);
    procedure FormActivate(Sender: TObject);
    procedure FormResize(Sender: TObject);
    procedure ComboBox1Change(Sender: TObject);
    procedure DateTimePicker1CloseUp(Sender: TObject);
    procedure DateTimePicker1Click(Sender: TObject);
    procedure BitBtn1Click(Sender: TObject);
    procedure DateTimePicker1UserInput(Sender: TObject;
      const UserString: String; var DateAndTime: TDateTime;
      var AllowChange: Boolean);
    procedure DateTimePicker1Exit(Sender: TObject);
  private
    { Private declarations }
  public
  Procedure DisplayComponent(TheObject:TWinControl);
  Procedure distributetext (canvas:tcanvas; width: integer; font: tfont; text:string; strings: tstringlist);
  Procedure writetext (canvas:tcanvas; x1,y1,x2,y2: integer; textxdirectionspace,textydirectionspace:integer;text: string; font: tfont; alignflag: integer; ifrh: boolean);
  Function  ShowMeDate(Date709str:string):string;
  Function  DateTo709Str(date709:Tdate):string;
  Function  IntToStrPad0(N:LongInt;Len:Integer):string;
  Function GetDate709(datestr:String):string;

    { Public declarations }
  end;

var
  Form2: TForm2;

implementation

uses datamodule, cghzbcx;

{$R *.DFM}



Function TForm2.GetDate709(datestr:string):string;
var date709str:string;
begin
    date709str:=Copy(datestr,1,4);
    date709str:=date709str+Copy(datestr,6,2);
    date709str:=date709str+Copy(datestr,9,2);
    result:=date709str;
end;


Function TForm2.ShowMeDate(Date709str:string):string;
var ShowDatestr:string;
    monthstr:string;
    daystr:string;
    bigmonth,smallmonth:Tmonthset;
begin
    bigmonth:=[1,3,5,7,8,10,12];
    smallmonth:=[4,6,9,11];
    if length(date709str)=8 then //1st if clause
    begin
      monthstr:=Copy(Date709str,5,2);
      daystr:=Copy(Date709str,7,2);
      ShowDatestr:=Copy(Date709str,1,4);
      ShowDatestr:=ShowDatestr+'-';

      if (strtoint(monthstr)<=12) and (strtoint(monthstr)>=1) then //判断月份是否正确
        ShowDatestr:=ShowDatestr+monthstr
      else
      begin
        showmessage('您输入的月份不符合要求！');
        result:='';
        exit;
      end;

      ShowDatestr:=ShowDatestr+'-';

      if  strtoint(monthstr) in bigmonth then   //判断日期是否正确
      begin
       if (strtoint(daystr)<=31) and (strtoint(daystr)>=1) then
         ShowDatestr:=ShowDatestr+daystr
       else
       begin
        showmessage('您输入的日期不符合要求！');
        result:='';
        exit;
       end;
      end
      else
      if strtoint(monthstr) in smallmonth then
      begin
       if (strtoint(daystr)<=30) and (strtoint(daystr)>=1) then
         ShowDatestr:=ShowDatestr+daystr
       else
       begin
        showmessage('您输入的日期不符合要求！');
        result:='';
        exit;
       end;
      end
      else
       if (strtoint(daystr)<=29) and (strtoint(daystr)>=1) then
         ShowDatestr:=ShowDatestr+daystr
       else
       begin
        showmessage('您输入的日期不符合要求！');
        result:='';
        exit;
       end;
    end
    else
    if length(date709str)=6 then
    begin
      monthstr:=Copy(Date709str,3,2);
      daystr:=Copy(Date709str,5,2);
      ShowDatestr:=Copy(Date709str,1,2);
      ShowDatestr:='20'+ShowDatestr+'-';

      if (strtoint(monthstr)<=12) and (strtoint(monthstr)>=1) then //判断月份是否正确
        ShowDatestr:=ShowDatestr+monthstr
      else
      begin
        showmessage('您输入的月份不符合要求！');
        result:='';
        exit;
      end;

      ShowDatestr:=ShowDatestr+'-';

      if  strtoint(monthstr) in bigmonth then   //判断日期是否正确
      begin
       if (strtoint(daystr)<=31) and (strtoint(daystr)>=1) then
         ShowDatestr:=ShowDatestr+daystr
       else
       begin
        showmessage('您输入的日期不符合要求！');
        result:='';
        exit;
       end;
      end
      else
      if strtoint(monthstr) in smallmonth then
      begin
       if (strtoint(daystr)<=30) and (strtoint(daystr)>=1) then
         ShowDatestr:=ShowDatestr+daystr
       else
       begin
        showmessage('您输入的日期不符合要求！');
        result:='';
        exit;
       end;
      end
      else
       if (strtoint(daystr)<=29) and (strtoint(daystr)>=1) then
         ShowDatestr:=ShowDatestr+daystr
       else
       begin
        showmessage('您输入的日期不符合要求！');
        result:='';
        exit;
       end;
    end;
    result:=ShowDatestr;
end;

Function TForm2.DateTo709Str(date709:Tdate):string;
var str709:string;
year,month,day:word;
begin
    decodeDate(date709,year,month,day);
    str709:=intTostr(year)+intTostrpad0(month,2)+IntTostrpad0(day,2);
    result:=str709;
end;

Function TForm2.IntToStrPad0(N:LongInt;Len:Integer):string; //定制字符串的长度，不够的加零补齐
begin
   FmtStr(Result,'%d',[N]);
   while Length(Result)<len do
    Result:='0'+Result;
end;

Procedure TForm2.distributetext (canvas:tcanvas; width: integer; font: tfont; text:string; strings: tstringlist);
Var
  count1 : integer;
  buf : string;
  addbuf : string;
Begin
  strings.Clear;
  Canvas.Font := font;
  buf := '';
  count1 := 1;
  While count1 <= length (text) Do
    Begin
      addbuf := '';
      If ord (text[count1]) <= 126 Then
        Begin
          // that is to say text[count1] is not chinese;
          addbuf := text[count1];
          inc (count1)
        End
      Else
        Begin
          addbuf := text[count1] + text[count1 + 1];
          count1 := count1 + 2
        End;
      If Canvas.TextWidth (buf + addbuf) <= width Then
        // that is to say there has enough space;
        buf := buf + addbuf
      Else
        Begin
          If Canvas.TextWidth (buf) <= width Then
            strings.Add (buf);
          buf := addbuf
        End
    End; // while count1<=length(text) do end;
  If ((strings.Count <> 0)
       and
      (strings[strings.count -
               1] <> buf))
      or
     ((strings.Count = 0)
       and
      (buf <> '')) Then
    strings.Add (buf)
End;

Procedure TForm2.writetext (canvas:tcanvas; x1,y1,x2,y2: integer; textxdirectionspace,textydirectionspace:integer;text: string; font: tfont; alignflag: integer; ifrh: boolean);
Var
  count1 : integer;
  count2 : integer;
  length : integer;
  textheight : integer;
  beforeheight : integer;
  strings : tstringlist;
  width,height:integer;
Begin
try
  canvas.Lock;
  canvas.Brush.style:=bsclear;
  Canvas.font := font;
  width:=abs(x1-x2);
  height:=abs(y1-y2);
  If ifrh = false Then
  //不进行绕行
    Begin
      textheight := Canvas.TextHeight (text);
      Case alignflag Of
      0:
      //左对齐
      canvas.textrect(rect(x1,y1,x2,y2),x1+textxdirectionspace,y1+textydirectionspace+round ((height - 2 *textydirectionspace - textheight) / 2),text);
      1://中对齐
        Begin
          length := Canvas.TextWidth (text);
          canvas.textrect(rect(x1,y1,x2,y2),x1+round (textxdirectionspace + (width - 2* textxdirectionspace - length) / 2),y1+textydirectionspace+round ((height - 2 *textydirectionspace - textheight) / 2),text);
        End;
      2://右对齐
        Begin
          length := Canvas.TextWidth (text);
          canvas.textrect(rect(x1,y1,x2,y2),x1+width - textxdirectionspace - length,y1+round ((height - 2 * textydirectionspace - textheight) / 2 +textydirectionspace), text);
        End;
      End
      // end case;

    End
  Else
    Begin // 字符需要绕行
      strings := tstringlist.Create;
      distributetext (canvas, width - 2 * textxdirectionspace, font, text, strings);
      textheight := 0;
      For count1 := 0 to strings.Count - 1 Do
        textheight := textheight + Canvas.TextHeight (strings[count1]);
      Case alignflag Of
      0: For count1 := 0 to strings.Count - 1 Do
        Begin
          beforeheight := 0;
          For count2 := 0 to count1 - 1 Do
            beforeheight := beforeheight + canvas.textheight (strings[count2]);
            canvas.textrect(rect(x1,y1,x2,y2),x1+textxdirectionspace,y1+textydirectionspace+round ((height - 2 *textydirectionspace - textheight) / 2)+beforeheight,strings[count1]);
        End;
      2: For count1 := 0 to strings.Count - 1 Do
        Begin