pubfun.bas

一个题库系统 可以按照试题的难度

Attribute VB_Name = "pubfun"
Option Explicit
Public p_conn  As String
Public dbcon As New ADODB.Connection

Public Const SNEW As String = "NEW"
Public Const SEDIT As String = "EDIT"
Public Const GWL_STYLE = (-16)
Public Const ES_NUMBER& = &H2000&

Public Const NULL_DATE = "9999-01-01"

Public tmp_value As String
Public tmp_value2 As String
Public user_name As String
Public user_qx As String

Public Declare Function hash Lib "FlwLib.dll" (ByVal src_data As String, hash_value As Any) As Long
Public Declare Function SetParent Lib "user32" (ByVal hWndChild As Long, ByVal hWndNewParent As Long) As Long
Public Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Public Declare Function SetBkColor Lib "gdi32" (ByVal hdc As Long, ByVal crColor As Long) As Long
Public Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Public Sub SetBkColorEx(ByVal hwnd As Long, ByVal cor As Long)
    Dim hdc As Long
    hdc = GetDC(hwnd)
    SetBkColor hdc, cor
End Sub
Public Sub SetWindowPos(ByVal frm As Form)
    SetParent frm.hwnd, frmLeft.hwnd
       
    With frm
        .Left = frmLeft.P1.Left
        .Width = frmLeft.Width
        .Top = frmLeft.Top
        .Height = frmLeft.Height
    End With
    With frm.Frame1
        .Left = frm.Width * 0.41 - .Width / 2
        .Top = frm.Height * 0.49 - .Height / 2
    End With
    frm.Show , frmLeft
End Sub
Public Function MsgboxYesOrNo(ByVal sMsg$) As Boolean
    Dim msg, Style, Title, Help, Ctxt, Response, MyString
    msg = sMsg
    Style = vbYesNo + vbQuestion + vbDefaultButton2
    Title = "系统提示"
    Response = MsgBox(msg, Style, Title)
    If Response = vbYes Then
          MsgboxYesOrNo = True
          Exit Function
       Else
          MsgboxYesOrNo = False
          Exit Function
    End If
End Function
Public Sub MsgMsg(ByVal msg As String)
    MsgBox msg, , "车务段题库管理系统"
End Sub
Public Sub CrRS(ByVal sSQL As String, ByRef db As ADODB.Connection, ByRef Rs As ADODB.Recordset)
    Rs.open sSQL, db, adOpenKeyset, adLockPessimistic, adCmdText
End Sub
Public Function GetID() As String
    Dim src As String
    Dim s_hash(31) As Byte
    src = Now & Rnd
    hash src, s_hash(0)
    GetID = StrConv(s_hash, vbUnicode)
End Function
Public Sub ShowForm(ByRef frm As Form, ByVal stype As String, ByVal sID As String)
    On Error Resume Next
    Unload frm
    frm.m_Type = stype
    frm.m_ID = sID
    SetWindowPos frm
    Load frm
    frm.Show
End Sub
Public Function GetHash(ByVal src As String)
    Dim s_hash(31) As Byte
    hash src, s_hash(0)
    GetHash = StrConv(s_hash, vbUnicode)
End Function

Public Sub SetNumMask(txtObj As Object)
   Dim lTemp&
   Dim value&
   value& = GetWindowLong(txtObj.hwnd, GWL_STYLE)
   value& = value& Or ES_NUMBER&
   lTemp = SetWindowLong(txtObj.hwnd, GWL_STYLE, value&)
End Sub

Public Function ReadBinData(ByVal strFileName As String) As Variant
    Dim lLen As Long
    Dim iFile As Integer
    Dim arrBytes() As Byte
    Dim lCount As Long
    Dim strOut As String
    
    iFile = FreeFile()
    Open strFileName For Binary Access Read As iFile
    lLen = FileLen(strFileName)
    ReDim arrBytes(lLen - 1)
    Get iFile, , arrBytes
    Close iFile
    
    ReadBinData = arrBytes
End Function