📄 form1.frm
字号:
TabIndex = 18
Top = 2370
Width = 900
End
Begin VB.Label Label5
BackStyle = 0 'Transparent
Height = 180
Index = 4
Left = 135
TabIndex = 17
Top = 1995
Width = 900
End
Begin VB.Label Label5
BackStyle = 0 'Transparent
Height = 180
Index = 3
Left = 135
TabIndex = 16
Top = 1575
Width = 900
End
Begin VB.Label Label5
BackStyle = 0 'Transparent
Height = 180
Index = 2
Left = 135
TabIndex = 15
Top = 1215
Width = 900
End
Begin VB.Label Label5
BackStyle = 0 'Transparent
Height = 180
Index = 1
Left = 135
TabIndex = 14
Top = 825
Width = 855
End
Begin VB.Label Label5
BackStyle = 0 'Transparent
Height = 180
Index = 0
Left = 135
TabIndex = 13
Top = 405
Width = 900
End
Begin VB.Label Label1
BackStyle = 0 'Transparent
Caption = "0"
Height = 150
Index = 6
Left = 1050
TabIndex = 12
Top = 270
Width = 165
End
End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Private Sub CmdXX() '绘制性向图
Dim i As Long
Dim j As Long
Dim t As Long
Dim Str1 As String
Dim Str2 As String
Dim Str3 As String
Dim Strr As String
Strr = StrJG
Picture1.Cls
Picture1.Scale (0, 12)-(20, 0) '画表格
Picture1.DrawWidth = 1
For i = 1 To 11
Picture1.Line (0, i)-(20, i) '画横线
Next
Picture1.DrawStyle = 2
For i = 1 To 19
Picture1.Line (i, 12)-(i, 0) '画竖线
Next
Picture1.DrawStyle = 0
Picture1.Line (10, 12)-(10, 0) '画中间线
Str1 = JiSuan(Strr)
Str2 = JS2(Strr)
Str3 = JSS(Str1)
Picture1.DrawStyle = 0
For i = 0 To 12 '
j = Val(Mid(Str1, i * 2 + 1, 2))
t = Val(Mid(Str1, i * 2 + 3, 2))
LabTA(i).Caption = j
Picture1.Line (j, 12 - i)-(t, 11 - i), vbRed '绘制性向累计分数图
j = Val(Mid(Str2, i + 1, 1))
t = Val(Mid(Str2, i + 2, 1))
LabTT(i).Caption = j
Picture1.Line (j, 12 - i)-(t, 11 - i), vbBlue '绘制不知道个数图
j = Val(Mid(Str3, i + 1, 1))
t = Val(Mid(Str3, i + 2, 1))
LabTB(i).Caption = j
Picture1.Line (j, 12 - i)-(t, 11 - i), vbGreen '绘制性向图
LabTT(i).Top = Label5(i).Top: LabTT(i).Left = 9150 '数值排列
LabTA(i).Top = Label5(i).Top: LabTA(i).Left = 9360
LabTB(i).Top = Label5(i).Top: LabTB(i).Left = 9630
Next
End Sub
Private Sub FFF() '查找
Dim SSS As String '查找已登记人员
List1.Clear
If Rs1.BOF And Rs1.EOF Then MsgBox "当前没有人员记录 ", vbInformation: Exit Sub
Rs1.MoveFirst
While Not Rs1.EOF
SSS = " "
SSS = SSS & My_Format(Rs1.Fields(0).Value, 16)
If IsNull(Rs1.Fields(1).Value) Then
SSS = SSS & Space(6)
Else
SSS = SSS & My_Format(Rs1.Fields(1).Value, 6)
End If
If IsNull(Rs1.Fields(2).Value) Then
SSS = SSS & Space(8)
Else
SSS = SSS & My_Format(Rs1.Fields(2).Value, 8)
End If
If IsNull(Rs1.Fields(3).Value) Then
SSS = SSS & Space(16)
Else
SSS = SSS & My_Format(Rs1.Fields(3).Value, 16)
End If
If IsNull(Rs1.Fields(4).Value) Then
SSS = SSS & Space(22)
Else
SSS = SSS & My_Format(Rs1.Fields(4).Value, 22)
End If
SSS = SSS & Rs1.Fields(5).Value
Rs1.MoveNext
List1.AddItem SSS
Wend
FamF.ZOrder
End Sub
Private Sub Form_Unload(Cancel As Integer)
Rs1.Close
Set Rs1 = Nothing
Conn.Close
Set Conn = Nothing
End Sub
Private Sub HKD1_MouseUp(ByVal Button As Integer, ByVal Shift As Integer) '开始测试
Text1(5).Text = Date
Frame2.Visible = False
Frame1.ZOrder
End Sub
Private Sub HKD10_MouseUp(ByVal Button As Integer, ByVal Shift As Integer) '删除记录
If List1.ListIndex < 0 Then MsgBox "请选定记录 ", vbInformation: Exit Sub
Rs1.AbsolutePosition = List1.ListIndex + 1
Rs1.Delete
List1.Clear
Call FFF
End Sub
Private Sub HKD11_MouseUp(ByVal Button As Integer, ByVal Shift As Integer) '退出
Unload Me
End Sub
Private Sub HKD12_MouseUp(ByVal Button As Integer, ByVal Shift As Integer)
If List1.ListIndex < 0 Then MsgBox "请选定记录 ", vbInformation: Exit Sub
Rs1.AbsolutePosition = List1.ListIndex + 1
Form4.Show 1
End Sub
Private Sub HKD2_MouseUp(ByVal Button As Integer, ByVal Shift As Integer) '显示结果
Call CSJG
End Sub
Private Sub HKD3_MouseUp(ByVal Button As Integer, ByVal Shift As Integer) '查询
Frame2.Visible = False
Call FFF
End Sub
Private Sub HKD4_MouseUp(ByVal Button As Integer, ByVal Shift As Integer) '显示性向图
If StrJG = "" Then
MsgBox "请选定人员 ", vbInformation
Call FFF
Exit Sub
End If
Frame2.Visible = False
Frame3.Visible = True
Frame3.ZOrder
Call CmdXX
End Sub
Private Sub HKD5_MouseUp(ByVal Button As Integer, ByVal Shift As Integer) '打印及预览
If StrJG = "" Then MsgBox "请选定人员 ", vbInformation: Exit Sub
Form2.Show 1
End Sub
Private Sub HKD6_MouseUp(ByVal Button As Integer, ByVal Shift As Integer) '帮助
MsgBox "请参阅ReadMe文件 ", vbInformation
End Sub
Private Sub HKD7_MouseUp(ByVal Button As Integer, ByVal Shift As Integer) '测试
Dim i As Long
Dim StrA As String
Dim StrB As String
Dim StrC As String
If Option1.Value Then
main.Show 1
Else
Form3.Show 1
End If
End Sub
Private Sub HKD8_MouseUp(ByVal Button As Integer, ByVal Shift As Integer)
Unload Me
End Sub
Private Sub HKD9_MouseUp(ByVal Button As Integer, ByVal Shift As Integer) '查找结果
If Text3.Text = "" Then FFF: Exit Sub
Rs1.MoveFirst
Rs1.Find "usern='" & Trim(Text3.Text) & "'"
If Rs1.EOF Then
List1.ListIndex = -1
StrJG = ""
MsgBox "查无此人，请重新输入！ ", vbExclamation
Text3.SelStart = 0
Text3.SelLength = Len(Text3.Text)
Text3.SetFocus
Else
List1.ListIndex = Rs1.AbsolutePosition - 1
End If
End Sub
Private Sub List1_Click()
If List1.ListIndex < 0 Then Exit Sub
Rs1.MoveFirst
Rs1.Move List1.ListIndex
UserN = Rs1.Fields(0)
UserS = ""
UserA = ""
UserL = ""
UserD = ""
UserT = ""
StrJG = ""
UserDC = ""
UserCC = ""
If Not IsNull(Rs1.Fields(1).Value) Then UserS = Rs1.Fields(1)
If Not IsNull(Rs1.Fields(2).Value) Then UserA = Rs1.Fields(2)
If Not IsNull(Rs1.Fields(3).Value) Then UserL = Rs1.Fields(3)
If Not IsNull(Rs1.Fields(4).Value) Then UserD = Rs1.Fields(4)
If Not IsNull(Rs1.Fields(5).Value) Then UserT = Rs1.Fields(5)
If Not IsNull(Rs1.Fields(6).Value) Then StrJG = Rs1.Fields(6)
If Not IsNull(Rs1.Fields(7).Value) Then UserCC = Rs1.Fields(7)
If Not IsNull(Rs1.Fields(8).Value) Then UserDC = Rs1.Fields(8)
End Sub
Private Sub List1_DblClick()
Call CSJG
End Sub
Private Sub Picture1_Paint()
If StrJG <> "" Then Call CmdXX
End Sub
Private Sub Text1_Change(Index As Integer)
If Text1(0).Text = "" Then
HKD7.Enabled = False
Else
HKD7.Enabled = True
End If
End Sub
Private Sub Form_Load()
Dim i, j As Long
Dim t As Long
If App.PrevInstance Then MsgBox "程序已经运行 ", vbInformation: End
Dim ConnStr
ConnStr = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & App.Path & "\DATA.mdb"
Conn.Open ConnStr
Rs1.Open "select * from user1", Conn, 3, 3
Text1(5).Text = Date
For i = 0 To 4
For j = 1 To 3
t = i * 3 + j
Load LabJG(t)
LabJG(t).Caption = t
LabJG(t).Top = i * 200 + 300
LabJG(t).Left = j * 3000 - 2500
LabJG(t).Visible = True
Next
Next
Me.Caption = "工作性向测试系统"
HKD1.Caption = "开始测试"
HKD2.Caption = "结果"
HKD3.Caption = "查询"
HKD4.Caption = "性向图"
HKD5.Caption = "打印"
HKD6.Caption = "帮助"
HKD7.Caption = "测 试"
HKD8.Caption = "退 出"
HKD9.Caption = "查 询"
HKD10.Caption = "删 除"
HKD11.Caption = "退出"
HKD12.Caption = "更 改"
Frame4.Caption = "说明"
Frame5.Caption = "性向判定"
Option1.Caption = "电脑答题"
Option2.Caption = "手工输入"
Label3.Caption = "性 向 测 试 系 统 VER1.2"
Label1(0).Caption = "姓 名："
Label1(1).Caption = "性 别："
Label1(2).Caption = "年 龄："
Label1(3).Caption = "工作类别："
Label1(4).Caption = "单 位："
Label1(5).Caption = "实施日："
Label2.Caption = " 欢迎使用由武汉智囊团管理顾问有限公司专门开发的性格能力测验系统!本系统用于对员工性向进行分析总结,能够测试出员工的性向走势,改善员工的工作方法,起到很好的效果,此版本为试用版.首先请输入您的信息。"
Label4(0).Caption = "姓 名"
Label4(1).Caption = "性 别"
Label4(2).Caption = "年 龄"
Label4(3).Caption = "工作类别："
Label4(4).Caption = "测试日期："
Label4(5).Caption = "单 位："
Label4(6).Caption = "长 处："
Label4(7).Caption = "短 处："
Label5(0).Caption = "(1)思考性"
Label5(1).Caption = "(2)共鸣性"
Label5(2).Caption = "(3)自律性"
Label5(3).Caption = "(4)活动性"
Label5(4).Caption = "(5)指导性"
Label5(5).Caption = "(6)社交性"
Label5(6).Caption = "(7)创造性"
Label5(7).Caption = "(8)成就性"
Label5(8).Caption = "(9)变易性"
Label5(9).Caption = "(10)抑郁性"
Label5(10).Caption = "(11)神经质"
Label5(11).Caption = "(12)自卑感"
Label5(12).Caption = "(13)虚构性"
Label6.Caption = "说明：蓝色表示回答“不知道”数目，红色代表累计分数，绿色代表性向。"
Label7(0).Caption = "姓 名"
Label7(1).Caption = "年 龄"
Label7(2).Caption = "性 别"
Label7(3).Caption = "工作类别"
Label7(4).Caption = "单 位"
Label7(5).Caption = "应征日期"
Label8.Caption = "请输入姓名："
End Sub
Private Sub Picture2_Paint()
If StrJG <> "" Then Call CSJG
End Sub
Private Sub Text1_KeyPress(Index As Integer, KeyAscii As Integer)
If Index = 2 Then
If InStr("0123456789" + Chr(8) + Chr(22), Chr(KeyAscii)) = 0 Then KeyAscii = 0
End If
End Sub
Public Sub CSJG() '测试结果函数
Dim i, j As Long
Dim Sum As Long
Dim t As Long
Dim TmpStr As String
Dim RsA As New ADODB.Recordset
Dim Strr As String
Dim Str1 As String
Dim Str2 As String
Dim Str3 As String
Dim Str4 As String
Strr = StrJG
If Strr = "" Then
Frame2.Visible = False
Call FFF
MsgBox "请选定人员 ", vbInformation
Exit Sub
End If
Frame3.Visible = False
Frame2.Visible = True
Frame2.ZOrder
LabN.Caption = UserN
LabS.Caption = UserS
LabA.Caption = UserA
LabL.Caption = UserL
LabD.Caption = UserD
LabT.Caption = UserT
Text2.Text = UserCC
Text4.Text = UserDC
Picture2.Cls
DoEvents
Picture2.Print
Picture2.Font = "宋体"
Picture2.Font.Size = 10
t = Len(Strr)
For j = 1 To 13
For i = j To t Step 13
Str2 = Mid(Strr, i, 1)
Select Case Str2
Case "0"
If i < 92 Then
Str3 = "-"
Else
Str3 = "+"
End If
Case "1": Str3 = "\"
Case "2"
If i < 92 Then
Str3 = "+"
Else
Str3 = "-"
End If
End Select
Str4 = Str4 + Format(i, "000") + "[" + Str3 + "] "
Next
Picture2.Print " " + Str4
Str4 = ""
Next
Str4 = JiSuan(Strr)
Str1 = JSS(Str4)
RsA.Open "select * from xx1", Conn, 1, 1
For i = 1 To 13
LabJG(i).Caption = RsA.Fields(0).Value + "：" + RsA.Fields(Val(Mid(Str1, i, 1))).Value
RsA.MoveNext
Next
RsA.Close
LabJG(14).Caption = " ＊＊＊＊＊ "
If Val(Mid(Str4, 1, 2)) > Val(Mid(Str1, 7, 2)) + 5 Then LabJG(14).Caption = "<深思缓慢的>"
If Val(Mid(Str4, 7, 2)) > Val(Mid(Str1, 1, 2)) + 5 Then LabJG(14).Caption = "<冲动快速的>"
Sum = 0
Str2 = JS2(Strr)
For i = 1 To Len(Str2)
If Mid(Str2, i, 1) = "1" Then Sum = Sum + 1
Next
LabJG(15).Caption = " ＊＊＊＊＊ "
If Sum > 25 Then LabJG(15).Caption = "<优柔寡断的>"
If Sum > 45 Then LabJG(15).Caption = "<缺决断力的>"
Sum = ZH(Str1)
If Sum > 17 And Sum < 19 Then TmpStr = "劣 [C-]": GoTo ExitAA
If Sum > 18 And Sum < 25 Then TmpStr = "差 [C]": GoTo ExitAA
If Sum > 24 And Sum < 31 Then TmpStr = "普通下位 [B-]": GoTo ExitAA
If Sum > 30 And Sum < 37 Then TmpStr = "普通 [B]": GoTo ExitAA
If Sum > 36 And Sum < 43 Then TmpStr = "普通上位 [B+]": GoTo ExitAA
If Sum > 42 And Sum < 49 Then TmpStr = "良 [A]": GoTo ExitAA
If Sum > 48 Then TmpStr = "优 [A+]": GoTo ExitAA
TmpStr = "NO"
ExitAA:
LabZH(0).Caption = "综合评定： " + TmpStr
LabZH(1).Caption = "得分：" & Sum
End Sub
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -