publicfunction.pas

地理资源的录入程序运用了api的一些知识

unit PublicFunction;

interface

uses
  Windows, SysUtils, Classes, Messages, Forms, DB, Dialogs, Controls, DBTables,
  Grids, ShellApi;
var lyzy,dqjj_str,tdly_str,dmsj:string;
{自定函数或程序}

function ExecuteForm(AFormClass: TFormClass): Boolean;
function DateCal(InDate: string; IncDec: Integer): string;
procedure MyWarning(MyMessage: string);
procedure MyError(MyMessage: string);
function MyConfirmation(MyMessage: string): Boolean;
procedure NullWarning(MyMessage: string);
procedure RepeatWarning(MyMessage: string);
procedure NotFoundWarning(FieldTitle, sValue: string);
procedure CannotDeleteWarning(FieldTitle, sValue: string);
procedure MyInformation(MyMessage: string);
function Space(NT: Integer): string;
function RepStr(sC: string; iCount: Integer): string;
procedure About;
function XToD(small: real): string;

//Function XiaoxieToDaxie(f : String) : String;
function XIaoToDa(const Num: Real): string;

implementation

uses main, datam;

function ExecuteForm(AFormClass: TFormClass): Boolean;
begin
  Screen.Cursor := crHourGlass;
  with AFormClass.Create(Application) do
  begin
    Screen.Cursor := crDefault;
    if ShowModal = mrOK then
      Result := True
    else
      Result := False;
    Free;
  end;
end;


procedure About;
//显示Windows关于对话框
begin
  ShellAbout(Application.Handle, PChar(application.MainForm.Caption), '',
    Application.Icon.Handle);
end;

function Space(NT: Integer): string;
var
  ms: string;
  i: Integer;
begin
  ms := '';
  for i := 1 to NT do
    ms := ms + ' ';
  Space := ms;
end;

function RepStr(sC: string; iCount: Integer): string;
var
  ms: string;
  i: Integer;
begin
  ms := '';
  for i := 1 to iCount do
    ms := ms + sC;
  RepStr := ms;
end;

function SubStr(cString: string; cB: Integer; cE: Integer): string;
var
  ms: string;
  ml, mb, me: Integer;
begin
  ms := cString;
  ml := Length(cString);
  mb := cB;
  me := cE;
  if mb > ml then
    mb := ml;
  if me > (ml - mb + 1) then
    me := (ml - mb + 1);
  SubStr := Copy(ms, mb, me);
end;

function LeftStr(cString: string; cL: Integer): string;
var
  ms: string;
  ml, mh, mb, me: Integer;
begin
  ms := cString;
  ml := Length(cString);
  mh := cL;
  if mh > ml then
    mh := ml;
  mb := 1;
  me := mh;
  LeftStr := Copy(ms, mb, me);
end;

function RightStr(cString: string; cR: Integer): string;
var
  ms: string;
  ml, mh, mb, me: Integer;
begin
  ms := cString;
  ml := Length(cString);
  mh := cR;
  if mh > ml then
    mh := ml;
  mb := ml - mh + 1;
  me := mh;
  RightStr := Copy(ms, mb, me);
end;

function AtStr(cString: string; eString: string): Integer;
var
  ms: string;
  i, ml: Integer;
begin
  ms := LeftStr(cString, 1);
  ml := Length(eString);
  AtStr := 0;
  for i := 1 to ml do
  begin
    if SubStr(eString, i, 1) = ms then
    begin
      AtStr := i;
      Break;
    end;
  end;
end;

function DateCal(InDate: string; IncDec: Integer): string;
var
  mInDate: TDateTime;
  Year, Month, Day: Word;
begin
  mInDate := StrToDateTime(
    IntToStr(StrToInt(LeftStr(InDate, 2)) + 1911) + '-' +
    SubStr(InDate, 4, 2) + '-' +
    RightStr(InDate, 2));
  mInDate := mInDate + IncDec;
  DecodeDate(mInDate, Year, Month, Day);
  Year := Year - 1911;
  DateCal := IntToStr(Year) + '-' +
    RightStr('00' + IntToStr(Month), 2) + '-' +
    RightStr('00' + IntToStr(Day), 2);
end;

procedure MyWarning(MyMessage: string);
begin
  MessageDlg(MyMessage, mtWarning, [mbOk], 0);
end;


function MyConfirmation(MyMessage: string): Boolean;
begin
  if MessageDlg(MyMessage, mtConfirmation, [mbOk, mbCancel], 0) = mrOk then
    MyConfirmation := True
  else
    MyConfirmation := False;
end;

procedure MyInformation(MyMessage: string);
begin
  MessageDlg(MyMessage, mtInformation, [mbOk], 0);
end;

procedure MyError(MyMessage: string);
begin
  MessageDlg(MyMessage, mtError, [mbOk], 0);
end;

procedure NullWarning(MyMessage: string);
begin
  MyWarning(MyMessage + '不可空白，请重新输入！');
end;

procedure RepeatWarning(MyMessage: string);
begin
  MyWarning(MyMessage + '重覆，请重新输入！');
end;

procedure NotFoundWarning(FieldTitle, sValue: string);
begin
  MyWarning(FieldTitle + '：[' + sValue + ']' + #10#13 +
    '在它的参考档中找不到，请重新输入！');
end;

procedure CannotDeleteWarning(FieldTitle, sValue: string);
begin
  MyWarning(FieldTitle + '：[' + sValue + ']' + #10#13 +
    '在被其它的档案所参考，不可删除！');
end; // 检验身分证号码的正确性

{Function XiaoxieToDaxie(f : String) : String;
var
   Fs,dx,d2,zs,xs,h,jg:string;
   i,ws,w,j,lx:integer;
begin    // l,
  f := Trim(f);
  if copy(f,1,1)='-' then begin
    Delete(f,1,1);fs:='负';end
  else fs:='';
  dx:='零壹贰叁肆伍陆柒捌玖';
  d2:='拾佰仟万亿';
  i := AnsiPos('.',f);   //小数点位置
  if i = 0 Then
     zs := f     //整数
  else begin
     zs:=copy(f,1,i - 1);  //整数部分
     xs:=copy(f,i + 1,200);
  end;
  ws:= 0; //l := 0;
  for i := Length(zs) downto 1 do begin
    ws := ws + 1; h := '';
    w:=strtoint(copy(zs, i, 1));
    if (w=0) and (i=1) then jg:='零';
    If w > 0 Then
       Case ws of
         2..5:h:=copy(d2,(ws-1)*2-1,2);
         6..8:begin
           h:=copy(d2,(ws-5)*2-1,2);
           If AnsiPos('万',jg)=0 Then h:=h+'万';
           end;
         10..13:h := copy(d2,(ws-9)*2-1, 2);
       End;
    jg:=copy(dx,(w+1)*2-1,2) + h + jg;
    If ws=9 Then jg := copy(jg,1,2) + '亿' + copy(jg,3,200);
  end;
  j:=AnsiPos('零零',jg);
  While j > 0 do begin
    jg := copy(jg, 1, j - 1) + copy(jg, j + 2,200);
    j := AnsiPos('零零',jg);
  end;
  If (Length(jg) > 1) And (copy(jg,length(jg)-1,2)='零') Then jg :=copy(jg,1,Length(jg)-2);
  j := AnsiPos('零亿',jg);
  If j > 0 Then jg := copy(jg,1, j - 1) + copy(jg, j + 2,200);
  //转换小数部分
  lx := Length(xs);
  If lx > 0 Then begin
    jg := jg + '元';
    For i := 1 To lx do begin
      if i=1 then begin
        jg := jg + copy(dx, strtoint(copy(xs,i,1))*2 + 1, 2);
        jg := jg +'角';
      end;
      if i=2 then begin
        jg := jg + copy(dx, strtoint(copy(xs,i,1))*2 + 1, 2);
        jg := jg +'分';
      end;
    end;
    j :=AnsiPos('零角零分',jg);
    if j>0 then jg := copy(jg,1,j-1)+copy(jg,j+8,200)+'整';
    j := AnsiPos('零角',jg);
    if j>0 then jg := copy(jg,1,j-1)+copy(jg,j+4,200);
    j := AnsiPos('零分',jg);
    if j>0 then jg := copy(jg,1,j-1)+copy(jg,j+4,200);
  End
  else
    jg := jg + '元整';
  result := fs+jg;
end;   }

function XToD(small: real): string;
var
  SmallMonth, BigMonth: string;
  wei1, qianwei1: string[2];
  wei, qianwei, dianweizhi, qian: integer;
begin
  {------- 修改参数令值更精确 -------}
  {小数点后的位数，需要的话也可以改动该值}
  qianwei := -2;
  {转换成货币形式，需要的话小数点后加多几个零}
  Smallmonth := formatfloat('0.00', small);
  {---------------------------------}
  dianweizhi := pos('.', Smallmonth); {小数点的位置}
  {循环小写货币的每一位，从小写的右边位置到左边}
  for qian := length(Smallmonth) downto 1 do
  begin
    {如果读到的不是小数点就继续}
    if qian <> dianweizhi then
    begin
      {位置上的数转换成大写}
      case strtoint(copy(Smallmonth, qian, 1)) of
        1: wei1 := '壹';
        2: wei1 := '贰';
        3: wei1 := '叁';
        4: wei1 := '肆';
        5: wei1 := '伍';
        6: wei1 := '陆';
        7: wei1 := '柒';
        8: wei1 := '捌';
        9: wei1 := '玖';
        0: wei1 := '零';
      end;
      {判断大写位置，可以继续增大到real类型的最大值，可是谁有那么多钱}
      case qianwei of
        -3: qianwei1 := '厘';
        -2: qianwei1 := '分';
        -1: qianwei1 := '角';
        0: qianwei1 := '元';
        1: qianwei1 := '拾';
        2: qianwei1 := '佰';
        3: qianwei1 := '千';
        4: qianwei1 := '万';
        5: qianwei1 := '拾';
        6: qianwei1 := '佰';
        7: qianwei1 := '千';
        8: qianwei1 := '亿';
        9: qianwei1 := '十';
        10: qianwei1 := '佰';
        11: qianwei1 := '千';
      end;
      inc(qianwei);
      BigMonth := wei1 + qianwei1 + BigMonth; {组合成大写金额}
    end;
  end;
  XToD := BigMonth;
end;

function XIaoToDa(const Num: Real): string;
//小写金额转大写金额
var
  aa, bb, cc: string;
  bbb: array[1..16] of string;
  uppna: array[0..9] of string;
  i: integer;
begin
  bbb[1] := '万';
  bbb[2] := '仟';
  bbb[3] := '佰';
  bbb[4] := '拾';
  bbb[5] := '亿';
  ;
  bbb[6] := '仟';
  ;
  bbb[7] := '佰';
  bbb[8] := '拾';
  bbb[9] := '万';
  bbb[10] := '仟';
  bbb[11] := '佰';
  bbb[12] := '拾';
  bbb[13] := '元';
  bbb[14] := '.';
  bbb[15] := '角';
  bbb[16] := '分';
  uppna[1] := '壹';
  uppna[2] := '贰';
  uppna[3] := '叁';
  uppna[4] := '肆';
  uppna[5] := '伍';
  uppna[6] := '陆';
  uppna[7] := '柒';
  uppna[8] := '捌';
  uppna[9] := '玖';
  Str(num: 16: 2, aa);
  cc := '';
  bb := '';
  result := '';
  for i := 1 to 16 do
  begin
    cc := aa[i];
    if cc <> ' ' then
    begin
      bb := bbb[i];
      if cc = '0' then
        cc := '零'
      else
      begin
        if cc = '.' then
        begin
          cc := '';
          bb := '';
        end
        else
        begin
          cc := uppna[StrToInt(cc)];
        end
      end;
      result := result + (cc + bb)
    end;
  end;
  result := result + '正';
end;

end.