modmain.bas

Visual basic 数据库编程技术与实例源码 源码

'realWidth:实际将要显示区域的宽度
'realHeight:实际将要显示区域的高度
'srcPicture:存在实际的图片大小
'destPicture:用来存放最终显示的图片
'(可以是预览区域，这时destPicture要小于srcWidth和srcHeight，
'也可以是实际区域，这时destPicture与srcWidth和srcHeight大小相同
'
Public Sub PaintImage(ByVal realWidth As Integer, ByVal realHeight As Integer, _
                      srcPicture As PictureBox, _
                      destPicture As PictureBox, _
                      ByVal lDisplayStyle As Long)
                      
    Dim dw_pic As Single
    Dim dh_pic As Single
    Dim x1 As Integer
    Dim y1 As Integer
    Dim iCt As Long
    Dim jCt As Long
    Dim i As Long
    Dim j As Long
    
    '计算缩放后的图片大小
    srcPicture.AutoSize = True
    dw_pic = srcPicture.ScaleWidth * destPicture.ScaleWidth / realWidth
    dh_pic = srcPicture.ScaleHeight * destPicture.ScaleHeight / realHeight
    
    '根据显示方式的不同，显示图片
    Select Case lDisplayStyle
        Case GL_DISPLAY_CENTER '居中
            x1 = (destPicture.ScaleWidth - dw_pic) / 2
            y1 = (destPicture.ScaleHeight - dh_pic) / 2
            
            destPicture = LoadPicture()
            destPicture.PaintPicture srcPicture.Picture, x1, y1, dw_pic, dh_pic, 0, 0, srcPicture.ScaleWidth, srcPicture.ScaleHeight
        Case GL_DISPLAY_TILE '平铺
            iCt = CInt(destPicture.ScaleWidth / dw_pic) + 1
            jCt = CInt(destPicture.ScaleHeight / dh_pic) + 1
            
            For i = 1 To iCt
                For j = 1 To jCt
                    '平铺
                    destPicture.PaintPicture srcPicture.Picture, (i - 1) * dw_pic, (j - 1) * dh_pic, dw_pic, dh_pic, 0, 0, srcPicture.ScaleWidth, srcPicture.ScaleHeight
                Next j
            Next i
        Case GL_DISPLAY_STRETCH '拉伸
            destPicture.PaintPicture srcPicture.Picture, 0, 0, destPicture.ScaleWidth, destPicture.ScaleHeight, 0, 0, srcPicture.ScaleWidth, srcPicture.ScaleHeight
    End Select
End Sub
'判断给定的关键字段是否已经存在了
Public Function IsKeyColumnExists(ByVal szSQL As String, adoCONN As ADODB.Connection, ByVal szMsg As String) As Boolean
    Dim rs As ADODB.Recordset
    
    On Error GoTo ErrHandler
    Set rs = adoCONN.Execute(szSQL)
    If Not rs.EOF Then rs.MoveLast
    If Not rs.BOF Then rs.MoveFirst
    If ToLong(rs("ct")) >= 1 Then
        MsgBox szMsg, vbOKOnly + vbInformation, "提示"
        IsKeyColumnExists = True
    Else
        IsKeyColumnExists = False
    End If
    Set rs = Nothing
    Exit Function
ErrHandler:
    Set rs = Nothing
    IsKeyColumnExists = True
    ErrMessageBox "IsKeyColumnExists()", "提示"
End Function
'计算图像的缩放系数
'如果srcPicutre的每一边都比destPicture小,则显示原来的大小
'如果其中有一边比destPicture的大,则按大边缩放
Public Function PictureScaleRatio(srcPicture As PictureBox, destPicture As PictureBox) As Double
    Dim r1 As Double
    Dim r2 As Double
    
    r1 = srcPicture.ScaleHeight / destPicture.ScaleHeight
    r2 = srcPicture.ScaleWidth / destPicture.ScaleWidth
    
    '取最大值
    If r1 < r2 Then
        r1 = r2
    End If
    
    If r1 < 1 Then
        PictureScaleRatio = 1
    Else
        PictureScaleRatio = r1
    End If
End Function
'只接收数字
Public Function AcceptNumber(ByVal KeyAscii As Integer) As Integer
    Select Case KeyAscii
        Case vbKey0, vbKey1, vbKey2, vbKey3, vbKey4, vbKey5, vbKey6, vbKey7, vbKey8, vbKey9, vbKeyBack, vbKeyTab, vbKeyDelete
            AcceptNumber = KeyAscii
        Case Else
            AcceptNumber = 0
    End Select
End Function
'生成考卷
Public Sub GenTestPaper()
    Dim rs As ADODB.Recordset
    Dim BL0 As Long '选择题
    Dim BL1 As Long '判断题
    Dim tmlb As Long '题目类别
    Dim tmlx As Long '题目类型
    Dim tmbh As Long '题目编号
    Dim sResult(1 To 100) As String '用于记录选出的试卷题目
    Dim sSelection() As String '
    Dim szSQL As String
    Dim i As Long
    Dim ct As Long
    Dim th As Long '随机的题号
    Dim j As Long
    Dim lUB As Long '数组上限
    
    On Error GoTo ErrHandler
    
    Screen.MousePointer = 11
    '10:读取选择题、判断题的比例设置
    Set rs = gadoCONN.Execute("SELECT xzt_bl,pdt_bl FROM tbParam WHERE id=1")
    If Not rs.EOF Then rs.MoveLast
    If Not rs.BOF Then rs.MoveFirst
    If rs.RecordCount >= 1 Then
        BL0 = ToLong(rs("xzt_bl"))
        BL1 = ToLong(rs("pdt_bl"))
    Else
        MsgBox "请先设置系统参数！", vbOKOnly + vbInformation
        Set rs = Nothing
        Exit Sub
    End If
    
    '20:将所有的选择题读出来放在数组中
    If Not rs Is Nothing Then
        If rs.State = adStateOpen Then
            rs.Close
        End If
        Set rs = Nothing
    End If
    
    Set rs = gadoCONN.Execute("SELECT * FROM tbTk WHERE tmlx_id=0")
    If Not rs.EOF Then rs.MoveLast
    If Not rs.BOF Then rs.MoveFirst
    ct = rs.RecordCount
    ReDim sSelection(1 To ct)
    '将选择题的题目类型、题目编号存起来
    For i = 1 To ct
        sSelection(i) = CStr(ToLong(rs("tmlb_id"))) & "-0" & "-" & CStr(ToLong(rs("tmbh")))
        rs.MoveNext
    Next i
    
    If Not rs Is Nothing Then
        If rs.State = adStateOpen Then
            rs.Close
        End If
        Set rs = Nothing
    End If
    
    '30:根据随机数产生选择题
    For i = 1 To BL0
        '产生随机数
        lUB = UBound(sSelection)
        Randomize '初始化
        th = Int(lUB * Rnd() + 1)
        
        '将产生的题目放在sResult中
        sResult(i) = sSelection(th)
        
        '调整数组sSelection:将已经产生的去掉
        If th < lUB Then
            For j = th + 1 To lUB
                sSelection(j - 1) = sSelection(j)
            Next j
        End If
        
        ReDim Preserve sSelection(1 To lUB - 1)
    Next i
    
    '40:判断题
    Set rs = gadoCONN.Execute("SELECT * FROM tbTk WHERE tmlx_id=1")
    If Not rs.EOF Then rs.MoveLast
    If Not rs.BOF Then rs.MoveFirst
    ct = rs.RecordCount
    ReDim sSelection(1 To ct)
    For i = 1 To ct
        sSelection(i) = CStr(ToLong(rs("tmlb_id"))) & "-1" & "-" & CStr(ToLong(rs("tmbh")))
        rs.MoveNext
    Next i
    If Not rs Is Nothing Then
        If rs.State = adStateOpen Then
            rs.Close
        End If
        Set rs = Nothing
    End If
    '50:根据随机数产生判断题
    
    For i = BL0 + 1 To 100
        '产生随机数
        lUB = UBound(sSelection)
        Randomize '初始化
        th = Int(lUB * Rnd() + 1)
        
        '将产生的题目放在sResult中
        sResult(i) = sSelection(th)
        
        '调整数组sSelection:将已经产生的去掉
        If th < lUB Then
            For j = th + 1 To lUB
                sSelection(j - 1) = sSelection(j)
            Next j
        End If
        
        ReDim Preserve sSelection(1 To lUB - 1)
    Next i
    
    '60:清空试卷库
    gadoCONN.Execute "DELETE FROM tbSj"
    
    For i = 1 To 100
        '取得题目类别、题目类型、题目编号
        GetParameters sResult(i), tmlb, tmlx, tmbh
        
        '写入数据库中
        szSQL = "INSERT INTO tbSj(sjbh,tmlb_id,tmlx_id,tmbh) VALUES(" & _
              CStr(i) & "," & CStr(tmlb) & "," & CStr(tmlx) & "," & CStr(tmbh) & ")"
        gadoCONN.Execute szSQL
    Next i
    Screen.MousePointer = 0
    Exit Sub
ErrHandler:
    If Not rs Is Nothing Then
        If rs.State = adStateOpen Then
            rs.Close
        End If
        Set rs = Nothing
    End If
    Screen.MousePointer = 0
    ErrMessageBox "生成试卷出错GenTestPaper()", "提示"
End Sub
'根据文件名获取题目类别，题目类型，题目编号
Private Sub GetParameters(ByVal sParam As String, lpTmlb As Long, lpTmlx As Long, lpTmbh As Long)
    Dim L1 As Long
    Dim L2 As Long
    
    '分离各编号
    L1 = InStr(1, sParam, "-", vbTextCompare)
    L2 = InStrRev(sParam, "-", , vbTextCompare)
        
    lpTmlb = CLng(Left(sParam, L1 - 1))
    lpTmlx = CLng(Mid(sParam, L1 + 1, L2 - L1 - 1))
    lpTmbh = CLng(Mid(sParam, L2 + 1, Len(sParam) - L2))
End Sub