module1.bas

该程序是思路是经过专门的顾问专家集十年的经验设计

Attribute VB_Name = "Module1"
Option Explicit
Public StrJG As String  '存储答题结果
Public UserN As String
Public UserS As String
Public UserA As String
Public UserL As String
Public UserD As String
Public UserT As String
Public UserCC As String
Public UserDC As String
Public Conn As New ADODB.Connection
Public Rs1 As New ADODB.Recordset
Function JiSuan(ByVal Str As String) As String  '计算每项得分
Dim i, j As Long
Dim Str1 As String
Dim StrT As String
Dim t As Long
Str = JS1(Str)
For i = 1 To Len(Str) Step 10
StrT = Mid(Str, i, 10)
t = 0
For j = 1 To 13
t = t + Val(Mid(StrT, j, 1))
Next
Str1 = Str1 + Format(t, "00")
Next
JiSuan = Str1
End Function
Function JS1(Str As String) As String   '将字符串排序
Dim Str1 As String
Str1 = Str1 + Mid(Str, 1, 1) + Mid(Str, 14, 1) + Mid(Str, 27, 1) + Mid(Str, 40, 1) + Mid(Str, 54, 1) + Mid(Str, 67, 1) + Mid(Str, 80, 1) + Mid(Str, 93, 1) + Mid(Str, 106, 1) + Mid(Str, 119, 1)
Str1 = Str1 + Mid(Str, 2, 1) + Mid(Str, 15, 1) + Mid(Str, 28, 1) + Mid(Str, 41, 1) + Mid(Str, 55, 1) + Mid(Str, 68, 1) + Mid(Str, 81, 1) + Mid(Str, 94, 1) + Mid(Str, 107, 1) + Mid(Str, 120, 1)
Str1 = Str1 + Mid(Str, 4, 1) + Mid(Str, 17, 1) + Mid(Str, 30, 1) + Mid(Str, 43, 1) + Mid(Str, 57, 1) + Mid(Str, 70, 1) + Mid(Str, 83, 1) + Mid(Str, 96, 1) + Mid(Str, 109, 1) + Mid(Str, 122, 1)
Str1 = Str1 + Mid(Str, 6, 1) + Mid(Str, 19, 1) + Mid(Str, 32, 1) + Mid(Str, 45, 1) + Mid(Str, 59, 1) + Mid(Str, 72, 1) + Mid(Str, 85, 1) + Mid(Str, 98, 1) + Mid(Str, 111, 1) + Mid(Str, 124, 1)
Str1 = Str1 + Mid(Str, 8, 1) + Mid(Str, 21, 1) + Mid(Str, 34, 1) + Mid(Str, 47, 1) + Mid(Str, 61, 1) + Mid(Str, 74, 1) + Mid(Str, 87, 1) + Mid(Str, 100, 1) + Mid(Str, 113, 1) + Mid(Str, 126, 1)
Str1 = Str1 + Mid(Str, 10, 1) + Mid(Str, 23, 1) + Mid(Str, 36, 1) + Mid(Str, 49, 1) + Mid(Str, 63, 1) + Mid(Str, 76, 1) + Mid(Str, 89, 1) + Mid(Str, 102, 1) + Mid(Str, 115, 1) + Mid(Str, 128, 1)
Str1 = Str1 + Mid(Str, 12, 1) + Mid(Str, 25, 1) + Mid(Str, 38, 1) + Mid(Str, 51, 1) + Mid(Str, 65, 1) + Mid(Str, 78, 1) + Mid(Str, 91, 1) + Mid(Str, 104, 1) + Mid(Str, 117, 1) + Mid(Str, 130, 1)
Str1 = Str1 + Mid(Str, 13, 1) + Mid(Str, 26, 1) + Mid(Str, 39, 1) + Mid(Str, 52, 1) + Mid(Str, 53, 1) + Mid(Str, 66, 1) + Mid(Str, 79, 1) + Mid(Str, 92, 1) + Mid(Str, 105, 1) + Mid(Str, 118, 1)
Str1 = Str1 + Mid(Str, 3, 1) + Mid(Str, 16, 1) + Mid(Str, 29, 1) + Mid(Str, 42, 1) + Mid(Str, 56, 1) + Mid(Str, 69, 1) + Mid(Str, 82, 1) + Mid(Str, 95, 1) + Mid(Str, 108, 1) + Mid(Str, 121, 1)
Str1 = Str1 + Mid(Str, 5, 1) + Mid(Str, 18, 1) + Mid(Str, 31, 1) + Mid(Str, 44, 1) + Mid(Str, 58, 1) + Mid(Str, 71, 1) + Mid(Str, 84, 1) + Mid(Str, 97, 1) + Mid(Str, 110, 1) + Mid(Str, 123, 1)
Str1 = Str1 + Mid(Str, 7, 1) + Mid(Str, 20, 1) + Mid(Str, 33, 1) + Mid(Str, 46, 1) + Mid(Str, 60, 1) + Mid(Str, 73, 1) + Mid(Str, 86, 1) + Mid(Str, 99, 1) + Mid(Str, 112, 1) + Mid(Str, 125, 1)
Str1 = Str1 + Mid(Str, 9, 1) + Mid(Str, 22, 1) + Mid(Str, 35, 1) + Mid(Str, 48, 1) + Mid(Str, 62, 1) + Mid(Str, 75, 1) + Mid(Str, 88, 1) + Mid(Str, 101, 1) + Mid(Str, 114, 1) + Mid(Str, 127, 1)
Str1 = Str1 + Mid(Str, 11, 1) + Mid(Str, 24, 1) + Mid(Str, 37, 1) + Mid(Str, 50, 1) + Mid(Str, 64, 1) + Mid(Str, 77, 1) + Mid(Str, 90, 1) + Mid(Str, 103, 1) + Mid(Str, 116, 1) + Mid(Str, 129, 1)
JS1 = Str1
End Function
Function JS2(Str As String) As String   '计算每项不知道的个数
Dim i, j As Long
Dim n As Long
Dim SSS As String
Str = JS1(Str)
For i = 0 To 12
SSS = Mid(Str, i * 10 + 1, 10)
For j = 1 To 10
If Mid(SSS, j, 1) = 1 Then n = n + 1
Next
JS2 = JS2 + Format(n, "0")
n = 0
Next
End Function
Function JSS(Str As String) As String   '性向测试得分
Dim i As Long
Dim tt As Long
Dim SS As String
tt = Val(Mid(Str, 1, 2))
Select Case tt  '思考性
Case 0, 1, 2, 3, 4: i = 1
Case 5, 6, 7, 8: i = 2
Case 9, 10, 11, 12: i = 3
Case 13, 14, 15, 16: i = 4
Case 17, 18, 19, 20: i = 5
End Select
SS = SS + Trim(Val(i))
tt = Val(Mid(Str, 3, 2))
Select Case tt  '共鸣性
Case 1, 2, 3, 4, 5, 6, 7, 8: i = 1
Case 9, 10, 11, 12: i = 2
Case 13, 14, 15: i = 3
Case 16, 17: i = 4
Case 18, 19, 20: i = 5
End Select
SS = SS + Trim(Val(i))
tt = Val(Mid(Str, 5, 2))
Select Case tt  '自律性
Case 0, 1, 2, 3, 4, 5: i = 1
Case 6, 7, 8, 9, 10: i = 2
Case 11, 12, 13, 14: i = 3
Case 15, 16, 17: i = 4
Case 18, 19, 20: i = 5
End Select
SS = SS + Trim(Val(i))
tt = Val(Mid(Str, 7, 2))
Select Case tt  '活动性
Case 0, 1, 2, 3, 4, 5, 6, 7: i = 1
Case 8, 9, 10, 11: i = 2
Case 12, 13, 14, 15: i = 3
Case 16, 17, 18: i = 4
Case 19, 20: i = 5
End Select
SS = SS + Trim(Val(i))
tt = Val(Mid(Str, 9, 2))
Select Case tt  '指导性
Case 0, 1, 2, 3, 4, 5: i = 1
Case 6, 7, 8, 9, 10: i = 2
Case 11, 12, 13, 14: i = 3
Case 15, 16, 17: i = 4
Case 18, 19, 20: i = 5
End Select
SS = SS + Trim(Val(i))
tt = Val(Mid(Str, 11, 2))
Select Case tt  '社交性
Case 0, 1, 2, 3, 4, 5: i = 1
Case 6, 7, 8, 9, 10: i = 2
Case 11, 12, 13, 14, 15: i = 3
Case 16, 17, 18, 19: i = 4
Case 20: i = 5
End Select
SS = SS + Trim(Val(i))
tt = Val(Mid(Str, 13, 2))
Select Case tt  '创造性
Case 0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10: i = 1
Case 11, 12, 13: i = 2
Case 13, 14, 15, 16: i = 3
Case 17, 18, 19: i = 4
Case 20: i = 5
End Select
SS = SS + Trim(Val(i))
tt = Val(Mid(Str, 15, 2))
Select Case tt  '成就性
Case 0, 1, 2, 3, 4, 5, 6, 7, 8, 9: i = 1
Case 10, 11, 12: i = 2
Case 13, 14, 15, 16: i = 3
Case 17, 18: i = 4
Case 19, 20: i = 5
End Select
SS = SS + Trim(Val(i))
tt = Val(Mid(Str, 17, 2))
Select Case tt  '变易性
Case 0, 1, 2, 3: i = 5
Case 4, 5, 6, 7: i = 4
Case 8, 9, 10, 11: i = 3
Case 12, 13, 14, 15: i = 2
Case 16, 17, 18, 19, 20: i = 1
End Select
SS = SS + Trim(Val(i))
tt = Val(Mid(Str, 19, 2))
Select Case tt  '抑郁性
Case 0, 1, 2, 3, 4: i = 5
Case 5, 6, 7, 8: i = 4
Case 9, 10, 11, 12, 13, 14: i = 3
Case 15, 16, 17: i = 2
Case 18, 19, 20: i = 1
End Select
SS = SS + Trim(Val(i))
tt = Val(Mid(Str, 21, 2))
Select Case tt  '神经质
Case 0, 1, 2, 3, 4, 5: i = 5
Case 6, 7, 8: i = 4
Case 9, 10, 11, 12: i = 3
Case 13, 14, 15, 16: i = 2
Case 17, 18, 19, 20: i = 1
End Select
SS = SS + Trim(Val(i))
tt = Val(Mid(Str, 23, 2))
Select Case tt  '自卑性
Case 0, 1, 2, 3: i = 5
Case 4, 5, 6, 7, 8: i = 4
Case 9, 10, 11, 12, 13: i = 3
Case 14, 15, 16, 17: i = 2
Case 18, 19, 20: i = 1
End Select
SS = SS + Trim(Val(i))
tt = Val(Mid(Str, 25, 2))
Select Case tt  '虚构性
Case 0, 1, 2, 3, 4, 5: i = 5
Case 6, 7, 8: i = 4
Case 9, 10, 11, 12: i = 3
Case 13, 14, 15, 16: i = 2
Case 17, 18, 19, 20: i = 1
End Select
SS = SS + Trim(Val(i))
JSS = SS
End Function
Function ZH(Str As String) As Long  '综合判定总分
Dim i As Long
Dim t As Long
For i = 1 To 12
t = t + Val(Mid(Str, i, 1))
Next
ZH = t
End Function

Function My_Format(SS As String, ii As Long) As String
My_Format = SS & Space(ii - LenB(StrConv(SS, vbFromUnicode)))
End Function