frmmain.frm

本系统可用于医院和专业体检中心的健康体检管理

VERSION 5.00
Begin VB.Form frmMain 
   BorderStyle     =   3  'Fixed Dialog
   Caption         =   "注册码生成"
   ClientHeight    =   3660
   ClientLeft      =   45
   ClientTop       =   330
   ClientWidth     =   5610
   Icon            =   "frmMain.frx":0000
   LinkTopic       =   "Form1"
   LockControls    =   -1  'True
   MaxButton       =   0   'False
   MinButton       =   0   'False
   ScaleHeight     =   3660
   ScaleWidth      =   5610
   StartUpPosition =   3  'Windows Default
   Begin VB.CommandButton cmdExit 
      Caption         =   "退出"
      Height          =   450
      Left            =   3960
      TabIndex        =   6
      Top             =   2505
      Width           =   1170
   End
   Begin VB.CommandButton cmdCopy 
      Caption         =   "复制到剪贴板"
      Enabled         =   0   'False
      Height          =   450
      Left            =   2160
      TabIndex        =   5
      Top             =   2505
      Width           =   1260
   End
   Begin VB.TextBox txtZCM 
      Height          =   315
      Left            =   1665
      Locked          =   -1  'True
      TabIndex        =   4
      Top             =   1425
      Width           =   3615
   End
   Begin VB.CommandButton cmdProduce 
      Caption         =   "生成注册码"
      Height          =   450
      Left            =   510
      TabIndex        =   1
      Top             =   2505
      Width           =   1170
   End
   Begin VB.TextBox txtZJM 
      Height          =   315
      Left            =   1665
      TabIndex        =   0
      Top             =   885
      Width           =   3615
   End
   Begin VB.Label Label2 
      Caption         =   "注册码："
      Height          =   210
      Left            =   360
      TabIndex        =   3
      Top             =   1470
      Width           =   1155
   End
   Begin VB.Label Label1 
      AutoSize        =   -1  'True
      Caption         =   "请输入主机码："
      Height          =   195
      Left            =   360
      TabIndex        =   2
      Top             =   930
      Width           =   1260
   End
End
Attribute VB_Name = "frmMain"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit

'获取加密的字符串
Public Function EncryptString(ByVal strData As String) As String
    Dim strReturn As String
    Dim arrCircle(35) As String
    Dim lngDepth As Long
    Dim lngLength As Long
    Dim i As Integer
    Dim j As Integer
    
    arrCircle(0) = "P":  arrCircle(1) = "L":  arrCircle(2) = "3"
    arrCircle(3) = "7":  arrCircle(4) = "K":  arrCircle(5) = "N"
    arrCircle(6) = "5":  arrCircle(7) = "J":  arrCircle(8) = "I"
    arrCircle(9) = "9":  arrCircle(10) = "4": arrCircle(11) = "V"
    arrCircle(12) = "C": arrCircle(13) = "6": arrCircle(14) = "G"
    arrCircle(15) = "8": arrCircle(16) = "X": arrCircle(17) = "F"
    arrCircle(18) = "D": arrCircle(19) = "Z": arrCircle(20) = "0"
    arrCircle(21) = "1": arrCircle(22) = "A": arrCircle(23) = "S"
    arrCircle(24) = "Q": arrCircle(25) = "9": arrCircle(26) = "W"
    
    arrCircle(27) = "2": arrCircle(28) = "R": arrCircle(29) = "M"
    arrCircle(30) = "U": arrCircle(31) = "B": arrCircle(32) = "Y"
    arrCircle(33) = "O": arrCircle(34) = "T": arrCircle(35) = "E"
    
    lngLength = Len(strData)
    For i = 1 To lngLength
        lngDepth = 0
        For j = i To lngLength
            lngDepth = lngDepth + Asc(Mid(strData, j, 1))
            If i > 1 Then
                lngDepth = lngDepth + Asc(Mid(strData, i - 1, 1))
            End If
            If i > 2 Then
                lngDepth = lngDepth + Asc(Mid(strData, i - 2, 1))
            End If
        Next
        lngDepth = lngDepth * Asc(Mid(strData, i, 1))
        lngDepth = lngDepth Mod 36
        
        strReturn = strReturn & arrCircle(lngDepth)
    Next
    
    EncryptString = strReturn
End Function

'获取定长的注册码（25位）
'返回格式：*****-*****-*****-*****-*****
Public Function GetFixedSerialNumber(ByVal strSerial As String, ByVal CodeLen As Integer) As String
    Dim i As Integer, j As Integer, k As Integer
    Dim strReturn As String
    Dim strEncrypted As String
    Dim strTemp As String
    
    strSerial = strDelSpecial(strSerial)
    strEncrypted = EncryptString(strSerial)
    
    i = 1
    Do While Len(strReturn) < CodeLen
        Select Case i
            Case 1
                For j = Len(strEncrypted) To 1 Step -1
                    strReturn = strReturn & Mid(strEncrypted, j, 1)
                Next j
            Case 2
                k = Len(strEncrypted) \ 3
                For j = 2 * k To k + 1 Step -1
                    strReturn = strReturn & Mid(strEncrypted, j, 1)
                Next j
                For j = 2 * k + 1 To Len(strEncrypted)
                    strReturn = strReturn & Mid(strEncrypted, j, 1)
                Next j
                For j = k To 1 Step -1
                    strReturn = strReturn & Mid(strEncrypted, j, 1)
                Next j
            Case 3
                k = Len(strEncrypted) \ 3
                For j = 2 * k + 1 To Len(strEncrypted)
                    strReturn = strReturn & Mid(strEncrypted, j, 1)
                Next j
                For j = k To 1 Step -1
                    strReturn = strReturn & Mid(strEncrypted, j, 1)
                Next j
                For j = k + 1 To 2 * k
                    strReturn = strReturn & Mid(strEncrypted, j, 1)
                Next j
            Case Else
                k = Len(strEncrypted) \ 2
                For j = k To 1 Step -1
                    strReturn = strReturn & Mid(strEncrypted, j, 1)
                Next j
                For j = k + 1 To Len(strEncrypted)
                    strReturn = strReturn & Mid(strEncrypted, j, 1)
                Next j
        End Select
        i = i + 1
        strEncrypted = EncryptString(strEncrypted)
        If Len(strEncrypted) < 2 Then
            strEncrypted = EncryptString(strSerial)
        End If
    Loop
    
    For i = Len(strReturn) To 1 Step -1
        strTemp = strTemp & Mid(strReturn, i, 1)
    Next
    strReturn = strTemp
    
    strReturn = Left(strReturn, 25)
    strReturn = EncryptString(strReturn)
    If CodeLen = 25 Then
        GetFixedSerialNumber = Mid(strReturn, 1, 5) & "-" & Mid(strReturn, 6, 5) & "-" _
              & Mid(strReturn, 11, 5) & "-" & Mid(strReturn, 16, 5) & "-" & Mid(strReturn, 21, 5)
    Else
        GetFixedSerialNumber = strReturn
    End If
End Function

Private Sub cmdCopy_Click()
    Clipboard.Clear
    Clipboard.SetText txtZCM.Text
    
'    MsgBox Asc(9)  '57
'    MsgBox Asc(0)  '48
'    MsgBox Asc("a")   '97
'    MsgBox Asc("z")   '122
'    MsgBox Asc("A")   '65
'    MsgBox Asc("Z")   '90
    
End Sub

Private Sub cmdExit_Click()
    Unload Me
End Sub

Private Sub cmdProduce_Click()
    Dim i As Integer
    Dim strTmp, strOri As String
    Dim tmpAsc As Integer
    
    If txtZJM.Text = "" Then
        MsgBox "请输入主机码！", vbInformation, "提示"
        txtZJM.SetFocus
        Exit Sub
    End If
    
'    txtZCM.Text = GetFixedSerialNumber(strDelSpecial(txtZJM.Text), 25)
    txtZCM.Text = GetFixedSerialNumber(Trim(txtZJM.Text), 25)
    cmdCopy.Enabled = True
End Sub

Private Sub txtZCM_GotFocus()
    txtZCM.SelStart = 0
    txtZCM.SelLength = Len(txtZCM.Text)
End Sub

Private Sub txtZJM_GotFocus()
    txtZJM.SelStart = 0
    txtZJM.SelLength = Len(txtZJM.Text)
End Sub

Private Sub txtZJM_LostFocus()
    txtZJM = Trim(txtZJM.Text)
End Sub
    
'**************20040413加入 闻***************************
'去掉主机码中的特殊字符,只留下数字和字母
Private Function strDelSpecial(ByVal incomeStr As String) As String
    Dim strTmp As String
    Dim i, tmpAsc As Integer
    
    For i = 1 To Len(incomeStr)
        tmpAsc = Asc(Mid(incomeStr, i, 1))
        If (tmpAsc >= Asc(0) And tmpAsc <= Asc(9)) Or (tmpAsc >= Asc("a") And tmpAsc <= Asc("z")) Or (tmpAsc >= Asc("A") And tmpAsc <= Asc("Z")) Then
            strTmp = strTmp & Mid(incomeStr, i, 1)
        End If
    Next
    strDelSpecial = strTmp
End Function
'**************20040413加入完 闻*************************