Copying attachments from one table to another. (1 Viewer)

[TNB]

Did you get an answer to this? I cannot even find the download of the sample DB from the original poster (referenced website doesn't have a dev's link anymore), however I too am trying to figure out how to code VBA to move attachments from one SharePoint list to another...

--

Hi Coffe Bunny,

I still did not get the answer. However, I could solve the problem by an alternative way:
- First, I copy the Source Table to make the Destination Table
- Second, delete all the field in Destination Table (except ID and Attachment field)
- Third, add the fields I want to the Destination Table
- Fourth, update the field in Destination Table from other source (depending on the ID)
- Fifth, export Destination Table to Sharepoint

If you could get the answer by code after referring to the sample database that Cyberman 55 pointed out above, please share your answer with me.

Thank you very much

 

[CoffeeBunny]

Hi TNB - It sounds like you are talking about taking an existing SharePoint list, and copying to a new SharePoint that has not yet been created? Not sure if I'm understanding this correctly, however what I'm doing - and I've found this VASTLY easier - is to create the destination list, then add or update list items between the two lists with the following code. I'm posting here if it may be of help to you:
Create the destination list manually. Avoid multi-select fields. Access doesn't seem to like those. I haven't worked with them, so I can't help you there. The following is my function that looks at two linked sharepoint lists - a source list, and a destination list. TempVars are values that were instantiated by fields on a user form that calls this function.

Public Function CopyItemsToADifferentList() As Boolean  'this is boolean as I call it from a command button on a user form
CopyItemsToADifferentList = False 'set this to false, so if something errors along the way, we don't continue on and purge the original items
'*********************************************
'Declare some variables here....
Dim dbs As DAO.Database
Dim rs As DAO.Recordset, rsMatch As DAO.Recordset, rsDestination As DAO.Recordset
Dim I As Integer, iBatch As Integer
Dim strSQL As String, strLogFileName As String, strLoopAction As String
'/variable declarations
'*********************************************
'Show the hour glass so the user knows the system is doing something
DoCmd.Hourglass True
On Error GoTo WhatBroke
Set dbs = CurrentDb
'this recordset needs the be from the list we are going to be archiving FROM (Source List Items). We need
'to determine if there are any records that need to be archived given our filtering selection(s).
strSQL = "Select * FROM [SourceListItems] WHERE [SomeField] = 'SomeValue'"
'now load up the recordset
Set rs = dbs.OpenRecordset(strSQL, dbOpenDynaset)
I = 0 'counter
Do While Not rs.EOF 'how many records are we dealing with?
        I = I + 1
        rs.MoveNext
Loop
'Show the progress bar. This is helpful for when processes take some time, so the user doesn't think the system locked up
SysCmd acSysCmdInitMeter, "Processing Source List Items Archive...", rs.RecordCount
'Prep the log file. We should NEVER end up with a duplicate file name.  Intentionally not bothering to check.
'Note: The trailing '\' IS INCLUDED in the LogFilesPath tempvar - which is set by a text box that allows for a folder path selection in my user form.
'If something goes wrong with the log write process, start by checking the value in this TV first
strLogFileName = TempVars![LogFilesPath] & "LogFile_SourceListItems_" & Year(Now()) & Month(Now()) & Day(Now()) & "_hr" & DatePart("h", Now()) & "_min" & DatePart("n", Now()) & "_sec" & DatePart("s", Now()) & ".txt"
'Debug.Print strLogFileName 'in the event there's some necessary troubleshooting, uncomment the first part of this line
Open strLogFileName For Output As #1
    Print #1, "Total Records to be processed to the SharePoint Destination Items List is " & I & "|Started at " & Now() & "|By: " & (Environ$("Username")) 'write in the log who ran this process
If I > 0 Then  'we have some records to process
    rs.MoveFirst 'need to move back to the beginning of our recordset
    I = 1 'reset our counter
    Do While Not rs.EOF
        strSQL = "Select Count(ID) as ItemMatch from [DestinationListItems] WHERE [OldID]=" & rs![Id].Value 'in my destination list, I copy the original list ID to help with pricessing tasks
        Set rsMatch = dbs.OpenRecordset(strSQL, dbOpenDynaset)
        If (rsMatch![ItemMatch].Value > 0) Then 'we already have this item in our destination list, so update it instead of adding a new item
            strSQL = "Select * from [DestinationListItems] WHERE [OldID]=" & rs![Id].Value
            Set rsDestination = dbs.OpenRecordset(strSQL, dbOpenDynaset)
            rsDestination.Edit
            strLoopAction = "Update"
        ElseIf (rsMatch![ItemMatch].Value = 0) Then 'Add a new Record
            Set rsDestination = dbs.OpenRecordset("[DestinationListItems]", dbOpenDynaset)
            rsDestination.AddNew
            rsDestination![OldID].Value = rs![Id].Value
            strLoopAction = "AddNew"
        End If
        rsMatch.Close

        rsDestination![DestinationFields].Value = rs![SourceFields].Value
        rsDestination![OriginalCreateDate].Value = rs![Created].Value
        'include other fields in the list that need to be populated.  Watch out for unmathced field types between the lists,
        'and for multiple-lines of text list field types, make sure the field is set to plain text, and not rich or enhanced rich text - updates/adds will fail
        
        rsDestination.Update
        rsDestination.Bookmark = rsDestination.LastModified 'move our cursor back to the row we just updated
'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
        'After we deal with updating or adding the list item data, then need to deal with the list item attachments
        'Sharepoint doesn't allow for the folder creation! need to rethink this section...
        'Right now this function breaks if VBA tries to create the destination item attachment folder
        If ProcessListItemAttachments(rs![Id].Value, TempVars!AttachPathSource.Value, rsDestination![Id].Value, TempVars!AttachPathDestination.Value) = False Then
            Print #1, "There was an error in the attachment copy process for Source List Item # " & rs![Id].Value
        End If
'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
        SysCmd acSysCmdUpdateMeter, I
        Print #1, "Loop#" & I & "|Source List Items RowID:" & rs![Id].Value & "|Destination RowID: " & rsDestination![Id].Value & "| " & strLoopAction & "|" & Now()
        rsDestination.Close
        I = I + 1
        rs.MoveNext
    Loop 'To the next Source List Items record we want to update or add to the destination list
Else
    MsgBox "There are no matching Source List Items records for copying.", vbInformation + vbOKOnly, "Nothing to Process"
    Print #1, "There are no matching Source List Items records for processing."
End If

rs.Close
I = I - 1
Print #1, "Completed updating/adding " & I & " records on " & Now()

exitblock:
    Set dbs = Nothing
    Set rs = Nothing
    Set rsMatch = Nothing
    Set rsDestination = Nothing
    Close #1
    'Remove the progress bar
    SysCmd acSysCmdRemoveMeter
    'Show the normal cursor again
    DoCmd.Hourglass False
    Exit Function
WhatBroke:
    If (Err.Number <> 0) Then
        CopyItemsToADifferentList = False 'make sure that we stop the purge function from running if something gets pooched during this process.
        MsgBox "Error " & Err.Number & ": " & Err.Description & " in " & VBE.ActiveCodePane.CodeModule, vbOKOnly, "Error"
        DoCmd.Hourglass False
        'Print #1, "Error " & Err.Number & ": " & Err.Description & " in " & VBE.ActiveCodePane.CodeModule
        Resume exitblock
    End If
End Function

Now, the function that is called for dealing with attachments (which currently fails when VBA tries to create the destination list attachment folder) - but I'll add it here anyway. I'm thinking there has to be a different way to copy over attachments. I have not yet found it in a week searching online, in books or nagging our software engineers.

Public Function ProcessListItemAttachments(SourceRowID As Integer, SourceAttachFolder As String, DestinationRowID As Integer, DestinationAttachFolder As String) As Boolean
ProcessListItemAttachments = False  'if we suceed in copying files - or if there aren't any to copy - this will be set to true at the end
Dim strFile As String

On Error GoTo WhatBroke
'The process is:
'1)Look and see if the SourceURL exists (not all list items have attachments, so we need to check)
'2)If it does exist, then see if the destination already has the folder created.
'3)With both Source and Destination folders, loop through file(s) from the source and copy to the destination. Overwrite existing files.
'*********************************************************
'Make sure the attachment folder paths end with '\'
    If Right(SourceAttachFolder, 1) <> "\" Then
        SourceAttachFolder = SourceAttachFolder & "\"
    End If
    If Right(DestinationAttachFolder, 1) <> "\" Then
        DestinationAttachFolder = DestinationAttachFolder & "\"
    End If
'Make sure the paths are correct, and an attachment folder was found
    If ((GetAttr(SourceAttachFolder) And vbDirectory) = vbDirectory) = False Then
        MsgBox "The source list does not appear to have an attachments folder at this location:" & vbCrLf & _
        SourceAttachFolder & vbCrLf & "Please check this folder path and try again", vbCritical + vbOKOnly, "Source Attachment Folder Not Found!"
        Exit Function
    ElseIf ((GetAttr(DestinationAttachFolder) And vbDirectory) = vbDirectory) = False Then
        MsgBox "The destination list does not appear to have an attachments folder at this location:" & vbCrLf & _
        DestinationAttachFolder & vbCrLf & "Please check this folder path and try again", vbCritical + vbOKOnly, "Destination Attachment Folder Not Found!"
        Exit Function
    End If
    'Change the sourcepath to look at the path for the specific list item. Attachment folders in SharePoint are named with the ID of the list item, ie ..\Attachments\12\.
    SourceAttachFolder = SourceAttachFolder & SourceRowID & "\"
    'Does this item ID have a folder? No means the item has no attachments, and we can nope out of this function.
    'Note than an item could have a folder with no files.  That means at some point in time it did have attachments, but they were deleted.
    If Len(Dir(SourceAttachFolder, vbDirectory)) = 0 Then
        ProcessListItemAttachments = True  'Nothing to copy, so it's all good
        Exit Function
    ElseIf Len(Dir(DestinationAttachFolder, vbDirectory)) > 0 Then  'We've got a folder. Now do some processing
        DestinationAttachFolder = DestinationAttachFolder & DestinationRowID & "\" 'where do the files need to be copied to?
        If Len(Dir(DestinationAttachFolder, vbDirectory)) = 0 Then
        'Right now this next line throws an error 75 path/file access error            
        MkDir DestinationAttachFolder 'if the destination attachment item folder doesn't yet exist, create it
        End If
'If the destination folder already exists, this part will copy over all files from source to destination with no problem
strFile = Dir(SourceAttachFolder)
        Do While Len(strFile) > 0
            'Debug.Print "FileCopy source: " & SourceAttachFolder & strFile & ", destination: "; DestinationAttachFolder & strFile
            FileCopy SourceAttachFolder & strFile, DestinationAttachFolder & strFile
            strFile = Dir
        Loop
    
        ProcessListItemAttachments = True  'we made it to this point. All's good
    End If

exitblock:
    Exit Function
WhatBroke:
    If (Err.Number <> 0) Then
        MsgBox "Error " & Err.Number & ": " & Err.Description & " in " & VBE.ActiveCodePane.CodeModule, vbOKOnly, "Error"
        DoCmd.Hourglass False
        Resume exitblock
    End If
End Function