mdlfunction.bas

本系统可用于医院和专业体检中心的健康体检管理

On Error GoTo ErrMsg
    Dim i As Integer
    Dim strRet As String
    
    strRet = Trim(CStr(lngValue))
    If Len(strRet) < intLength Then
        strRet = String(intLength - Len(strRet), "0") & strRet
    ElseIf Len(LongToString) > intLength Then
        '
    End If
    LongToString = strRet
    Exit Function
ErrMsg:
    LongToString = ""
End Function

'刷新网格控件
Public Sub RefreshGrid(ByRef frmForm As Form, ByRef mshGrid As mshFlexGrid, _
        ByVal strSQL As String, Optional ByVal blnSort As Boolean = True)
On Error GoTo ErrMsg
    Dim Status
    Dim rstemp As ADODB.Recordset
    
    frmForm.MousePointer = vbHourglass
    Set rstemp = New ADODB.Recordset
    rstemp.Open strSQL, GCon, adOpenStatic, adLockPessimistic
    If rstemp.EOF Then
        mshGrid.Clear
        mshGrid.Rows = 2
        mshGrid.Refresh
        frmForm.MousePointer = vbDefault
        Exit Sub
    End If
    mshGrid.FixedCols = 0
    Set mshGrid.DataSource = rstemp
        
    If blnSort Then
        mshGrid.col = gintPXFC
        mshGrid.Sort = 5
    End If
    
    rstemp.Close
    SetMSHFlexGridColor mshGrid
'    mshGrid.FixedCols = 1
    
    frmForm.MousePointer = vbDefault
    Exit Sub
ErrMsg:
    frmForm.MousePointer = vbDefault
    Status = SetError(Err.Number, Err.Description, Err.Source)
    ErrMsg Status
End Sub

''刷新DataGrid控件
'Public Sub RefreshDataGrid(ByRef frmForm As Form, ByRef dtgGrid As DataGrid, ByVal strSQL As String)

'    Dim Status
'
'    frmForm.MousePointer = vbHourglass
'    Status = GetRows(strSQL)
'    If ErrTrue(Status) Then
'        If Status(0) <> NoRecord Then
'            ErrMsg Status
'        Else
'            dtgGrid.ClearFields
'        End If
'        GoTo ExitLab
'    End If
'
'    Set dtgGrid.DataSource = RS
''    CloseRS
'    GoTo ExitLab
'
'ErrMsg:
'    Status = SetError(Err.Number, Err.Description, Err.Source)
'    ErrMsg Status
'ExitLab:
'    frmForm.MousePointer = vbDefault
'End Sub

'设置窗体中网格控件的列宽
'在窗体加载时调用
Public Sub SetGridWidth(ByVal strTableName As String, _
        ByRef mshFlexGrid As mshFlexGrid, Optional ByVal intCols As Integer = 0)
On Error GoTo ErrMsg
    Dim Status
    Dim strSQL As String
    Dim i As Integer
    Dim rstemp As ADODB.Recordset
    
    strSQL = "select * from " & strTableName
    Set rstemp = New ADODB.Recordset
    rstemp.Open strSQL, GCon, adOpenForwardOnly, adLockReadOnly
    If rstemp.EOF Then
        '无记录时直接退出
        Exit Sub
    End If
    
    With mshFlexGrid
        If intCols <> 0 Then
            .Cols = intCols
        Else
            .Cols = rstemp.Fields.Count
        End If
        
        For i = 0 To .Cols - 1
            .ColWidth(i) = rstemp(i)
        Next
    End With
    rstemp.Close
    
    Exit Sub
ErrMsg:
    Status = SetError(Err.Number, Err.Description, Err.Source)
    ErrMsg Status
End Sub

'设置数据库中网格控件的列宽
'在窗体卸出内存时调用
Public Sub SetGridWidthInDB(ByVal strTableName As String, _
        ByRef mshFlexGrid As mshFlexGrid, Optional ByVal intColsCount As Integer = 0)
On Error GoTo ErrMsg
    Dim Status
    Dim strSQL As String
    Dim intCols As Integer
    Dim i As Integer
    
    '网格为空时直接退出
    If mshFlexGrid.TextMatrix(1, 0) = "" Then Exit Sub
    
    strSQL = "delete from " & strTableName
    Status = Execute(strSQL)
    If ErrTrue(Status) Then
        ErrMsg Status
    End If
    
    strSQL = "insert into " & strTableName & " values("
    With mshFlexGrid
        If intColsCount <> 0 Then
            intCols = intColsCount
        Else
            intCols = .Cols
        End If
        
        For i = 0 To intCols - 1
            If i <> intCols - 1 Then
                strSQL = strSQL & .ColWidth(i) & "," '不是最后一列，跟逗号
            Else
                strSQL = strSQL & .ColWidth(i) & ")" '是最后一列，跟括号
            End If
        Next
    End With
    
    Status = Execute(strSQL)
    If ErrTrue(Status) Then
        ErrMsg Status
    End If
    Exit Sub
ErrMsg:
    Status = SetError(Err.Number, Err.Description, Err.Source)
    ErrMsg Status
End Sub

'获取文本框的行数
Public Function GetLineCount(ByVal txtName As TextBox) As Long
   Dim lineCount As Long
   lineCount = SendMessage(txtName.hwnd, EM_GETLINECOUNT, 0, ByVal 0&)
   GetLineCount = lineCount
End Function

'读取文本框中指定行的值
Public Function GetPosChar(ByVal Row As Long, ByVal txtName As TextBox) As String
    Dim pos As Long
    Dim Length As Integer
    Dim strChar As String
    
    pos = SendMessage(txtName.hwnd, EM_LINEINDEX, Row, ByVal 0&)
    Length = SendMessage(txtName.hwnd, EM_LINELENGTH, pos, ByVal 0&)
    strChar = ""
    If Length > 0 Then
         strChar = String(Length, Chr(0))
         RtlMoveMemory ByVal strChar, Length, 2
         SendMessage txtName.hwnd, EM_GETLINE, Row, ByVal strChar
    End If
    GetPosChar = strChar
End Function

'把字符串变成十六进制
Public Function CharToHex(ByVal strData As String) As String
    Dim i As Integer
    Dim strRet As String
    
    For i = 1 To Len(strData)
        strRet = strRet & Hex(Asc(Mid(strData, i, 1)))
    Next
    
    CharToHex = strRet
End Function

'把十六进制变成字符串
Public Function HexToChar(ByVal strHex As String) As String
    Dim i As Integer
    Dim strRet As String
    
    For i = 1 To Len(strHex) \ 2
        strRet = strRet & Chr("&H" & Mid(strHex, 2 * i - 1, 2))
    Next
    
    HexToChar = strRet
End Function

'返回定长字符串
Public Function GetFixedString(ByVal strInput As String, ByVal lngLength As Long) As String
    If Len(strInput) >= lngLength Then
        GetFixedString = strInput
    Else
        GetFixedString = strInput & Space(lngLength - lstrlen(strInput))
    End If
End Function

'获取指定单位指定年龄段的客户
'返回值：男士人数＋“,”＋女士人数
Public Function GetTJRSByAge(ByVal strYYID As String, _
        ByVal intBegin As Integer, ByVal intStop As Integer) As String
    Dim rstemp As ADODB.Recordset
    Dim strSQL As String
    Dim strRet As String
    
    strSQL = "select count(*) as '人数',Sex from SET_GRXX" _
            & " where YYID='" & strYYID & "'" _
            & " and Age between " & intBegin & " and " & intStop _
            & " group by Sex" _
            & " order by Sex"
    Set rstemp = New ADODB.Recordset
    rstemp.Open strSQL, GCon, adOpenStatic, adLockReadOnly
    If rstemp.RecordCount <= 0 Then
        '零条记录
        strRet = "0,0"
        '没有记录时不能使用rsTemp.Close
    ElseIf rstemp.RecordCount = 1 Then
        '一条记录（只有男或者只有女）
        rstemp.MoveFirst
        If rstemp("Sex") = "男" Then
            '只有男
            strRet = CStr(rstemp(0)) & ",0"
        Else
            '只有女
            strRet = "0," & CStr(rstemp(0))
        End If
        rstemp.Close
    Else
        '两条记录（正常情况）
        rstemp.MoveFirst
        strRet = CStr(rstemp(0))
        rstemp.MoveNext
        strRet = strRet & "," & CStr(rstemp(0))
        rstemp.Close
    End If
    Set rstemp = Nothing
    
    GetTJRSByAge = strRet
End Function

'根据健康档案号和卡号进行发卡
'传入参数1：客户的健康档案号
'传入参数2：准备发的卡号
'返回值：True或False
Public Function SendCard(ByVal strHealthID As String, _
        ByVal strCard As String) As Boolean
On Error GoTo ErrMsg
    Dim Status
    Dim strSQL As String
    Dim cmd As ADODB.Command
    Dim rstemp As ADODB.Recordset
    
    Screen.MousePointer = vbArrowHourglass
    
    SendCard = False
    
    '首先检查卡号是否已经存在
    strSQL = "select Count(*) from SET_ICKGL_Index" _
            & " where ICKNum='" & strCard & "'"
    Set rstemp = New ADODB.Recordset
    rstemp.Open strSQL, GCon, adOpenStatic, adLockReadOnly
    If rstemp(0) >= 1 Then
        MsgBox "您输入的卡号已经存在，请核查后重新输入！", vbExclamation, "提示"
        GoTo ExitLab
    End If
    rstemp.Close
    
    '检查当前客户是否已经发过卡
    strSQL = "select * from SET_ICKGL_Index" _
            & " where HealthID='" & strHealthID & "'"
    Set rstemp = New ADODB.Recordset
    rstemp.Open strSQL, GCon, adOpenStatic, adLockReadOnly
    If rstemp.RecordCount >= 1 Then
        MsgBox "档案号为“" & strHealthID & "”的客户已经发过卡，其卡号为“" _
                & rstemp("ICKNum") & "”。请核查！", vbExclamation, "提示"
        rstemp.Close
        GoTo ExitLab
    End If
    
    '在事务中为客户发卡
    GCon.BeginTrans '开始事务
    strSQL = "insert into SET_ICKGL_Index(ICKNum,HealthID,FKRQ,Status) values(" _
            & "'" & strCard & "'" _
            & ",'" & strHealthID & "'" _
            & ",'" & Date & "'" _
            & ",0)" '0表示在用
    GCon.Execute strSQL
    
    GCon.CommitTrans '提交事务
    
    MsgBox "发卡成功！", vbInformation, "提示"
    SendCard = True '发卡成功
    
    GoTo ExitLab
ErrMsg:
    Status = SetError(Err.Number, Err.Description, Err.Source)
    ErrMsg Status
ExitLab:
    Screen.MousePointer = vbDefault
End Function

'新建一个模块，代码：
'Public Function WndProc(ByVal hwnd As Long, ByVal msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
'On Error GoTo ShowErr
'
'    If msg = WM_SYSCOMMAND Then
'        If wParam = SC_RESTORE Then
'            MDIForm1.MDIForm_Resize
'            DoEvents
'            MDIForm1.SetBackground
''            MsgBox "窗体恢复原状！"
''            Exit Function     '''这里如果被使用了，则移除相关操作，可以尝试使其有效
''        ElseIf wParam = SC_MAXIMIZE Then
''            MsgBox "窗体最大化！"
''            'Exit Function
''        ElseIf wParam = SC_MINIMIZE Then
''            MsgBox "窗体最小化！"
''            'Exit Function
'        Else
'            WndProc = CallWindowProc(prevWndProc, hwnd, msg, wParam, lParam)
'        End If
'    ElseIf msg = WM_NCLBUTTONDBLCLK Then
'        MDIForm1.MDIForm_Resize
'        DoEvents
''        MsgBox "你双击了标题栏！"
'        'Exit Function
'    End If
'
'    WndProc = CallWindowProc(prevWndProc, hwnd, msg, wParam, lParam)
'    Exit Function
'ShowErr:
'    WndProc = CallWindowProc(prevWndProc, hwnd, msg, wParam, lParam)
'    Exit Function
'End Function

'访问注册表值
Public Function GetKeyValue(KeyRoot As Long, KeyName As String, SubKeyRef As String, ByRef KeyVal As String) As Boolean
    Dim i As Long                                           ' Loop Counter
    Dim rc As Long                                          ' Return Code
    Dim hkey As Long                                        ' Handle To An Open Registry Key
    Dim hDepth As Long                                      '
    Dim KeyValType As Long                                  ' Data Type Of A Registry Key
    Dim tmpVal As String                                    ' Tempory Storage For A Registry Key Value
    Dim KeyValSize As Long                                  ' Size Of Registry Key Variable
    '------------------------------------------------------------
    ' Open RegKey Under KeyRoot {HKEY_LOCAL_MACHINE...}
    '------------------------------------------------------------
    rc = RegOpenKeyEx(KeyRoot, KeyName, 0, KEY_ALL_ACCESS, hkey) ' Open Registry Key
    
    If (rc <> ERROR_SUCCESS) Then GoTo GetKeyError          ' Handle Error...
    
    tmpVal = String$(1024, 0)                             ' Allocate Variable Space
    KeyValSize = 1024                                       ' Mark Variable Size
    
    '------------------------------------------------------------
    ' Retrieve Registry Key Value...
    '------------------------------------------------------------
    rc = RegQueryValueEx(hkey, SubKeyRef, 0, _
                         KeyValType, tmpVal, KeyValSize)    ' Get/Create Key Value
                        
    If (rc <> ERROR_SUCCESS) Then GoTo GetKeyError          ' Handle Errors
    
    If (Asc(Mid(tmpVal, KeyValSize, 1)) = 0) Then           ' Win95 Adds Null Terminated String...
        tmpVal = Left(tmpVal, KeyValSize - 1)               ' Null Found, Extract From String
    Else                                                    ' WinNT Does NOT Null Terminate String...
        tmpVal = Left(tmpVal, KeyValSize)                   ' Null Not Found, Extract String Only
    End If
    '------------------------------------------------------------
    ' Determine Key Value Type For Conversion...
    '------------------------------------------------------------
    Select Case KeyValType                                  ' Search Data Types...
    Case REG_SZ                                             ' String Registry Key Data Type
        KeyVal = tmpVal                                     ' Copy String Value
    Case REG_DWORD                                          ' Double Word Registry Key Data Type
        For i = Len(tmpVal) To 1 Step -1                    ' Convert Each Bit
            KeyVal = KeyVal + Hex(Asc(Mid(tmpVal, i, 1)))   ' Build Value Char. By Char.
        Next
        KeyVal = Format$("&h" + KeyVal)                     ' Convert Double Word To String
    End Select
    
    GetKeyValue = True                                      ' Return Success
    rc = RegCloseKey(hkey)                                  ' Close Registry Key
    Exit Function                                           ' Exit
    
GetKeyError:      ' Cleanup After An Error Has Occured...