怎样从数据库中直接读出图片(不要写到本地)

Question

下面是我测试用的,每次都要先写到硬盘再读出来,再从硬盘删除,有没有不用写到硬盘直接显示的好法子(不要用其它控件),用APIPrivate Sub Command3_Click()
    Dim c As New ADODB.Stream
    Dim tmp As String
    
    tmp = "d:\aa.jpg"
    Set Image1.Picture = Nothing
    c.Mode = adModeReadWrite
    c.Type = adTypeBinary
    c.Open
    rs.Open "select * from [EMP_Pic]", cnn, adOpenDynamic, adLockOptimistic
    If rs.EOF Then
        c.LoadFromFile "D:\VBKQ\KQ91\KQ\back.jpg"
        'c.LoadFromFile "D:\VBKQ\KQ92\KQ\Icon.ico"
        If c.Size > 102400 Then
            MsgBox "图片文不能大于100KB"
            rs.Close: c.Close
            Exit Sub
        Else
            rs.AddNew
            rs.Fields(0).Value = 1
            rs.Fields(1).Value = c.Read()
            rs.Update
        End If
    End If
    c.Write (rs.Fields(1).Value)
    c.SaveToFile tmp, adSaveCreateOverWrite     '???
    Image1.Picture = LoadPicture(tmp)           '???
    Kill tmp                                    '???
    rs.Close
    c.Close
End SubPublic Sub ReadFromDB(ByRef Fld As ADODB.Field, DiskFile As String)
    Dim byteData() As Byte '定义数据块数组
    Dim NumBlocks As Long  '定义数据块个数
    Dim FileLength As Long '标识文件长度 编程大本营HTTp://www.timihome.net
    Dim LeftOver As Long '定义剩余字节长度
    Dim SourceFile As Long '定义自由文件号
    Dim i As Long '定义循环变量
    
    FileLength = Fld.ActualSize  '得到字段的实际长度
    SourceFile = FreeFile '提供一个尚未使用的文件号
    Open DiskFile For Binary Access Write As SourceFile '打开文件
    If FileLength = 0 Then '判断文件是否存在
        Close SourceFile
        ' MsgBox DiskFile & "无 内 容 或 不 存 在 !"
        Exit Sub
    Else
        NumBlocks = FileLength \ BlockSize '得到数据块的个数
        LeftOver = FileLength Mod BlockSize '得到剩余字节数
        'Fld.Value = Null
        ReDim byteData(LeftOver) '重新定义数据块的大小
        byteData() = Fld.GetChunk(LeftOver)
        Put SourceFile, , byteData()
        For i = 1 To NumBlocks
            ReDim byteData(BlockSize) '重新定义数据块的大小
            byteData() = Fld.GetChunk(BlockSize) '从数据库中读出一数据块到内存中
            Put SourceFile, , byteData() '从内存块写入文件中
        Next i
        Close SourceFile '关闭源文件
    End If
End Sub

Answer 1

'我在网上找了个,给有需要的人分享一下,请大家多多指教
Option ExplicitPrivate Type GUID
    Data1 As Long
    Data2 As Integer
    Data3 As Integer
    Data4(0 To 7) As Byte
End TypePrivate Type GdiplusStartupInput
    GdiplusVersion As Long
    DebugEventCallback As Long
    SuppressBackgroundThread As Long
    SuppressExternalCodecs As Long
End TypePrivate Type EncoderParameter
    GUID As GUID
    NumberOfValues As Long
    type As Long
    Value As Long
End TypePrivate Type EncoderParameters
    count As Long
    Parameter As EncoderParameter
End TypePrivate Declare Function GdiplusStartup Lib "GDIPlus" (token As Long, inputbuf As GdiplusStartupInput, Optional ByVal outputbuf As Long = 0) As Long
Private Declare Function GdiplusShutdown Lib "GDIPlus" (ByVal token As Long) As Long
Private Declare Function GdipCreateBitmapFromHBITMAP Lib "GDIPlus" (ByVal hbm As Long, ByVal hPal As Long, BitMap As Long) As Long
Private Declare Function GdipDisposeImage Lib "GDIPlus" (ByVal Image As Long) As Long
Private Declare Function GdipSaveImageToFile Lib "GDIPlus" (ByVal Image As Long, ByVal FileName As Long, clsidEncoder As GUID, encoderParams As Any) As Long
'Private Declare Function CLSIDFromString Lib "ole32" (ByVal Str As Long, id As GUID) As Long
Private Declare Function CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Dest As Any, Src As Any, ByVal cb As Long) As LongPrivate Declare Function CreateStreamOnHGlobal Lib "ole32" (ByVal hGlobal As Long, ByVal fDeleteOnRelease As Long, ppstm As Any) As Long
Private Declare Function OleLoadPicture Lib "olepro32" (pStream As Any, ByVal lSize As Long, ByVal fRunmode As Long, riid As Any, ppvObj As Any) As Long
Private Declare Function CLSIDFromString Lib "ole32" (ByVal lpsz As Any, pclsid As Any) As Long
Private Declare Function GlobalAlloc Lib "kernel32" (ByVal uFlags As Long, ByVal dwBytes As Long) As Long
Private Declare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function GlobalFree Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Sub MoveMemory Lib "kernel32" Alias "RtlMoveMemory" (pDest As Any, pSource As Any, ByVal dwLength As Long)'Private Const GMEM_ZEROINIT = &H40'*************************************************************************
'**    作    者 ：    laviewpbt
'**    函 数 名 ：    SavePic
'**    输    入 ：    hPic(Long)             -   图象句柄
'**             ：    FileName(String)       -   保存路径
'**             ：    Quality(Byte)          -   JPG图象质量
'**             ：    TIFF_ColorDepth(Long)  -   TTF格式的颜色深度
'**             ：    TIFF_Compression(Long) -   TTF格式的压缩比
'**    输    出 ：    无
'**    功能描述 ：    把图象保存为JPG、TIFF、PNG、GIF、BMP格式
'**    日    期 ：
'**    修 改 人 ：    laviewpbt
'**    日    期 ：    2005-10-23 14.43.52
'**    版    本 ：    Version 1.2.1
'*************************************************************************
Public Sub SavePic(ByVal hPic As Long, ByVal FileName As String, Optional ByVal PicType As String, _
                    Optional ByVal Quality As Byte = 80, _
                    Optional ByVal TIFF_ColorDepth As Long = 24, _
                    Optional ByVal TIFF_Compression As Long = 6)
   
    Dim tSI As GdiplusStartupInput
    Dim lRes As Long
    Dim lGDIP As Long
    Dim lBitmap As Long
    Dim aEncParams() As Byte
    
    If PicType = "" Then
        If InStrRev(FileName, ".") > 0 Then
            PicType = Right(FileName, Len(FileName) - InStrRev(FileName, ".") + 1)
        End If
    End If
    PicType = LCase$(PicType)
    tSI.GdiplusVersion = 1   ' 初始化 GDI+
    lRes = GdiplusStartup(lGDIP, tSI)
    If lRes = 0 Then     ' 从句柄创建 GDI+ 图像
        lRes = GdipCreateBitmapFromHBITMAP(hPic, 0, lBitmap)
        If lRes = 0 Then
            Dim tJpgEncoder As GUID
            Dim tParams As EncoderParameters    '初始化解码器的GUID标识
            
            Select Case PicType
            Case ".jpg", ".jpeg"
                CLSIDFromString StrPtr("{557CF401-1A04-11D3-9A73-0000F81EF32E}"), tJpgEncoder
                tParams.count = 1                               ' 设置解码器参数
                With tParams.Parameter ' Quality
                    CLSIDFromString StrPtr("{1D5BE4B5-FA4A-452D-9CDD-5DB35105E7EB}"), .GUID    ' 得到Quality参数的GUID标识
                    .NumberOfValues = 1
                    .type = 4
                    .Value = VarPtr(Quality)
                End With
                ReDim aEncParams(1 To Len(tParams))
                Call CopyMemory(aEncParams(1), tParams, Len(tParams))
                
            Case ".png"
                CLSIDFromString StrPtr("{557CF406-1A04-11D3-9A73-0000F81EF32E}"), tJpgEncoder
                ReDim aEncParams(1 To Len(tParams))
                
            Case ".gif"
                CLSIDFromString StrPtr("{557CF402-1A04-11D3-9A73-0000F81EF32E}"), tJpgEncoder
                ReDim aEncParams(1 To Len(tParams))
                
            Case ".tiff"
                CLSIDFromString StrPtr("{557CF405-1A04-11D3-9A73-0000F81EF32E}"), tJpgEncoder
                tParams.count = 2
                ReDim aEncParams(1 To Len(tParams) + Len(tParams.Parameter))
                With tParams.Parameter
                    .NumberOfValues = 1
                    .type = 4
                    CLSIDFromString StrPtr("{E09D739D-CCD4-44EE-8EBA-3FBF8BE4FC58}"), .GUID    ' 得到ColorDepth参数的GUID标识
                    .Value = VarPtr(TIFF_Compression)
                End With
                Call CopyMemory(aEncParams(1), tParams, Len(tParams))
                With tParams.Parameter
                    .NumberOfValues = 1
                    .type = 4
                    CLSIDFromString StrPtr("{66087055-AD66-4C7C-9A18-38A2310B8337}"), .GUID    ' 得到Compression参数的GUID标识
                    .Value = VarPtr(TIFF_ColorDepth)
                End With
                Call CopyMemory(aEncParams(Len(tParams) + 1), tParams.Parameter, Len(tParams.Parameter))
                
            Case Else   'Case ".bmp"
                CLSIDFromString StrPtr("{557CF400-1A04-11D3-9A73-0000F81EF32E}"), tJpgEncoder
                ReDim aEncParams(1 To Len(tParams))
            
            End Select
            
            lRes = GdipSaveImageToFile(lBitmap, StrPtr(FileName), tJpgEncoder, aEncParams(1))           '保存图像
            GdipDisposeImage lBitmap       ' 销毁GDI+图像
        End If
        GdiplusShutdown lGDIP              '销毁 GDI+
    End If
    Erase aEncParams
End Sub'-----------------------------------------------------------------------------
'将二进制数据转为Picture
Public Function PicFromByte(PicByte() As Byte) As IPicture
    Dim LowerBound As Long
    Dim ByteCount  As Long
    Dim hMem  As Long
    Dim lpMem  As Long
    Dim IID_IPicture(15)
    Dim istm As stdole.IUnknown    If UBound(PicByte, 1) < 0 Then Exit Function
    
    LowerBound = LBound(PicByte)
    ByteCount = (UBound(PicByte) - LowerBound) + 1
    hMem = GlobalAlloc(&H2, ByteCount)
    If hMem <> 0 Then
        lpMem = GlobalLock(hMem)
        If lpMem <> 0 Then
            MoveMemory ByVal lpMem, PicByte(LowerBound), ByteCount
            Call GlobalUnlock(hMem)
            If CreateStreamOnHGlobal(hMem, 1, istm) = 0 Then
                If CLSIDFromString(StrPtr("{7BF80980-BF32-101A-8BBB-00AA00300CAB}"), IID_IPicture(0)) = 0 Then
                    Call OleLoadPicture(ByVal ObjPtr(istm), ByteCount, 0, IID_IPicture(0), PicFromByte)
                End If
            End If
        End If
    End If
    
    Call GlobalFree(hMem)
    
End Function