试试这个：
================================================================
用ADO打开Access数据库,把一个图片写到其中一个二进制格式的字段里，数据库
有四个字段： no long类型 用于存id
pict binary类型 用于存图片
name text类型 用于存图片名及路径
about text类型 用于存图片的描述
现在运行时用错误，错误如下：Private Function appendfun(ByVal txt0 As String, ByVal txt1 As String, ByVal txt2 As String)
Dim lngfilelength As Long '所打开文件的长度
Dim lngblocksize As Long '每一块读娶文件的长度
Dim lngblockcount As Long '文件要分为多少块
Dim lnglastblock As Integer '最后一块的大小
Dim lngblockindex As Long '用于控制读数据的循环
Dim lngposition As Long '用于记录读出文件的指针
Dim btyget() As Byte '用于传送数据的二进制数组
lngblocksize = 2000 '每一块的大小If cnn.State = adStateOpen Then
cnn.Close
End If
cnn.Open strconnect
rst.Open "gamephoto_tbl", cnn, adOpenKeyset, adLockPessimistic
If strfilename <> "" Thenrst.AddNew
rst.Fields("no") = Val(txt0)
rst.Fields("name") = strfilename
rst.Fields("about") = txt2DIM Filnum as integer
filnum=FREEFILE
Open strfilename For Binary Access Read As #filnumlngfilelength = LOF(1)
lngblockcount = lngfilelength \ lngblocksize
lnglastblock = lngfilelength Mod lngblocksizeFor lngblockindex = 1 To lngblockcount
Get #filnum, , btyget()
rst.Fields("pict").AppendChunk btyget()
lngposition = lngposition + lngblocksize
NextIf lnglastblock > 0 Then
ReDim btyget(lnglastblock)
Get #filnum, , btyget()
rst.Fields("pict").AppendChunk btyget()
End Ifrst.Update
close #filnumMsgBox "OK"
cnn.Close
Unload Me
Else
MsgBox "请选择文件后再要求添加", vbOKOnly, "注意"
Unload Me
End If
End Function
================================================================
用ADO打开Access数据库,把一个图片写到其中一个二进制格式的字段里，数据库
有四个字段： no long类型 用于存id
pict binary类型 用于存图片
name text类型 用于存图片名及路径
about text类型 用于存图片的描述
现在运行时用错误，错误如下：Private Function appendfun(ByVal txt0 As String, ByVal txt1 As String, ByVal txt2 As String)
Dim lngfilelength As Long '所打开文件的长度
Dim lngblocksize As Long '每一块读娶文件的长度
Dim lngblockcount As Long '文件要分为多少块
Dim lnglastblock As Integer '最后一块的大小
Dim lngblockindex As Long '用于控制读数据的循环
Dim lngposition As Long '用于记录读出文件的指针
Dim btyget() As Byte '用于传送数据的二进制数组
lngblocksize = 2000 '每一块的大小If cnn.State = adStateOpen Then
cnn.Close
End If
cnn.Open strconnect
rst.Open "gamephoto_tbl", cnn, adOpenKeyset, adLockPessimistic
If strfilename <> "" Thenrst.AddNew
rst.Fields("no") = Val(txt0)
rst.Fields("name") = strfilename
rst.Fields("about") = txt2DIM Filnum as integer
filnum=FREEFILE
Open strfilename For Binary Access Read As #filnumlngfilelength = LOF(1)
lngblockcount = lngfilelength \ lngblocksize
lnglastblock = lngfilelength Mod lngblocksizeFor lngblockindex = 1 To lngblockcount
Get #filnum, , btyget()
rst.Fields("pict").AppendChunk btyget()
lngposition = lngposition + lngblocksize
NextIf lnglastblock > 0 Then
ReDim btyget(lnglastblock)
Get #filnum, , btyget()
rst.Fields("pict").AppendChunk btyget()
End Ifrst.Update
close #filnumMsgBox "OK"
cnn.Close
Unload Me
Else
MsgBox "请选择文件后再要求添加", vbOKOnly, "注意"
Unload Me
End If
End Function
因为上面的程序也是我写的，是前两天我发上去的帖，而且你留意到了没有：我问的是出库的，你贴的是入库的......
不过，还是谢谢你。起码你理我......
=============================================================
Public Sub AppendChunkX() Dim cnn1 As ADODB.Connection
Dim rstPubInfo As ADODB.Recordset
Dim strCnn As String
Dim strPubID As String
Dim strPRInfo As String
Dim lngOffset As Long
Dim lngLogoSize As Long
Dim varLogo As Variant
Dim varChunk As Variant
Const conChunkSize = 100 ' 打开连接
Set cnn1 = New ADODB.Connection
strCnn = "Provider=sqloledb;" & _
"Data Source=srv;Initial Catalog=pubs;User Id=sa;Password=; "
cnn1.Open strCnn
' 打开 pub_info 表。
Set rstPubInfo = New ADODB.Recordset
rstPubInfo.CursorType = adOpenKeyset
rstPubInfo.LockType = adLockOptimistic
rstPubInfo.Open "pub_info", cnn1, , , adCmdTable
' 提示复制徽标。
strMsg = "Available logos are : " & vbCr & vbCr
Do While Not rstPubInfo.EOF
strMsg = strMsg & rstPubInfo!pub_id & vbCr & _
Left(rstPubInfo!pr_info, InStr(rstPubInfo!pr_info, ",") - 1) & _
vbCr & vbCr
rstPubInfo.MoveNext
Loop
strMsg = strMsg & "Enter the ID of a logo to copy:"
strPubID = InputBox(strMsg)
' 将徽标复制到大块中的变量。
rstPubInfo.Filter = "pub_id = '" & strPubID & "'"
lngLogoSize = rstPubInfo!logo.ActualSize
Do While lngOffset < lngLogoSize
varChunk = rstPubInfo!logo.GetChunk(conChunkSize)
varLogo = varLogo & varChunk
lngOffset = lngOffset + conChunkSize
Loop
' 从用户得到数据。
strPubID = Trim(InputBox("Enter a new pub ID:"))
strPRInfo = Trim(InputBox("Enter descriptive text:"))
' 添加新记录，将徽标复制到大块中。
rstPubInfo.AddNew
rstPubInfo!pub_id = strPubID
rstPubInfo!pr_info = strPRInfo lngOffset = 0 ' 重置位移。
Do While lngOffset < lngLogoSize
varChunk = LeftB(RightB(varLogo, lngLogoSize - lngOffset), _
conChunkSize)
rstPubInfo!logo.AppendChunk varChunk
lngOffset = lngOffset + conChunkSize
Loop
rstPubInfo.Update
' 显示新添加的数据。
MsgBox "New record: " & rstPubInfo!pub_id & vbCr & _
"Description: " & rstPubInfo!pr_info & vbCr & _
"Logo size: " & rstPubInfo!logo.ActualSize ' 删除新记录，因为这只是演示。
rstPubInfo.Requery
cnn1.Execute "DELETE FROM pub_info " & _
"WHERE pub_id = '" & strPubID & "'" rstPubInfo.Close
cnn1.Close End Sub
Save and restore pictures in a database using ADO with AppendChunk and GetChunk
==========================================================
VERSION 5.00
Object = "{F9043C88-F6F2-101A-A3C9-08002B2F49FB}#1.2#0"; "COMDLG32.OCX"
Begin VB.Form Form1
Caption = "Form1"
ClientHeight = 3195
ClientLeft = 165
ClientTop = 735
ClientWidth = 5295
LinkTopic = "Form1"
ScaleHeight = 3195
ScaleWidth = 5295
StartUpPosition = 3 'Windows Default
Begin VB.ListBox lstPeople
Height = 450
ItemData = "Form1.frx":0000
Left = 0
List = "Form1.frx":0002
TabIndex = 1
Top = 0
Width = 1935
End
Begin VB.PictureBox picPerson
AutoSize = -1 'True
Height = 3015
Left = 2040
ScaleHeight = 2955
ScaleWidth = 3075
TabIndex = 0
Top = 0
Visible = 0 'False
Width = 3135
End
Begin MSComDlg.CommonDialog dlgPicture
Left = 240
Top = 1920
_ExtentX = 847
_ExtentY = 847
_Version = 393216
End
Begin VB.Menu mnuRecord
Caption = "&Record"
Begin VB.Menu mnuRecordAdd
Caption = "Add"
Shortcut = ^A
End
End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option ExplicitPrivate Declare Function GetTempFileName Lib "kernel32" Alias "GetTempFileNameA" (ByVal lpszPath As String, ByVal lpPrefixString As String, ByVal wUnique As Long, ByVal lpTempFileName As String) As Long
Private Declare Function GetTempPath Lib "kernel32" Alias "GetTempPathA" (ByVal nBufferLength As Long, ByVal lpBuffer As String) As Long
Private Const MAX_PATH = 260Private m_DBConn As ADODB.ConnectionPrivate Const BLOCK_SIZE = 10000
' Return a temporary file name.
Private Function TemporaryFileName() As String
Dim temp_path As String
Dim temp_file As String
Dim length As Long ' Get the temporary file path.
temp_path = Space$(MAX_PATH)
length = GetTempPath(MAX_PATH, temp_path)
temp_path = Left$(temp_path, length) ' Get the file name.
temp_file = Space$(MAX_PATH)
GetTempFileName temp_path, "per", 0, temp_file
TemporaryFileName = Left$(temp_file, InStr(temp_file, Chr$(0)) - 1)
End Function
Private Sub Form_Load()
Dim db_file As String
Dim rs As ADODB.Recordset ' Get the database file name.
db_file = App.Path
If Right$(db_file, 1) <> "\" Then db_file = db_file & "\"
db_file = db_file & "dbpict.mdb" ' Open the database connection.
Set m_DBConn = New ADODB.Connection
m_DBConn.Open _
"Provider=Microsoft.Jet.OLEDB.4.0;" & _
"Data Source=" & db_file & ";" & _
"Persist Security Info=False" ' Get the list of people.
Set rs = m_DBConn.Execute("SELECT Name FROM People ORDER BY Name", , adCmdText)
Do While Not rs.EOF
lstPeople.AddItem rs!Name
rs.MoveNext
Loop rs.Close
Set rs = Nothing
End Sub
Private Sub Form_Resize()
lstPeople.Height = ScaleHeight
End Sub
' Display the clicked person.
Private Sub lstPeople_Click()
Dim rs As ADODB.Recordset
Dim bytes() As Byte
Dim file_name As String
Dim file_num As Integer
Dim file_length As Long
Dim num_blocks As Long
Dim left_over As Long
Dim block_num As Long
Dim hgt As Single picPerson.Visible = False
Screen.MousePointer = vbHourglass
DoEvents ' Get the record.
Set rs = m_DBConn.Execute("SELECT * FROM People WHERE Name='" & _
lstPeople.Text & "'", , adCmdText)
If rs.EOF Then Exit Sub ' Get a temporary file name.
file_name = TemporaryFileName() ' Open the file.
file_num = FreeFile
Open file_name For Binary As #file_num ' Copy the data into the file.
file_length = rs!FileLength
num_blocks = file_length / BLOCK_SIZE
left_over = file_length Mod BLOCK_SIZE For block_num = 1 To num_blocks
bytes() = rs!Picture.GetChunk(BLOCK_SIZE)
Put #file_num, , bytes()
Next block_num If left_over > 0 Then
bytes() = rs!Picture.GetChunk(left_over)
Put #file_num, , bytes()
End If Close #file_num ' Display the picture file.
picPerson.Picture = LoadPicture(file_name)
picPerson.Visible = True Width = picPerson.Left + picPerson.Width + Width - ScaleWidth
hgt = picPerson.Top + picPerson.Height + Height - ScaleHeight
If hgt < 1440 Then hgt = 1440
Height = hgt Kill file_name
Screen.MousePointer = vbDefault
End SubPrivate Sub mnuRecordAdd_Click()
Dim rs As ADODB.Recordset
Dim person_name As String
Dim file_num As String
Dim file_length As String
Dim bytes() As Byte
Dim num_blocks As Long
Dim left_over As Long
Dim block_num As Long person_name = InputBox("Name")
If Len(person_name) = 0 Then Exit Sub dlgPicture.Flags = _
cdlOFNFileMustExist Or _
cdlOFNHideReadOnly Or _
cdlOFNExplorer
dlgPicture.CancelError = True
dlgPicture.Filter = "Graphics Files|*.bmp;*.ico;*.jpg;*.gif" On Error Resume Next
dlgPicture.ShowOpen
If Err.Number = cdlCancel Then
Exit Sub
ElseIf Err.Number <> 0 Then
MsgBox "Error " & Format$(Err.Number) & _
" selecting file." & vbCrLf & Err.Description
Exit Sub
End If ' Open the picture file.
file_num = FreeFile
Open dlgPicture.FileName For Binary Access Read As #file_num file_length = LOF(file_num)
If file_length > 0 Then
num_blocks = file_length / BLOCK_SIZE
left_over = file_length Mod BLOCK_SIZE Set rs = New ADODB.Recordset
rs.CursorType = adOpenKeyset
rs.LockType = adLockOptimistic
rs.Open "Select Name, Picture, FileLength FROM People", m_DBConn rs.AddNew
rs!Name = person_name
rs!FileLength = file_length ReDim bytes(BLOCK_SIZE)
For block_num = 1 To num_blocks
Get #file_num, , bytes()
rs!Picture.AppendChunk bytes()
Next block_num If left_over > 0 Then
ReDim bytes(left_over)
Get #file_num, , bytes()
rs!Picture.AppendChunk bytes()
End If rs.Update
Close #file_num lstPeople.AddItem person_name
lstPeople.Text = person_name
End If
End Sub
现在我改了以下：
rst.open "select * from xxxx where [no] ='"_
&int(trim(datagrid.columns("no"))),cnn
但报错了：实时错误“6147”：列未找到no
改为 rst.open "select * from xxxx where [no] ='"_
&int(trim(datagrid.columns(0))),cnn
也报错： 实时错误“7005”：行设置不可用
有谁可以帮我，我还可以加分
只要解决这个问题
有谁可以帮我，我还可以加分
现在我改了以下：
rst.open "select * from xxxx where [no] ='"_
& val(trim(datagrid.columns("no"))),cnn
但报错了：实时错误“6147”：列未找到no
改为 rst.open "select * from xxxx where [no] ='"_
& val(trim(datagrid.columns(0))),cnn
也报错： 实时错误“7005”：行设置不可用
有谁可以帮我，我还可以加分
只要解决这个问题
有谁可以帮我，我还可以加分