frmconfig.frm

1、以DLL形式提供医生工作站 2、 根据【检查项目】

    
    
    GetConnectConfig = True
    Exit Function
ErrHandler:
    GetConnectConfig = False
End Function


'保存连接配置信息
'pStrConfigPath:配置文件路径
Private Function SetConnectConfig(ByVal pStrConfigPath As String) As Boolean
On Error GoTo ErrHandler
    ERR_STRING = ""

    '=保存HIS连接信息========================================================
    Dim nRet As Long
    nRet = WritePrivateProfileString(SECTION_CONNECTION, KEY_HIS_DATA_SOURCE, _
        Trim(txtHisDataSource.Text), strConfigFilePath)
    If nRet = 0 Then
        'MsgBox "数据库连接配置保存失败, 请与系统管理", vbExclamation, "提示"
        SetConnectConfig = False
        Exit Function
    End If
    
    SetConnectionArg HIS_REG_KEY_USER, PacsEncrypt(Trim(txtHisUser.Text))
    SetConnectionArg HIS_REG_KEY_PASSWORD, PacsEncrypt(Trim(txtHisPassword.Text))
    
        '=保存PACS连接信息========================================================

    nRet = WritePrivateProfileString(SECTION_CONNECTION, KEY_PACS_DATA_SOURCE, _
        Trim(txtPacsDataSource.Text), strConfigFilePath)
    If nRet = 0 Then
        'MsgBox "数据库连接配置保存失败, 请与系统管理", vbExclamation, "提示"
        SetConnectConfig = False
        Exit Function
    End If
    
    SetConnectionArg PACS_REG_KEY_USER, PacsEncrypt(Trim(txtPacsUser.Text))
    SetConnectionArg HIS_REG_KEY_PASSWORD, PacsEncrypt(Trim(txtPacsPassword.Text))
    
    
        '=保存REPORT连接信息========================================================

'    nRet = WritePrivateProfileString(SECTION_CONNECTION, KEY_REPORT_DATA_SOURCE, _
'        Trim(txtReportDataSource.Text), strConfigFilePath)
'    If nRet = 0 Then
'        'MsgBox "数据库连接配置保存失败, 请与系统管理", vbExclamation, "提示"
'        SetConnectConfig = False
'        Exit Function
'    End If
    
'    SetConnectionArg PACS_REG_KEY_USER, PacsEncrypt(Trim(txtPacsUser.Text))
'    SetConnectionArg REPORT_REG_KEY_PASSWORD, PacsEncrypt(Trim(txtReportPassword.Text))
    
'    Dim strReportInUse As String
'    If chkInUse.Value = 1 Then
'        strReportInUse = KEY_REPORT_IN_USE
'    Else
'        strReportInUse = ""
'    End If
'    nRet = WritePrivateProfileString(SECTION_CONNECTION, KEY_REPORT_IN_USE, _
'        strReportInUse, strConfigFilePath)
    If nRet = 0 Then
        'MsgBox "数据库连接配置保存失败, 请与系统管理", vbExclamation, "提示"
        SetConnectConfig = False
        Exit Function
    End If
    
    SetConnectConfig = True
    
    
    Exit Function
ErrHandler:
    ERR_STRING = Err.Description
    SetConnectConfig = False
End Function

'获取工作站配置
'pStrConfigPath:配置文件的路径
Private Function GetStationConfig(ByVal pStrConfigPath As String) As Boolean
On Error GoTo ErrHandler
    Dim nRet As Long
'    Dim strHospitalName As String
'    strHospitalName = Space(256)
'    nRet = GetPrivateProfileString(SECTION_WORKSTATION, KEY_HOSPITAL_NAME, "", strHospitalName, _
'        256, pStrConfigPath)
'    strHospitalName = Left(strHospitalName, nRet)
'    If Trim(strHospitalName) <> "" Then
'        txtHospitalName.Text = Trim(strHospitalName)
'    End If
'---??????
    Dim strStationName As String
    strStationName = Space(256)
    nRet = GetPrivateProfileString(SECTION_WORKSTATION, KEY_STATION_NAME, "", strStationName, _
        256, pStrConfigPath)

    strStationName = left(strStationName, nRet)
    If Trim(strStationName) <> "" Then
        txtStationName.Text = Trim(strStationName)
    End If
    
    Dim ii As Integer
    Dim iListIndex As Integer
    iListIndex = -1
    For ii = 0 To cmbStationName.ListCount - 1
        cmbStationName.ListIndex = ii
        If Trim(strStationName) = cmbStationName.Text Then
            iListIndex = ii
            Exit For
        End If
    Next


    '====影像设备接收端口============================================================
    Dim strDcmReceivePort As String
    strDcmReceivePort = Space(256)
    nRet = GetPrivateProfileString(SECTION_WORKSTATION, KEY_DICOM_RECEIVE_PORT, "", strDcmReceivePort, _
        256, pStrConfigPath)
    strDcmReceivePort = left(strDcmReceivePort, nRet)
    If Trim(strDcmReceivePort) <> "" Then
        txtDcmReceivePort.Text = Trim(strDcmReceivePort)
    End If

    '====胶片服务器IP地址============================================================
    Dim strDcmServerIP As String
    strDcmServerIP = Space(256)
    nRet = GetPrivateProfileString(SECTION_WORKSTATION, KEY_DCM_SERVER_IP, "", strDcmServerIP, _
        256, pStrConfigPath)
    strDcmServerIP = left(strDcmServerIP, nRet)
    If Trim(strDcmServerIP) <> "" Then
        txtDcmServerIP.Text = Trim(strDcmServerIP)
    End If


    Dim strFtpUser As String
    strFtpUser = GetConnectionArg(regkey, FTP_REG_KEY_USER)
    strFtpUser = PacsDecrypt(strFtpUser)
    txtFtpUser.Text = strFtpUser
    
    Dim strFtpPassword As String
    strFtpPassword = GetConnectionArg(regkey, FTP_REG_KEY_PASSWORD)
    strFtpPassword = PacsDecrypt(strFtpPassword)
    txtFtpPassword.Text = strFtpPassword



    '====胶片服务器端口============================================================
    Dim strDcmServerPort As String
    strDcmServerPort = Space(256)
    nRet = GetPrivateProfileString(SECTION_WORKSTATION, KEY_DCM_SERVER_PORT, "", strDcmServerPort, _
        256, pStrConfigPath)
    strDcmServerPort = left(strDcmServerPort, nRet)
    If Trim(strDcmServerPort) <> "" Then
        txtDcmServerPort.Text = Trim(strDcmServerPort)
    End If

    '====胶片本地存放根目录============================================================
    Dim strDcmRoot As String
    strDcmRoot = Space(256)
    nRet = GetPrivateProfileString(SECTION_WORKSTATION, KEY_DCM_LOCAL_ROOT, "", strDcmRoot, _
        256, pStrConfigPath)
    strDcmRoot = left(strDcmRoot, nRet)
    If Trim(strDcmRoot) <> "" Then
        txtDcmRoot.Text = Trim(strDcmRoot)
    End If
    
    '====胶片本地临时存放根目录============================================================
    Dim strTempDcmRoot As String
    strTempDcmRoot = Space(256)
    nRet = GetPrivateProfileString(SECTION_WORKSTATION, KEY_TEMPDCM_LOCAL_ROOT, "", strTempDcmRoot, _
        256, pStrConfigPath)
    strTempDcmRoot = left(strTempDcmRoot, nRet)
    If Trim(strTempDcmRoot) <> "" Then
        txtTempDcmRoot.Text = Trim(strTempDcmRoot)
    End If

    GetStationConfig = True
    Exit Function
ErrHandler:
    GetStationConfig = False
End Function


'设置工作站配置
'pStrConfigPath:配置文件的路径
'工作站名称应与数据库中的MACHINE表的NAME字段一致
'登记系统的工作站名称则不需要与数据库一致
Private Function SetStationConfig(ByVal pStrConfigPath As String) As Boolean
    On Error GoTo ErrHandler
    HOSPITALNAME = getHospitalName()
    
    
    If HOSPITALNAME = "" Then
        MsgBox "医院名称未设置，请通知管理员!", vbInformation, "提示"
        SetStationConfig = False
        Exit Function
    End If

    Dim nRet As Long
    nRet = WritePrivateProfileString(SECTION_WORKSTATION, KEY_HOSPITAL_NAME, _
        HOSPITALNAME, pStrConfigPath)
    If nRet = 0 Then
        'MsgBox "数据库连接配置保存失败, 请与系统管理", vbExclamation, "提示"
        SetStationConfig = False
        Exit Function
    End If
'--?????

    nRet = WritePrivateProfileString(SECTION_WORKSTATION, KEY_DCM_SERVER_IP, _
        Trim(txtDcmServerIP.Text), pStrConfigPath)
    If nRet = 0 Then
        'MsgBox "胶片FTP服务连接配置保存失败, 请与系统管理", vbExclamation, "提示"
        SetStationConfig = False
        Exit Function
    End If
    
    nRet = WritePrivateProfileString(SECTION_WORKSTATION, KEY_DCM_SERVER_PORT, _
        Trim(txtDcmServerPort.Text), pStrConfigPath)
    If nRet = 0 Then
        'MsgBox "胶片FTP服务连接配置保存失败, 请与系统管理", vbExclamation, "提示"
        SetStationConfig = False
        Exit Function
    End If
    
    nRet = WritePrivateProfileString(SECTION_WORKSTATION, KEY_STATION_NAME, _
        Trim(cmbStationName.Text), pStrConfigPath)
    If nRet = 0 Then
        'MsgBox "工作站配置保存失败, 请与系统管理", vbExclamation, "提示"
        SetStationConfig = False
        Exit Function
    End If
        
    SetConnectionArg FTP_REG_KEY_USER, PacsEncrypt(Trim(txtFtpUser.Text))
    SetConnectionArg FTP_REG_KEY_PASSWORD, PacsEncrypt(Trim(txtFtpPassword.Text))
    
    nRet = WritePrivateProfileString(SECTION_WORKSTATION, KEY_DCM_LOCAL_ROOT, _
    Trim(txtDcmRoot.Text), pStrConfigPath)
    If nRet = 0 Then
        'MsgBox "工作站配置保存失败, 请与系统管理", vbExclamation, "提示"
        SetStationConfig = False
        Exit Function
    End If
        
    nRet = WritePrivateProfileString(SECTION_WORKSTATION, KEY_TEMPDCM_LOCAL_ROOT, _
    Trim(txtTempDcmRoot.Text), pStrConfigPath)
    If nRet = 0 Then
        'MsgBox "工作站配置保存失败, 请与系统管理", vbExclamation, "提示"
        SetStationConfig = False
        Exit Function
    End If
    
    SetStationConfig = True
    Exit Function
ErrHandler:
    SetStationConfig = False
End Function








'获取打印机配置信息
Private Sub GetPrintInfo(ByVal pStrConfigFilePath)
On Error GoTo ErrHandler

    Dim nRet As Long
'    strConfigFilePath = App.Path + "\" + PRINT_CONFIG_FILE
    Dim strDescription As String
    strDescription = Space(256)
    
    'DESCRIPTION
    nRet = GetPrivateProfileString(SECTION_PRINT_CONFIG_PRINT, "Description", "", _
        strDescription, 256, pStrConfigFilePath)

    If nRet > 0 Then
        strDescription = left(strDescription, nRet)
    End If
'    txtDescription.Text = strDescription


    'IP地址
    Dim strIp As String
    strIp = Space(256)
    nRet = GetPrivateProfileString(SECTION_PRINT_CONFIG_PRINT, "Hostname", "", _
        strIp, 256, pStrConfigFilePath)

    If nRet > 0 Then
        strIp = left(strIp, nRet)
    End If
'    txtIp.Text = strIp
    
    'PORT
    Dim strPort As String
    strPort = Space(256)
    nRet = GetPrivateProfileString(SECTION_PRINT_CONFIG_PRINT, "Port", "", _
        strPort, 256, pStrConfigFilePath)
    
    If nRet > 0 Then
        strPort = left(strPort, nRet)
    End If
'    txtPort.Text = strPort
    
    'Called AE
    Dim strCalledAe As String
    strCalledAe = Space(256)
    nRet = GetPrivateProfileString(SECTION_PRINT_CONFIG_PRINT, "Aetitle", "", _
        strCalledAe, 256, pStrConfigFilePath)
    If nRet > 0 Then
        strCalledAe = left(strCalledAe, nRet)
    End If
'    txtCalledAe.Text = strCalledAe
    
    'Calling AE
    Dim strCallingAE As String
    strCallingAE = Space(256)
    nRet = GetPrivateProfileString(SECTION_PRINT_CONFIG_NETWORK, "aetitle", "", _
        strCallingAE, 256, pStrConfigFilePath)
    If nRet > 0 Then
        strCallingAE = left(strCallingAE, nRet)
    End If
'    txtCallingAe.Text = strCallingAE
    
    
    If Dir(App.Path + "\" + DCM_PRINT_TEST, vbArchive Or vbSystem Or vbReadOnly Or vbHidden) <> "" Then
'        txtDcmPath.Text = App.Path + "\" + DCM_PRINT_TEST
    End If
    

    Exit Sub
ErrHandler:
    

End Sub




Private Function getHospitalName() As String
    On Error GoTo ErrHandler
        '=获取PACS连接信息========================================================
    Dim strPacsDataSource As String
    strPacsDataSource = Space(256)
    
    Dim nRet As Long
    nRet = GetPrivateProfileString(SECT