modinspublic.bas

医院门诊医生工作站,vb6 SqlServer

Attribute VB_Name = "ModInspublic"
Private Declare Function StartPolicy Lib "fyfj.dll" (ByVal MyShowProgress As Long) As Integer
Private Declare Function Get_ErrInfo Lib "fyfj.dll" (ByVal ErrInfoStr As String) As Integer
Private Declare Function StopPolicy Lib "fyfj.dll" () As Integer
Private Declare Function Get_SumInfo Lib "fyfj.dll" (ByVal SumInfo As String) As Integer
Private Declare Function Get_SumInfo2 Lib "fyfj.dll" (ByVal PersonInfo As String, ByVal SumInfo As String) As Integer
Private Declare Function Divide Lib "fyfj.dll" (ByVal InputStr As String, ByVal OutputStr As String) As Long
Private Declare Function Spec_Divide Lib "fyfj.dll" (ByVal InputStr As String) As Long ', ByVal OutputStr As String) As Long
Private Declare Function Spec_Divide2 Lib "fyfj.dll" (ByVal InputStr As String, ByVal OutputStr As String) As Long
Public Declare Function Hosp_Divide Lib "fyfj.dll" (ByVal InputStr As String) As Long
Public Declare Function Hosp_Divide2 Lib "fyfj.dll" (ByVal InputStr As String) As Long
Public Declare Function Home_Divide Lib "fyfj.dll" (ByVal InputStr As String) As Long
Public Declare Function Home_Divide2 Lib "fyfj.dll" (ByVal InputStr As String, ByVal OutputStr As String) As Long
Public Declare Function Get_Ver Lib "fyfj.dll" (ByVal DllVer As String, ByVal DateVer As String) As Long
Public Declare Function RegOpenKey Lib "advapi32.dll" Alias "RegOpenKeyA" (ByVal HKey As Long, ByVal lpSubKey As String, phkResult As Long) As Long
Public Declare Function RegQueryValueEx Lib "advapi32.dll" Alias "RegQueryValueExA" (ByVal HKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, lpType As Long, lpData As Any, lpcbData As Long) As Long         ' Note that if you declare the lpData parameter as String, you must pass it By Value.
Private Declare Function compress Lib "capinfocab.dll" (ByVal strSourcePath As String, ByVal strTargetPath As String, ByVal strFileName As String) As Integer
Private Declare Function uncompress Lib "capinfocab.dll" (ByVal strZipFilePath As String, ByVal strZipFileName As String, ByVal strTargetPath As String) As Integer
Public Declare Function GetPersonCommInfo Lib "fyfj.dll" (ByVal PersonInfo As String) As Integer
Public Declare Function Reg Lib "fyfj.dll" (ByVal InputStr As String, ByVal OutputStr As String) As Long
Public Const REG_SZ = 1
Public Const REG_DWORD = 4
Public Const HKEY_CLASSES_ROOT = &H80000000
Public Const HKEY_CURRENT_USER = &H80000001
Public Const HKEY_LOCAL_MACHINE = &H80000002
Public Const HKEY_USERS = &H80000003
Public Const HKEY_PERFORMANCE_DATA = &H80000004
Public Const ERROR_SUCCESS = 0&
Public Function RegSub(ByVal InputStr As String) As String
    Dim OutputStr As String * 200
    Dim ErrInfoStr As String * 200
    Dim Iflag As Integer
    Dim Jflag As Integer
    OutputStr = Space(200)
    ErrInfoStr = Space(200)
    Iflag = Reg(InputStr, OutputStr)
    If Iflag = 0 Then
        RegSub = OutputStr
    Else
        Jflag = Get_ErrInfo(ErrInfoStr)
        RegSub = "A" & ErrInfoStr
    End If
End Function
Public Function GetPersonCommInfoSub() As String
    Dim OutputStr As String * 400
    Dim ErrInfoStr As String * 200
    Dim Iflag As Integer
    Dim Jflag As Integer
    
    OutputStr = Space(400)
    ErrInfoStr = Space(200)
    Iflag = GetPersonCommInfo(OutputStr)
    If Iflag = 0 Then
        GetPersonCommInfoSub = OutputStr
        gErrInfo = "成功"
    Else
        Jflag = Get_ErrInfo(ErrInfoStr)
        gErrInfo = ErrInfoStr
        MsgBox ErrInfoStr, vbCritical, "错误"
    End If
End Function
Public Function Get_SumInfo2Sub(ByVal InputStr As String) As String
    Dim OutputStr As String * 200
    Dim Iflag As Integer
    Dim Jflag As Integer
    Dim ErrInfoStr As String * 200
    OutputStr = Space(200)
    ErrInfoStr = Space(200)
    
    Iflag = Get_SumInfo2(InputStr, OutputStr)
    If Iflag = 0 Then
        Get_SumInfo2Sub = OutputStr
        gErrInfo = "成功"
    Else
        Jflag = Get_ErrInfo(ErrInfoStr)
        'MsgBox Trim(ErrInfoStr), vbExclamation, "分解错误"
        gErrInfo = ErrInfoStr
    End If
End Function

Public Sub UN_Compress()
    Dim i As Integer
    Dim S As String * 100
    'Dim S As String
    Dim tmp1, tmp2, tmp3 As String
    S = Space(100)
    tmp1 = "D:\capinfo\测试用例\下载文件样本\增加\temp\"
    tmp2 = "D:\capinfo\测试用例\下载文件样本\增加\"
    
    i = compress("D:\capinfo\测试用例\下载文件样本\删除\temp", "D:\capinfo\测试用例\下载文件样本\删除", S)
    i = uncompress("D:\capinfo\测试用例\下载文件样本\增加", "download_04110002_20011110.dat", "D:\capinfo\测试用例\下载文件样本\增加")
End Sub

Public Function InitFile()
    Dim StrFile As String
    StrFile = left(InitPath, Len(InitPath) - 1)
    If Dir(StrFile + "home_divide.in") = "" Then
        Open (StrFile + "home_divide.in") For Random As #1
        Close #1
    End If
    If Dir(StrFile + "home_divide.out") = "" Then
        Open (StrFile + "home_divide.out") For Random As #1
        Close #1
    End If
    If Dir(StrFile + "hosp_divide.in") = "" Then
        Open (StrFile + "hosp_divide.in") For Random As #1
        Close #1
    End If
    If Dir(StrFile + "hosp_divide.out") = "" Then
        Open (StrFile + "hosp_divide.out") For Random As #1
        Close #1
    End If
    If Dir(StrFile + "hosp_fee.in") = "" Then
        Open (StrFile + "hosp_fee.in") For Random As #1
        Close #1
    End If
    If Dir(StrFile + "spec_divide.in") = "" Then
        Open (StrFile + "spec_divide.in") For Random As #1
        Close #1
    End If
    If Dir(StrFile + "spec_divide.out") = "" Then
        Open (StrFile + "spec_divide.out") For Random As #1
        Close #1
    End If
End Function
Public Function GetString(HKey As Long, ByVal StrPath As String, ByVal StrSubValue As String) As String
    Dim keyhand As Long
    Dim DataType As Long
    Dim lresult As Long
    Dim strbuf As String
    Dim ldatabufsize As Long
    Dim intzeropos As Integer
    r = RegOpenKey(HKey, StrPath, keyhand)
    result = RegQueryValueEx(keyhand, StrSubValue, 0&, lvaluetype, ByVal 0&, ldatabufsize)
    If lvaluetype = REG_SZ Then
        strbuf = String(ldatabufsize, " ")
        lresult = RegQueryValueEx(keyhand, StrSubValue, 0&, 0&, ByVal strbuf, ldatabufsize)
        If lresult = ERROR_SUCCESS Then
            intzeropos = InStr(strbuf, Chr(0))
            If intzeropos > 0 Then
                GetString = left(strbuf, Len(strbuf))
            Else
                GetString = strbuf
            End If
        End If
    End If
End Function
Public Function InitPath() As String
    InitPath = GetString(&H80000002, "Software\Capinfo\BJYB\HOSPClient", _
        "Swap_path")
End Function

Public Function Get_VerSub() As String
    Dim OutPutStr1 As String * 200
    Dim OutPutStr2 As String * 200
    Dim ErrInfoStr As String * 200
    Dim Iflag As Integer
    Dim Jflag As Integer
    OutPutStr1 = Space(200)
    OutPutStr2 = Space(200)
    ErrInfoStr = Space(200)
    Iflag = Get_Ver(OutPutStr1, OutPutStr2)
    If Iflag = 0 Then
        Get_VerSub = "动态库版本号：" & OutPutStr1 & "数据包版本号：" & OutPutStr2
        MsgBox "版本号取得成功！", vbInformation, "成功"
    Else
        Jflag = Get_ErrInfo(ErrInfoStr)
        MsgBox Trim(ErrInfoStr), vbCritical, "分解失败"
    End If
End Function
Public Function Home_Divide2Sub(ByVal PutStr As String) As String
    Dim InputStr As String
    Dim OutputStr As String * 200
    Dim ErrInfoStr As String * 200
    Dim Iflag As Integer
    Dim Jflag As Integer
    OutputStr = Space(200)
    ErrInfoStr = Space(200)
    InputStr = PutStr
    Iflag = Home_Divide2(InputStr, OutputStr)
    If Iflag = 0 Then
        Home_Divide2Sub = OutputStr
'        MsgBox "分解成功", vbInformation, "分解"
    Else
        Jflag = Get_ErrInfo(ErrInfoStr)
'        MsgBox Trim(ErrInfoStr), vbCritical, "分解失败"
    End If
End Function

Public Function Home_DivideSub(ByVal PutStr As String) As String
    Dim InputStr As String
    Dim ErrInfoStr As String * 200
    Dim Iflag As Integer
    Dim Jflag As Integer
    ErrInfoStr = Space(200)
    InputStr = PutStr
    Iflag = Home_Divide(InputStr)
    If Iflag = 0 Then
 '       MsgBox "分解成功", vbInformation, "分解"
    Else
       ErrInfoStr = Get_ErrInfo(ErrInfoStr)
       MsgBox Trim(ErrInfoStr), vbCritical, "分解失败"
    End If
End Function
Public Function Hosp_Divide2Sub(ByVal PutStr As String) As Boolean
    Dim InputStr As String
    Dim ErrInfoStr As String * 200
    Dim Iflag As Integer
    Dim Lflag As Integer
    ErrInfoStr = Space(200)
    InputStr = ""
    InputStr = PutStr
    Iflag = Hosp_Divide2(InputStr)
    If Iflag = 0 Then
        'MsgBox "分解成功", vbInformation, "分解"
        Hosp_Divide2Sub = True
        gErrInfo = "成功"
    Else
        Lflag = Get_ErrInfo(ErrInfoStr)
        'MsgBox Trim(ErrInfoStr), vbCritical, "分解失败"
        gErrInfo = ErrInfoStr
        Hosp_Divide2Sub = False
    End If
End Function
Public Function Hosp_DivideSub(ByVal PutStr As String) As String
    Dim InputStr As String
    Dim ErrInfoStr As String * 200
    'Dim OutputStr As String * 200
    Dim Iflag As Integer
    Dim Lflag As Integer
    InputStr = PutStr
    'OutputStr = Space(200)
    ErrInfoStr = Space(200)
    Iflag = Hosp_Divide(InputStr)
    If Iflag = 0 Then
        'Hosp_divideSub = OutputStr
        MsgBox "分解成功", vbInformation, "分解"
    Else
        Jflag = Get_ErrInfo(ErrInfoStr)
        MsgBox Trim(ErrInfoStr), vbCritical, "分解失败"
    End If
End Function

Public Function Spec_Divide2Sub(ByVal PutStr As String) As String
    Dim InputStr As String
    Dim OutputStr As String * 200
    Dim ErrInfoStr As String * 200
    Dim Iflag As Integer
    Dim Jflag As Integer
    InputStr = ""
    InputStr = PutStr
    OutputStr = Space(200)
    ErrInfoStr = Space(200)
    Iflag = Spec_Divide2(InputStr, OutputStr)
    If Iflag = 0 Then
        Spec_Divide2Sub = Trim(OutputStr)
        MsgBox "分解成功", vbInformation, "分解"
    Else
        Jflag = Get_ErrInfo(ErrInfoStr)
        MsgBox Trim(ErrInfoStr), vbCritical, "分解失败"
    End If
End Function
Public Function Spec_DivideSub(ByVal PutStr As String) As String
    Dim InputStr As String
    'Dim OutputStr As String * 200
    Dim OutStr1 As String * 200
    Dim ErrInfoStr As String * 200
    Dim Iflag As Integer
    Dim Jflag As Integer
    
    'OutputStr = Space(200)
    OutStr1 = Space(200)
    ErrInfoStr = Space(200)
    InputStr = PutStr
    Iflag = Spec_Divide(InputStr) ', OutputStr)
    If Iflag = 0 Then
        'Spec_DivideSub = Trim(OutStr1) 'OutputStr
        MsgBox "分解成功", vbInformation, "分解"
    Else
        Jflag = Get_ErrInfo(errinofstr)
        MsgBox Str(Jflag) + "分解失败", vbCritical, "分解"
    End If
End Function
Public Function DivideSub(ByVal PutStr As String) As String
    Dim InputStr As String
    Dim OutputStr As String * 200
    Dim DivideFlag As Integer
    Dim Jflag As Integer
    Dim ErrInfoStr As String * 200
    ErrInfoStr = Space(200)
    OutputStr = Space(200)
    InputStr = PutStr
    DivideFlag = Divide(InputStr, OutputStr)
    If DivideFlag = -1 Then
        Jflag = Get_ErrInfo(ErrInfoStr)
        'MsgBox "分解失败" + ErrInfoStr, vbCritical, "分解"
    Else
        'MsgBox "分解成功", vbCritical, "分解"
        DivideSub = Trim(OutputStr)
    End If
    
End Function

Public Function Get_SumInfoSub() As String
    Dim OutStr1 As String * 200
    Dim ErrInfoStr As String * 200
    Dim Iflag As Integer
    Dim Jflag As Integer
    OutStr1 = Space(200)
    ErrInfoStr = Space(200)
    Iflag = Get_SumInfo(OutStr1)
    If Iflag = 0 Then
        Get_SumInfoSub = Trim(OutStr1)
        gErrInfo = "成功"
        'MsgBox "分解成功", vbExclamation, "分解"
    Else
        Jflag = Get_ErrInfo(ErrInfoStr)
        gErrInfo = ErrInfoStr
        MsgBox Trim(ErrInfoStr), vbExclamation, "错误"
    End If
End Function
Public Function StartPolicySub() As Integer  '调用StartPolicy函数，同时穿插Get_ErrInfo函数
    Dim StartFlag As Integer
    Dim ErrInfoStr As String * 200
    Dim i As Integer
    
    ErrInfoStr = Space(200)  '一定要开空间
    i = StopPolicy
    
    StartFlag = StartPolicy(AddressOf MyShowProgress)
    
    If StartFlag <> 0 Then
        i = Get_ErrInfo(ErrInfoStr)
        If i = 0 Then
            StartPolicySub = -1
        Else
            StartPolicySub = i
        End If
        
'        MsgBox "启动 StartPolicy 函数失败" & vbCrLf & "错误代码 " & StartFlag & vbCrLf & Trim(ErrInfoStr), vbExclamation, "启动失败"
'        I = StopPolicy
    Else
        StartPolicySub = 0
    End If
End Function
'回调函数
Public Sub MyShowProgress(ByVal i As Integer)
  'ProgressBar1.Value = I   '显示当前分解进度
End Sub
Public Function StopPolicySub() As Integer
    Dim StopFlag As Integer
    Dim ErrInfoStr As String * 200
    Dim i As Integer
    ErrInfoStr = Space(200)
    StopFlag = StopPolicy
    If StopFlag <> 0 Then
        i = Get_ErrInfo(ErrInfoStr)
        StopPolicySub = i
    Else
        StopPolicySub = 0
    End If
End Function