读取adobe.stream溢出，VBA存Access数据库遇Overflow错误求排查优化

The primary reasons for the Overflow error when using ADODB.Stream to save image data are:

1. Incorrect Database Field Type: The Photo field in your ID_Card table is likely configured with a data type that can't accommodate large binary data (like images). For example:

   • Using Binary (limited to 255 bytes) instead of OLE Object (for Microsoft Access) or VarBinary(MAX) (for SQL Server).
   • A fixed-size binary type with a maximum length smaller than your image file size.

2. Unchecked Stream Reading: Reading the entire image file into memory in one go with stringStream.Read can trigger an overflow if the file is extremely large, exceeding VBA's memory limits for a single byte array.

3. Variable Name Mismatch: You declared strStream As ADODB.Stream but used stringStream later—while this might not directly cause the overflow, it’s a bug that can lead to unexpected behavior (especially if Option Explicit is disabled).

Here’s how to resolve the overflow and improve your code:

1. Correct the Database Field Type #

• For Microsoft Access: Set the Photo field’s data type to OLE Object (this supports large binary data like images).
• For SQL Server: Use VarBinary(MAX) instead of smaller binary types.

2. Fix Variable & Stream Handling #

• Match your variable declarations to usage: Change Dim strStream As ADODB.Stream to Dim stringStream As ADODB.Stream.
• Always clean up stream objects after use to free memory:

  stringStream.Close
  Set stringStream = Nothing
  

• For very large images, read the stream in chunks (though this is rarely needed for standard photos):

  Const CHUNK_SIZE As Long = 1024 * 1024 ' 1MB chunks
  Dim chunk() As Byte
  Do Until stringStream.EOS
      chunk = stringStream.Read(CHUNK_SIZE)
      RS.Fields("Photo").AppendChunk chunk
  Loop
  

  Note: Use AppendChunk instead of direct assignment when working with chunks.

3. Add Error Handling #

Wrap your database operations in error handling to catch issues like missing files, connection problems, or invalid data:

On Error GoTo ErrorHandler
' Your existing code here

ExitSub:
    ' Clean up objects
    If Not RS Is Nothing Then
        If RS.State = adStateOpen Then RS.Close
        Set RS = Nothing
    End If
    If Not stringStream Is Nothing Then
        If stringStream.State = adStateOpen Then stringStream.Close
        Set stringStream = Nothing
    End If
    Exit Sub

ErrorHandler:
    MsgBox "Error: " & Err.Description & " (Code: " & Err.Number & ")"
    Resume ExitSub

4. Simplify Option Button Logic #

Replace your nested If/ElseIf with a cleaner check:

With Sheets("ID_Entry")
    If .OptionButton1.Value Then
        RS.Fields("EmpType") = .OptionButton1.Caption
    ElseIf .OptionButton2.Value Then
        RS.Fields("EmpType") = .OptionButton2.Caption
    Else
        MsgBox "Please select employee type"
        GoTo ExitSub ' Exit early if no selection
    End If
End With

5. Enable Option Explicit #

Add Option Explicit at the top of your module to catch undeclared variables (like the stringStream/strStream mismatch) during compilation.

Here’s your revised code incorporating the above fixes:

Option Explicit

Sub SaveEmployeeData()
    Dim cn As ADODB.Connection
    Dim RS As ADODB.Recordset
    Dim SearchID As String
    Dim stringStream As ADODB.Stream
    Dim TempPath As String ' Assume this is defined elsewhere
    
    On Error GoTo ErrorHandler
    
    ' Initialize connection and recordset
    Set cn = New ADODB.Connection
    cn.Open MSACCString ' Assuming MSACCString is your connection string
    
    Set RS = New ADODB.Recordset
    With RS
        .CursorLocation = adUseServer
        .Open "ID_Card", cn, adOpenStatic, adLockOptimistic, adCmdTableDirect
        .Index = "NA_EMP_ID"
        SearchID = Card_Screen.Range("Sh_EmpID").Value
        .Seek SearchID
        
        If Not .EOF Then
            ' Update basic fields
            .Fields("First") = Range("FName").Value
            .Fields("Third") = Range("TName").Value
            .Fields("DOB") = Range("Sh_DOB").Value
            .Fields("PassportNumber") = Range("Sh_Passport").Value
            
            ' Handle employee type selection
            With Sheets("ID_Entry")
                If .OptionButton1.Value Then
                    .Fields("EmpType") = .OptionButton1.Caption
                ElseIf .OptionButton2.Value Then
                    .Fields("EmpType") = .OptionButton2.Caption
                Else
                    MsgBox "Please select employee type"
                    GoTo ExitSub
                End If
            End With
            
            ' Save photo to database
            If CheckFolder(Card_Screen.Range("SH_Photo"), Card_Screen.Range("Sh_EmpID") & ".jpg") Then
                Set stringStream = New ADODB.Stream
                stringStream.Type = adTypeBinary
                stringStream.Open
                stringStream.LoadFromFile Range("Photo").Value
                
                ' Use AppendChunk for large files (optional but safer)
                .Fields("Photo").AppendChunk stringStream.Read
                
                stringStream.Close
                Set stringStream = Nothing
            End If
            
            ' Update photo display (assuming imageToFile is a helper function)
            Range("Photo").Value = imageToFile(TempPath & Trim(.Fields("NA_Emp_ID")) & ".jpg", .Fields("Photo"))
            .Update
        End If
        .Close
    End With

ExitSub:
    ' Clean up resources
    If Not RS Is Nothing Then Set RS = Nothing
    If Not cn Is Nothing Then
        If cn.State = adStateOpen Then cn.Close
        Set cn = Nothing
    End If
    Exit Sub

ErrorHandler:
    MsgBox "Error saving data: " & Err.Description & " (Error Code: " & Err.Number & ")"
    Resume ExitSub
End Sub

内容的提问来源于stack exchange，提问作者Nisreen Ali