问卷调查统计程序代码更新

继续复制粘贴。
继续On Error Resume Next。
继续堆垃圾。
继续修正各种臭虫。
继续使用某种情况下会不稳定的设计方案。

'Current: 1 to 17, integer
'What's special:
'3 - TextBox - input a integer
'5, 7, 8, 9, 10, 11 - MultiSelect - max 3 selections
Dim Current As Integer
Dim CurrentN As Integer
Dim CountC As Integer
'
Dim Sel(1 To 17, 1 To 11) As CheckBox
Dim SelA(1 To 17, 1 To 11, 1 To 300) As Boolean '全部问卷
Dim SelS(1 To 17, 1 To 11) As Integer '总体统计用
Dim SelSt(1 To 17, 1 To 11) As Integer '分类统计用
Dim SelName(1 To 17, 1 To 11) As String '记录选项名称

Sub Sel_Click()
Debug.Print "C"
End Sub

Sub BuildReport()
' 'On Error GoTo Err1
' On Error Resume Next
' Text1.Text = ""
' Dim iI As Integer, iJ As Integer
' For iJ = 1 To 17
' For iI = 1 To 11
' Text1.Text = Text1.Text & " " & SelS(iJ, iI)
' Sel(iJ, iI).Caption = SelS(iJ, iI)
''Err1:
' Next
' Text1.Text = Text1.Text & Chr(13) & Chr(10)
' Next
End Sub

Sub LoadA(LNum As Integer)
On Error Resume Next
CurrentN = LNum
Dim iI As Integer, iJ As Integer
For iI = 1 To 11
For iJ = 1 To 17
If SelA(iJ, iI, LNum) = True Then
Sel(iJ, iI).Value = 1
Else
Sel(iJ, iI).Value = 0
End If
Next
Next
End Sub

Sub SaveA()
On Error Resume Next
Dim iI As Integer, iJ As Integer
For iI = 1 To 11
For iJ = 1 To 17
SelA(iJ, iI, CurrentN) = Sel(iJ, iI).Value
If Sel(iJ, iI).Value = 1 Then
SelS(iJ, iI) = SelS(iJ, iI) + 1
End If
Next
Next
End Sub

Sub SSelC()
Select Case Current
Case 4:
SSel.Top = Label1(0).Top
Case 5:
SSel.Top = Label1(1).Top
Case 6:
SSel.Top = Label1(2).Top
Case 7:
SSel.Top = Label1(3).Top
Case 8:
SSel.Top = Label1(4).Top
Case 9:
SSel.Top = Label1(5).Top
Case 10:
SSel.Top = Label1(6).Top
Case 11:
SSel.Top = Label1(7).Top
Case 12:
SSel.Top = Label1(8).Top
Case 13 To 17:
SSel.Top = Label1(9).Top
Case Else
SSel.Top = 0
End Select
End Sub

Private Sub A_MouseDown(Index As Integer, Button As Integer, Shift As Integer, X As Single, Y As Single)
SaveAD
End Sub

Private Sub B_MouseDown(Index As Integer, Button As Integer, Shift As Integer, X As Single, Y As Single)
SaveAD
End Sub

Private Sub C_MouseDown(Index As Integer, Button As Integer, Shift As Integer, X As Single, Y As Single)
SaveAD
End Sub

Private Sub Command1_Click()
' BuildReport
On Error Resume Next
Dim iI As Integer, iJ As Integer, iK As Integer
'统计
For iI = 1 To 17
For iJ = 1 To 11
SelSt(iI, iJ) = 0
Next
Next
For iK = 1 To 300
For iI = 1 To 17
For iJ = 1 To 11
If SelA(iI, iJ, iK) = True Then SelSt(iI, iJ) = SelSt(iI, iJ) + 1
Next
Next
Next
'显示
For iJ = 1 To 17
For iI = 1 To 11
Text1.Text = Text1.Text & " " & SelSt(iJ, iI)
Sel(iJ, iI).Caption = SelSt(iJ, iI)
Next
Text1.Text = Text1.Text & Chr(13) & Chr(10)
Next
End Sub

'based on sex
Private Sub Command2_Click(Index As Integer)
On Error Resume Next
Dim iI As Integer, iJ As Integer, iK As Integer
'统计
For iI = 1 To 17
For iJ = 1 To 11
SelSt(iI, iJ) = 0
Next
Next
For iK = 1 To 300
If SelA(1, Index + 1, iK) = True Then
For iI = 1 To 17
For iJ = 1 To 11
If SelA(iI, iJ, iK) = True Then SelSt(iI, iJ) = SelSt(iI, iJ) + 1
Next
Next
End If
Next
'显示
For iJ = 1 To 17
For iI = 1 To 11
Text1.Text = Text1.Text & " " & SelSt(iJ, iI)
Sel(iJ, iI).Caption = SelSt(iJ, iI)
Next
Text1.Text = Text1.Text & Chr(13) & Chr(10)
Next
End Sub

Private Sub Command3_Click(Index As Integer)
On Error Resume Next
Dim iI As Integer, iJ As Integer, iK As Integer
'统计
For iI = 1 To 17
For iJ = 1 To 11
SelSt(iI, iJ) = 0
Next
Next
For iK = 1 To 300
If SelA(2, Index + 1, iK) = True Then
For iI = 1 To 17
For iJ = 1 To 11
If SelA(iI, iJ, iK) = True Then SelSt(iI, iJ) = SelSt(iI, iJ) + 1
Next
Next
End If
Next
'显示
For iJ = 1 To 17
For iI = 1 To 11
Text1.Text = Text1.Text & " " & SelSt(iJ, iI)
Sel(iJ, iI).Caption = SelSt(iJ, iI)
Next
Text1.Text = Text1.Text & Chr(13) & Chr(10)
Next
End Sub

Private Sub Command4_Click(Index As Integer)
On Error Resume Next
Dim iI As Integer, iJ As Integer, iK As Integer
'统计
For iI = 1 To 17
For iJ = 1 To 11
SelSt(iI, iJ) = 0
Next
Next
For iK = 1 To 300
If SelA(3, Index + 1, iK) = True Then
For iI = 1 To 17
For iJ = 1 To 11
If SelA(iI, iJ, iK) = True Then SelSt(iI, iJ) = SelSt(iI, iJ) + 1
Next
Next
End If
Next
'显示
For iJ = 1 To 17
For iI = 1 To 11
Text1.Text = Text1.Text & " " & SelSt(iJ, iI)
Sel(iJ, iI).Caption = SelSt(iJ, iI)
Next
Text1.Text = Text1.Text & Chr(13) & Chr(10)
Next
End Sub

Private Sub Command5_Click()
On Error Resume Next
Dim iI As Integer, iJ As Integer
For iI = 1 To 17
For iJ = 1 To 11
Sel(iI, iJ).Caption = SelName(iI, iJ)
Next
Next
End Sub
Sub SaveFile(FileN As String)
LStat.Caption = "开始保存……"
DoEvents
SaveA
'write these items:
'Dim Current As Integer
'Dim CurrentN As Integer
'Dim CountC As Integer
' x Dim Sel(1 To 17, 1 To 11) As CheckBox
'Dim SelA(1 To 17, 1 To 11, 1 To 300) As Boolean '全部问卷
'Dim SelS(1 To 17, 1 To 11) As Integer '总体统计用
' x Dim SelSt(1 To 17, 1 To 11) As Integer '分类统计用
' x Dim SelName(1 To 17, 1 To 11) As String '记录选项名称
Open App.Path & "\" & FileN For Output As #1
Write #1, Current, CurrentN, CountC
Dim iI As Integer, iJ As Integer, iK As Integer
For iK = 1 To 300
For iI = 1 To 17
For iJ = 1 To 11
Write #1, SelA(iI, iJ, iK)
Next
Next
Next
For iI = 1 To 17
For iJ = 1 To 11
Write #1, SelS(iI, iJ)
Next
Next
Close #1
LStat.Caption = "保存完毕"

End Sub

Private Sub Command6_Click()
SaveFile "dat.txt"
End Sub

Private Sub Command7_Click()
LStat.Caption = "开始读取"
DoEvents
'read these items:
'Dim Current As Integer
'Dim CurrentN As Integer
'Dim CountC As Integer
' x Dim Sel(1 To 17, 1 To 11) As CheckBox
'Dim SelA(1 To 17, 1 To 11, 1 To 300) As Boolean '全部问卷
'Dim SelS(1 To 17, 1 To 11) As Integer '总体统计用
' x Dim SelSt(1 To 17, 1 To 11) As Integer '分类统计用
' x Dim SelName(1 To 17, 1 To 11) As String '记录选项名称
Dim Tmp
Open App.Path & "\dat.txt" For Input As #2
Input #2, Current, CurrentN, CountC
Dim iI As Integer, iJ As Integer, iK As Integer
For iK = 1 To 300
For iI = 1 To 17
For iJ = 1 To 11
Input #2, Tmp
SelA(iI, iJ, iK) = Tmp
Next
Next
Next
For iI = 1 To 17
For iJ = 1 To 11
Input #2, Tmp
SelS(iI, iJ) = Tmp
Next
Next
Close #2
LoadA CurrentN
SSelC
LStat = "读取完毕"
End Sub

Private Sub Command8_Click()
SaveA
Dim Pg As Integer
Pg = Val(Text2.Text)
If Pg < 1 Or Pg > 300 Then Exit Sub
Current = Pg
SSel.Top = 0
Current = 1
CountC = 0
LoadA Pg
End Sub

Private Sub Command9_Click()
If MsgBox("确认清空报表数据？", vbYesNo, "确认清空") = vbYes Then
Text1.Text = ""
End If
End Sub

Private Sub D_MouseDown(Index As Integer, Button As Integer, Shift As Integer, X As Single, Y As Single)
SaveAD
End Sub

Private Sub E_MouseDown(Index As Integer, Button As Integer, Shift As Integer, X As Single, Y As Single)
SaveAD
End Sub

Private Sub F_MouseDown(Index As Integer, Button As Integer, Shift As Integer, X As Single, Y As Single)
SaveAD
End Sub

Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer)
LStat.Caption = "调试信息 问卷：" & CurrentN & " 当前选项：" & Current & " 当前副选项：" & CountC + 1
Dim kK As Integer
'撤消
If KeyCode = 38 Then
CountC = 0
If Current >= 2 Then Current = Current - 1
SSelC
Exit Sub
End If
'特殊判别
If KeyCode = 110 Then '.
kK = 11
ElseIf KeyCode = 96 Then '0
kK = 10
ElseIf KeyCode >= 97 And KeyCode <= 97 + 8 Then
kK = KeyCode - 97 + 1
Else
Exit Sub
End If
'If Current = 3 Then
' T.Text = Chr(KeyCode)
' Current = Current + 1
' SSelC
' Exit Sub
'End If
On Error GoTo Err1
Sel(Current, kK).Value = 1 'Checked
'MultiSelect
Select Case Current
Case 5, 7, 8, 9, 10, 11:
If CountC >= 2 Then
CountC = 0
Current = Current + 1
Else
CountC = CountC + 1
End If
Case Else
Current = Current + 1
End Select
'Finish
If Current > 17 Then
Current = 1
SaveA
CurrentN = CurrentN + 1
LoadA CurrentN
End If
SSelC
Exit Sub
Err1:
MsgBox "Error", vbOKOnly, "Error"
End Sub

Private Sub Form_Load()
On Error Resume Next
Dim iI As Integer, iJ As Integer
For iI = 1 To 11
Set Sel(1, iI) = A(iI - 1)
Set Sel(2, iI) = B(iI - 1)
Set Sel(3, iI) = T(iI - 1)
Set Sel(4, iI) = C(iI - 1)
Set Sel(5, iI) = D(iI - 1)
Set Sel(6, iI) = E(iI - 1)
Set Sel(7, iI) = F(iI - 1)
Set Sel(8, iI) = G(iI - 1)
Set Sel(9, iI) = H(iI - 1)
Set Sel(10, iI) = I(iI - 1)
Set Sel(11, iI) = J(iI - 1)
Set Sel(12, iI) = K(iI - 1)
Set Sel(13, iI) = L(iI - 1)
Set Sel(14, iI) = M(iI - 1)
Set Sel(15, iI) = N(iI - 1)
Set Sel(16, iI) = O(iI - 1)
Set Sel(17, iI) = P(iI - 1)
Next
'back up items
For iI = 1 To 17
For iJ = 1 To 11
SelName(iI, iJ) = Sel(iI, iJ).Caption
Next
Next
CurrentN = 1
Current = 1
End Sub

Private Sub Form_Unload(Cancel As Integer)
SaveAD
SaveFile "E " & Year(Date) & "." & Month(Date) & "." & Day(Date) & " " & Hour(Time) & "." & Minute(Time) & ".txt"
End Sub

Private Sub G_MouseDown(Index As Integer, Button As Integer, Shift As Integer, X As Single, Y As Single)
SaveAD
End Sub

Private Sub H_MouseDown(Index As Integer, Button As Integer, Shift As Integer, X As Single, Y As Single)
SaveAD
End Sub

Private Sub I_MouseDown(Index As Integer, Button As Integer, Shift As Integer, X As Single, Y As Single)
SaveAD
End Sub

Private Sub J_MouseDown(Index As Integer, Button As Integer, Shift As Integer, X As Single, Y As Single)
SaveAD
End Sub

Private Sub K_MouseDown(Index As Integer, Button As Integer, Shift As Integer, X As Single, Y As Single)
SaveAD
End Sub

Private Sub L_MouseDown(Index As Integer, Button As Integer, Shift As Integer, X As Single, Y As Single)
SaveAD
End Sub

Private Sub M_MouseDown(Index As Integer, Button As Integer, Shift As Integer, X As Single, Y As Single)
SaveAD
End Sub

Private Sub N_MouseDown(Index As Integer, Button As Integer, Shift As Integer, X As Single, Y As Single)
SaveAD
End Sub

Private Sub O_MouseDown(Index As Integer, Button As Integer, Shift As Integer, X As Single, Y As Single)
SaveAD
End Sub

Private Sub P_MouseDown(Index As Integer, Button As Integer, Shift As Integer, X As Single, Y As Single)
SaveAD
End Sub

Private Sub Paper_KeyDown(KeyCode As Integer, Shift As Integer)
Form_KeyDown KeyCode, Shift
End Sub

Private Sub Paper_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
LStat.Caption = "调试信息 问卷：" & CurrentN & " 当前选项：" & Current & " 当前副选项：" & CountC + 1
End Sub


Private Sub T_MouseDown(Index As Integer, Button As Integer, Shift As Integer, X As Single, Y As Single)
SaveAD
End Sub

Private Sub Timer1_Timer()
LT.Caption = Val(LT.Caption) - 1
If Val(LT.Caption) = 0 Then
SaveA
SaveFile Year(Date) & "." & Month(Date) & "." & Day(Date) & " " & Hour(Time) & "." & Minute(Time) & ".txt"
LT.Caption = "10"
End If
End Sub

Sub SaveAD()
TT.Enabled = True
End Sub

Private Sub TT_Timer()
SaveA
TT.Enabled = False
End Sub