单据编码类，可以根据指定的格式产生编码

url:http://www.itpub.net/191245.html

偶写得单据编码类，可以根据指定的格式产生编码PB&DELPHI

DELPHI版：
unit coding;

{
作者：谢中辉
电邮：xzh2000@hotmail.com
说明：单据编码类
示例：
var
code: TCoding;
C: String;
begin
Code := TCoding.Create( dmSys.admin);

Code.Register('K001','#4','',''); //0001,0002,0003......
Code.Register('K002','@y2@m2@d2#4','',''); //0401020001,0401020002
Code.Register('K003','K1.1#4','',''); //K.0001,K.0002,......
Code.Register('K004','@#1#4','',''); //#0001,#0002......
Code.Register('K005','@@1#4','',''); //@0001,@0002......

C := Code.GetCode('K001');

Code.Free;
end;
}

interface

uses
SysUtils, Classes, ADODB, StrUtils;

type
TCoding = class (TComponent)
FQry: TADOQuery;
private
public
constructor Create(const Value: TADOConnection);
destructor Destroy; override;

// 取得最大的流水号
function GetSeq(id: string): Integer;
// 设置最大的流水号
procedure SetSeq(id: string);

// 取得编码的日期与系统的日期
function GetDate(id: string; var sysdate, codedate: String): Boolean;
// 修改编码的日期
procedure SetDate(id, value: string);

// 获取编码ID的编码格式
function GetStyle(id: String): string;
// 修改编码ID的编码格式
procedure SetStyle(const Id, Value: string);

// 判断是否初始化编码类
function IsInit: Boolean;
// 初始化编码类，创建编码类需要的表
procedure Init;

// 判断某个字符是数字如'3'
function IsDigit(c: string): boolean; overload;
function IsDigit(c: char): boolean; overload;
// 判断编码格式是否有效
function IsValid(style: string): Boolean;

// 生成连续的N个C，如：0000
function Fill(C: String; Num: Integer): String;
// 执行SQL语句
function ExecSQL(const sql :string): Integer;
// 取得产生的单据号
function GetCode(id: string): string;
// 求得日期的某一部分
function GetPart(part: String): Integer;

// 判断某个编码ID是否注册
function IsRegister(const id: string): Boolean;
// 注册某个编码格式
procedure Register(const id, style, descr, bind: string);
// 取消某个编码格式的注册
procedure UnRegister(const id: string);
end;

implementation

{
*********************************** TCoding ************************************
}

constructor TCoding.Create(const Value: TADOConnection);
begin
FQry := TADOQuery.Create(Self);
FQry.Connection := Value;

// 初始化编码类所需的表
If not IsInit then Init;
end;

destructor TCoding.Destroy;
begin
FQry.Free;
inherited Destroy;
end;

function TCoding.ExecSQL(const sql :string): Integer;
var
li_ret: Integer;
begin
if FQry.Active then
FQry.Close;
FQry.SQL.Clear;
FQry.SQL.Add(sql);
if pos('select',sql) >0 then begin
FQry.Open;
li_ret := FQry.RecordCount;
end else begin
FQry.ExecSQL;
li_ret := FQry.RowsAffected;
Fqry.Close;
end;
Result := li_ret;
end;

function TCoding.GetCode(id: String): String;
var
li_num, li_code, li_part: Integer;
ls_str, ls_key, ls_sysdate, ls_codedate: String;
ls_style, ls_part, ls_parse, ls_format: String;
begin
ls_style := LowerCase(GetStyle( id ));
if ls_style = '' then exit;

GetDate(id, ls_sysdate, ls_codedate);
if (pos('@y', ls_style) > 0) and
(pos('@m', ls_style) > 0) and (ls_sysdate > ls_codedate) then
Self.SetDate(id, ls_sysdate);

while length(ls_style) > 0 do
begin
ls_str := Leftstr(ls_style, 1);
ls_style := MidStr(ls_style, 2, length(ls_style));
Case Integer(ls_str[1]) of
Integer('@'): Begin
ls_key := LeftStr(ls_style, 1);
ls_style := MidStr(ls_style, 2, length(ls_style));
Case Integer(ls_key[1]) of
Integer('@'):
if (IsDigit(leftstr(ls_style, 1))) and (IsDigit(midStr(ls_style, 2, 1))) then
begin
li_num := StrToInt(leftstr(ls_style, 2));
ls_parse := ls_parse + Fill('@', li_num);
ls_style := midStr(ls_style, 3, length(ls_style));
end else if IsDigit(leftStr(ls_style, 1)) then begin
li_num := StrToInt(leftStr(ls_style, 1));
ls_parse := ls_parse + Fill('@', li_num);
ls_style := midStr(ls_style, 2, length(ls_style));
end;
Integer('#'): Begin
if IsDigit(LeftStr(ls_style, 1)) and IsDigit(MidStr(ls_style, 2, 1)) then
begin
li_num := StrToInt(LeftStr(ls_style, 2));
ls_parse := ls_parse + Fill('#', li_num);
ls_style := midStr(ls_style, 3, length(ls_style));
end else if IsDigit(LeftStr(ls_style, 1)) then
begin
li_num := StrToInt(LeftStr(ls_style, 1));
ls_parse := ls_parse + Fill('#', li_num);
ls_style := MidStr(ls_style, 2, length(ls_style));
end;
end;
Integer('y'): Begin
li_num := StrToInt(LeftStr(ls_style, 1));
ls_style := midStr(ls_style, 2, length(ls_style));
if (li_num = 2) or (li_num = 4) then
ls_part := Fill('y', li_num);
li_part := GetPart(ls_part );
if li_part > 0 then begin
ls_format := fill('0', li_num);
ls_parse := ls_parse + rightStr(FormatFloat(ls_format, li_part), li_num);
end;
end;
Integer('m'), Integer('d'): Begin
li_num := StrToInt(leftStr(ls_style, 1));
ls_style := midStr(ls_style, 2, length(ls_style));
if (li_num = 1) or (li_num = 2) then
begin
ls_part := fill(ls_key, li_num);
li_part := GetPart(ls_part);
if li_part >= 0 then
ls_parse := ls_parse + FormatFloat(fill('0',li_num), li_part);
end
else
if IsDigit(ls_key) and IsDigit(leftStr(ls_style, 1)) and IsDigit(midStr(ls_style, 2, 1)) then
begin
li_num := StrToInt(leftStr(ls_style, 2));
ls_parse := ls_parse + Fill(ls_key, li_num);
ls_style := MidStr(ls_style, 3, Length(ls_style));
end else if IsDigit(ls_key) and IsDigit(leftStr(ls_style, 1)) then
begin
li_num := StrToInt(leftStr(ls_style, 1));
ls_parse := ls_parse + Fill(ls_key, li_num);
ls_style := MidStr(ls_style, 2, length(ls_style));
end;
end;
End;
end;
Integer('#'):
if IsDigit(leftStr(ls_style, 1)) and IsDigit(midStr(ls_style, 2, 1)) then
begin
li_num := StrToInt(leftStr(ls_style, 2));
ls_part := Fill('0', li_num);
li_code := GetSeq(id);
ls_parse := ls_parse + FormatFloat(ls_part, li_code);
ls_style := midStr(ls_style, 3, length(ls_style));
end
else if IsDigit(leftStr(ls_style, 1)) then
begin
li_num := StrToInt(leftStr(ls_style, 1));
ls_part := Fill('0', li_num);
li_code := GetSeq(id);
ls_parse := ls_parse + FormatFloat(ls_part, li_code);
ls_style := midStr(ls_style, 2, length(ls_style));
end;
else begin
if not IsDigit(ls_str) and IsDigit(leftstr(ls_style, 1)) and IsDigit(midstr(ls_style, 2, 1)) then
begin
li_num := StrToInt(leftStr(ls_style, 2));
ls_part := Fill(ls_str,li_num);
ls_parse := ls_parse + ls_part;
ls_style := midStr(ls_style, 3, length(ls_style));
end
else if not IsDigit(ls_str) and IsDigit(leftstr(ls_style, 1)) then
begin
li_num := StrToInt(leftStr(ls_style, 1));
ls_part := Fill(ls_str,li_num);
ls_parse := ls_parse + ls_part;
ls_style := midStr(ls_style, 2, length(ls_style));
end;
End;
end;
end;

Result := ls_parse;
end;

function TCoding.GetDate(id: string; var sysdate, codedate: String): Boolean;
var
Sql: String;
begin
Result := False;
Sql := 'select getdate() sysdate, dt from sys_code where id=' + QuotedStr(id);
if Self.ExecSQL(Sql) > 0 then begin
sysdate := LeftStr(FQry.Fields[0].AsString, 10);
codedate := LeftStr(FQry.Fields[1].AsString, 10);
FQry.Close;
Result := True;
end;
end;

function TCoding.GetPart(part: String): Integer;
var
Sql: String;
begin
Result := -1;
if LeftStr(part,1) = 'y' then
Sql := 'select year(GetDate())';
if LeftStr(part,1) = 'm' then
Sql := 'select month(GetDate())';
if LeftStr(part,1) = 'd' then
Sql := 'select day(GetDate())';
// 执行SQL，求出年月日
if Self.ExecSQL(sql) > 0 then
Result := FQry.Fields[0].AsInteger;
end;

function TCoding.GetSeq(id: string): Integer;
var
Sql: String;
Ret: Integer;
begin
Sql := 'select code from sys_code where id = ' + QuotedStr(id);

if Self.ExecSQL(sql) > 0 then
begin
Ret := FQry.Fields[0].AsInteger;
SetSeq(id);
end else
Ret := -1;

Result := Ret;
end;

function TCoding.GetStyle(Id: String): string;
var
Sql: String;
begin
Sql := 'select style from sys_style where id = ' + QuotedStr(id);
if Self.ExecSQL(sql) > 0 then
Result := FQry.Fields[0].AsString
else
Result := '';
end;

procedure TCoding.Init;
var
sql: string;
begin
sql := 'CREATE TABLE [sys_style]([id] [varchar](32) NOT NULL primary key,';
sql := sql + '[style] [varchar](64) NOT NULL, [descr] [varchar](64) NULL ,';
sql := sql + '[bind] [varchar](64) NULL, [flag] [char](1) NULL)';
Self.ExecSQL(sql);
sql := 'CREATE TABLE [sys_code]([id] [varchar](32) NOT NULL primary key,';
sql := sql + '[dt] [smalldatetime] NOT NULL DEFAULT (getdate()),[code] [int] NOT NULL,';
sql := sql + 'CONSTRAINT [fk_style_code] FOREIGN KEY([id]) REFERENCES [sys_style]([id]))';
Self.ExecSQL(sql);
end;

function TCoding.isDigit(c: string): boolean;
var
p: Array[0..1] of Char;
s: char;
begin
StrPCopy(p,c);
s := p[0];
if s in ['0'..'9'] then
Result := true
else
Result := false;
end;

function TCoding.isDigit(c: char): boolean;
begin
if c in ['0'..'9'] then
Result := true
else
Result := false;
end;

function TCoding.IsInit: Boolean;
var
sql: string;
i: Integer;
begin
Result := False;
sql := 'select name from sysobjects where name in (';
sql := sql + quotedStr('sys_code') + ','+quotedstr('sys_style')+')';
i := Self.ExecSQL(sql);
if i > 0 then
Result := True;
end;

function TCoding.IsRegister(const id: string): Boolean;
var
sql: string;
ret: Integer;
begin
sql := 'select id from sys_style where id = '+QuotedStr(id);
ret := Self.ExecSQL(sql);
if ret > 0 then
Result := true
else
Result := false;
end;

{
function TCoding.IsSync(id: string): Boolean;
var
SQL, Sync: String;
begin
SQL := 'select flag from sys_style where id = ' + QuotedStr(id);

if Self.ExecSQL(SQL) > 0 then
begin
Sync := FQry.Fields[0].AsString;
if Sync = '0' then
Result := True
else
Result := False;
end;
end;
}

function TCoding.IsValid(style: string): Boolean;
var
ls_f, ls_old, ls_1, ls_2: string;
li_pos: Integer;
begin
Result := true;
ls_old := LowerCase(style);
// 判断一般情况下编码格式是否有效
while length(ls_old) > 0 do
begin
ls_f := leftstr(ls_old, 1);
case Integer(ls_f[1]) of
Integer('@'):begin
ls_old := midstr(ls_old, 2, length(ls_old));
if (leftstr(ls_old, 1) = '@') and (IsDigit(Pchar(midstr(ls_old, 2, 1)))) and (IsDigit(midstr(ls_old, 3, 1))) then
ls_old := Midstr(ls_old, 4, length(ls_old))
else if (leftstr(ls_old, 1) = '@') and (IsDigit(midstr(ls_old, 2, 1))) then
ls_old := MidStr(ls_old, 3, length(ls_old))
else if (leftstr(ls_old, 1) = '#') and (IsDigit(midstr(ls_old, 2, 1))) and (IsDigit(midstr(ls_old, 3, 1))) then
ls_old := Midstr(ls_old, 4, length(ls_old))
else if (leftstr(ls_old, 1) = '#') and (IsDigit(MidStr(ls_old, 2, 1))) then
ls_old := MidStr(ls_old, 3, length(ls_old))
else if (IsDigit(leftstr(ls_old, 1))) and (IsDigit(MidStr(ls_old, 2, 1))) and (IsDigit(MidStr(ls_old, 3, 1))) then
ls_old := MidStr(ls_old, 4, length(ls_old))
else if (IsDigit(leftstr(ls_old, 1))) and (IsDigit(MidStr(ls_old, 2, 1))) then
ls_old := MidStr(ls_old, 3, length(ls_old))
else if not IsDigit(leftstr(ls_old, 1)) and (IsDigit(MidStr(ls_old, 2, 1))) then
ls_old := MidStr(ls_old, 3, length(ls_old))
else if IsDigit(leftstr(ls_old, 1)) then
Result := False;
end;
Integer('#'):begin
ls_old := midstr(ls_old, 2, length(ls_old));
if IsDigit(leftstr(ls_old, 1)) and IsDigit(midstr(ls_old, 2, 1)) then
ls_old := Midstr(ls_old, 3, length(ls_old))
else if IsDigit(leftstr(ls_old, 1)) then
ls_old := midstr(ls_old, 2, length(ls_old))
else
Result := false;
end;
else begin
ls_old := midstr(ls_old, 2, length(ls_old));
if not IsDigit(ls_f) and IsDigit(leftstr(ls_old, 1)) and IsDigit(midstr(ls_old, 2, 1)) then
ls_old := Midstr(ls_old, 3, length(ls_old))
else if not IsDigit(ls_f) and IsDigit(leftstr(ls_old, 1)) then
ls_old := Midstr(ls_old, 2, length(ls_old))
else
Result := false;
end;
end;
end;

// 验证有YMD时骗码格式是否有效
ls_old := LowerCase(style);
li_pos := pos('@', ls_old);
while li_pos > 0 do
begin
ls_old := midstr(ls_old, li_pos + 1, length(ls_old));
ls_1 := leftstr(ls_old, 1);
ls_2 := midstr(ls_old, 2, 1);
if ls_1 = '' then exit;
if (ls_1 = 'y') or (ls_1 = 'm') or (ls_1 = 'd') or
(ls_1 = '@') or (ls_1 = '#') then
begin
if (ls_1 = 'y') and (ls_2 <> '2') and (ls_2 <> '4') then
Result := False
else if (ls_1 = 'm') and (ls_2 <> '1') and (ls_2 <> '2') then
Result := False
else if (ls_1 = 'd') and (ls_2 <> '1') and (ls_2 <> '2') then
Result := False
else if (ls_1 = '@') and not IsDigit(ls_2) then
Result := False
else if (ls_1 = '#') and not IsDigit(ls_2) then
Result := False;
end;
ls_old := midstr(ls_old, 3, length(ls_old));
li_pos := pos('@', ls_old);
end;
end;

procedure TCoding.Register(const id, style, descr, bind: string);
var
sql: string;
begin
// 已经注册则退出
if IsRegister(id) then exit;

// 判断编码是效，有效则注册
if IsValid(style) then begin
sql := 'insert into sys_style values('+quotedstr(id) + ',' + quotedstr(style);
sql := sql+','+quotedstr(descr)+','+quotedstr(bind)+','+quotedstr('0')+')';
ExecSQL(sql);
sql := 'insert into sys_code(id, code) values('+quotedstr(id)+', 1)';
ExecSQL(sql);
end;
end;

procedure TCoding.SetSeq(id: string);
var
SQL: String;
begin
SQL := 'update sys_code set code = code + 1 where id = ' + QuotedStr(id);
ExecSQL(SQL);
end;

procedure TCoding.SetDate(id, value: string);
var
Sql: String;
begin
Sql := 'update sys_code set dt='+QuotedStr(Value)+' where id='+QuotedStr(id);
Self.ExecSQL(sql);
end;

procedure TCoding.SetStyle(const Id, Value: string);
var
SQL: String;
begin
SQL := 'update sys_style set style = ' + QuotedStr(Value);
SQL := SQL + ' where id = ' + QuotedStr(id);

Self.ExecSQL(SQL);
end;

{
procedure TCoding.Sync(id: string);
var
Sql, Bind: String;
begin
Sql := 'select bind from sys_style where id = ' + QuotedStr(id);
Sql := Sql + ' and bind is not null';

if Self.ExecSQL(sql) > 0 then
Begin
Bind := Fqry.Fields[0].AsString;
end;
end;
}

procedure TCoding.UnRegister(const id: string);
var
sql: string;
begin
if self.IsRegister(id) then begin
sql := 'delete from sys_code where id = '+QuotedStr(id);
Self.ExecSQL(sql);
sql := 'delete from sys_style where id = '+QuotedStr(id);
Self.ExecSQL(sql);
end;
end;

function TCoding.Fill(C: String; Num: Integer): String;
var
I: Integer;
begin
Result :='';

for I := 1 to Num do
begin
Result := Result + C;
end;
end;

end.

创建一个文件Coding.Pas就可以测试它啦，有什么问题请发EMAIL给我，不得在PUB之外的论坛转贴。
QQ：77056803
EM：xzhui@vip.sina.com
MSN:xzh2000@hotmail.com