1{ 2 This file is part of the Free Pascal FCL library. 3 Copyright (c) 2017 by Michael Van Canneyt 4 member of the Free Pascal development team 5 6 Barcode encoding routines. 7 8 See the file COPYING.FPC, included in this distribution, 9 for details about the copyright. 10 11 This program is distributed in the hope that it will be useful, 12 but WITHOUT ANY WARRANTY; without even the implied warranty of 13 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 14 15 **********************************************************************} 16 17unit fpbarcode; 18 19{$mode objfpc}{$H+} 20 21interface 22 23uses 24 sysutils; 25 26Type 27 // Various encodings. Sorted 28 TBarcodeEncoding = ( 29 be128A, be128B, be128C, 30 be2of5industrial, be2of5interleaved, be2of5matrix, 31 be39, be39Extended, 32 be93, be93Extended, 33 beCodabar, 34 beEAN13, beEAN8, 35 beMSI, 36 bePostNet 37 ); 38 TBarcodeEncodings = Set of TBarcodeEncoding; 39 40 { 41 Various types of known bars in a barcode. 42 Each type encapsulates 3 parameters. 43 Color: black/white 44 width: 100, (weighted) 150 or 200 % of unit width 45 Height: full height or 2/5th (the latter is for postnet) 46 } 47 TBarColor = (bcWhite,bcBlack); 48 TBarWidth = (bw100,bwWeighted,bw150,bw200); 49 TBarheight = (bhFull,bhTwoFifth); 50 TBarWidthArray = Array[TBarWidth] of Integer; 51 52 TBarParams = record 53 c : TBarColor; 54 w : TBarWidth; 55 h : TBarHeight; 56 end; 57 58 TBarType = 0..11; 59 // auxiliary type for the constant 60 TBarTypeParams = Array[TBarType] of TBarParams; 61 // This 62 TBarTypeArray = array of TBarType; 63 TBarParamsArray = Array of TBarParams; 64 EBarEncoding = class(exception); 65 66Const 67 NumericalEncodings = [beEAN8,beEAN13,be2of5industrial,be2of5interleaved, be2of5matrix,bePostNet,beMSI,be128C]; 68 BarcodeEncodingNames: array[TBarcodeEncoding] of string = 69 ( 70 '128 A', '128 B', '128 C', 71 '2 of 5 industrial', '2 of 5 interleaved', '2 of 5 matrix', 72 '39', '39 Extended', 73 '93', '93 Extended', 74 'Codabar', 75 'EAN 13', 'EAN 8', 76 'MSI', 77 'PostNet' 78 ); 79 80Function StringAllowsBarEncoding(S : AnsiString; aEncoding : TBarcodeEncoding) : Boolean; 81Function StringToBarTypeArray(S : AnsiString; aEncoding : TBarcodeEncoding) : TBarTypeArray; 82Function StringToBarcodeParams(S : AnsiString; aEncoding : TBarcodeEncoding) : TBarParamsArray; 83Function IntToBarTypeArray(I: Int64; aEncoding : TBarcodeEncoding; aWidth : Integer = 0) : TBarTypeArray; 84Function IntToBarcodeParams(I : Int64; aEncoding : TBarcodeEncoding; aWidth : Integer = 0) : TBarParamsArray; 85Function BarTypeToBarParams(aType : TBarType) : TBarParams; 86Function BarTypeArrayToBarParamsArray(anArray : TBarTypeArray) : TBarParamsArray; 87Function CalcBarWidths(aEncoding : TBarcodeEncoding; aUnit : Integer; AWeight : Double) : TBarWidthArray; 88Function CalcStringWidthInBarCodeEncoding(S : String;aEncoding : TBarcodeEncoding; aUnit : Integer; AWeight : Double) : Cardinal; 89 90// Check with barcode unit 91 92implementation 93 94Const 95 NumChars = ['0'..'9']; 96 97 98Procedure IllegalChar(C : AnsiChar;E : TBarcodeEncoding); 99 100Var 101 S : AnsiString; 102 103begin 104 Str(E,S); 105 Raise EBarEncoding.CreateFmt('%s is an illegal character for encoding %s',[C,S]); 106end; 107 108Const 109 BarTypes : TBarTypeParams = ( 110 { 0} (c: bcWhite; w: bw100; h: bhFull), 111 { 1} (c: bcWhite; w: bwWeighted; h: bhFull), 112 { 2} (c: bcWhite; w: bw150; h: bhFull), 113 { 3} (c: bcWhite; w: bw200; h: bhFull), 114 { 4} (c: bcBlack; w: bw100; h: bhFull), 115 { 5} (c: bcBlack; w: bwWeighted; h: bhFull), 116 { 6} (c: bcBlack; w: bw150; h: bhFull), 117 { 7} (c: bcBlack; w: bw200; h: bhFull), 118 { 8} (c: bcBlack; w: bw100; h: bhTwoFifth), 119 { 9} (c: bcBlack; w: bwWeighted; h: bhTwoFifth), 120 {10} (c: bcBlack; w: bw150; h: bhTwoFifth), 121 {11} (c: bcBlack; w: bw200; h: bhTwoFifth) 122 ); 123 124{ --------------------------------------------------------------------- 125 EAN 8 126 ---------------------------------------------------------------------} 127Type 128 TEANChar = array[1..4] of TBarType; 129 TEanParity = array[1..6] of TBarType; 130 131Const 132 EANStartStop : array[1..3] of TBarType = (4,0,4); 133 EANSep : array[1..5] of TBarType = (0,4,0,4,0); 134 135 EANEncodingA : array['0'..'9'] of TEANChar = ( 136 ( 2, 5, 0, 4), // 0 137 ( 1, 5, 1, 4), // 1 138 ( 1, 4, 1, 5), // 2 139 ( 0, 7, 0, 4), // 3 140 ( 0, 4, 2, 5), // 4 141 ( 0, 5, 2, 4), // 5 142 ( 0, 4, 0, 7), // 6 143 ( 0, 6, 0, 5), // 7 144 ( 0, 5, 0, 6), // 8 145 ( 2, 4, 0, 5) // 9 146 ); 147 148 EANEncodingC : array['0'..'9'] of TEANChar = ( 149 ( 6, 1, 4, 0), // 0 150 ( 5, 1, 5, 0), // 1 151 ( 5, 0, 5, 1), // 2 152 ( 4, 3, 4, 0), // 3 153 ( 4, 0, 6, 1), // 4 154 ( 4, 1, 6, 0), // 5 155 ( 4, 0, 4, 3), // 6 156 ( 4, 2, 4, 1), // 7 157 ( 4, 1, 4, 2), // 8 158 ( 6, 0, 4, 1) // 9 159 ); 160 161 EANEncodingB : array['0'..'9'] of TEANChar = ( 162 ( 0, 4, 1, 6), // 0 163 ( 0, 5, 1, 5), // 1 164 ( 1, 5, 0, 5), // 2 165 ( 0, 4, 3, 4), // 3 166 ( 1, 6, 0, 4), // 4 167 ( 0, 6, 1, 4), // 5 168 ( 3, 4, 0, 4), // 6 169 ( 1, 4, 2, 4), // 7 170 ( 2, 4, 1, 4), // 8 171 ( 1, 4, 0, 6) // 9 172 ); 173 174 EANEncodingParity : array[0..9] of TEanParity = ( 175 ( 8, 8, 8, 8, 8, 8), // 0 176 ( 8, 8, 9, 8, 9, 9), // 1 177 ( 8, 8, 9, 9, 8, 9), // 2 178 ( 8, 8, 9, 9, 9, 8), // 3 179 ( 8, 9, 8, 8, 9, 9), // 4 180 ( 8, 9, 9, 8, 8, 9), // 5 181 ( 8, 9, 9, 9, 8, 8), // 6 182 ( 8, 9, 8, 9, 8, 9), // 7 183 ( 8, 9, 8, 9, 9, 8), // 8 184 ( 8, 9, 9, 8, 9, 8) // 9 185 ); 186 187Procedure AddToArray(A : TBarTypeArray; var aPos : integer; Elements : Array of TBarType); 188 189Var 190 I,L : Integer; 191begin 192 L:=Length(Elements); 193 // Safety check 194 if ((aPos+L)>Length(A)) then 195 Raise EBarEncoding.CreateFmt('Cannot add %d elements to array of length %d at pos %d,',[L,Length(A),aPos]); 196 For I:=0 to L-1 do 197 begin 198 A[aPos]:=Elements[i]; 199 inc(aPos); 200 end; 201end; 202 203function CheckEANValue(const AValue:AnsiString; const ASize: Byte): AnsiString; 204 205var 206 L,I : Integer; 207 208begin 209 Result:=AValue; 210 UniqueString(Result); 211 L:=Length(Result); 212 for i:=1 to L do 213 if not (Result[i] in NumChars) then 214 Result[i]:='0'; 215 if L<ASize then 216 Result:=StringOfChar('0', ASize-L-1)+Result+'0'; 217end; 218 219function EncodeEAN8(S : AnsiString) : TBarTypeArray; 220 221var 222 i, p: integer; 223 224begin 225 S:=CheckEANValue(S,8); 226 SetLength(Result,2*Length(EANStartStop)+Length(EANSep)+8*4); 227 P:=0; 228 AddToArray(Result,P,EANStartStop); // start 229 for I:=1 to 4 do 230 AddToArray(Result,P,EANEncodingA[S[i]]); 231 AddToArray(Result,P,EANSep); // Separator 232 for i := 5 to 8 do 233 AddToArray(Result,P,EANEncodingC[S[i]]); 234 AddToArray(Result,P,EANStartStop); // Stop 235end; 236 237function EnCodeEAN13(S : AnsiString) : TBarTypeArray; 238 239var 240 i, p, cc : integer; 241 242begin 243 S:=CheckEanValue(S, 13); 244 SetLength(Result,2*Length(EANStartStop)+Length(EANSep)+12*4); 245 cc:=Ord(S[1])-Ord('0'); 246 Delete(S,1,1); 247 P:=0; 248 AddToArray(Result,P,EANStartStop); // start 249 for i := 1 to 6 do 250 case EANEncodingParity[cc,i] of 251 8: AddToArray(Result,P,EANEncodingA[s[i]]); 252 9: AddToArray(Result,P,EANEncodingB[s[i]]); 253 10: AddToArray(Result,P,EANEncodingC[s[i]]);// will normally not happen... 254 end; 255 AddToArray(Result,P,EANSep); // Separator 256 for i := 7 to 12 do 257 AddToArray(Result,P,EANEncodingC[s[i]]); 258 AddToArray(Result,P,EANStartStop); // stop 259end; 260 261{ --------------------------------------------------------------------- 262 Encoding 39 (+ extended) 263 ---------------------------------------------------------------------} 264 265Type 266 TCode39Char = array[0..9] of TBarType; 267 TCode39Data = record 268 c: AnsiChar; 269 ck: byte; 270 Data: TCode39Char; 271 end; 272 273Const 274 Encoding39 : array[0..43] of TCode39Data = ( 275 (c: '0'; ck: 0; data: ( 4, 0, 4, 1, 5, 0, 5, 0, 4, 0)), 276 (c: '1'; ck: 1; data: ( 5, 0, 4, 1, 4, 0, 4, 0, 5, 0)), 277 (c: '2'; ck: 2; data: ( 4, 0, 5, 1, 4, 0, 4, 0, 5, 0)), 278 (c: '3'; ck: 3; data: ( 5, 0, 5, 1, 4, 0, 4, 0, 4, 0)), 279 (c: '4'; ck: 4; data: ( 4, 0, 4, 1, 5, 0, 4, 0, 5, 0)), 280 (c: '5'; ck: 5; data: ( 5, 0, 4, 1, 5, 0, 4, 0, 4, 0)), 281 (c: '6'; ck: 6; data: ( 4, 0, 5, 1, 5, 0, 4, 0, 4, 0)), 282 (c: '7'; ck: 7; data: ( 4, 0, 4, 1, 4, 0, 5, 0, 5, 0)), 283 (c: '8'; ck: 8; data: ( 5, 0, 4, 1, 4, 0, 5, 0, 4, 0)), 284 (c: '9'; ck: 9; data: ( 4, 0, 5, 1, 4, 0, 5, 0, 4, 0)), 285 (c: 'A'; ck: 10; data: ( 5, 0, 4, 0, 4, 1, 4, 0, 5, 0)), 286 (c: 'B'; ck: 11; data: ( 4, 0, 5, 0, 4, 1, 4, 0, 5, 0)), 287 (c: 'C'; ck: 12; data: ( 5, 0, 5, 0, 4, 1, 4, 0, 4, 0)), 288 (c: 'D'; ck: 13; data: ( 4, 0, 4, 0, 5, 1, 4, 0, 5, 0)), 289 (c: 'E'; ck: 14; data: ( 5, 0, 4, 0, 5, 1, 4, 0, 4, 0)), 290 (c: 'F'; ck: 15; data: ( 4, 0, 5, 0, 5, 1, 4, 0, 4, 0)), 291 (c: 'G'; ck: 16; data: ( 4, 0, 4, 0, 4, 1, 5, 0, 5, 0)), 292 (c: 'H'; ck: 17; data: ( 5, 0, 4, 0, 4, 1, 5, 0, 4, 0)), 293 (c: 'I'; ck: 18; data: ( 4, 0, 5, 0, 4, 1, 5, 0, 0, 0)), 294 (c: 'J'; ck: 19; data: ( 4, 0, 4, 0, 5, 1, 5, 0, 4, 0)), 295 (c: 'K'; ck: 20; data: ( 5, 0, 4, 0, 4, 0, 4, 1, 5, 0)), 296 (c: 'L'; ck: 21; data: ( 4, 0, 5, 0, 4, 0, 4, 1, 5, 0)), 297 (c: 'M'; ck: 22; data: ( 5, 0, 5, 0, 4, 0, 4, 1, 4, 0)), 298 (c: 'N'; ck: 23; data: ( 4, 0, 4, 0, 5, 0, 4, 1, 5, 0)), 299 (c: 'O'; ck: 24; data: ( 5, 0, 4, 0, 5, 0, 4, 1, 4, 0)), 300 (c: 'P'; ck: 25; data: ( 4, 0, 5, 0, 5, 0, 4, 1, 4, 0)), 301 (c: 'Q'; ck: 26; data: ( 4, 0, 4, 0, 4, 0, 5, 1, 5, 0)), 302 (c: 'R'; ck: 27; data: ( 5, 0, 4, 0, 4, 0, 5, 1, 4, 0)), 303 (c: 'S'; ck: 28; data: ( 4, 0, 5, 0, 4, 0, 5, 1, 4, 0)), 304 (c: 'T'; ck: 29; data: ( 4, 0, 4, 0, 5, 0, 5, 1, 4, 0)), 305 (c: 'U'; ck: 30; data: ( 5, 1, 4, 0, 4, 0, 4, 0, 5, 0)), 306 (c: 'V'; ck: 31; data: ( 4, 1, 5, 0, 4, 0, 4, 0, 5, 0)), 307 (c: 'W'; ck: 32; data: ( 5, 1, 5, 0, 4, 0, 4, 0, 4, 0)), 308 (c: 'X'; ck: 33; data: ( 4, 1, 4, 0, 5, 0, 4, 0, 5, 0)), 309 (c: 'Y'; ck: 34; data: ( 5, 1, 4, 0, 5, 0, 4, 0, 4, 0)), 310 (c: 'Z'; ck: 35; data: ( 4, 1, 5, 0, 5, 0, 4, 0, 4, 0)), 311 (c: '-'; ck: 36; data: ( 4, 1, 4, 0, 4, 0, 5, 0, 5, 0)), 312 (c: '.'; ck: 37; data: ( 5, 1, 4, 0, 4, 0, 5, 0, 4, 0)), 313 (c: ' '; ck: 38; data: ( 4, 1, 5, 0, 4, 0, 5, 0, 4, 0)), 314 (c: '*'; ck: 0; data: ( 4, 1, 4, 0, 5, 0, 5, 0, 4, 0)), 315 (c: '$'; ck: 39; data: ( 4, 1, 4, 1, 4, 1, 4, 0, 4, 0)), 316 (c: '/'; ck: 40; data: ( 4, 1, 4, 1, 4, 0, 4, 1, 4, 0)), 317 (c: '+'; ck: 41; data: ( 4, 1, 4, 0, 4, 1, 4, 1, 4, 0)), 318 (c: '%'; ck: 42; data: ( 4, 0, 4, 1, 4, 1, 4, 1, 4, 0)) 319 ); 320 321function IndexOfCode39Char(c: AnsiChar): integer; 322 323begin 324 Result:=High(Encoding39); 325 While (Result>=0) and (c<>Encoding39[Result].c) do 326 Dec(Result); 327end; 328 329Function AllowEncode39 (S : AnsiString) : boolean; 330 331Var 332 I,L : integer; 333 334begin 335 L:=Length(S); 336 Result:=L>0; 337 I:=1; 338 While Result and (I<=L) do 339 begin 340 Result:=IndexOfCode39Char(S[i])>=0; 341 Inc(I); 342 end; 343end; 344 345Function Encode39(S : AnsiString; aCheckSum : Boolean) : TBarTypeArray; 346 347Const 348 StartStopIndex = 39; 349 350 351 function IndexOfCC(cs: byte): integer; 352 353 Var 354 H : integer; 355 356 begin 357 Result:=0; 358 H:=High(Encoding39); 359 While (Result<=H) and (cs<>Encoding39[Result].ck) do 360 Inc(Result); 361 if Result>=H then 362 Result:=StartStopIndex; 363 end; 364 365var 366 cs, p, Idx: integer; 367 c : AnsiChar; 368 369begin 370 cs:=0; 371 // Length = (length text + startstop * 2) * (length of data) 372 SetLength(Result,(Length(S)+2)*10); 373 P:=0; 374 // Startcode 375 AddToArray(Result,P,Encoding39[StartStopIndex].Data); 376 for C in S do 377 begin 378 Idx:=IndexOfCode39Char(C); 379 if Idx<0 then 380 IllegalChar(C,be39); 381 AddToArray(Result,P,Encoding39[Idx].Data); 382 Inc(cs, Encoding39[Idx].ck); 383 end; 384 // Calculate Checksum if requested and add. 385 if aCheckSum then 386 begin 387 AddToArray(Result,P,Encoding39[IndexOfCc(cs mod 43)].Data); 388 SetLength(Result,P); // Correct result 389 end 390 else // No checksum: add startcode, minus last 0 ! 391 begin 392 AddToArray(Result,P,Encoding39[StartStopIndex].Data); 393 SetLength(Result,P-1); // Correct result 394 end; 395end; 396 397function AllowEncode39Extended(S : AnsiString) : boolean; 398 399Var 400 I,L : integer; 401 402begin 403 L:=Length(S); 404 Result:=L>0; 405 I:=1; 406 While Result and (I<=L) do 407 begin 408 Result:=Ord(S[i])<128; 409 Inc(I); 410 end; 411end; 412 413function Encode39Extended(S : AnsiString; aCheckSum : boolean): TBarTypeArray; 414 415// Extended uses an encoding for the first 127 characters... 416 417const 418 CharEncoding : array[0..127] of String[2] = ( 419 '%U', '$A', '$B', '$C', '$D', '$E', '$F', '$G', 420 '$H', '$I', '$J', '$K', '$L', '$M', '$N', '$O', 421 '$P', '$Q', '$R', '$S', '$T', '$U', '$V', '$W', 422 '$X', '$Y', '$Z', '%A', '%B', '%C', '%D', '%E', 423 ' ', '/A', '/B', '/C', '/D', '/E', '/F', '/G', 424 '/H', '/I', '/J', '/K', '/L', '/M', '/N', '/O', 425 '0', '1', '2', '3', '4', '5', '6', '7', 426 '8', '9', '/Z', '%F', '%G', '%H', '%I', '%J', 427 '%V', 'A', 'B', 'C', 'D', 'E', 'F', 'G', 428 'H', 'I', 'J', 'K', 'L', 'M', 'N', 'O', 429 'P', 'Q', 'R', 'S', 'T', 'U', 'V', 'W', 430 'X', 'Y', 'Z', '%K', '%L', '%M', '%N', '%O', 431 '%W', '+A', '+B', '+C', '+D', '+E', '+F', '+G', 432 '+H', '+I', '+J', '+K', '+L', '+M', '+N', '+O', 433 '+P', '+Q', '+R', '+S', '+T', '+U', '+V', '+W', 434 '+X', '+Y', '+Z', '%P', '%Q', '%R', '%S', '%T' 435 ); 436 437var 438 T : AnsiString; 439 O,i: integer; 440 441begin 442 T:=''; 443 for I:=1 to Length(S) do 444 begin 445 O:=Ord(S[i]); 446 if (O>127) then 447 IllegalChar(S[i],be39Extended); 448 T:=T+CharEncoding[O]; 449 end; 450 Result:=Encode39(T,aChecksum); 451end; 452 453{ --------------------------------------------------------------------- 454 Code 93 455 ---------------------------------------------------------------------} 456Type 457 TCode93Char = array[0..5] of TBarType; 458 TCode93Data = record 459 c: AnsiChar; 460 Data: TCode93Char; 461 end; 462 463Const 464 Encoding93 : array[0..46] of TCode93Data = ( 465 (c: '0'; data: ( 4, 2, 4, 0, 4, 1)), 466 (c: '1'; data: ( 4, 0, 4, 1, 4, 2)), 467 (c: '2'; data: ( 4, 0, 4, 2, 4, 1)), 468 (c: '3'; data: ( 4, 0, 4, 3, 4, 0)), 469 (c: '4'; data: ( 4, 1, 4, 0, 4, 2)), 470 (c: '5'; data: ( 4, 1, 4, 1, 4, 1)), 471 (c: '6'; data: ( 4, 1, 4, 2, 4, 0)), 472 (c: '7'; data: ( 4, 0, 4, 0, 4, 3)), 473 (c: '8'; data: ( 4, 2, 4, 1, 4, 0)), 474 (c: '9'; data: ( 4, 3, 4, 0, 4, 0)), 475 (c: 'A'; data: ( 5, 0, 4, 0, 4, 2)), 476 (c: 'B'; data: ( 5, 0, 4, 1, 4, 1)), 477 (c: 'C'; data: ( 5, 0, 4, 2, 4, 0)), 478 (c: 'D'; data: ( 5, 1, 4, 0, 4, 1)), 479 (c: 'E'; data: ( 5, 1, 4, 1, 4, 0)), 480 (c: 'F'; data: ( 5, 2, 4, 0, 4, 0)), 481 (c: 'G'; data: ( 4, 0, 5, 0, 4, 2)), 482 (c: 'H'; data: ( 4, 0, 5, 1, 4, 1)), 483 (c: 'I'; data: ( 4, 0, 5, 2, 4, 0)), 484 (c: 'J'; data: ( 4, 1, 5, 0, 4, 1)), 485 (c: 'K'; data: ( 4, 2, 5, 0, 4, 0)), 486 (c: 'L'; data: ( 4, 0, 4, 0, 5, 2)), 487 (c: 'M'; data: ( 4, 0, 4, 1, 5, 1)), 488 (c: 'N'; data: ( 4, 0, 4, 2, 5, 0)), 489 (c: 'O'; data: ( 4, 1, 4, 0, 5, 1)), 490 (c: 'P'; data: ( 4, 2, 4, 0, 5, 0)), 491 (c: 'Q'; data: ( 5, 0, 5, 0, 4, 1)), 492 (c: 'R'; data: ( 5, 0, 5, 1, 4, 0)), 493 (c: 'S'; data: ( 5, 0, 4, 0, 5, 1)), 494 (c: 'T'; data: ( 5, 0, 4, 1, 5, 0)), 495 (c: 'U'; data: ( 5, 1, 4, 0, 5, 0)), 496 (c: 'V'; data: ( 5, 1, 5, 0, 4, 0)), 497 (c: 'W'; data: ( 4, 0, 5, 0, 5, 1)), 498 (c: 'X'; data: ( 4, 0, 5, 1, 5, 0)), 499 (c: 'Y'; data: ( 4, 1, 5, 0, 5, 0)), 500 (c: 'Z'; data: ( 4, 1, 6, 0, 4, 0)), 501 (c: '-'; data: ( 4, 1, 4, 0, 6, 0)), 502 (c: '.'; data: ( 6, 0, 4, 0, 4, 1)), 503 (c: ' '; data: ( 6, 0, 4, 1, 4, 0)), 504 (c: '$'; data: ( 6, 1, 4, 0, 4, 0)), 505 (c: '/'; data: ( 4, 0, 5, 0, 6, 0)), 506 (c: '+'; data: ( 4, 0, 6, 0, 5, 0)), 507 (c: '%'; data: ( 5, 0, 4, 0, 6, 0)), 508 (c: '['; data: ( 4, 1, 4, 1, 5, 0)), 509 (c: ']'; data: ( 6, 0, 5, 0, 4, 0)), 510 (c: '{'; data: ( 6, 0, 4, 0, 5, 0)), 511 (c: '}'; data: ( 4, 1, 5, 1, 4, 0)) 512 ); 513 514function IndexOfCode93Char(c: AnsiChar): integer; 515 516begin 517 Result:=High(Encoding93); 518 While (Result>=0) and (c<>Encoding93[Result].c) do 519 Dec(Result); 520end; 521 522Function AllowEncode93 (S : AnsiString) : boolean; 523 524Var 525 I,L : integer; 526 527begin 528 L:=Length(S); 529 Result:=L>0; 530 I:=1; 531 While Result and (I<=L) do 532 begin 533 Result:=IndexOfCode93Char(S[i])>=0; 534 Inc(I); 535 end; 536end; 537 538Function Encode93(S : AnsiString) : TBarTypeArray; 539 540Const 541 Code93Start : Array[1..6] of TBarType = ( 4, 0, 4, 0, 7, 0); 542 Code93Stop : Array[1..7] of TBarType = ( 4, 0, 4, 0, 7, 0, 4); 543 544var 545 L,i, P, Idx, CC, CK, WC, WK : integer; 546 C : Char; 547 548begin 549 L:=Length(S); 550 // Length String * 6 + Start + Stop + Checksum 551 SetLength(Result,L*6+6+7+2*6); 552 P:=0; 553 AddToArray(Result,P,Code93Start); 554 for C in S do 555 begin 556 Idx:=IndexOfCode93Char(C); 557 if Idx<0 then 558 IllegalChar(C,be93); 559 AddToArray(Result,P,Encoding93[Idx].Data); 560 end; 561 CC:=0; 562 CK:=0; 563 WC:=1; 564 WK:=2; 565 for i:=L downto 1 do 566 begin 567 Idx:=IndexOfCode93Char(S[i]); 568 Inc(CC,Idx*WC); 569 Inc(CK,Idx*WK); 570 Inc(WC); 571 if (WC>20) then 572 WC:=1; 573 Inc(WK); 574 if (WK>15) then 575 WK:=1; 576 end; 577 Inc(CK,CC); 578 CC:=CC mod 47; 579 CK:=CK mod 47; 580 AddToArray(Result,P,Encoding93[CC].Data); 581 AddToArray(Result,P,Encoding93[CK].Data); 582 AddToArray(Result,P,Code93Stop); 583end; 584 585function AllowEncode93Extended(S : AnsiString) : boolean; 586 587Var 588 I,L : integer; 589 590begin 591 L:=Length(S); 592 Result:=L>0; 593 I:=1; 594 While Result and (I<=L) do 595 begin 596 Result:=Ord(S[i])<128; 597 Inc(I); 598 end; 599end; 600 601 602function Encode93Extended(S: string) : TBarTypeArray; 603 604const 605 CharEncoding: array[0..127] of string[2] = ( 606 ']U', '[A', '[B', '[C', '[D', '[E', '[F', '[G', 607 '[H', '[I', '[J', '[K', '[L', '[M', '[N', '[O', 608 '[P', '[Q', '[R', '[S', '[T', '[U', '[V', '[W', 609 '[X', '[Y', '[Z', ']A', ']B', ']C', ']D', ']E', 610 ' ', '{A', '{B', '{C', '{D', '{E', '{F', '{G', 611 '{H', '{I', '{J', '{K', '{L', '{M', '{N', '{O', 612 '0', '1', '2', '3', '4', '5', '6', '7', 613 '8', '9', '{Z', ']F', ']G', ']H', ']I', ']J', 614 ']V', 'A', 'B', 'C', 'D', 'E', 'F', 'G', 615 'H', 'I', 'J', 'K', 'L', 'M', 'N', 'O', 616 'P', 'Q', 'R', 'S', 'T', 'U', 'V', 'W', 617 'X', 'Y', 'Z', ']K', ']L', ']M', ']N', ']O', 618 ']W', '}A', '}B', '}C', '}D', '}E', '}F', '}G', 619 '}H', '}I', '}J', '}K', '}L', '}M', '}N', '}O', 620 '}P', '}Q', '}R', '}S', '}T', '}U', '}V', '}W', 621 '}X', '}Y', '}Z', ']P', ']Q', ']R', ']S', ']T' 622 ); 623 624var 625 T : AnsiString; 626 O,i: integer; 627 628begin 629 T:=''; 630 for I:=1 to Length(S) do 631 begin 632 O:=Ord(S[i]); 633 if (O>127) then 634 IllegalChar(S[i],be93Extended); 635 T:=T+CharEncoding[O]; 636 end; 637 Result:=Encode93(T); 638end; 639 640{ --------------------------------------------------------------------- 641 MSI 642 ---------------------------------------------------------------------} 643 644Type 645 TMSIChar = Array[1..8] of TBarType; 646 647Const 648 EncodingMSI : array['0'..'9'] of TMSIChar = ( 649 ( 4, 1, 4, 1, 4, 1, 4, 1), // 0 650 ( 4, 1, 4, 1, 4, 1, 5, 0), // 1 651 ( 4, 1, 4, 1, 5, 0, 4, 1), // 2 652 ( 4, 1, 4, 1, 5, 0, 5, 0), // 3 653 ( 4, 1, 5, 0, 4, 1, 4, 1), // 4 654 ( 4, 1, 5, 0, 4, 1, 5, 0), // 5 655 ( 4, 1, 5, 0, 5, 0, 4, 1), // 6 656 ( 4, 1, 5, 0, 5, 0, 5, 0), // 7 657 ( 5, 0, 4, 1, 4, 1, 4, 1), // 8 658 ( 5, 0, 4, 1, 4, 1, 5, 0) // 9 659 ); 660 661function EncodeMSI(S : AnsiString) : TBarTypeArray; 662 663 function SumDigits(D: integer): integer; 664 665 begin 666 Result:=0; 667 while (D>0) do 668 begin 669 Result:=Result+(D mod 10); 670 D:=D div 10; 671 end; 672 end; 673 674 675Const 676 MSIPrefix : Array [1..2] of TBarType = (5,0); 677 MSISuffix : Array [1..3] of TBarType = (4,1,4); 678 679var 680 P,I,CSE,CSO,CS : integer; 681 C : AnsiChar; 682 683begin 684 // Length(Prefix)+Length(Suffix)+Length(S)+CheckSum 685 SetLength(Result,(Length(S)+1)*8+2+3); 686 P:=0; 687 AddToArray(Result,P,MSIPrefix); // Prefix 688 CSE:=0; 689 CSO:=0; 690 for i:=1 to Length(s) do 691 begin 692 C:=S[i]; 693 if Not (C in NumChars) then 694 IllegalChar(S[i],beMSI); 695 if odd(i-1) then 696 CSO:=CSO*10+Ord(C) 697 else 698 CSE:=CSE+Ord(c); 699 AddToArray(Result,P,EncodingMSI[C]); 700 end; 701 // Add checksum 702 CS:=(SumDigits(CSO*2) + CSE) mod 10; 703 if CS>0 then 704 CS:=10-CS; 705 AddToArray(Result,P,EncodingMSI[chr(Ord('0')+CS)]); 706 AddToArray(Result,P,MSISuffix); // Suffix 707end; 708 709{ --------------------------------------------------------------------- 710 CodaBar 711 ---------------------------------------------------------------------} 712 713Type 714 TCodabarChar = array[0..6] of TBarType; 715 TCodabarCharZero = array[0..7] of TBarType; 716 717 TCodaBarData = record 718 c: AnsiChar; 719 Data: TCodabarChar; 720 end; 721 722Var 723 EncodingCodaBar : array[0..19] of TCodaBarData = ( 724 (c: '1'; data: ( 4, 0, 4, 0, 5, 1, 4)), 725 (c: '2'; data: ( 4, 0, 4, 1, 4, 0, 5)), 726 (c: '3'; data: ( 5, 1, 4, 0, 4, 0, 4)), 727 (c: '4'; data: ( 4, 0, 5, 0, 4, 1, 4)), 728 (c: '5'; data: ( 5, 0, 4, 0, 4, 1, 4)), 729 (c: '6'; data: ( 4, 1, 4, 0, 4, 0, 5)), 730 (c: '7'; data: ( 4, 1, 4, 0, 5, 0, 4)), 731 (c: '8'; data: ( 4, 1, 5, 0, 4, 0, 4)), 732 (c: '9'; data: ( 5, 0, 4, 1, 4, 0, 4)), 733 (c: '0'; data: ( 4, 0, 4, 0, 4, 1, 5)), 734 (c: '-'; data: ( 4, 0, 4, 1, 5, 0, 4)), 735 (c: '$'; data: ( 4, 0, 5, 1, 4, 0, 4)), 736 (c: ':'; data: ( 5, 0, 4, 0, 5, 0, 5)), 737 (c: '/'; data: ( 5, 0, 5, 0, 4, 0, 5)), 738 (c: '.'; data: ( 5, 0, 5, 0, 5, 0, 4)), 739 (c: '+'; data: ( 4, 0, 5, 0, 5, 0, 5)), 740 (c: 'A'; data: ( 4, 0, 5, 1, 4, 1, 4)), 741 (c: 'B'; data: ( 4, 1, 4, 1, 4, 0, 5)), 742 (c: 'C'; data: ( 4, 0, 4, 1, 4, 1, 5)), 743 (c: 'D'; data: ( 4, 0, 4, 1, 5, 1, 4)) 744 ); 745 746 747function IndexOfCodaChar(c: AnsiChar): integer; 748 749begin 750 Result:=High(EncodingCodaBar); 751 While (Result>=0) and (c<>EncodingCodaBar[Result].c) do 752 Dec(Result); 753end; 754 755Function AllowEncodeCodaBar (S : AnsiString) : boolean; 756 757Var 758 I,L : integer; 759 760begin 761 L:=Length(S); 762 Result:=L>0; 763 I:=1; 764 While Result and (I<=L) do 765 begin 766 Result:=IndexOfCodaChar(S[i])>=0; 767 Inc(I); 768 end; 769end; 770 771 772Function EncodeCodaBar(S : AnsiString) : TBarTypeArray; 773 774 Function AddZero(C :TCodaBarChar) : TCodabarCharZero; 775 776 begin 777 Move(C,result,SizeOf(C)); 778 Result[7]:=0; 779 end; 780 781var 782 i, P, Idx: integer; 783 784begin 785 // (Length(S)+1)*8+7 786 Setlength(Result,(Length(S)+1)*8+7); 787 P:=0; 788 AddToArray(Result,P,AddZero(EncodingCodaBar[IndexOfCodaChar('A')].Data)); 789 for i:=1 to Length(S) do 790 begin 791 Idx:=IndexOfCodaChar(S[i]); 792 if Idx<0 then 793 IllegalChar(S[i],beCodabar); 794 AddToArray(Result,P,AddZero(EncodingCodaBar[Idx].Data)); 795 end; 796 AddToArray(Result,P,EncodingCodaBar[IndexOfCodaChar('B')].Data); 797end; 798 799{ --------------------------------------------------------------------- 800 Postnet 801 ---------------------------------------------------------------------} 802Type 803 TPostNetChar = Packed Array[1..10] of TBarType; 804 805Const 806 EncodingPostNet : Packed array['0'..'9'] of TPostNetChar = ( 807 ( 4, 1, 4, 1, 8, 1, 8, 1, 8, 1), // 0 808 ( 8, 1, 8, 1, 8, 1, 4, 1, 4, 1), // 1 809 ( 8, 1, 8, 1, 4, 1, 8, 1, 4, 1), // 2 810 ( 8, 1, 8, 1, 4, 1, 4, 1, 8, 1), // 3 811 ( 8, 1, 4, 1, 8, 1, 8, 1, 4, 1), // 4 812 ( 8, 1, 4, 1, 8, 1, 4, 1, 8, 1), // 5 813 ( 8, 1, 4, 1, 4, 1, 8, 1, 8, 1), // 6 814 ( 4, 1, 8, 1, 8, 1, 8, 1, 4, 1), // 7 815 ( 4, 1, 8, 1, 8, 1, 4, 1, 8, 1), // 8 816 ( 4, 1, 8, 1, 4, 1, 8, 1, 8, 1) // 9 817 ); 818 819 820Function EncodePostNet (S : AnsiString) : TBarTypeArray; 821 822var 823 i,P : integer; 824 825begin 826 SetLength(Result,Length(S)*10+2+1); 827 P:=0; 828 AddToArray(Result,P,[4,1]); 829 for i := 1 to Length(S) do 830 begin 831 if Not (S[I] in NumChars) then 832 IllegalChar(S[i],bePostNet); 833 AddToArray(Result,P,EncodingPostNet[S[i]]); 834 end; 835 AddToArray(Result,P,[4]); 836end; 837 838{ --------------------------------------------------------------------- 839 Code 128 840 ---------------------------------------------------------------------} 841 842Type 843 TCode128Char = Packed Array[1..6] of TBarType; 844 TCode128StopChar = Packed Array[1..7] of TBarType; 845 846Const 847 848 // The order of these elements must be the same as for 849 // the Encoding128A,Encoding128B,Encoding128C arrays below ! 850 851 Encoding128Data : Packed array[0..102] of TCode128Char = ( 852 ( 5, 0, 5, 1, 5, 1), // 0 853 ( 5, 1, 5, 0, 5, 1), // 1 854 ( 5, 1, 5, 1, 5, 0), // 2 855 ( 4, 1, 4, 1, 5, 2), // 3 856 ( 4, 1, 4, 2, 5, 1), // 4 857 ( 4, 2, 4, 1, 5, 1), // 5 858 ( 4, 1, 5, 1, 4, 2), // 6 859 ( 4, 1, 5, 2, 4, 1), // 7 860 ( 4, 2, 5, 1, 4, 1), // 8 861 ( 5, 1, 4, 1, 4, 2), // 9 862 ( 5, 1, 4, 2, 4, 1), // 10 863 ( 5, 2, 4, 1, 4, 1), // 11 864 ( 4, 0, 5, 1, 6, 1), // 12 865 ( 4, 1, 5, 0, 6, 1), // 13 866 ( 4, 1, 5, 1, 6, 0), // 14 867 ( 4, 0, 6, 1, 5, 1), // 15 868 ( 4, 1, 6, 0, 5, 1), // 16 869 ( 4, 1, 6, 1, 5, 0), // 17 870 ( 5, 1, 6, 1, 4, 0), // 18 871 ( 5, 1, 4, 0, 6, 1), // 19 872 ( 5, 1, 4, 1, 6, 0), // 20 873 ( 5, 0, 6, 1, 4, 1), // 21 874 ( 5, 1, 6, 0, 4, 1), // 22 875 ( 6, 0, 5, 0, 6, 0), // 23 876 ( 6, 0, 4, 1, 5, 1), // 24 877 ( 6, 1, 4, 0, 5, 1), // 25 878 ( 6, 1, 4, 1, 5, 0), // 26 879 ( 6, 0, 5, 1, 4, 1), // 27 880 ( 6, 1, 5, 0, 4, 1), // 28 881 ( 6, 1, 5, 1, 4, 0), // 29 882 ( 5, 0, 5, 0, 5, 2), // 30 883 ( 5, 0, 5, 2, 5, 0), // 31 884 ( 5, 2, 5, 0, 5, 0), // 32 885 ( 4, 0, 4, 2, 5, 2), // 33 886 ( 4, 2, 4, 0, 5, 2), // 34 887 ( 4, 2, 4, 2, 5, 0), // 35 888 ( 4, 0, 5, 2, 4, 2), // 36 889 ( 4, 2, 5, 0, 4, 2), // 37 890 ( 4, 2, 5, 2, 4, 0), // 38 891 ( 5, 0, 4, 2, 4, 2), // 39 892 ( 5, 2, 4, 0, 4, 2), // 40 893 ( 5, 2, 4, 2, 4, 0), // 41 894 ( 4, 0, 5, 0, 6, 2), // 42 895 ( 4, 0, 5, 2, 6, 0), // 43 896 ( 4, 2, 5, 0, 6, 0), // 44 897 ( 4, 0, 6, 0, 5, 2), // 45 898 ( 4, 0, 6, 2, 5, 0), // 46 899 ( 4, 2, 6, 0, 5, 0), // 47 900 ( 6, 0, 6, 0, 5, 0), // 48 901 ( 5, 0, 4, 2, 6, 0), // 49 902 ( 5, 2, 4, 0, 6, 0), // 50 903 ( 5, 0, 6, 0, 4, 2), // 51 904 ( 5, 0, 6, 2, 4, 0), // 52 905 ( 5, 0, 6, 0, 6, 0), // 53 906 ( 6, 0, 4, 0, 5, 2), // 54 907 ( 6, 0, 4, 2, 5, 0), // 55 908 ( 6, 2, 4, 0, 5, 0), // 56 909 ( 6, 0, 5, 0, 4, 2), // 57 910 ( 6, 0, 5, 2, 4, 0), // 58 911 ( 6, 2, 5, 0, 4, 0), // 59 912 ( 6, 0, 7, 0, 4, 0), // 60 913 ( 5, 1, 4, 3, 4, 0), // 61 914 ( 7, 2, 4, 0, 4, 0), // 62 915 ( 4, 0, 4, 1, 5, 3), // 63 916 ( 4, 0, 4, 3, 5, 1), // 64 917 ( 4, 1, 4, 0, 5, 3), // 65 918 ( 4, 1, 4, 3, 5, 0), // 66 919 ( 4, 3, 4, 0, 5, 1), // 67 920 ( 4, 3, 4, 1, 5, 0), // 68 921 ( 4, 0, 5, 1, 4, 3), // 69 922 ( 4, 0, 5, 3, 4, 1), // 70 923 ( 4, 1, 5, 0, 4, 3), // 71 924 ( 4, 1, 5, 3, 4, 0), // 72 925 ( 4, 3, 5, 0, 4, 1), // 73 926 ( 4, 3, 5, 1, 4, 0), // 74 927 ( 5, 3, 4, 1, 4, 0), // 75 928 ( 5, 1, 4, 0, 4, 3), // 76 929 ( 7, 0, 6, 0, 4, 0), // 77 930 ( 5, 3, 4, 0, 4, 1), // 78 931 ( 4, 2, 7, 0, 4, 0), // 79 932 ( 4, 0, 4, 1, 7, 1), // 80 933 ( 4, 1, 4, 0, 7, 1), // 81 934 ( 4, 1, 4, 1, 7, 0), // 82 935 ( 4, 0, 7, 1, 4, 1), // 83 936 ( 4, 1, 7, 0, 4, 1), // 84 937 ( 4, 1, 7, 1, 4, 0), // 85 938 ( 7, 0, 4, 1, 4, 1), // 86 939 ( 7, 1, 4, 0, 4, 1), // 87 940 ( 7, 1, 4, 1, 4, 0), // 88 941 ( 5, 0, 5, 0, 7, 0), // 89 942 ( 5, 0, 7, 0, 5, 0), // 90 943 ( 7, 0, 5, 0, 5, 0), // 91 944 ( 4, 0, 4, 0, 7, 2), // 92 945 ( 4, 0, 4, 2, 7, 0), // 93 946 ( 4, 2, 4, 0, 7, 0), // 94 947 ( 4, 0, 7, 0, 4, 2), // 95 948 ( 4, 0, 7, 2, 4, 0), // 96 949 ( 7, 0, 4, 0, 4, 2), // 97 950 ( 7, 0, 4, 2, 4, 0), // 98 951 ( 4, 0, 6, 0, 7, 0), // 99 952 ( 4, 0, 7, 0, 6, 0), // 100 953 ( 6, 0, 4, 0, 7, 0), // 101 954 ( 7, 0, 4, 0, 6, 0) // 102 955 ); 956 957 958Const 959 Encoding128ACount = 64; 960 Encoding128AChecksumInit = 103; 961 962 Encoding128BCount = 95; 963 Encoding128BChecksumInit = 104; 964 965 Encoding128CChecksumInit = 105; 966 967Type 968 /// 0 based, checksum relies on 0-based index 969 TEncoding128AArray = Packed Array[0..Encoding128ACount-1] of Ansichar; 970 TEncoding128BArray = Packed Array[0..Encoding128BCount-1] of Ansichar; 971 972Const 973 StartEncoding128A : TCode128Char = ( 5, 0, 4, 3, 4, 1); 974 StartEncoding128B : TCode128Char = ( 5, 0, 4, 1, 4, 3); 975 StartEncoding128C : TCode128Char = ( 5, 0, 4, 1, 6, 1); 976 StopEncoding128 : TCode128StopChar = ( 5, 2, 6, 0, 4, 0, 5); 977 978 // The order of these elements must be the same as on Encoding128Data 979 980 Encoding128A : TEncoding128AArray = ( 981 ' ','!','"','#','$','%','&','''','(',')', 982 '*','+',',','-','.','/','0','1','2','3', 983 '4','5','6','7','8','9',':',';','<','=', 984 '>','?','@','A','B','C','D','E','F','G', 985 'H','I','J','K','L','M','N','O','P','Q', 986 'R','S','T','U','V','W','X','Y','Z','[', 987 '\',']','^','_' 988 ); 989 990 Encoding128B : TEncoding128BArray = ( 991 ' ','!','"','#','$','%','&','''','(',')', 992 '*','+',',','-','.','/','0','1','2','3', 993 '4','5','6','7','8','9',':',';','<','=', 994 '>','?','@','A','B','C','D','E','F','G', 995 'H','I','J','K','L','M','N','O','P','Q', 996 'R','S','T','U','V','W','X','Y','Z','[', 997 '\',']','^','_','`','a','b','c','d','e', 998 'f','g','h','i','j','k','l','m','n','o', 999 'p','q','r','s','t','u','v','w','x','y', 1000 'z','{','|','}','~' 1001 ); 1002 1003function IndexOf128AChar(c: AnsiChar): integer; 1004 1005begin 1006 Result:=0; 1007 While (Result<Encoding128ACount) and (c<>Encoding128A[Result]) do 1008 Inc(Result); 1009 if Result>=Encoding128ACount then 1010 Result:=-1; 1011end; 1012 1013Function AllowEncode128A(S : String) : Boolean; 1014 1015Var 1016 I,L : integer; 1017 1018begin 1019 L:=Length(S); 1020 Result:=L>0; 1021 I:=1; 1022 While Result and (I<=L) do 1023 begin 1024 Result:=IndexOf128AChar(S[i])>=0; 1025 Inc(I); 1026 end; 1027end; 1028 1029Function Encode128A(S : AnsiString) : TBarTypeArray; 1030 1031Var 1032 CS,I,P,Idx : integer; 1033 1034begin 1035 // Length(S)+StartCode+CheckSum+StopCode (stopcode has 7 bars) 1036 SetLength(Result,(Length(S)+2)*6+7); 1037 P:=0; 1038 AddToArray(Result,P,StartEncoding128A); 1039 CS:=Encoding128AChecksumInit; 1040 For I:=1 to Length(S) do 1041 begin 1042 Idx:=IndexOf128AChar(S[i]); 1043 if Idx<0 then 1044 IllegalChar(S[i],be128a); 1045 AddToArray(Result,P,Encoding128Data[Idx]); 1046 Inc(CS,Idx*I); 1047 end; 1048 // Cap CS 1049 CS:=CS mod 103; 1050 AddToArray(Result,P,Encoding128Data[CS]); 1051 AddToArray(Result,P,StopEncoding128); 1052end; 1053 1054function IndexOf128BChar(c: AnsiChar): integer; 1055 1056begin 1057 Result:=1; 1058 While (Result<=Encoding128BCount) and (c<>Encoding128B[Result]) do 1059 Inc(Result); 1060 if Result>Encoding128BCount then 1061 Result:=-1; 1062end; 1063 1064Function AllowEncode128B(S : String) : Boolean; 1065 1066Var 1067 I,L : integer; 1068 1069begin 1070 L:=Length(S); 1071 Result:=L>0; 1072 I:=1; 1073 While Result and (I<=L) do 1074 begin 1075 Result:=IndexOf128BChar(S[i])>=0; 1076 Inc(I); 1077 end; 1078end; 1079 1080Function Encode128B(S : AnsiString) : TBarTypeArray; 1081 1082 1083Var 1084 CS,I,P,Idx : integer; 1085 1086begin 1087 // Length(S)+StartCode+CheckSum+StopCode (stopcode has 7 bars) 1088 SetLength(Result,(Length(S)+2)*6+7); 1089 P:=0; 1090 AddToArray(Result,P,StartEncoding128B); 1091 CS:=Encoding128BChecksumInit; 1092 For I:=1 to Length(S) do 1093 begin 1094 Idx:=IndexOf128BChar(S[i]); 1095 if Idx<0 then 1096 IllegalChar(S[i],be128b); 1097 AddToArray(Result,P,Encoding128Data[Idx]); 1098 Inc(CS,Idx*I); 1099 end; 1100 // Cap CS 1101 CS:=CS mod 103; 1102 AddToArray(Result,P,Encoding128Data[CS]); 1103 AddToArray(Result,P,StopEncoding128); 1104end; 1105 1106Function C(S : AnsiString) : TBarTypeArray; 1107 1108 function IndexOfChar(c: AnsiChar): integer; 1109 1110 begin 1111 Result:=1; 1112 While (Result<=Encoding128BCount) and (c<>Encoding128A[Result]) do 1113 Inc(Result); 1114 if Result>Encoding128BCount then 1115 Result:=-1; 1116 end; 1117 1118Var 1119 CS,I,P,Idx : integer; 1120 1121begin 1122 // Length(S)+StartCode+CheckSum+StopCode (stopcode has 7 bars) 1123 SetLength(Result,(Length(S)+2)*6+7); 1124 P:=0; 1125 AddToArray(Result,P,StartEncoding128B); 1126 CS:=Encoding128BChecksumInit; 1127 For I:=1 to Length(S) do 1128 begin 1129 Idx:=IndexOfChar(S[i]); 1130 if Idx<0 then 1131 IllegalChar(S[i],be128b); 1132 AddToArray(Result,P,Encoding128Data[Idx]); 1133 Inc(CS,Idx*I); 1134 end; 1135 // Cap CS 1136 CS:=CS mod 103; 1137 AddToArray(Result,P,Encoding128Data[CS]); 1138 AddToArray(Result,P,StopEncoding128); 1139end; 1140 1141Function Encode128C(S : AnsiString) : TBarTypeArray; 1142 1143Var 1144 CS,I,CC,P,Idx : integer; 1145 T : AnsiString; 1146 1147begin 1148 // Length(S)+StartCode+CheckSum+StopCode (stopcode has 7 bars) 1149 if Odd(Length(S)) then 1150 S:='0'+S; 1151 I:=1; 1152 T:=''; 1153 // construct a AnsiString with codes. 1154 while i<Length(S) do 1155 begin 1156 CC:=StrToIntDef(Copy(S,i,2),-1); 1157 if CC=-1 then 1158 IllegalChar(S[i],be128C); 1159 T:=T+Chr(CC); 1160 Inc(I,2); 1161 end; 1162 // With the new AnsiString, construct barcode 1163 SetLength(Result,(Length(T)+2)*6+7); 1164 P:=0; 1165 AddToArray(Result,P,StartEncoding128C); 1166 CS:=Encoding128CChecksumInit; 1167 For I:=1 to Length(T) do 1168 begin 1169 Idx:=Ord(T[i]); 1170 AddToArray(Result,P,Encoding128Data[Idx]); 1171 Inc(CS,Idx*I); 1172 end; 1173 // Cap CS 1174 CS:=CS mod 103; 1175 AddToArray(Result,P,Encoding128Data[CS]); 1176 AddToArray(Result,P,StopEncoding128); 1177end; 1178 1179{ --------------------------------------------------------------------- 1180 Barcode 2 of 5 1181 ---------------------------------------------------------------------} 1182Type 1183 TCode2of5Char = Packed array [1..5] of boolean; 1184 1185Const 1186 Encoding2of5 : array['0'..'9'] of TCode2of5Char = ( 1187 (false, false, True, True, false), // 0 1188 (True, false, false, false, True), // 1 1189 (false, True, false, false, True), // 2 1190 (True, True, false, false, false), // 3 1191 (false, false, True, false, True), // 4 1192 (True, false, True, false, false), // 5 1193 (false, True, True, false, false), // 6 1194 (false, false, false, True, True), // 7 1195 (True, false, false, True, false), // 8 1196 (false, True, false, True, false) // 9 1197 ); 1198 1199Function Encode2of5Interleaved(S : AnsiString) : TBarTypeArray; 1200 1201Const 1202 Encode2of5Start : Array [1..4] of TBarType = (4,0,4,0); 1203 Encode2of5Stop : Array [1..3] of TBarType = (5,0,4); 1204 1205 COdd : Array [Boolean] of TBarType = (4,5); 1206 CEven : Array [Boolean] of TBarType = (0,1); 1207 1208var 1209 P, i, j: integer; 1210 CC : Array[1..2] of TBarType; 1211 1212begin 1213 SetLength(Result,(Length(S)*5)+4+3); 1214 P:=0; 1215 AddToArray(Result,P,Encode2of5Start); 1216 for i := 1 to Length(S) div 2 do 1217 for j:=1 to 5 do 1218 begin 1219 if not (S[i*2-1] in NumChars) then 1220 IllegalChar(S[i*2-1],be2of5interleaved); 1221 if not (S[i*2] in NumChars) then 1222 IllegalChar(S[i*2],be2of5interleaved); 1223 CC[1]:=COdd[Encoding2of5[S[i*2-1],j]]; 1224 CC[2]:=CEven[Encoding2of5[S[i*2],j]]; 1225 AddToArray(Result,P,CC); 1226 end; 1227 AddToArray(Result,P,Encode2of5Stop); 1228end; 1229 1230Function Encode2of5Industrial(S : AnsiString) : TBarTypeArray; 1231 1232Const 1233 Encode2of5Start : Array [1..6] of TBarType = (5,0,5,0,4,0); 1234 Encode2of5Stop : Array [1..6] of TBarType = (5,0,4,0,5,0); 1235 1236 Codes : Array [Boolean] of Array[1..2] of TBarType = ((4,0),(5,0)); 1237 1238var 1239 P,I,J : integer; 1240 C : Char; 1241begin 1242 // Length of AnsiString * 2 + StartCode+StopCode 1243 SetLength(Result,Length(S)*10+6+6); 1244 P:=0; 1245 AddToArray(Result,P,Encode2of5Start); 1246 for i := 1 to Length(S) do 1247 for j := 1 to 5 do 1248 begin 1249 C:=S[i]; 1250 if not (C in NumChars) then 1251 IllegalChar(C,be2of5industrial); 1252 AddToArray(Result,P,Codes[Encoding2of5[S[i],j]]); 1253 end; 1254 AddToArray(Result,P,Encode2of5Stop); 1255end; 1256 1257Function Encode2of5Matrix(S : AnsiString) : TBarTypeArray; 1258 1259Const 1260 Encode2of5Start : Array [1..6] of TBarType = (6,0,4,0,4,0); 1261 Encode2of5Stop : Array [1..5] of TBarType = (6,0,4,0,4); 1262 1263var 1264 P,I,J : integer; 1265 C : Char; 1266 BT : TBarType; 1267begin 1268 // Length of AnsiString + StartCode+StopCode 1269 SetLength(Result,Length(S)*6+6+5); 1270 P:=0; 1271 AddToArray(Result,P,Encode2of5Start); 1272 for i:=1 to Length(S) do 1273 begin 1274 for j:=1 to 5 do 1275 begin 1276 C:=S[i]; 1277 if not (C in NumChars) then 1278 IllegalChar(C,be2of5industrial); 1279 BT:=Ord(Encoding2of5[S[i],j]); // 0 or 1 1280 if odd(J) then 1281 BT:=BT+4; 1282 AddToArray(Result,P,[BT]); 1283 end; 1284 AddToArray(Result,P,[0]); 1285 end; 1286 AddToArray(Result,P,Encode2of5Stop); 1287end; 1288 1289{ --------------------------------------------------------------------- 1290 Global routines 1291 ---------------------------------------------------------------------} 1292 1293Function AllNumerical (S : AnsiString) : boolean; 1294 1295Var 1296 I,L : integer; 1297 1298begin 1299 L:=Length(S); 1300 Result:=L>0; 1301 I:=1; 1302 While Result and (I<=L) do 1303 begin 1304 Result:=S[i] in Numchars; 1305 Inc(I); 1306 end; 1307end; 1308 1309Function StringAllowsBarEncoding(S : AnsiString; aEncoding : TBarcodeEncoding) : Boolean; 1310 1311begin 1312 if (AEncoding in NumericalEncodings) then 1313 Result:=AllNumerical(S) 1314 else 1315 Case aEncoding of 1316 be128A : Result:=AllowEncode128A(S); 1317 be128B : Result:=AllowEncode128B(S); 1318 be39: Result:=AllowEncode39(S); 1319 be39Extended: Result:=AllowEncode39Extended(S); 1320 be93: Result:=AllowEncode93(S); 1321 be93Extended: Result:=AllowEncode93Extended(S); 1322 beCodabar: Result:=AllowEncodeCodaBar(S); 1323 else 1324 Raise EBarEncoding.CreateFmt('Unknown/Unhandled encoding, ordinal value : %d',[ord(aEncoding)]); 1325 end; 1326end; 1327 1328 1329Function StringToBarTypeArray(S : AnsiString; aEncoding : TBarcodeEncoding) : TBarTypeArray; 1330 1331begin 1332 SetLength(Result,0); 1333 Case aEncoding of 1334 beEAN8 : Result:=EncodeEan8(S); 1335 beEAN13 : Result:=EncodeEan13(S); 1336 be128A : Result:=Encode128A(S); 1337 be128B : Result:=Encode128B(S); 1338 be128C: Result:=Encode128C(S); 1339 be2of5industrial: Result:=Encode2of5Industrial(S); 1340 be2of5interleaved: Result:=Encode2of5Interleaved(S); 1341 be2of5matrix: Result:=Encode2of5Matrix(S); 1342 be39: Result:=Encode39(S,False); 1343 be39Extended: Result:=Encode39Extended(S,False); 1344 be93: Result:=Encode93(S); 1345 be93Extended: Result:=Encode93Extended(S); 1346 beCodabar: Result:=EncodeCodaBar(S); 1347 beMSI: Result:=EncodeMSI(S); 1348 bePostNet : Result:=EncodePostNet(S); 1349 else 1350 Raise EBarEncoding.CreateFmt('Unknown/Unhandled encoding, ordinal value : %d',[ord(aEncoding)]); 1351 end; 1352end; 1353 1354Function StringToBarcodeParams(S : AnsiString; aEncoding : TBarcodeEncoding) : TBarParamsArray; 1355 1356begin 1357 Result:=BarTypeArrayToBarParamsArray(StringToBarTypeArray(S,aEncoding)); 1358end; 1359 1360Function IntToBarTypeArray(I: Int64; aEncoding : TBarcodeEncoding; aWidth : Integer = 0) : TBarTypeArray; 1361 1362Var 1363 S : AnsiString; 1364 L : integer; 1365 1366begin 1367 S:=IntToStr(i); 1368 L:=Length(S); 1369 if (AWidth>0) and (L<AWidth) then 1370 S:=StringOfChar('0',AWidth-L)+S; 1371 Result:=StringToBarTypeArray(S,aEncoding); 1372end; 1373 1374Function IntToBarcodeParams(I : Int64; aEncoding : TBarcodeEncoding; aWidth : Integer = 0) : TBarParamsArray; 1375 1376begin 1377 Result:=BarTypeArrayToBarParamsArray(IntToBarTypeArray(I,aEncoding,aWidth)); 1378end; 1379 1380Function BarTypeToBarParams(aType : TBarType) : TBarParams; 1381 1382begin 1383 Result:=BarTypes[aType]; 1384end; 1385 1386Function BarTypeArrayToBarParamsArray(anArray : TBarTypeArray) : TBarParamsArray; 1387 1388Var 1389 I: Integer; 1390 1391begin 1392 Setlength(Result,Length(anArray)); 1393 For I:=0 to length(AnArray)-1 do 1394 Result[i]:=BarTypeToBarParams(anArray[i]); 1395end; 1396 1397function CalcBarWidths(aEncoding: TBarcodeEncoding; aUnit: Integer; AWeight: Double): TBarWidthArray; 1398 1399Const 1400 Weight2to3Encodings = 1401 [be2of5interleaved, be2of5industrial, be39, beEAN8, beEAN13, be39Extended, beCodabar]; 1402 Weight225to3Encodings = [be2of5matrix]; 1403 1404begin 1405 if aEncoding in Weight2to3Encodings then 1406 begin 1407 if aWeight < 2.0 then 1408 aWeight := 2.0; 1409 if aWeight > 3.0 then 1410 aWeight := 3.0; 1411 end 1412 else if aEncoding in Weight225to3Encodings then 1413 begin 1414 if aWeight < 2.25 then 1415 aWeight := 2.25; 1416 if aWeight > 3.0 then 1417 aWeight := 3.0; 1418 end; 1419 1420 Result[bw100]:=aUnit; 1421 Result[bwWeighted]:=Round(aUnit*aWeight); 1422 Result[bw150]:=Result[bwWeighted]*3 div 2; 1423 Result[bw200]:=Result[bwWeighted]*2; 1424end; 1425 1426function CalcStringWidthInBarCodeEncoding(S : String;aEncoding: TBarcodeEncoding; aUnit: Integer; AWeight: Double): Cardinal; 1427 1428Var 1429 BP : TBarParams; 1430 Data : TBarTypeArray; 1431 BWT : TBarWidthArray; 1432 I : integer; 1433 1434begin 1435 Result:=0; 1436 BWT:=CalcBarWidths(aEncoding,aUnit,aWeight); 1437 Data:=StringToBarTypeArray(S,aEncoding); 1438 for i:=0 to Length(Data)-1 do // examine the pattern string 1439 begin 1440 BP:=BarTypeToBarParams(Data[i]); 1441 Result:=Result+BWT[BP.w]; 1442 end; 1443end; 1444 1445end. 1446 1447