想对给定的数字按规则转换后结果还为数字。类似于加密和解密。在线等待

[lanzhoulamian]

各位网友：
现在遇到一个问题，谁又完成这样功能的函数：想对给定的数字按规则转换后结果还为数字。类似于加密和解密。而且给定的数字不同得到的转换结果不能重复。谁又，请指教。在线等待。。。急！！！！！！

[Cooly]

xor

[dandy1437]

我的程序是对字符和数字通用的
得到的结果也是字符和数字
但是完全是数字的我没有

[lanzhoulamian]

danday1437 那也行呀。能不能把其中的代码贴出来。让我看看。谢谢

[dandy1437]

Option Explicit

Type TBytes8
Data(1 To 8) As Byte
End Type

Declare Sub DesEncrypt Lib "des.dll" (ByRef Key As TBytes8, ByRef SrcData As TBytes8, ByRef DesData As TBytes8)
Declare Sub DesDecrypt Lib "des.dll" (ByRef Key As TBytes8, ByRef SrcData As TBytes8, ByRef DesData As TBytes8)

Function ByteToHex(ByVal Value As Byte) As String
Dim H1 As Integer
Dim H2 As Integer
Dim S1 As String
Dim S2 As String

H1 = Value \ 16
H2 = Value Mod 16

Select Case H1
Case 0 To 9
S1 = CStr(H1)
Case 10 To 15
S1 = Chr(Asc("A") + H1 - 10)
End Select

Select Case H2
Case 0 To 9
S2 = CStr(H2)
Case 10 To 15
S2 = Chr(Asc("A") + H2 - 10)
End Select

ByteToHex = S1 & S2
End Function

'SerialNo是一个8位的字符串
Function EncryptStr(SerialNo As String, SrcData As String) As String
Dim DesKey As TBytes8
Dim DesSrcData As TBytes8
Dim DesRetData As TBytes8
Dim SerialNoBuf() As Byte
Dim SrcDataBuf() As Byte

Dim i As Integer
Dim l As Integer

SerialNoBuf = StrConv(SerialNo, vbFromUnicode)

If (UBound(SerialNoBuf) <> 7) Then
MsgBox "序列号错误", vbOKOnly, "错误"

Exit Function
Else
For i = 0 To 7
DesKey.Data(i + 1) = SerialNoBuf(i)
Next i
End If

l = 0
EncryptStr = ""

SrcDataBuf = StrConv(SrcData, vbFromUnicode) ' Convert string.

While l <= UBound(SrcDataBuf)
For i = 0 To 7
If (l + i) <= UBound(SrcDataBuf) Then
DesSrcData.Data(i + 1) = SrcDataBuf(l + i)
Else
DesSrcData.Data(i + 1) = 0
End If
Next i

l = l + 8

Call DesEncrypt(DesKey, DesSrcData, DesRetData)

For i = 1 To 8
DesKey.Data(i) = DesRetData.Data(i)
Next i
Wend

For i = 1 To 8
EncryptStr = EncryptStr + ByteToHex(DesRetData.Data(i))
Next i
End Function


我做了一个DLL，你看不见的

其实就是DES的方法拉

[lanzhoulamian]

你这个冬冬咋用呀？能大概说说吗？怎样检测一下效果？谢谢。

[wxj8228]

你让你的程序遍历你的数据，将你的数字一个个转换成你想得到的数
例：将1变成4，依次类推

[put2001_ruan]

简单的ASCII码转换了，然后解密的时候用反的算法就可以了。

[双杯献酒]

你的“数字”，是 100（二进制） 还是 “100”（字符串）？
如果是100（二进制），一般的加密算法就可以。
如果是"100"（字符串）,你可以把最后得到的二进制密码编码成数字串。
比如字符"A",可以是"049"

[machete]

'加密
'
'把 税号后六位、代码10位、号码7位、金额位数不定（整数和两位小数）加密成一密文(get_Encrypt())

'算法：
'（1） 先把四项按一定规则排成一个字符串 (get_strWillEncrypt())
' 第一位标志位：指示税号从左数第几位是字母（1-6），没有字母则为0
' 第二位：如果税号中有字母，则把高位数字存在此位，如是“A”（转换为01）,则此位为0；如为"Z"（转换为26）,则此位为2
' 从第三位开始按一定顺序重排，第一圈代码、金额，第二圈代码、金额、税号，
' 第三圈代码、金额、税号、号码，第四圈代码、金额、税号、号码，。。。。。。。(并且如税号有字母，低位存于此处)
'(2）将此字符串加密 （set_Encrypt()）
' 用加秘密钥，从第二位开始加密，仅仅是一个对应关系（因为要求加密后仍是数字）
' 加密密钥：7251408396 对应原文：0123456789
'

Option Explicit
Private Const DMWS As Integer = 10 '代码位数
Private Const ENCRYKEY2$ = "08396" '密钥后半段
Private Jews As Integer '金额位数
Private Const SHWS As Integer = 6 '税号位数
Private Const HMWS As Integer = 7 '号码位数
Private Const ENCRYKEY1$ = "72514" '密钥前半段
Private Const SHQSQ As Integer = 2 '税号起始圈
Private Const HMQSQ As Integer = 3 '号码起始圈

Public Function get_Encrypt(strDm As String, ByVal Je As Double, strSh As String, strHm As String) As String
Dim strWillEncry As String
strWillEncry = get_strWillEncrypt(strDm, Je, strSh, strHm)
frmEncDec.Text5.Text = strWillEncry
get_Encrypt = set_Encrypt(strWillEncry)
End Function

Private Function get_strWillEncrypt(strDm As String, ByVal Je As Double, strSh As String, strHm As String) As String
Dim strWillEncrypt As String '待加密字符串
Dim TolEncWs As Integer, EncWh As Integer, circleNum As Integer '密文总位数;指示密文字符位置，即位号;表示是第几圈
Dim strJe As String '浮点数转换为字符串，格式如：0.00,1.00,0.78,0.70,33.00等
Dim Dmwh As Integer, Jewh As Integer, Shwh As Integer, Hmwh As Integer '代码位号；金额位号；税号位号；号码位号
Dim shzmWh As Integer '税号字母位号
If valid_EncElement(strDm, Je, strSh, strHm) > 0 Then
frmEncDec.Text3.Text = frmEncDec.Text3.Text & "zym"
Exit Function
End If
strJe = Je_to_String(Je)
Jews = Len(strJe)

shzmWh = get_ShZmWh(strSh)
strWillEncrypt = Format(shzmWh, "0")
If shzmWh > 0 Then
Dim Shzm As String, ShzmL As String, ShzmU As String, SHZmCon As String
Shzm = Mid(strSh, shzmWh, 1)
SHZmCon = Format(Asc(UCase(Shzm)) - 64, "00")
ShzmU = Left(SHZmCon, 1)
ShzmL = Right(SHZmCon, 1)
strWillEncrypt = strWillEncrypt & ShzmU
Else
strWillEncrypt = strWillEncrypt & "0"
End If

TolEncWs = DMWS + Jews + SHWS + HMWS
circleNum = 1
Dmwh = 1: Jewh = 1: Shwh = 1: Hmwh = 1
For EncWh = 1 To TolEncWs
If Dmwh <= 10 Then
strWillEncrypt = strWillEncrypt & Mid(strDm, Dmwh, 1)
Dmwh = Dmwh + 1
EncWh = EncWh + 1
End If
If Jewh <= Jews Then
strWillEncrypt = strWillEncrypt & Mid(strJe, Jewh, 1)
Jewh = Jewh + 1
EncWh = EncWh + 1
End If
If circleNum >= SHQSQ Then
If Shwh <= SHWS Then
If Shwh = shzmWh Then
strWillEncrypt = strWillEncrypt & ShzmL
Else
strWillEncrypt = strWillEncrypt & Mid(strSh, Shwh, 1)
End If
Shwh = Shwh + 1
EncWh = EncWh + 1
End If
End If
If circleNum >= HMQSQ Then
If Hmwh <= HMWS Then
strWillEncrypt = strWillEncrypt & Mid(strHm, Hmwh, 1)
Hmwh = Hmwh + 1
EncWh = EncWh + 1
End If
End If
circleNum = circleNum + 1
EncWh = EncWh - 1
Next EncWh
get_strWillEncrypt = strWillEncrypt
End Function
Private Function set_Encrypt(strWillEncry As String) As String
Dim EncryKey As String '加密密钥
Dim strEncrypt As String
EncryKey = ENCRYKEY1 & ENCRYKEY2
' strEncrypt = Mid(strWillEncry, 1, 1)
Dim EncLen As Integer, I As Integer
EncLen = Len(strWillEncry)
For I = 1 To EncLen
strEncrypt = strEncrypt & Mid(EncryKey, CInt(Mid(strWillEncry, I, 1)) + 1, 1)
Next I
set_Encrypt = strEncrypt
End Function
Private Function get_ShZmWh(strSh As String) As Integer '税号字母位号，没有字母则为返回0
Dim I As Integer
Dim ss As String
get_ShZmWh = 0
For I = 1 To 6
ss = Mid(strSh, I, 1)
If ss > "9" Or ss < "0" Then
get_ShZmWh = I
Exit For
End If
Next I
End Function
Private Function Je_to_String(ByVal Je As Double) As String
Dim strJeTmp As String, strJe As String
Dim I As Integer
strJeTmp = Format(Je, "0.00")
I = InStr(1, strJeTmp, ".", 1)
strJe = Left(strJeTmp, I - 1)
strJe = strJe & Mid(strJeTmp, I + 1)
Je_to_String = strJe
End Function

Public Function valid_EncElement(strDm As String, ByVal Je As Double, strSh As String, strHm As String) As Integer
valid_EncElement = 0
Dim I As Integer
Dim Flag As Boolean
Dim sChar As String
If Len(strDm) > DMWS Then
Flag = True
End If
For I = 1 To DMWS
sChar = Mid(strDm, I, 1)
If sChar > "9" Or sChar < "0" Then
Flag = True
Exit For
End If
Next I
If Flag = True Then
valid_EncElement = 1
Exit Function
End If

If Je > 99999999 Then
valid_EncElement = 2
Exit Function

End If

Dim j As Integer
If Len(strSh) > SHWS Then
j = 2
End If
For I = 1 To SHWS
sChar = Mid(strSh, I, 1)
If sChar > "9" Or sChar < "0" Then
j = j + 1
End If
Next I
If j > 1 Then
valid_EncElement = 3
Exit Function
End If

If Len(strHm) > HMWS Then
Flag = True
End If
For I = 1 To HMWS
sChar = Mid(strHm, I, 1)
If sChar > "9" Or sChar < "0" Then
Flag = True
Exit For
End If
Next I
If Flag = True Then
valid_EncElement = 4
Exit Function
End If
End Function

[machete]

'解密
'已知密文，解出税号后六位、代码10位、号码7位、金额位数不定（整数和两位小数）
'把 税号后六位、代码10位、号码7位、金额位数不定（整数和两位小数）加密成一密文(get_Encrypt())


Option Explicit
Private Const DMWS As Integer = 10 '代码位数
Private Jews As Integer '金额位数
Private Const DECRYKEY2$ = "29068" '密钥后半段
Private Const SHWS As Integer = 6 '税号位数
Private Const HMWS As Integer = 7 '号码位数
Private Const DECRYKEY1$ = "53174" '密钥前半段
Private Const SHQSQ As Integer = 2 '税号起始圈
Private Const HMQSQ As Integer = 3 '号码起始圈

'得到解密后的dm,je,sh,hm
Public Function get_DmJeShHm(strEncry As String) As String()
Dim strDecrypt As String
strDecrypt = get_strDecrypt(strEncry)
frmEncDec.Text6.Text = strDecrypt

Dim strDm As String, strJe As String, strSh As String, strHm As String
Dim TolEncWs As Integer, EncWh As Integer, circleNum As Integer '密文总位数;指示密文字符位置，即位号;表示是第几圈
' Dim strJe As String '浮点数转换为字符串，格式如：0.00,1.00,0.78,0.70,33.00等
Dim Dmwh As Integer, Jewh As Integer, Shwh As Integer, Hmwh As Integer '代码位号；金额位号；税号位号；号码位号


Dim Shzm As String, ShzmU As String, ShzmL As String
Dim shzmWh As Integer
shzmWh = CInt(Left(strDecrypt, 1))
TolEncWs = Len(strDecrypt)
Jews = TolEncWs - DMWS - SHWS - HMWS - 2
circleNum = 1
Dmwh = 1: Jewh = 1: Shwh = 1: Hmwh = 1
For EncWh = 3 To TolEncWs
If Dmwh <= 10 Then
strDm = strDm & Mid(strDecrypt, EncWh, 1)
Dmwh = Dmwh + 1
EncWh = EncWh + 1
End If
If Jewh <= Jews Then
strJe = strJe & Mid(strDecrypt, EncWh, 1)
Jewh = Jewh + 1
EncWh = EncWh + 1
End If
If circleNum >= SHQSQ Then
If Shwh <= SHWS Then
If Shwh = shzmWh Then
ShzmU = Mid(strDecrypt, 2, 1)
ShzmL = Mid(strDecrypt, EncWh, 1)
Shzm = Chr(CInt(ShzmU & ShzmL) + 64)
strSh = strSh & Shzm
Else
strSh = strSh & Mid(strDecrypt, EncWh, 1)
End If
Shwh = Shwh + 1
EncWh = EncWh + 1
End If
End If
If circleNum >= HMQSQ Then
If Hmwh <= HMWS Then
strHm = strHm & Mid(strDecrypt, EncWh, 1)
Hmwh = Hmwh + 1
EncWh = EncWh + 1
End If
End If
circleNum = circleNum + 1
EncWh = EncWh - 1
Next EncWh
strJe = Mid(strJe, 1, Jews - 2) & "." & Right(strJe, 2)
Dim returnDecry(1 To 4) As String
returnDecry(1) = strDm
returnDecry(2) = strJe
returnDecry(3) = strSh
returnDecry(4) = strHm
get_DmJeShHm = returnDecry

End Function

'得到带加密的明文字符串（即解密）
Private Function get_strDecrypt(strEncry As String) As String
Dim DecryKey As String '解密密钥
Dim strDecrypt As String
DecryKey = DECRYKEY1 & DECRYKEY2
Dim DecLen As Integer, I As Integer
DecLen = Len(strEncry)
For I = 1 To DecLen
strDecrypt = strDecrypt & Mid(DecryKey, CInt(Mid(strEncry, I, 1)) + 1, 1)
Next I
get_strDecrypt = strDecrypt
End Function
Public Function valid_strEncrypt(strEncry As String) As Boolean
Dim EncryLen As Integer, EncryLenL As Integer, EncryLenU As Integer
EncryLen = Len(strEncry)
EncryLenL = DMWS + SHWS + HMWS + 3 + 2
EncryLenU = DMWS + SHWS + HMWS + 10 + 2
If EncryLen < EncryLenL Or EncryLen > EncryLenU Then valid_strEncrypt = True
End Function