提取sqlserver数据库中的二进制图片

shaojq123

各位老师：

      您好！

     在别的论坛里提问了许久，没有解决的问题：

    如何从sqlserver数据库中提取二进制图片，并显示在excel单元格中！

谢谢！！！

amulee

SQLServer没耍过，前些日子写了一个Access的供参考

Dim ADOCon As New ADODB.Connection 'ADODB Connection对象
Dim ADORst As New ADODB.Recordset 'ADODB Recordset 对象
Dim ADOFld As ADODB.Field 'ADODB Field 对象
Dim Constr As String   'ODBC路径
Const BLOCKSIZE = 4096 '每次读写块的大小
Sub 上传图片()
    Constr = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & ThisWorkbook.Path & "\test.mdbersist Security Info=False"
    ADOCon.Open Constr '创建一个连接
    ADOCon.CursorLocation = adUseClient
    Dim strRecs As String
    strRecs = "Select * from AA"
    ADORst.Open strRecs, ADOCon, 3, 3
    'Set AdoCtr.Recordset = ADORst
    ADORst.AddNew '新增纪录
    ADORst("ID").Value = 3    '给动态集的第一个字段赋值
    ADORst("Name").Value = "amulee" '给动态集的第二个字段赋值
    Set ADOFld = ADORst("Pic") '给ADODB.Field对象赋值
    Call SaveToDB(ADOFld, ThisWorkbook.Path & "\AA.JPG") 'PicFilePath为图片的硬盘存储路径
    '调用子程序，给第三个字段（image）赋值
    ADORst.Update
    ADOCon.Close
End Sub

Private Sub SaveToDB(ByRef Fld As ADODB.Field, DiskFile As String)
    Dim byteData() As Byte '定义数据块数组
    Dim NumBlocks As Long '定义数据块个数
    Dim FileLength As Long '标识文件长度
    Dim LeftOver As Long '定义剩余字节长度
    Dim SourceFile As Long '定义自由文件号
    Dim i As Long '定义循环变量
    SourceFile = FreeFile '提供一个尚未使用的文件号
    Open DiskFile For Binary Access Read As SourceFile '打开文件
    FileLength = LOF(SourceFile) '得到文件长度
    If FileLength = 0 Then '判断文件是否存在
        Close SourceFile
        MsgBox DiskFile & " 无 内 容 或 不 存 在 !"
    Else
        NumBlocks = FileLength \ BLOCKSIZE '得到数据块的个数
        LeftOver = FileLength Mod BLOCKSIZE '得到剩余字节数
        Fld.Value = Null
        ReDim byteData(BLOCKSIZE) '重新定义数据块的大小
        For i = 1 To NumBlocks
            Get SourceFile, , byteData ' 读到内存块中
            Fld.AppendChunk byteData '写入FLD
        Next i
        ReDim byteData(LeftOver) '重新定义数据块的大小
        Get SourceFile, , byteData '读到内存块中
        Fld.AppendChunk byteData '写入FLD
        Close SourceFile '关闭源文件
    End If
End Sub
Sub 读取图片()
    Dim Chunk() As Byte
    Constr = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & ThisWorkbook.Path & "\test.mdbersist Security Info=False"
    ADOCon.Open Constr '创建一个连接
    ADOCon.CursorLocation = adUseClient
    Dim strRecs As String
    Dim FName As String
    Dim Datafile As Integer
    strRecs = "Select * from AA Where ID=2"
    ADORst.Open strRecs, ADOCon, 3, 3
    Chunk = ADORst.Fields("Pic").GetChunk(ADORst.Fields("Pic").ActualSize)
    ADOCon.Close

    FName = ThisWorkbook.Path & "\Ab"
    Datafile = FreeFile
    Open FName For Binary Access Write As Datafile
      Put Datafile, , Chunk()
    Close Datafile
   
    ActiveSheet.Pictures.Insert FName
    Kill FName
   
End Sub

shaojq123

表是：t_Accessory   二进制字段：fdata
图片名：ffilename

谢谢amulee老师：ACCESS的有！主要是sqlserver的！

谢谢！！！！

shaojq123

顶上去！老师给看看

shaojq123

呵呵！可能也是无功而返啊！！！

看来确是难点

amulee

可能这里SQLServer用的人不多。不多ADO也可以连接SQLServer啊。

你改一下相关的语句即可，没用过，也不知道对不对。

其余的应该都一样啊

连接语句如下：Constr = "Provider=sqloledb;Server=服务器名;Database=数据库名;Uid=用户名wd=密码;"

shaojq123

能连上！也改过！

但是不行！！！

amulee

字段名，表名都要改的

shaojq123

Sub tp1()

Dim ADOCon As New ADODB.Connection 'ADODB Connection对象
Dim ADORst As New ADODB.Recordset 'ADODB Recordset 对象
Dim ADOFld As ADODB.Field 'ADODB Field 对象
Dim Constr As String   'ODBC路径
Const BLOCKSIZE = 4096 '每次读写块的大小

Dim Chunk() As Byte
    Constr = "Provider=SQLOLEDB;" _
        & "User ID=sa;" _
        & "Password =shaojq;" _
        & "Data Source=SUIBAO-8832127D;" _
        & "Initial Catalog =AIS20090410141516"
    ADOCon.Open Constr '创建一个连接
    ADOCon.CursorLocation = adUseClient
    Dim strRecs As String
    Dim FName As String
    Dim Datafile As Integer
    strRecs = "select * from t_Accessory"
    ADORst.Open strRecs, ADOCon, 3, 3
    Chunk = ADORst.Fields("Pic").GetChunk(ADORst.Fields("Pic").ActualSize)
    ADOCon.Close

    FName = ThisWorkbook.Path & "\Ab"
    Datafile = FreeFile
    Open FName For Binary Access Write As Datafile
      Put Datafile, , Chunk()
    Close Datafile
   
    ActiveSheet.Pictures.Insert FName
    Kill FName
    'End With
   
End Sub
总是提示程序对象定义错误

amulee

要引用MicroSoft ActiveX Data Objects组件的