mdlfunction.bas

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

Attribute VB_Name = "mdlFunction"
Option Explicit

'**************************************************************
'**************************************************************
'************************  作    者：吴明远   ******************
'************************  功能简介：通用函数 ******************
'************************  开发时间：2003-2   ******************
'**************************************************************
'**************************************************************


Public gstrManagerName As String
Public gintManagerID As Integer
Public gstrClassifyID As String
Public gstrKSID As String '科室id
Public gstrKSMC As String '科室名称
Public gstrHospital As String '注册单位(医院)的名称
Public gstrManagerBackground As String
Public gstrCurrPath As String                           '含斜杠的应用程序路径
Public gblnReLogin As Boolean
Public gblnIsSpy As Boolean
Public gblnSuccess As Boolean                           '传送文件是否成功
Public gblnRegister As Boolean

Public Const BackgroundDir = "Background\"              '背景图片所在文件夹
Public Const StartPage = "StartPage\"                   '起始图片所在文件夹
Public Const IrrigationMap = "Config\IrrigationMap\"    '灌区地图所在文件夹
Public Const DataCollDir = "Data\Collection\"           '采集数据所在文件夹
Public Const PluginDir = "Config\Plugin\"               '插件所在文件夹
Public Const PluginFile = "PluginConfig.ini"          '配置文件
Public Const CustomError = 555555
Public Const SystemManager = "00001"
Public Const FSBSmallChange = 10
Public Const FSBLargeChange = 100
Public Const JoinSymbol = "@#$%&*&%$#@"
Public Const BorderSpace = 10                           '显示打印预览时多余的距离
Public Const ErrorReturn = -1

'以下结构用于模板输出
Public Type TempReportHeader
    KESHI       As String
    KESHIYICHANG As String '科室异常
    DAXIANG     As String
    XIAOXIANG   As String
    DOCTOR      As String
    DOCTORSIGN  As String   '医生亲笔签名
    DOCTOR_KESHI As String '科室医生
    DOCTOR_SIGN_KESHI As String
    RESULT      As String
    SRESULT     As String
    OTHER       As String
    TUANTI      As String
    KSXJ        As String
    ZJJL        As String
    ZJJY        As String
    PICTURE     As String
    BOOKMARK_NAME As String '姓名
    BOOKMARK_SEX As String '性别
    BOOKMARK_AGE As String '年龄
    BOOKMARK_XM As String '项目
    BOOKMARK_SELECTION As String '选择框
    BOOKMARK_BM As String '编码
    BOOKMARK_JG As String '价格
    BOOKMARK_XX As String '小项
    BOOKMARK_XB As String '小项编码
    BOOKMARK_TotalPrice As String '每页的价格和
    BOOKMARK_ZYSX As String '注意事项
    BOOKMARK_KSMC As String '科室名称
End Type
Public gtypHeader As TempReportHeader

Public Type OtherTemplateID
    name        As String
    SEX         As String
    AGE         As String
    TJRQ        As String
    DYRQ        As String
    ZJJL        As String
    ZJJY        As String
    HEALTHID    As String
    CXM         As String
    TCMC        As String
    DWMC        As String
    LXDZ        As String
    JTDH        As String
    BGDH        As String
    YDDH        As String
    TJYC        As String '体检异常
    SELFID      As String '自定义档案号
    SELF_JY_1   As String '自定义建议1
    SELF_JY_2   As String '自定义建议2
    SELF_JY_3   As String '自定义建议3
    SELF_JY_4   As String '自定义建议4
    SELF_JY_5   As String '自定义建议5
    HEALTH_STATUS As String
    HEALTH_RESULT As String
    HEALTH_SUGGESTION As String
    DOCTOR_ZONGJIAN As String
    DOCTOR_SIGN_ZONGJIAN As String
    '***************20050524加入 闻*********************
    FZMC        As String     '分组名称
    '***************20050524加入 闻*********************

End Type
Public gtypTemplateID As OtherTemplateID

Public Type TuanTiReport
    PROBLEM         As String '主要问题列表，建议
    AGEGROUP        As String '各年龄段的体检人数
    KESHIYICHANG    As String '各科室体检异常体征的例数
    FRONTTENYICHANG As String '排列前10位的异常体征
    UnnormalTitleAndPersonInTable As String '异常指征及人员名单，带表格
    UnnormalTitleNoPerson As String '各种病不出现名单清单，有异常比例
    UnnormalTitleAandPersonWithSuggest As String '各病名，人数比例后面，跟上相关的健康建议
    HEALTH_STATUS As String
    HEALTH_STATUS_GRADE As String
End Type
Public gtypTuanti As TuanTiReport

Public Declare Function GetVolumeInformation Lib "kernel32.dll" Alias _
        "GetVolumeInformationA" (ByVal lpRootPathName As String, ByVal _
        lpVolumeNameBuffer As String, ByVal nVolumeNameSize As Integer, _
        lpVolumeSerialNumber As Long, lpMaximumComponentLength As Long, _
        lpFileSystemFlags As Long, ByVal lpFileSystemNameBuffer As String, _
        ByVal nFileSystemNameSize As Long) As Long
Public Declare Function Beep Lib "kernel32" (ByVal dwFreq As Long, ByVal dwDuration As Long) As Long
Public Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
Public Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Private Declare Sub RtlMoveMemory Lib "kernel32.dll" (Destination As Any, Source As Any, ByVal Length As Long)
Public Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal hwnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Public Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Public Declare Function GetTickCount Lib "kernel32" () As Long
Public Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
Public Declare Function GetTempPath Lib "kernel32" Alias "GetTempPathA" (ByVal nBufferLength As Long, ByVal lpBuffer As String) As Long
Private Declare Function lstrlen Lib "kernel32" Alias "lstrlenA" (ByVal lpString As String) As Long

Private Declare Function RegCreateKey Lib "advapi32.dll" Alias "RegCreateKeyA" (ByVal hkey As Long, ByVal lpSubKey As String, phkResult As Long) As Long
Private Declare Function RegSetValueEx Lib "advapi32" Alias "RegSetValueExA" (ByVal hkey As Long, ByVal lpValueName As String, ByVal Reserved As Long, ByVal dwType As Long, ByVal lpData As String, ByVal cbData As Long) As Long
Private Declare Function RegOpenKeyEx Lib "advapi32" Alias "RegOpenKeyExA" (ByVal hkey As Long, ByVal lpSubKey As String, ByVal ulOptions As Long, ByVal samDesired As Long, ByRef phkResult As Long) As Long
Private Declare Function RegQueryValueEx Lib "advapi32" Alias "RegQueryValueExA" (ByVal hkey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, ByRef lpType As Long, ByVal lpData As String, ByRef lpcbData As Long) As Long
Private Declare Function RegCloseKey Lib "advapi32" (ByVal hkey As Long) As Long
Private Declare Function GetSystemDirectory Lib "kernel32" Alias "GetSystemDirectoryA" (ByVal lpBuffer As String, ByVal nSize As Long) As Long

'*************20040405 加入 闻***********************************************
Public Declare Function Myfunc Lib "Wforcaldll.dll" (ByRef strIn As String, ByRef strErr As String) As Integer
Public Declare Function LoadLibrary Lib "kernel32" Alias "LoadLibraryA" (ByVal lpLibFileName As String) As Long
Public Declare Function GetProcAddress Lib "kernel32" (ByVal hModule As Long, ByVal lpProcName As String) As Long
Public Declare Function FreeLibrary Lib "kernel32" (ByVal hLibModule As Long) As Long
'Public Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal hWnd As Long, ByVal Msg As Any, ByVal wParam As Any, ByVal lParam As Any) As Long
'*************20040405 加入完 闻*********************************************

'keybd_event函数用于取代SendKeys
Private Declare Sub keybd_event Lib "user32" (ByVal bVk As Byte, ByVal _
        bScan As Byte, ByVal dwFlags As Long, ByVal dwExtraInfo As Long)

Const KEYEVENTF_KEYUP = &H2
Const VK_TAB = &H9
Private Const EM_GETLINECOUNT = &HBA
Private Const EM_LINEINDEX = &HBB
Private Const EM_LINELENGTH = &HC1
Private Const EM_GETLINE = &HC4

' Reg Key Security Options...
Const READ_CONTROL = &H20000
Const KEY_QUERY_VALUE = &H1
Const KEY_SET_VALUE = &H2
Const KEY_CREATE_SUB_KEY = &H4
Const KEY_ENUMERATE_SUB_KEYS = &H8
Const KEY_NOTIFY = &H10
Const KEY_CREATE_LINK = &H20

' Reg Key ROOT Types...
Public Const HKEY_LOCAL_MACHINE = &H80000002
Const ERROR_SUCCESS = 0
Const REG_SZ = 1                         ' Unicode nul terminated string
Const REG_DWORD = 4                      ' 32-bit number
Const KEY_ALL_ACCESS = KEY_QUERY_VALUE + KEY_SET_VALUE + _
                       KEY_CREATE_SUB_KEY + KEY_ENUMERATE_SUB_KEYS + _
                       KEY_NOTIFY + KEY_CREATE_LINK + READ_CONTROL

Public Const SW_SHOW = 5
Public Const GWL_WNDPROC = (-4)
Public Const SC_MAXIMIZE = &HF030&
Public Const SC_MINIMIZE = &HF020&
Public Const SC_SIZE = &HF000
Public Const SC_CLOSE = &HF060
Public Const WM_SYSCOMMAND = &H112
Public Const SC_DEFAULT = &HF160
Public Const WM_NCLBUTTONDBLCLK = &HA3
Public Const SC_RESTORE = &HF120&

Public prevWndProc As Long        ''''默认窗口程序地址


'Windows 95 Shell API to use the browse for folders
'dialog box. To use the browse for folders dialog box,
'please call the BrowseForFolders function using the
'syntax:  stringFolderPath=BrowseForFolders(Hwnd,TitleOfDialog)
'
'For contacting information, see other module
Public Type BrowseInfo
     hwndOwner As Long
     pIDLRoot As Long
     pszDisplayName As Long
     lpszTitle As Long
     ulFlags As Long
     lpfnCallback As Long
     lParam As Long
     iImage As Long
End Type

Public Const BIF_RETURNONLYFSDIRS = 1
Public Const MAX_PATH = 260

Public Declare Sub CoTaskMemFree Lib "ole32.dll" (ByVal hMem As Long)
Public Declare Function lstrcat Lib "kernel32" Alias "lstrcatA" (ByVal lpString1 As String, ByVal lpString2 As String) As Long
Public Declare Function SHBrowseForFolder Lib "shell32" (lpbi As BrowseInfo) As Long
Public Declare Function SHGetPathFromIDList Lib "shell32" (ByVal pidList As Long, ByVal lpBuffer As String) As Long

Public Function BrowseForFolder(hwndOwner As Long, sPrompt As String) As String
      
    'declare variables to be used
     Dim iNull As Integer
     Dim lpIDList As Long
     Dim lResult As Long
     Dim sPath As String
     Dim udtBI As BrowseInfo

    'initialise variables
     With udtBI
        .hwndOwner = hwndOwner
        .lpszTitle = lstrcat(sPrompt, "")
        .ulFlags = BIF_RETURNONLYFSDIRS
     End With

    'Call the browse for folder API
     lpIDList = SHBrowseForFolder(udtBI)
      
    'get the resulting string path
     If lpIDList Then
        sPath = String$(MAX_PATH, 0)
        lResult = SHGetPathFromIDList(lpIDList, sPath)
        Call CoTaskMemFree(lpIDList)
        iNull = InStr(sPath, vbNullChar)
        If iNull Then sPath = Left$(sPath, iNull - 1)
     End If

    'If cancel was pressed, sPath = ""
     BrowseForFolder = sPath

End Function

'设置应用程序的当前路径：含斜杠“\”
Public Sub SetCurrPath()
On Error Resume Next
    If Right(App.Path, 1) <> "\" Then
        gstrCurrPath = App.Path & "\"
    Else
        gstrCurrPath = App.Path
    End If
End Sub

'获取临时路径
Public Function GetTempPathW() As String
    Dim strTempPath As String
    
    strTempPath = String(256, Chr(0))
    Call GetTempPath(256, strTempPath)
    'strip the rest of the buffer
    strTempPath = Left(strTempPath, InStr(strTempPath, Chr(0)) - 1)
    If Right(strTempPath, 1) <> "\" Then
        strTempPath = strTempPath & "\"
    End If
    GetTempPathW = strTempPath
End Function

'移动控件焦点
Public Sub EnterToTab(ByVal KeyAscii As Integer)
    If KeyAscii = 13 Then
'        SendKeys "{TAB}"
        keybd_event VK_TAB, 0, 0, 0
        keybd_event VK_TAB, 0, KEYEVENTF_KEYUP, 0
    End If
End Sub

'等待过去多长时间，以毫秒计
Public Sub TimeDelay(DT As Long)
    Dim TT As Long
    TT = GetTickCount()
    Do
        DoEvents
        DoEvents
        If GetTickCount - TT < 0 Then TT = GetTickCount
'        If gblnCancel = True Then Exit Do '用户单击了取消
    Loop Until GetTickCount - TT >= DT
End Sub

'等待 RS 字符串传回，或是时间到达
'Public Function WaitRS(Comm As MSComm, RS As String, DT As Long) As String
'    Dim buf$, TT As Long
'    buf = ""
'    TT = GetTickCount
'    Do
'        buf = buf & Comm.Input
'    Loop Until InStr(1, buf, RS) > 0 Or GetTickCount - TT >= DT
'    If InStr(1, buf, RS) > 0 Then
'        WaitRS = buf
'    Else
'        WaitRS = ""
'    End If
'End Function

'设置网格控件颜色
Public Sub SetMSHFlexGridColor(ByRef mshGrid As mshFlexGrid)
On Error Resume Next
'    Dim i As Long, j As Integer
'    With mshGrid
'        For i = 1 To mshGrid.Rows - 1
'            .Row = i
'            For j = 0 To mshGrid.Cols - 1
'                .col = j
'                If i Mod 2 = 1 Then
'                    .CellBackColor = vbInfoBackground
'                Else
'                    .CellBackColor = RGB(255, 255, 255)
'                End If
'            Next j
'            DoEvents '刷完每一行之后稍停
'        Next i
'        .Refresh
'    End With
End Sub

'设置图片预览，包括滚动条的显示与否
Public Sub MapPreview(ByRef picFather As PictureBox, _
        ByRef picChild As PictureBox, _
        ByRef fsbVertical As FlatScrollBar, _
        ByRef fsbHorizontal As FlatScrollBar)
On Error Resume Next
    '水平滚动条是否启用
    If picChild.ScaleWidth <= picFather.ScaleWidth Then
        fsbHorizontal.Enabled = False
        picChild.Left = (picFather.ScaleWidth - picChild.ScaleWidth) / 2
    Else
        fsbHorizontal.Enabled = True
        '启用水平滚动条
        fsbHorizontal.Min = 0
        fsbHorizontal.Max = picChild.ScaleWidth - picFather.ScaleWidth
        fsbHorizontal.Value = 0
        fsbHorizontal.SmallChange = IIf(Int(fsbHorizontal.Max / 20) < 1, 1, Int(fsbHorizontal.Max / 10))
        fsbHorizontal.LargeChange = IIf(5 * fsbHorizontal.SmallChange <= fsbHorizontal.Max, 5 * fsbHorizontal.SmallChange, fsbHorizontal.Max)
'        fsbHorizontal.LargeChange = IIf(picFather.ScaleWidth <= fsbHorizontal.Max, _
                picFather.ScaleWidth, fsbHorizontal.Max)
        picChild.Left = fsbHorizontal.Min
    End If
    
    '垂直滚动条是否启用
    If picChild.ScaleHeight <= picFather.ScaleHeight Then
        fsbVertical.Enabled = False
        picChild.Top = (picFather.ScaleHeight - picChild.ScaleHeight) / 2
    Else
        fsbVertical.Enabled = True
        '启用垂直滚动条
        fsbVertical.Min = 0
        fsbVertical.Max = picChild.ScaleHeight - picFather.ScaleHeight
        fsbVertical.Value = 0
        fsbVertical.SmallChange = IIf(Int(fsbVertical.Max / 10) < 1, 1, Int(fsbVertical.Max / 10))
        fsbVertical.LargeChange = IIf(5 * fsbVertical.SmallChange <= fsbVertical.Max, 5 * fsbVertical.SmallChange, fsbVertical.Max)
'        fsbVertical.LargeChange = IIf(picFather.ScaleHeight <= fsbVertical.Max, _
                picFather.ScaleHeight, fsbVertical.Max)
        picChild.Top = fsbVertical.Min
    End If
End Sub

'显示子窗体
Public Sub ShowForm(ByRef frmParent As Form, ByRef frmChild As Form, _
        Optional ByVal blnModal = vbModeless)
    frmParent.MousePointer = vbHourglass
    Load frmChild
    If frmChild.WindowState = 1 Then frmChild.WindowState = 0
'    frmChild.WindowState = 2
    frmChild.ZOrder 0
    frmParent.MousePointer = vbDefault
    frmChild.Show blnModal
End Sub

'显示提示消息
Public Sub ShowMessage(ByVal strMessage As String)
'    frmMessage.txtMessage.Text = strMessage
'    frmMessage.Show
'    frmMessage.ZOrder 0
End Sub

'显示状态信息
Public Sub ShowStatus(ByVal strMessage As String)
'    MDIForm1.StatusBar1.Panels(1).Text = strMessage
End Sub

'显示提示信息2
'该模态对话框可以自己关闭
Public Sub ShowDialog(ByVal strMessage As String)
'    dlgInformation.lblInformation = strMessage
'    dlgInformation.Show vbModal
End Sub

'把数字型变量变成定长字符串
Public Function LongToString(ByVal lngValue As Long, ByVal intLength As Integer) As String