access2010 access2007 ADO.Stream SaveToFile

添付ファイル型フィールドに保存されているファイルをローカルに保存する。

#If VBA7 Then
Declare PtrSafe Sub CopyMemory Lib "kernel32" _
                                Alias "RtlMoveMemory" ( _
                                Destination As Any, _
                                Source As Any, _
                                ByVal Length As LongPtr)
#Else
Declare Sub CopyMemory Lib "kernel32" _
                                Alias "RtlMoveMemory" ( _
                                Destination As Any, _
                                Source As Any, _
                                ByVal Length As Long)
#End If

Sub SaveToFileADOStream()
    Dim cn As New ADODB.Connection
    Dim rs As New ADODB.Recordset, strm As New ADODB.Stream
    Dim rs2 As New ADODB.Recordset
    Dim fileBin() As Byte, fileBinSize As Long, bOffset As Long
    Dim fileBin2() As Byte, strSQL As String
    
    strSQL = "Select AttachmentField_Name As FileName " & _
             "From table_Name "
             
'このSQLだと超絶遅い
'    strSQL = "Select AttachmentField_Name.FileName As FileName, " & _
'             "AttachmentField_Name.FileData As FileData " & _
'             "From table_Name"
     
    Set cn = Application.CurrentProject.AccessConnection

    rs.Open strSQL, cn, adOpenForwardOnly, adLockReadOnly
    Set rs2 = rs(0).Value

    fileBin = rs2.Fields("FileData")
    fileBinSize = UBound(fileBin)
    bOffset = fileBin(0)

    ReDim fileBin2(fileBinSize - bOffset)
    CopyMemory fileBin2(0), fileBin(bOffset), fileBinSize - bOffset

    With strm
        .Open
        .Type = adTypeBinary
        .Write fileBin2
        .SaveToFile CurrentProject.Path & "\" & _
                    rs2("FileName"), adSaveCreateOverWrite
        .Close
    End With

    Set strm = Nothing
    rs2.Close: Set rs2 = Nothing
    rs.Close: Set rs = Nothing
    cn.Close: Set cn = Nothing
End Sub