Mega Code Archive
A component for credit card numbers
<![CDATA[
Title: A component for credit card numbers
Question: Based on an old article I wrote here, there's a powerfull component visible
in designing mode only, that allows you to manipulate credit card's and their
numbers.
It's the ideal for shareware registration forms, and so on...
Answer:
Unit uCreditCardCheck;
Interface
Uses
Windows, Messages, SysUtils, Classes,
Graphics, Controls, Forms, Dialogs;
Type
tCCTypes =
(
ccUnknown, ccMasterCard, ccVisa, ccAmericanExpress,
ccDinersClub, ccCarteBlanche, ccDiscover, ccenRoute,
ccJCB
);
tCCType = Set Of tCCTypes;
TCreditCardCheck =
Class( TComponent )
Private
fCCNumber : String;
fCCType : tCCType;
fCCIsValid : Boolean;
Protected
Procedure SetCreditCardNumber( Value : String );
Procedure SetCreditCardType( Value : tCCType );
Function CheckCreditCard : Boolean;
Function GetCreditCardID( CardNumber : String ) : tCCType;
Published
Property CreditCardNumber : String Read fCCNumber Write SetCreditCardNumber;
Property CreditCardType : tCCType Read fCCType Write SetCreditCardType;
Property IsValid : Boolean Read fCCIsValid Write fCCIsValid Default False;
End;
Procedure Register;
Implementation
Function TCreditCardCheck.CheckCreditCard : Boolean;
Var
CC : String;
Bits : Array[ 1..20 ] Of Byte;
IdX : Integer;
Somma : Integer;
Begin
Result := False;
If ( GetCreditCardID( fCCNumber ) = [ccenRoute] ) Then Exit;
If ( GetCreditCardID( fCCNumber ) = [ccUnknown] ) Then Exit;
Somma := 0;
For IdX := 1 To 20 Do Bits[ IdX ] := 0;
For IdX := 1 To Length( fCCNumber ) Do CC := CC + ' ';
For IdX := 1 To Length( fCCNumber ) Do CC[ IdX ] := fCCNumber[ Length( fCCNumber ) - ( IdX - 1 ) ];
For IdX := 1 To Length( CC ) Do Bits[ IdX ] := Ord( CC[ IdX ] ) - 48;
For IdX := 1 To Length( fCCNumber ) Do
If Bool( IdX Mod 2 ) Then Begin
Bits[ IdX ] := Bits[ IdX ] * 2;
If ( Bits[ IdX ] 10 ) Then Bits[ IdX ] := Bits[ IdX ] - 9;
End;
For IdX := 1 To Length( fCCNumber ) Do Somma := Somma + Bits[ IdX ];
If ( Somma Mod 10 = 0 ) Then Result := True;
End;
Function TCreditCardCheck.GetCreditCardID( CardNumber : String ) : tCCType;
Var
L : Integer;
D1 : String;
D2 : String;
D3 : String;
D4 : String;
Begin
Result := [ccUnknown];
L := Length( CardNumber );
D1 := Copy( CardNumber, 1, 1 );
D2 := Copy( CardNumber, 1, 2 );
D3 := Copy( CardNumber, 1, 3 );
D4 := Copy( CardNumber, 1, 4 );
If ( D1 = '4' ) And ( L = 16 ) Then Result := [ ccVisa ];
If ( D1 = '4' ) And ( L = 13 ) Then Result := [ ccVisa ];
If ( D2 = '51' ) And ( L = 16 ) Then Result := [ ccMasterCard ];
If ( D2 = '52' ) And ( L = 16 ) Then Result := [ ccMasterCard ];
If ( D2 = '53' ) And ( L = 16 ) Then Result := [ ccMasterCard ];
If ( D2 = '54' ) And ( L = 16 ) Then Result := [ ccMasterCard ];
If ( D2 = '55' ) And ( L = 16 ) Then Result := [ ccMasterCard ];
If ( D2 = '34' ) And ( L = 15 ) Then Result := [ ccAmericanExpress ];
If ( D2 = '37' ) And ( L = 15 ) Then Result := [ ccAmericanExpress ];
If ( D3 = '300' ) And ( L = 14 ) Then Result := [ ccDinersClub ];
If ( D3 = '301' ) And ( L = 14 ) Then Result := [ ccDinersClub ];
If ( D3 = '302' ) And ( L = 14 ) Then Result := [ ccDinersClub ];
If ( D3 = '303' ) And ( L = 14 ) Then Result := [ ccDinersClub ];
If ( D3 = '304' ) And ( L = 14 ) Then Result := [ ccDinersClub ];
If ( D3 = '305' ) And ( L = 14 ) Then Result := [ ccDinersClub ];
If ( D2 = '36' ) And ( L = 14 ) Then Result := [ ccDinersClub ];
If ( D2 = '38' ) And ( L = 14 ) Then Result := [ ccDinersClub ];
If ( D4 = '6011' ) And ( L = 14 ) Then Result := [ ccDiscover ];
If ( D4 = '2014' ) And ( L = 16 ) Then Result := [ ccenRoute ];
If ( D4 = '2149' ) And ( L = 16 ) Then Result := [ ccenRoute ];
If ( D1 = '3' ) And ( L = 16 ) Then Result := [ ccJCB ];
If ( D4 = '2131' ) And ( L = 15 ) Then Result := [ ccJCB ];
If ( D4 = '1800' ) And ( L = 15 ) Then Result := [ ccJCB ];
End;
Procedure TCreditCardCheck.SetCreditCardNumber( Value : String );
Begin
If ( Value fCCNumber ) Then Begin
fCCNumber := Value;
fCCIsValid := CheckCreditCard;
fCCType := GetCreditCardID( Value );
End;
End;
Procedure TCreditCardCheck.SetCreditCardType( Value : tCCType );
Begin
If ( Value fCCType ) Then Begin
fCCType := Value;
If ( fCCType = GetCreditCardID( fCCNumber ) ) Then
fCCIsValid := CheckCreditCard
Else Begin
fCCNumber := '0';
fCCIsValid := CheckCreditCard;
fCCType := [ccUnknown];
End;
End;
End;
Procedure Register;
Begin
RegisterComponents( 'Christian', [ TCreditCardCheck ] );
End;
End.
]]>