form10.frm

主要用于学校机房考试,主要包括选择题,问答题,WORD操作题,WINDOWS操作题.学生做完后,可立即得到考试分数.

      Height          =   180
      Left            =   5340
      TabIndex        =   17
      Top             =   90
      Width           =   1560
   End
   Begin VB.Label Label4 
      AutoSize        =   -1  'True
      BackColor       =   &H00FFC0C0&
      BackStyle       =   0  'Transparent
      Caption         =   "改前文件名列表："
      BeginProperty Font 
         Name            =   "楷体_GB2312"
         Size            =   9
         Charset         =   134
         Weight          =   700
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      ForeColor       =   &H000000FF&
      Height          =   180
      Left            =   3480
      TabIndex        =   16
      Top             =   90
      Width           =   1560
   End
   Begin VB.Image Image1 
      BorderStyle     =   1  'Fixed Single
      Height          =   4215
      Left            =   6990
      Stretch         =   -1  'True
      Top             =   300
      Width           =   3435
   End
   Begin VB.Label Label3 
      Caption         =   "选择图片质量（1-90越大越好）："
      ForeColor       =   &H000000FF&
      Height          =   240
      Left            =   45
      TabIndex        =   9
      Top             =   5085
      Width           =   3465
   End
   Begin VB.Label Label1 
      AutoSize        =   -1  'True
      Caption         =   "改前文件名："
      BeginProperty Font 
         Name            =   "楷体_GB2312"
         Size            =   10.5
         Charset         =   134
         Weight          =   700
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Height          =   210
      Left            =   120
      TabIndex        =   7
      Top             =   3885
      Width           =   1365
   End
   Begin VB.Label Label2 
      AutoSize        =   -1  'True
      Caption         =   "改后文件名："
      BeginProperty Font 
         Name            =   "楷体_GB2312"
         Size            =   10.5
         Charset         =   134
         Weight          =   700
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Height          =   210
      Left            =   120
      TabIndex        =   6
      Top             =   4245
      Width           =   1365
   End
End
Attribute VB_Name = "Form10"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False

Option Explicit
Dim aas As Integer '当前表
Dim aad As Integer 'list框中当前位置
Dim aa As String
Private m As New cDIBSection '

Private Sub Command1_Click()
Timer2.Interval = 10
Command1.Enabled = False
End Sub

Private Sub Command2_Click() '把excel导入数据库11.mdb  导入前先删除所存在的工作表,excel应有zph,zph1 两列
On Error Resume Next
Dim db As Database
Set db = OpenDatabase(App.Path & "\11.mdb")
 db.Execute "Drop TABLE " & Trim(Str(aas))  '删除存在的工作表
 db.Close
C2.ShowOpen
 C2.Filter = "*.xls"
ExportExcelSheetToAccess "sd", C2.FileName, Trim(Str(aas)), App.Path & "\11.mdb"
Command4.Enabled = True
End Sub
Private Sub Command3_Click() '暂停
Timer1.Interval = 0
Timer2.Interval = 0
Command1.Enabled = True
End Sub

Private Sub Command4_Click()  '打开库
Data1.DatabaseName = App.Path + "\" + "11.mdb"
Data1.RecordSource = Trim(Str(aas))
Data1.Refresh
End Sub

Private Sub Command5_Click()
Data1.RecordSource = ""
Data1.Refresh
Command4.Enabled = False
Text1.Text = ""
Text2.Text = ""
End Sub
Private Sub Dir1_Change()
File1.Path = Dir1
End Sub

Private Sub Dir1_Click()
List1.Clear
Timer1.Interval = 1
End Sub

Private Sub Drive1_Change()
Dir1.Path = Drive1
End Sub
Private Function plQuality() As Long '照片质量设定
   On Error Resume Next
   plQuality = CLng(Text4.Text)
   If Not Err.Number = 0 Then
      Text4.Text = "90"
      plQuality = 90
   End If
End Function

Private Sub Form_Load() '当前表为111
List1.Clear
Timer1.Interval = 1
aas = 111
Timer2.Interval = 0
End Sub

Private Sub List1_Click() '执行转换
On Error Resume Next
Dim myquery As String
Dim cc As String
Dim de As Integer
Image1.Picture = LoadPicture("")
aad = List1.ListIndex
Select Case Len(List1.Text) '读取zph字段
Case 5
Text3.Text = Mid(List1.Text, 1, 1)
Case 6
Text3.Text = Mid(List1.Text, 1, 2)
Case 7
Text3.Text = Mid(List1.Text, 1, 3)
Case 8
Text3.Text = Mid(List1.Text, 1, 4)
Case 9
Text3.Text = Mid(List1.Text, 1, 5)
Case 10
Text3.Text = Mid(List1.Text, 1, 6)
Case 11
Text3.Text = Mid(List1.Text, 1, 7)
Case 12
Text3.Text = Mid(List1.Text, 1, 8)
Case 13
Text3.Text = Mid(List1.Text, 1, 9)
Case 14
Text3.Text = Mid(List1.Text, 1, 10)
Case 15
Text3.Text = Mid(List1.Text, 1, 11)
Case 16
Text3.Text = Mid(List1.Text, 1, 12)
End Select
myquery = "zph " & " = " & " '" & Text3.Text & "'"
Data1.RecordSource = "SELECT * FROM " & Trim(Str(aas)) & " WHERE " & myquery
Data1.Refresh
Data1.Recordset.MoveLast: Data1.Recordset.MoveFirst
If Text2.Text <> "" Then
    List2.AddItem Text2.Text
    Image1.Picture = LoadPicture(Dir1.Path + "\" + Text1.Text + ".jpg")
    cc = Trim(Text2.Text) & ".jpg"
    If cc <> ".jpg" Then   '完成图片的令存储
       m.CreateFromPicture Image1.Picture
       aa = sysfilefind(App.Path & "\照片\", cc)
       If aa <> "没找到" Then
       de = MsgBox("文件已存在，要删除原文件吗？", vbYesNo)
          If de = vbYes Then
            Kill App.Path & "\照片\" & cc '删除已存在的图片
            SaveJPG m, App.Path & "\照片\" & cc, plQuality()
            List1.ListIndex = aad
          Else '如果不存在同名的图片，则新建立一个图片文件。
            SaveJPG m, App.Path & "\照片\" & cc, plQuality()
            List1.ListIndex = aad '读取下一个图片
          End If
       Else
         SaveJPG m, App.Path & "\照片\" & cc, plQuality()
         List1.ListIndex = aad
       End If
    End If
    List1.RemoveItem (List1.ListIndex)
'    Kill App.Path & "\照片\" & Text1.Text + ".jpg" '删除原有图片
End If
If Text1.Text = "" Then
   Image1.Picture = LoadPicture("")
   MsgBox "没有照片号或没有打开数据库"
   Image1.Picture = LoadPicture(App.Path & "\照片\black.jpg")
   Timer1.Interval = 0
End If
    
Data1.RecordSource = ""


End Sub

Private Sub List2_Click()
On Error Resume Next
Dim myquery As String
myquery = "zph1 " & " = " & " '" & Trim(List2.Text) & "'"
Data1.RecordSource = "SELECT * FROM " & Trim(Str(aas)) & " WHERE " & myquery
Data1.Refresh
If Data1.Recordset.RecordCount <> 0 Then
Image1.Picture = LoadPicture(App.Path & "\照片\" & Trim(List2.Text) & ".jpg")
Else
Image1.Picture = LoadPicture(App.Path & "\照片\black.jpg")
End If
End Sub
Private Sub Text5_KeyPress(KeyAscii As Integer)
Dim myquery As String
Dim cc As String
Dim de As Integer
Dim Search As String, SearchLen As Integer, i As Integer
If KeyAscii = 13 Then                 '快速定位于list框
    Search = UCase(Text5.Text)
    SearchLen = Len(Search)
    If SearchLen Then
        For i = 0 To List1.ListCount - 1
            If UCase(Left(List1.List(i), SearchLen)) = Search Then
                List1.ListIndex = i
                Exit For
            End If
        Next
    Else
        List1.ListIndex = 0
    End If
myquery = "zph " & " = " & " '" & Text5.Text & "'"
Data1.RecordSource = "SELECT * FROM " & Trim(Str(aas)) & " WHERE " & myquery
Data1.Refresh
If Data1.Recordset.RecordCount <> 0 Then

Data1.Recordset.MoveLast: Data1.Recordset.MoveFirst
Else
MsgBox "没有这个照片号，请重新输入"
Text5.Text = ""
End If
End If
End Sub
Private Sub Text4_KeyPress(KeyAscii As Integer)
 If KeyAscii = 8 Then
   ElseIf KeyAscii >= Asc("0") And KeyAscii <= Asc("9") Then
   Else
      KeyAscii = 0
   End If
End Sub

Private Sub Timer1_Timer()
If File1.ListIndex < File1.ListCount - 1 Then
File1.ListIndex = File1.ListIndex + 1
List1.AddItem File1.FileName
End If
End Sub

Private Sub Timer2_Timer()
If aad < List1.ListCount Then
List1.ListIndex = aad
Else
Timer2.Interval = 0
Command1.Enabled = True
End If
End Sub