moddcmpath.bas

来自「1、以DLL形式提供医生工作站 2、 根据【检查项目】」· BAS 代码 · 共 96 行

Attribute VB_Name = "modDcmPath"
'----------------------------------------------------------------------------------------------------
'文件：modDcmPath.bas
'作者：冷家锋
'时间：2008-4-10
'说明：当前检查病人相关信息
'----------------------------------------------------------------------------------------------------


Option Explicit


'由相对路径得到绝对路径--Local
Public Function GetAbsolutePath(SERVER_IP As String, strPart As String) As String
On Error GoTo ErrHandler
        GetAbsolutePath = SERVER_IP
        If Right(SERVER_IP, 1) <> "\" Then
            GetAbsolutePath = GetAbsolutePath + "\"
        End If

        GetAbsolutePath = GetAbsolutePath + strPart

'    If InStr(SERVER_IP, ":") = 2 Then
'        If left(strPart, 1) <> "\" Then
'          GetAbsolutePath = SERVER_IP + "\" + strPart
'        Else
'            GetAbsolutePath = SERVER_IP + "\" + strPart
'        End If
'    Else
'        If left(strPart, 1) <> "\" Then
'            GetAbsolutePath = "\\" + SERVER_IP + "\" + ROOT_DIRECTORY + "\" + strPart
'        Else
'            GetAbsolutePath = "\\" + SERVER_IP + "\" + ROOT_DIRECTORY + strPart
'        End If
'    End If
    Exit Function
ErrHandler:
    GetAbsolutePath = strPart
    MsgBox Err.Description, vbExclamation, "提示"
End Function

'路径转换函数--共享方式转换成FTP方式
Public Function changePath(primaryPath As String) As String
On Error GoTo ErrHandler
     Dim nCount As Long
    'If InStr(primaryPath, "\") <> 0 Then
        'primaryPath = Right(primaryPath, Len(primaryPath) - 2)
        While (InStr(primaryPath, "\"))
        nCount = InStr(primaryPath, "\")
        primaryPath = left(primaryPath, nCount - 1) + "/" + Right(primaryPath, Len(primaryPath) - nCount)
        Wend
    'End If
    changePath = primaryPath
    Exit Function
ErrHandler:
    changePath = ""
    MsgBox Err.Description, vbExclamation, "提示"
End Function
'共享方式上传图片
Public Function putShareFile(ByVal strSrc As String, ByVal strDstLocal As String, ByVal strDstServer As String) As Boolean
On Error GoTo ErrHandler
    If CopyFile(strSrc, strDstLocal, 0) = False Or CopyFile(strSrc, strDstServer, 0) = False Then
        putShareFile = False
        Exit Function
    End If
    putShareFile = True
    Exit Function
ErrHandler:
    putShareFile = False
    MsgBox Err.Description, vbExclamation, "提示"
End Function

'FTP方式下载图片
Public Function getFTPFile(ByVal strDstLocal As String, ByVal strDstServer As String) As Boolean
On Error GoTo ErrHandler
    Dim strPath As String
    strPath = changePath(strDstServer)
    Dim nCount As Long
    Dim IP As String
    Dim filmPath As String
    nCount = InStr(strPath, "/")
    IP = left(strPath, nCount - 1)
    filmPath = Right(strPath, Len(strPath) - nCount)
        
    If GetFileFromFtp(IP, INTERNET_DEFAULT_FTP_PORT, INTERNET_DEFAULT_FTP_USER_NAME, INTERNET_DEFAULT_FTP_PASSWORD, strDstLocal, filmPath) = False Then
        getFTPFile = False
        Exit Function
    End If
    
    getFTPFile = True
    Exit Function
ErrHandler:
    getFTPFile = False
    MsgBox Err.Description, vbExclamation, "提示"
End Function