SQL 相片保存

tcy119

求助：字段太小而不能接受所要添加的数据的数量，不知道什么原因，请高手帮助解决，谢谢！
Sub SavePic()
    Dim BtArr() As Byte
    Dim PicPath As String
    Dim PicName As String
    Dim SQL As String
    Dim Fn As Integer
    Dim cnn As New ADODB.Connection
    Dim rst As New ADODB.Recordset
    Dim myPath As String
    Dim myTable As String
    'Dim PicSum As Long
   Path = ThisWorkbook.Path & "\学校管理.xlsx"
    If Dir(myPath) = "" Then
    MsgBox ("ON")
    End If
   
    myTable = "学生档案"
    Set cnn = New ADODB.Connection
        With cnn
            .Provider = "Microsoft.ACE.OLEDB.12.0"
            .ConnectionString = "Extended Properties=Excel 12.0;" _
                & "Data Source=" & Path
            .Open
        End With
        Set rst = New ADODB.Recordset
      SQL = "select 学生编号,相片 from [学生档案$] Where IsNull(相片)= True"
        rst.Open SQL, cnn, adOpenKeyset, adLockOptimistic
   
   
    On Error GoTo ErrMsg
       Do Until rst.EOF
        PicName = rst(0)
        PicPath = Dir(ThisWorkbook.Path & "\pic\" & PicName & ".*")
        If Len(PicPath) <> 0 Then
            PicPath = ThisWorkbook.Path & "\pic\" & PicPath
            Fn = FreeFile
            Open PicPath For Binary As #Fn
            ReDim BtArr(LOF(Fn) - 1)
            Get #Fn, , BtArr
            Close #Fn
            rst("相片") = BtArr
            PicSum = PicSum + 1
        End If
        rst.MoveNext
    Loop
    MsgBox "共有 " & PicSum & " 张相片存入数据库" & vbCr _
    & "还有 " & rst.RecordCount - PicSum & " 人未提供相片", , "保存相片"
    Exit Sub
ErrMsg:
    MsgBox Err.Description, , "错误报告"
End Sub

opiona

你这是要在单元格内保存相片的文件流么

如果一定要将照片文件保存在数据库内
建议用ACCESS的OLE对象保存

426楼：http://club.excelhome.net/thread-1409141-1-1.html

tcy119

opiona 发表于 2019-10-20 10:55
你这是要在单元格内保存相片的文件流么

如果一定要将照片文件保存在数据库内

由于审核没有能及时回复，不好意思，多谢，但我不太懂ACCESS，所以还是另想办法。

opiona

那就试试插入对象：

1.         PathG = ThisWorkbook.Path & "" & SH1.Cells(I, 4).Value & ".docx" '//指定文件路径
   
2.    
   
3.         If FSO.FileExists(PathG) = True Then   '//如果文件存在
   
4.            Rem 对象文件名,对象链接到该文件,图标或正常图片方式,指定图标文件,图标序号,图标下方显示一个标签
   
5.            Rem 指定位置和大小，图标就不会相互重叠  最后还有个括号
   
6.            
   
7.            Set RA = SH1.Range("E" & I)
   
8.            Set Obj = SH1.OLEObjects.Add(Filename:=PathG, Link:=True, DisplayAsIcon:=True _
   
9.             , IconFileName:=ThisWorkbook.Path & "\ICO.ICO", IconIndex:=0, IconLabel:=PathG _
   
10.             , Left:=RA.Left + 3 _
    
11.             , Top:=RA.Top + 3 _
    
12.             , Height:=SH1.Rows(RA.Row).RowHeight - 6 _
    
13.             , Width:=RA.Width - 6 _
    
14.             )
    
15.             With Obj
    
16.                 .Select '//声明为：Obj 是为了可能的其他操作
    
17.                 Rem 把行高改为与图标文件一样高，图标就不会相互重叠
    
18.                 SH1.Rows(I).RowHeight = .Height + 6
    
19.             End With
    
20.         Else
    
21.             SH1.Cells(I, 5).Value = "没有此文件"
    
22.         End If

复制代码

tcy119

opiona 发表于 2019-10-21 09:19
那就试试插入对象：

真想不到老师这么热心，但还不能用， 谢谢！非常感谢！