modphotostorage.bas

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

Attribute VB_Name = "modPhotoStorage"
    Option Explicit
    
    Const lngDataFile = 1
    Dim myConn As New ADODB.Connection
    

'图片保存到数据库
Public Function PicToDatabase(ByVal strTableName As String, ByVal strFieldName As String, _
    ByVal strCondition As String, ByVal strPicPath As String) As Boolean
On Error GoTo ErrHandler
    If Trim(strTableName) = "" Or Trim(strFieldName) = "" Or Trim(strPicPath) = "" Then
        Exit Function
    End If


    Dim rs As New ADODB.Recordset
    myConn.CursorLocation = adUseClient
    If myConn.State <> adStateOpen Then
        myConn.Open modGlobalDbConnect.GetConnectionString
    End If
    

    'Dim strmPic As New ADODB.Stream
    'strmPic.Type = adTypeBinary
    'Dim strFileName As String
    'strFileName = strPicPath
    'strFileName = "f:\1.bmp"
    'If strmPic.State = adStateOpen Then
    '    strmPic.Close
    'End If
    'strmPic.Open
    'strmPic.LoadFromFile strFileName
    
    'Dim bytPic() As Byte
    'ReDim bytPic(strmPic.Size)
    
    'bytPic = strmPic.Read
    'strmPic.Close
    
    Dim strSql As String

    strSql = "SELECT " + strFieldName + " FROM " + strTableName + strCondition
    If rs.State = adStateOpen Then
        rs.Close
    End If
    rs.Open strSql, myConn, adOpenDynamic, adLockOptimistic
    
   
    
    rs.Update
    Close lngDataFile
    rs.Close
    Set rs = Nothing
    myConn.Close
    Set myConn = Nothing
    
    'rs.AddNew
    'rs.Fields(strFieldName) = bytPic
    'rs.Fields("ID") = strFieldID
    'rs.Fields(strFieldName) = strmPic.Read
        
    
    PicToDatabase = True
    
    Exit Function
ErrHandler:
    Dim strErr As String
    strErr = Err.Description
    MsgBox Err.Description
    
    PicToDatabase = False
End Function

'数据库图片读取到文件
Public Function DatabasePicToFile(ByVal strTableName As String, ByVal strFieldName As String, _
     ByVal strCondition As String, ByVal strPicPath As String) As Boolean
On Error GoTo ErrHandler

    
    Const CHUNK_SIZE = 1000
    
    Dim strSql As String
    strSql = "SELECT " + strFieldName + " FROM " + strTableName + " " + strCondition
    'DcmNum = DCMRS.RecordCount
    
    Dim rsPicPaths As New ADODB.Recordset
    myConn.CursorLocation = adUseClient
    If myConn.State <> adStateOpen Then
        myConn.Open modGlobalDbConnect.GetConnectionString
    End If
    
    If rsPicPaths.State = adStateOpen Then
        rsPicPaths.Close
    End If
    rsPicPaths.Open strSql, myConn
    If rsPicPaths.EOF Or rsPicPaths.BOF Then
        DatabasePicToFile = False
        Exit Function
    End If
    
    Dim lLength As Long
    Dim lChunks As Long
    Dim lFragment As Long
    'Dim lChunkSize As Long
    Dim bytes() As Byte
    
    If IsNull(rsPicPaths.Fields(strFieldName)) Then
        DatabasePicToFile = False
        Exit Function
    End If
    If Not IsNull(rsPicPaths.Fields(strFieldName).ActualSize) Then
        lLength = rsPicPaths.Fields(strFieldName).ActualSize
    End If
    If lLength <= 0 Then
        DatabasePicToFile = False
        Exit Function
    End If
    
    lChunks = lLength \ CHUNK_SIZE
    lFragment = lLength Mod CHUNK_SIZE
    ReDim bytes(lFragment)
    If Not IsNull(rsPicPaths.Fields(strFieldName).GetChunk(lFragment)) Then
        bytes = rsPicPaths.Fields(strFieldName).GetChunk(lFragment)
    End If
    
    'strPicPath = "d:\2.dcm"
    'strPicPath = "F:\Projects\HTPROJECTS\HP-ORACLE-pic\HP-ORACLE-pic\HP-ORACLE\download\1.dcm"
    Open strPicPath For Binary Access Write As lngDataFile

    Put lngDataFile, , bytes()
    
    Dim i As Long
    For i = 1 To lChunks
        bytes() = rsPicPaths.Fields(strFieldName).GetChunk(CHUNK_SIZE)
        Put lngDataFile, , bytes()
    Next
    
    Close lngDataFile
    
    DatabasePicToFile = True
    
    rsPicPaths.Close
    Set rsPicPaths = Nothing
    myConn.Close
    Set myConn = Nothing
    Exit Function
    
ErrHandler:
    MsgBox Err.Description, vbExclamation, "提示"
    DatabasePicToFile = False
End Function