Visual Basic - generar clave en visual basic

' Return the disk's serial number

' as a 10-digit string.

Function GetDiskSerialNumber() As String

Static serial_number As Long

Dim volume_name As String

Dim max_component_length As Long

Dim file_system_flags As Long

Dim file_system_name As String

If serial_number = 0 Then

' Get the disk serial number.

volume_name = Space$(1024)

file_system_name = Space$(1024)

If GetVolumeInformation(vbNullString, _

volume_name, Len(volume_name), _

serial_number, _

max_component_length, file_system_flags, _

file_system_name, Len(file_system_name)) = 0 _

Then

MsgBox "Error getting system information."

GetDiskSerialNumber = 0

Exit Function

End If

End If

GetDiskSerialNumber = Invert(Right$(Format$(serial_number, "0000000000"), 10))

End Function

Private Function Invert(strng As String) ' Inversion function

Dim i As Integer

Dim tmp_txt As String

i = Len(strng)

Do Until i = 0

tmp_txt = tmp_txt & Mid(strng, i, 1)

i = i - 1

Loop

Invert = tmp_txt

End Function

Function noserie() As String

noserie = GetDiskSerialNumber() & "392353683786868"

End Function

'Function PRO(ByVal Expression As String, ByVal Password As String) As String

'On Error Resume Next

'Dim RB(0 To 255) As Integer, X As Long, Y As Long, Z As Long, Key() As Byte, ByteArray() As Byte, Temp As Byte

'If Len(Password) = 0 Then

' Exit Function

'End If

'If Len(Expression) = 0 Then

' Exit Function

'End If

'If Len(Password) > 256 Then

' Key() = StrConv(Left$(Password, 256), vbFromUnicode)

'Else

' Key() = StrConv(Password, vbFromUnicode)

'End If

'For X = 0 To 255

' RB(X) = X

'Next X

'X = 0

'Y = 0

'Z = 0

'For X = 0 To 255

' Y = (Y + RB(X) + Key(X Mod Len(Password))) Mod 256

' Temp = RB(X)

' RB(X) = RB(Y)

' RB(Y) = Temp

'Next X

'X = 0

'Y = 0

'Z = 0

'ByteArray() = StrConv(Expression, vbFromUnicode)

'For X = 0 To Len(Expression)

' Y = (Y + 1) Mod 256

' Z = (Z + RB(Y)) Mod 256

' Temp = RB(Y)

' RB(Y) = RB(Z)

' RB(Z) = Temp

' ByteArray(X) = ByteArray(X) Xor (RB((RB(Y) + RB(Z)) Mod 256))

'Next X

'PRO = StrConv(ByteArray, vbUnicode)

'End Function

Function VerificaActivacion()

Dim ws As Worksheet

Dim Clave As String

Set ws = Worksheets("DATOSEMP")

Clave = ws.Range("D24").Value

If Clave = llave("Excelente Punto de Venta 2015") Then

VerificaActivacion = True

Else

VerificaActivacion = False

End If

End Function

Function llave(permiso As String)

Dim code1 As String

Dim code2 As String

Dim code3 As String

Dim code4 As String

Dim code5 As String

Dim code11 As String

Dim code22 As String

Dim code33 As String

Dim code44 As String

Dim code55 As String

Dim Mfact As Integer

Dim i As Integer

Dim serie As String

If permiso = "Excelente Punto de Venta 2015" Then

serie = noserie()

'Split And morph

If Mid(serie, 1, 1) = 0 Then

If Mid(serie, 2, 1) = 0 Then

Mfact = Int(Val(Val(Val(Mid(serie, 3, 1)) + Val(Mid(serie, 12, 1)) + Val(Mid(serie, 24, 1)) + Val(Mid(serie, Val(Mid(serie, 3, 1)), 1))) / 4))

Else

Mfact = Int(Val(Val(Val(Mid(serie, 2, 1)) + Val(Mid(serie, 12, 1)) + Val(Mid(serie, 24, 1)) + Val(Mid(serie, Val(Mid(serie, 2, 1)), 1))) / 4))

End If

Else

Mfact = Int(Val(Val(Val(Mid(serie, 1, 1)) + Val(Mid(serie, 12, 1)) + Val(Mid(serie, 24, 1)) + Val(Mid(serie, Val(Mid(serie, 1, 1)), 1))) / 4))

End If

'Mfact = Int(Val(Val(Val(Mid(serie, 1, 1)) + Val(Mid(serie, 12, 1)) + Val(Mid(serie, 24, 1)) + Val(Mid(serie, Val(Mid(serie, 1, 1)), 1))) / 4))

code1 = Mid(iSplit(serie, Mfact, 0), 1, 5)

code2 = Mid(iSplit(serie, Mfact, 1), 1, 5)

code3 = Mid(iSplit(serie, Mfact, 2), 1, 5)

code4 = Mid(iSplit(serie, Mfact, 3), 1, 5)

code5 = Mid(iSplit(serie, Mfact, 4), 1, 5)

'Selective Inv. Proc.

If Mid(code1, 5, 1) <> 0 Then

code1 = Invert(code1)

End If

code3 = Invert(code3)

code5 = Invert(code5)

'Alpha Repla.

code1 = Replace(code1, "27", "Z3")

code1 = Replace(code1, "91", "8F")

code1 = Replace(code1, "72", "1K")

code1 = Replace(code1, "19", "PS")

code1 = Replace(code1, "56", "O1")

code1 = Replace(code1, "65", "M3")

code1 = Replace(code1, "83", "L0")

code1 = Replace(code1, "38", "E5")

code1 = Replace(code1, "01", "XD")

code1 = Replace(code1, "10", "PW")

code2 = Replace(code2, "30", "C4")

code2 = Replace(code2, "03", "UX")

code2 = Replace(code2, "55", "I8")

code2 = Replace(code2, "66", "PS")

code2 = Replace(code2, "23", "MZ")

code2 = Replace(code2, "32", "8Q")

code2 = Replace(code2, "14", "0L")

code2 = Replace(code2, "41", "XS")

code2 = Replace(code2, "74", "9U")

code2 = Replace(code2, "47", "NT")

code3 = Replace(code3, "27", "Z3")

code3 = Replace(code3, "91", "8F")

code3 = Replace(code3, "72", "1K")

code3 = Replace(code3, "19", "PS")

code3 = Replace(code3, "56", "O1")

code3 = Replace(code3, "32", "8Q")

code3 = Replace(code3, "14", "0L")

code3 = Replace(code3, "41", "XS")

code3 = Replace(code3, "74", "9U")

code3 = Replace(code3, "47", "NT")

code4 = Replace(code4, "27", "Z3")

code4 = Replace(code4, "91", "8F")

code4 = Replace(code4, "72", "1K")

code4 = Replace(code4, "19", "PS")

code4 = Replace(code4, "56", "O1")

code4 = Replace(code4, "65", "M3")

code4 = Replace(code4, "83", "L0")

code4 = Replace(code4, "38", "E5")

code4 = Replace(code4, "01", "XD")

code4 = Replace(code4, "10", "PW")

code5 = Replace(code5, "30", "C4")

code5 = Replace(code5, "03", "UX")

code5 = Replace(code5, "55", "I8")

code5 = Replace(code5, "66", "PS")

code5 = Replace(code5, "23", "MZ")

code5 = Replace(code5, "32", "8Q")

code5 = Replace(code5, "14", "0L")

code5 = Replace(code5, "41", "XS")

code5 = Replace(code5, "74", "9U")

code5 = Replace(code5, "47", "NT")

'Position Swap

code11 = code1

code22 = code2

code33 = code3

code44 = code4

code55 = code5

i = Val(Mid(serie, 1, 1))

Select Case i = Val(Mid(serie, 1, 1))

Case i = 1

code1 = code22

code2 = code44

code3 = code11

code4 = code55

code5 = code33

Case i = 2

code1 = code44

code2 = code11

code3 = code33

code4 = code22

code5 = code55

Case i = 3

code1 = code33

code2 = code11

code3 = code44

code4 = code55

code5 = code22

Case i = 4

code1 = code11

code2 = code22

code3 = code44

code4 = code55

code5 = code33

Case i = 5

code1 = code22

code2 = code44

code3 = code11

code4 = code55

code5 = code33

Case i = 6

code1 = code22

code2 = code44

code3 = code11

code4 = code55

code5 = code33

Case i = 7

code1 = code22

code2 = code44

code3 = code11

code4 = code55

code5 = code33

Case i = 8

code1 = code44

code2 = code11

code3 = code33

code4 = code22

code5 = code55

Case i = 9

code1 = code55

code2 = code11

code3 = code33

code4 = code22

code5 = code44

End Select

llave = code1 & code2 & code3 & code4 & code5

Else

llave = "Acceso indevido!"

End If

End Function

Private Function iSplit(orig As String, mFactor As Integer, Partition As Integer) As String

Dim tmp_key As String

Dim tmp_istring(0 To 5) As String

tmp_key = orig

tmp_istring(0) = Val(Mid(tmp_key, 1, 5)) * mFactor

tmp_istring(1) = Val(Mid(tmp_key, 6, 5)) * mFactor

tmp_istring(2) = Val(Mid(tmp_key, 11, 5)) * mFactor

tmp_istring(3) = Val(Mid(tmp_key, 16, 5)) * mFactor

tmp_istring(4) = Val(Mid(tmp_key, 21, 5)) * mFactor

iSplit = tmp_istring(Partition)

End Function