欢迎访问infoheader的Blog——年华似水浪淘沙
E-mail：infoheader@gmail.com
GTalk：infoheader@gmail.com
来自fanfou：
显示标签为“VB”的博文。显示所有博文
显示标签为“VB”的博文。显示所有博文

2009年3月31日星期二

VB俄罗斯方块



  1. Const WidthCount As Integer = 10

  2. Const HeightCount As Integer = 20

  3. '"ttttffffffffffff"

  4. '"ttffttffffffffff"

  5. '"tttfftffffffffff"

  6. '"ttfffttfffffffff"

  7. '"tttftftfffffffff"

  8. 'Dim BlockS(1 To 10) As String

  9. Const BlockSCount As Integer = 8


  10. Dim Block(1 To 10, 1 To 4, 1 To 4, 1 To 4) As Boolean


  11. Dim P As PictureBox


  12. Dim B() As Integer

  13. Dim PosX As Integer

  14. Dim PosY As Integer

  15. Dim CurrentBlock As Integer

  16. Dim CurrentTurn As Integer


  17. Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer)

  18.     If KeyCode = vbKeyReturn Then

  19.         ReStart

  20.         Exit Sub

  21.     End If

  22.     If Timer1.Enabled Then

  23.         If KeyCode = vbKeyLeft And PosX > 0 Then

  24.             If Not CheckSet(PosX - 1, PosY) Then

  25.                 PosX = PosX - 1

  26.             End If

  27.         ElseIf KeyCode = vbKeyRight And PosX < WidthCount - GetBlockWidth(CurrentBlock) Then

  28.             If Not CheckSet(PosX + 1, PosY) Then

  29.                 PosX = PosX + 1

  30.             End If

  31.         ElseIf KeyCode = vbKeyUp Then

  32.             TurnBlock

  33.         ElseIf KeyCode = vbKeyDown Then

  34.     '        Do

  35.     '            If CheckSet(PosX, PosY + 1) Then

  36.     '                SetBlock

  37.     '                CheckDecrease

  38.     '                NextBlock

  39.     '                Exit Do

  40.     '            Else

  41.     '                PosY = PosY + 1

  42.     '                Draw

  43.     '            End If

  44.     '        Loop

  45.             Timer1_Timer

  46.             Timer1.Interval = 20

  47.         End If

  48.         Draw

  49.     End If

  50. End Sub


  51. Private Sub Form_KeyUp(KeyCode As Integer, Shift As Integer)

  52.     Timer1.Interval = 200

  53. End Sub


  54. Private Sub Form_Load()

  55.     Set P = Picture1

  56.     P.AutoRedraw = True

  57.     Inti

  58.     Me.Show

  59.     Draw

  60. End Sub


  61. Private Sub TurnBlock()

  62.     CurrentTurn = CurrentTurn + 1

  63.     If CurrentTurn = 5 Then CurrentTurn = 1

  64.     If PosX + GetBlockWidth(CurrentBlock) > WidthCount Then

  65.         CurrentTurn = CurrentTurn - 1

  66.         If CurrentTurn = 0 Then CurrentTurn = 4

  67.     ElseIf CheckSet(PosX, PosY) Then

  68.         CurrentTurn = CurrentTurn - 1

  69.         If CurrentTurn = 0 Then CurrentTurn = 4

  70.     End If

  71. End Sub


  72. Private Sub CheckDecrease()

  73.     Dim I As Integer, J As Integer, M As Integer

  74.     For J = 1 To HeightCount

  75.         For I = 1 To WidthCount

  76.             If B(I, J) = 0 Then GoTo Lab1

  77.         Next

  78.         For M = J To 2 Step -1

  79.             For I = 1 To WidthCount

  80.                 B(I, M) = B(I, M - 1)

  81.             Next

  82.         Next

  83.         For I = 1 To WidthCount

  84.             B(I, 1) = 0

  85.         Next

  86. Lab1:

  87.     Next

  88. End Sub


  89. Private Function GetBlockWidth(BlockID As Integer) As Integer

  90.     Dim I As Integer, J As Integer

  91.     Dim Temp As Integer

  92.     Temp = 0

  93.     For J = 1 To 4

  94.         For I = 1 To 4

  95.             If Block(BlockID, I, J, CurrentTurn) Then

  96.                 If I > Temp Then Temp = I

  97.             End If

  98.         Next

  99.     Next

  100.     GetBlockWidth = Temp

  101. End Function


  102. Private Function CheckSet(pX As Integer, pY As Integer) As Boolean

  103.     Dim I As Integer, J As Integer

  104.     For J = 1 To 4

  105.         For I = 1 To 4

  106.             If Block(CurrentBlock, I, J, CurrentTurn) Then

  107.                 If pY + J > HeightCount Then

  108.                     CheckSet = True

  109.                     Exit Function

  110.                 ElseIf B(pX + I, pY + J) <> 0 Then

  111.                     CheckSet = True

  112.                     Exit Function

  113.                 End If

  114.             End If

  115.         Next

  116.     Next

  117.     CheckSet = False

  118. End Function


  119. Private Sub SetBlock()

  120.     On Error Resume Next

  121.     Dim I As Integer, J As Integer

  122.     For J = 1 To 4

  123.         For I = 1 To 4

  124.             If Block(CurrentBlock, I, J, CurrentTurn) Then

  125.                 B(PosX + I, PosY + J) = 2

  126.             End If

  127.         Next

  128.     Next

  129. End Sub


  130. Private Sub NextBlock()

  131.     Randomize

  132.     CurrentBlock = Int(Rnd() * BlockSCount + 1)

  133.     CurrentTurn = Int(Rnd() * 4 + 1)

  134.     PosX = Int((WidthCount - GetBlockWidth(CurrentBlock)) / 2)

  135.     PosY = 0

  136.     If CheckSet(PosX, PosY) Then

  137.         'Game Over

  138.         Timer1.Enabled = False

  139.         Draw

  140.     Else

  141.         Draw

  142.     End If

  143. End Sub


  144. Private Sub Inti()

  145.     Dim BlockS()

  146.     ReDim BlockS(1 To BlockSCount)

  147.     BlockS(1) = "tttt............t...t...t...t...tttt............t...t...t...t..."

  148.     BlockS(2) = "tt...tt..........t..tt..t.......tt...tt..........t..tt..t......."

  149.     BlockS(3) = "ttt..t..........t...tt..t........t..ttt..........t..tt...t......"

  150.     BlockS(4) = "tt..tt..........tt..tt..........tt..tt..........tt..tt.........."

  151.     BlockS(5) = "t...tt...t.......tt.tt..........t...tt...t.......tt.tt.........."

  152.     BlockS(6) = "ttt.t.t.........tt..t...tt......t.t.ttt.........tt...t..tt......"

  153.     BlockS(7) = "t...ttt...t......tt..t..tt......t...ttt...t......tt..t..tt......"

  154.     BlockS(8) = "t.t.....t.t.....t.t..t..t.t..........t..t.t......t..ttt..t......"

  155.     ReDim B(1 To WidthCount, 1 To HeightCount)

  156.     P.ScaleWidth = WidthCount

  157.     P.ScaleHeight = HeightCount

  158.     Dim I As Integer, J As Integer, H As Integer, G As Integer

  159.     For G = 1 To BlockSCount

  160.         For H = 1 To 4

  161.             For I = 1 To 4

  162.                 For J = 1 To 4

  163.                     Debug.Print (H - 1) * 16 + (J - 1) * 4 + I

  164.                     If Mid(BlockS(G), (H - 1) * 16 + (J - 1) * 4 + I, 1) = "t" Then

  165.                         Block(G, I, J, H) = True

  166.                     Else

  167.                         Block(G, I, J, H) = False

  168.                     End If

  169.                 Next

  170.             Next

  171.         Next

  172.     Next

  173.     ReStart

  174. End Sub


  175. Private Sub ReStart()

  176.     Dim I As Integer, J As Integer

  177.     For J = 1 To HeightCount

  178.         For I = 1 To WidthCount

  179.             B(I, J) = 0

  180.         Next

  181.     Next

  182.     Draw

  183.     Timer1.Enabled = True

  184.     NextBlock

  185. End Sub


  186. Private Sub Draw()

  187.     On Error Resume Next

  188.     Dim I As Integer, J As Integer

  189.     For J = 1 To HeightCount

  190.         For I = 1 To WidthCount

  191.             Select Case B(I, J)

  192.                 Case 0:

  193.                     P.Line (I - 1, J - 1)-(I, J), vbBlack, BF

  194.                 Case 1:

  195.                     P.Line (I - 1, J - 1)-(I, J), vbGreen, BF

  196.                 Case 2:

  197.                     P.Line (I - 1, J - 1)-(I, J), vbRed, BF

  198.             End Select

  199.         Next

  200.     Next

  201.     For J = 1 To 4

  202.         For I = 1 To 4

  203.             If Block(CurrentBlock, I, J, CurrentTurn) Then

  204.                 P.Line (PosX + I - 1, PosY + J - 1)-(PosX + I, PosY + J), vbGreen, BF

  205.             End If

  206.         Next

  207.     Next

  208. End Sub


  209. Private Sub Picture1_KeyDown(KeyCode As Integer, Shift As Integer)

  210.     Form_KeyDown KeyCode, Shift

  211. End Sub


  212. Private Sub Picture1_KeyUp(KeyCode As Integer, Shift As Integer)

  213.     Form_KeyUp KeyCode, Shift

  214. End Sub


  215. Private Sub Timer1_Timer()

  216.     If CheckSet(PosX, PosY + 1) Then

  217.         SetBlock

  218.         CheckDecrease

  219.         NextBlock

  220.     Else

  221.         PosY = PosY + 1

  222.         Draw

  223.     End If

  224. End Sub
发帖者 时间： 2 条评论:
标签： ,

2008年12月30日星期二

VB表达式计算函数（修正1）

有问题请联系我。
感谢Aegisys[0GiNr]发现未检查减法运算的错误
感谢iceboy发现小数识别的错误

'函数：Calc(Exp As String) As Double
'用于计算包含括号、四则运算的字符串表达式

'infoheader版权所有，转载、使用请注明出处
'Blog：infoheader.blogspot.com
'E-mail：infoheader@gmail.com
'仅供技术交流使用，严禁用于商业用途

'叠代深度（调试用）
'Public Deep As Integer

Public CalcErr As String

Public Function Calc(ByVal Exp As String) As Double
    CalcErr = ""
    '去空格
    Exp = Replace(Exp, " ", "")
    '去掉最外括号
    While Left(Exp, 1) = "(" And Right(Exp, 1) = ")"
        Exp = Mid(Exp, 2, Len(Exp) - 2)
    Wend
    '括号配对检查
    Dim I As Integer, CountL As Integer, CountR As Integer, Chr As String
    For I = 1 To Len(Exp)
        Chr = Mid(Exp, I, 1)
        If Chr = "(" Then
            CountL = CountL + 1
        ElseIf Chr = ")" Then
            CountR = CountR + 1
        End If
    Next
    If CountL <> CountR Then
        CalcErr = "括号不匹配"
        Exit Function
    End If
    '计算
    Calc = CalcA(Exp)
End Function

Public Function CalcA(ByVal Exp As String) As Double
    'Deep = Deep + 1
    '(1+2)*3+4*5+2=?
    '(1+2)*(3+4)+5=?
    '(1+2)*((3+4)*5)+3=?
    '11111012222211100
   
    DoEvents '防止死机
    Dim LvS As Integer
   
    '循环变量
    Dim I As Integer, J As Integer
   
    '对于纯数值
    Dim Temp As String, Temp2 As String
    Temp = Str(Val(Exp))
    Temp2 = Replace(Temp, ".", "0.")
    Exp = Trim(Exp)
    If Trim(Temp) = Exp Or Trim(Temp2) = Exp Then
        CalcA = Val(Exp)
        GoTo LAB_END
    ElseIf Exp = "" Then '对于空（负号）
        CalcA = 0
        GoTo LAB_END
    End If

    'Dim AscN As Integer
    'For I = 1 To Len(Exp)
    '    AscN = Asc(Mid(Exp, I, 1))
    '    If AscN > 57 Or AscN < ascn =" 47" ascn =" 44" calca =" Val(Exp)" i =" 1" lvs =" I" currentlv =" 0:" lvmb =" False" i =" LvS" currentlv =" CurrentLv"> LvM Then
                    LvM = CurrentLv
                    LvMS = I '最大级别启始点
                    LvMB = True
                End If
            ElseIf Mid(Exp, I, 1) = ")" Then
                CurrentLv = CurrentLv - 1
                If LvMB Then
                    LvME = I '最大级别结束点
                    LvMB = False
                End If
            End If
            'Lv(I) = CurrentLv '存储级别（优化备用）
        Next
        '计算最高级括号
        Exp = Left(Exp, LvMS - 1) & CalcA(Mid(Exp, LvMS + 1, LvME - LvMS - 1)) & Right(Exp, Len(Exp) - LvME)
        CalcA = CalcA(Exp)
        GoTo LAB_END

LAB_A2:
    '对于没有括号的表达式
        '加减法跳转
        Dim AscS As Integer
        For I = 1 To Len(Exp)
            If Mid(Exp, I, 1) = "+" Then GoTo LAB_B1
            If Mid(Exp, I, 1) = "-" And I > 1 Then
                AscS = Asc(Mid(Exp, I - 1, 1))
                If AscS >= Asc("0") And AscS < i =" 1" exp =" CalcA(Left(Exp," calca =" CalcA(Exp)" exp =" Str(CalcA(Left(Exp," calca =" CalcA(Exp)" i =" 1" exp =" Str(CalcA(Left(Exp," calca =" CalcA(Exp)" exp =" Str(CalcA(Left(Exp," calca =" CalcA(Exp)" deep =" Deep">
发帖者 时间： 没有评论:
标签： , ,

2008年12月10日星期三

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

继续复制粘贴。
继续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
发帖者 时间： 3 条评论:
标签： ,

2008年12月9日星期二

问卷统计程序代码

混乱啊混乱。很多为了省事而产生的名称。功能一般。不少内部的Ctrl+C/V。
不过至少说明了我还会写一些简单的程序……

'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 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 Command1_Click()
BuildReport
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

Private Sub Command6_Click()
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 & "\dat.txt" 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 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()
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 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 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
发帖者 时间： 没有评论:
标签： ,

2008年12月8日星期一

自动灌水软件代码

从我在0Gsns的日志复制过来的。
==================================================================
今天无聊到底了。。。于是去hnubbs灌水了。。。于是就有了这个软件。

Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
'Private Declare Function SetCursorPos Lib "user32" (ByVal X As Long, ByVal Y As Long) As Long
Private Declare Sub mouse_event Lib "user32" (ByVal dwFlags As Long, ByVal dx As Long, _
ByVal dy As Long, ByVal cButtons As Long, ByVal dwExtraInfo As Long)

Private Const MOUSEEVENTF_LEFTDOWN = &H2
Private Const MOUSEEVENTF_LEFTUP = &H4
'Private Const MOUSEEVENTF_RIGHTDOWN = &H8
'Private Const MOUSEEVENTF_RIGHTUP = &H10

Private Type POINTAPI
X As Long
Y As Long
End Type

Private Sub Command1_Click()
SendKeys "{PGDN}", 100
ML
SendKeys Text1.Text
SendKeys "^{enter}", 100
End Sub

Private Sub Command2_Click()
Timer1.Enabled = Not Timer1.Enabled
Command2.Caption = Timer1.Enabled
End Sub

Private Sub Command3_Click()
List1.AddItem Text1.Text
End Sub

Private Sub Command4_Click()
On Error Resume Next
List1.RemoveItem List1.ListIndex
End Sub

Private Sub Form_Load()
On Error Resume Next
Dim I As Integer, N As Integer, T As String
Open App.Path & "\list.txt" For Input As #1
Input #1, N
For I = 1 To N
Input #1, T
List1.AddItem T
Next
Close #1
End Sub

Private Sub Form_Unload(Cancel As Integer)
On Error Resume Next
Dim I As Integer
Open App.Path & "\list.txt" For Output As #1
Write #1, List1.ListCount
For I = 0 To List1.ListCount - 1
Write #1, List1.List(I)
Next
Close #1
End Sub

Private Sub HScroll1_Change()
Label1.Caption = "速度：" & HScroll1.Value & "秒/次"
Timer1.Interval = HScroll1.Value * 1000
End Sub

Private Sub Image1_Click()
Shell "explorer.exe http://www.0ginr.com/"
End Sub

Private Sub Label3_Click()
Shell "explorer.exe http://bbs.hnubbs.com/"
End Sub

Private Sub Timer1_Timer()
Text1.Text = List1.List(Int(Rnd() * List1.ListCount))
Command1_Click
End Sub

Private Sub ML()
Dim MouseCurPos As POINTAPI
GetCursorPos MouseCurPos
mouse_event MOUSEEVENTF_LEFTDOWN, MouseCurPos.X, MouseCurPos.Y, 0, 0 '设置鼠标左键按下
mouse_event MOUSEEVENTF_LEFTUP, MouseCurPos.X, MouseCurPos.Y, 0, 0 '设置鼠标左键弹出
End Sub
发帖者 时间： 2 条评论:
标签：
订阅： 博文 (Atom)