frmconfig.frm

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

'ErrHandler:
'
'End Sub

'按钮事件----取消
Private Sub btnServerCancel_Click()
    Unload Me
End Sub

Private Sub btnServerOk_Click()
    If SetConnectConfig(strConfigFilePath) Then
        MsgBox "服务器连接配置成功!", vbInformation, "提示"
    Else
        MsgBox "服务器连接配置失败!", vbInformation, "提示"
    End If
End Sub

'HIS连接测试
Private Sub btnTestHis_Click()
    If TestHisConnection(Trim(txtHisDataSource.Text), Trim(txtHisUser.Text), Trim(txtHisPassword.Text)) Then
        MsgBox "HIS连接成功!", vbInformation, "提示"
    Else
        MsgBox "HIS连接失败, 原因：" + ERR_STRING, vbExclamation, "提示"
    End If
    
End Sub



'PACS连接测试
Private Sub btnTestPacs_Click()
    If TestPacsConnection(Trim(txtPacsDataSource.Text), Trim(txtPacsUser.Text), Trim(txtPacsPassword.Text)) Then
        MsgBox "PACS连接成功!", vbInformation, "提示"
    Else
        MsgBox "PACS连接失败, 原因：" + ERR_STRING, vbExclamation, "提示"
    End If
    
End Sub
'胶片FTP连接测试
Private Sub btnTestFtp_Click()
    If TestFTPConnection(Trim(txtDcmServerIP.Text), Trim(txtDcmServerPort.Text), Trim(txtFtpUser.Text), Trim(txtFtpPassword.Text)) Then
        MsgBox "胶片FTP服务器连接成功!", vbInformation, "提示"
    Else
        MsgBox "胶片FTP服务器连接失败, 原因：" + ERR_STRING, vbExclamation, "提示"
    End If
End Sub


Private Sub Command1_Click()

End Sub

'Private Sub btnTestReport_Click()
'    If TestReportConnection(Trim(txtReportDataSource.Text), "admin", Trim(txtReportPassword.Text)) Then
'        MsgBox "REPORT连接成功!", vbInformation, "提示"
'    Else
'        MsgBox "REPORT连接失败, 原因：" + ERR_STRING, vbExclamation, "提示"
'    End If
'End Sub

Private Sub Form_Load()
    On Error GoTo ErrHandler
    strConfigFilePath = App.Path + "\" + CONFIG_FILE_NAME
    strPrintConfigFilePath = App.Path + "\" + PRINT_CONFIG_FILE
    
    
    '配置文件不存在
    If Dir(strConfigFilePath, vbArchive Or vbSystem Or vbReadOnly Or vbHidden) = "" Then
        'strConfigFilePath = ""
        dlgOpenConfigFile.DialogTitle = "打开配置文件"
        dlgOpenConfigFile.DefaultExt = ".ini"
        dlgOpenConfigFile.ShowOpen
        If dlgOpenConfigFile.FileName <> "" Then
            strConfigFilePath = dlgOpenConfigFile.FileName
        End If
    End If
    
    '添加工作站列表
    Call InitCmbStationName(strConfigFilePath)
        
    '获取连接配置信息
    GetConnectConfig (strConfigFilePath)
    '获取工作站配置信息
    GetStationConfig (strConfigFilePath)
    '获取胶片打印机配置信息
    GetPrintInfo (strPrintConfigFilePath)
    
    stbConfig.Tab = 0
    Exit Sub
ErrHandler:
End Sub



'测试HIS连接
'pStrConfigPath:配置文件的路径
Public Function TestHisConnection(ByVal strHisDataSource As String, ByVal strHisUser As String, _
    ByVal strHisPassword As String) As Boolean
    On Error GoTo ErrHandler
    ERR_STRING = ""
    
    
    If strHisDataSource = "" Or strHisUser = "" Or strHisPassword = "" Then
        TestHisConnection = False
        Exit Function
    End If
    
    Dim HisConn As New ADODB.Connection
    Dim ConnectionString As String
    ConnectionString = DbType _
            + "Data Source=" + strHisDataSource _
            + ";User ID=" + strHisUser _
            + ";Password=" + strHisPassword + ""
    
    HisConn.Open ConnectionString
    
    If HisConn.State = adStateOpen Then
        HisConn.Close
        Set HisConn = Nothing
    Else
        TestHisConnection = False
        Exit Function
    
    End If
    
    
    TestHisConnection = True
    Exit Function
ErrHandler:
    ERR_STRING = Err.Description
    TestHisConnection = False
End Function



'测试PACS连接
'pStrConfigPath:配置文件的路径
Public Function TestPacsConnection(ByVal strPacsDataSource As String, ByVal strPacsUser As String, _
    ByVal strPacsPassword As String) As Boolean
    On Error GoTo ErrHandler
    ERR_STRING = ""
    
    
    If strPacsDataSource = "" Or strPacsUser = "" Or strPacsPassword = "" Then
        TestPacsConnection = False
        Exit Function
    End If
    
    Dim pacsConn As New ADODB.Connection
    Dim ConnectionString As String
    ConnectionString = DbType _
            + "Data Source=" + strPacsDataSource _
            + ";User ID=" + strPacsUser _
            + ";Password=" + strPacsPassword + ""
    
    pacsConn.Open ConnectionString
    
    If pacsConn.State = adStateOpen Then
        pacsConn.Close
        Set pacsConn = Nothing
    Else
        TestPacsConnection = False
        Exit Function
    
    End If
    
    
    TestPacsConnection = True
    Exit Function
ErrHandler:
    ERR_STRING = Err.Description
    TestPacsConnection = False
End Function

'测试报表数据库连接
'pStrConfigPath:配置文件的路径
Public Function TestReportConnection(ByVal strReportDataSource As String, ByVal strReportUser As String, _
    ByVal strReportPassword As String) As Boolean
    On Error GoTo ErrHandler
    ERR_STRING = ""
    
    
    If strReportDataSource = "" Or strReportUser = "" Or strReportPassword = "" Then
        TestReportConnection = False
        Exit Function
    End If
    
    Dim ReportConn As New ADODB.Connection
    Dim ConnectionString As String
    ConnectionString = DbAccess _
            + "Data Source=" + strReportDataSource + ";" _
            + "Jet OLEDB:Database Password=" + strReportPassword + ";"
    
    ReportConn.Open ConnectionString
    
    If ReportConn.State = adStateOpen Then
        ReportConn.Close
        Set ReportConn = Nothing
    Else
        TestReportConnection = False
        Exit Function
    
    End If
    
    
    TestReportConnection = True
    Exit Function
ErrHandler:
    ERR_STRING = Err.Description
    TestReportConnection = False
End Function


'测试胶片FTP服务器连接
'pStrConfigPath:配置文件的路径

Public Function TestFTPConnection(ByVal strDcmServerIP As String, ByVal strDcmServerPort As String, _
    ByVal strFtpUser As String, ByVal strFtpPassword As String) As Boolean

    ERR_STRING = ""
    
    If strDcmServerIP = "" Or strDcmServerPort = "" Or strFtpUser = "" Or strFtpPassword = "" Then
        TestFTPConnection = False
        Exit Function
    End If
    
    Dim lngINet As Long
    Dim lngINetConn As Long
    Dim blnRC As Boolean

    btnTestFtp.Enabled = False
    btnTestFtp.Caption = "请等待"
    
    
    On Error GoTo ErrHandler
    
    lngINet = InternetOpen("FTP Control", 1, vbNullString, vbNullString, 0)
    If lngINet = 0 Then
        ERR_STRING = "本地系统缺少组建支持，请联系管理员！"
        TestFTPConnection = False
    Else
        lngINetConn = InternetConnect(lngINet, strDcmServerIP, strDcmServerPort, _
    strFtpUser, strFtpPassword, 1, 0, 0)
        If lngINetConn = 0 Then
            ERR_STRING = "请检查，FTP服务器是否已开启，相关设置是否正确！"
            TestFTPConnection = False
        Else
'            blnRC = FtpGetFile(lngINetConn, "projects\82projects相关\pacs文档--82\PACS操作手册.doc", "E:\工作\PACS操作手册.doc", 0, 0, 1, 0)
'
'            If blnRC Then
'                MsgBox "received in e:\"
'            Else
'                MsgBox "received failed"
'            End If
            TestFTPConnection = True
        End If
        
        InternetCloseHandle lngINetConn

    End If
    
    InternetCloseHandle lngINet
        
    btnTestFtp.Enabled = True
    btnTestFtp.Caption = "测试"

    Exit Function
ErrHandler:
    ERR_STRING = Err.Description
    TestFTPConnection = False
    InternetCloseHandle lngINetConn
    InternetCloseHandle lngINet
    btnTestFtp.Enabled = True
    btnTestFtp.Caption = "测试"
End Function





'获取服务器连接配置
'pStrConfigPath:配置文件路径
Private Function GetConnectConfig(ByVal pStrConfigPath As String) As Boolean
On Error GoTo ErrHandler
    '=获取HIS连接信息========================================================
    Dim strHisDataSource As String
    strHisDataSource = Space(256)
    Dim nRet As Long
    nRet = GetPrivateProfileString(SECTION_CONNECTION, "HIS_DATA_SOURCE", "", strHisDataSource, _
        256, pStrConfigPath)
    strHisDataSource = left(strHisDataSource, nRet)
    txtHisDataSource.Text = Trim(strHisDataSource)
    
    Dim strHisUser As String
    strHisUser = GetConnectionArg(regkey, HIS_REG_KEY_USER)
    strHisUser = PacsDecrypt(strHisUser)
    txtHisUser.Text = strHisUser
    
    Dim strHisPassword As String
    strHisPassword = GetConnectionArg(regkey, HIS_REG_KEY_PASSWORD)
    strHisPassword = PacsDecrypt(strHisPassword)
    txtHisPassword.Text = strHisPassword
    
    
    '=获取PACS连接信息========================================================
    Dim strPacsDataSource As String
    strPacsDataSource = Space(256)
    
    nRet = GetPrivateProfileString(SECTION_CONNECTION, KEY_PACS_DATA_SOURCE, "", strPacsDataSource, _
        256, pStrConfigPath)
    strPacsDataSource = left(strPacsDataSource, nRet)
    txtPacsDataSource.Text = Trim(strPacsDataSource)
    
    Dim strPacsUser As String
    strPacsUser = GetConnectionArg(regkey, PACS_REG_KEY_USER)
    strPacsUser = PacsDecrypt(strPacsUser)
    txtPacsUser.Text = strPacsUser
    
    Dim strPacsPassword As String
    strPacsPassword = GetConnectionArg(regkey, PACS_REG_KEY_PASSWORD)
    strPacsPassword = PacsDecrypt(strPacsPassword)
    txtPacsPassword.Text = strPacsPassword

    '=获取REPORT连接信息========================================================
    Dim strReportDataSource As String
    strReportDataSource = Space(256)
    
    nRet = GetPrivateProfileString(SECTION_CONNECTION, KEY_REPORT_DATA_SOURCE, "", strReportDataSource, _
        256, pStrConfigPath)
    strReportDataSource = left(strReportDataSource, nRet)
'    txtReportDataSource.Text = Trim(strReportDataSource)
    
'    Dim strPacsUser As String
'    strPacsUser = GetConnectionArg(regkey, PACS_REG_KEY_USER)
'    strPacsUser = PacsDecrypt(strPacsUser)
'    txtPacsUser.Text = strPacsUser
    
    Dim strReportPassword As String
    strReportPassword = GetConnectionArg(regkey, REPORT_REG_KEY_PASSWORD)
    strReportPassword = PacsDecrypt(strReportPassword)
'    txtReportPassword.Text = strReportPassword

    
    Dim strReportInUse As String
    strReportInUse = Space(256)
    nRet = GetPrivateProfileString(SECTION_CONNECTION, KEY_REPORT_IN_USE, "", strReportInUse, _
        256, pStrConfigPath)
    strReportInUse = left(strReportInUse, nRet)
    If (Trim(strReportInUse) = KEY_REPORT_IN_USE) Then
'        chkInUse.Value = 1
    Else
'        chkInUse.Value = 0
    End If