|
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件 ★ 免费下载 ★ ★ 使用帮助★
本帖最后由 tcy119 于 2019-10-19 14:05 编辑
求助:字段太小而不能接受所要添加的数据的数量,请高手帮助解决。谢谢。
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
详见附件
|
|