insert an attachment to an XML tag using VBA

Viewed 321

I am using the below code to cycle through data in a spreadsheet to create an XML file:

Private Sub btn_Submit_Click()
    Dim colIndex As Integer
    Dim rwIndex As Integer
    Dim asCols() As String
    Dim oWorkSheet As Worksheet
    Dim sName As String
    Dim lCols As Long, lRows As Long
    Dim iFileNum As Integer
    Dim str_switch As String ' To use first column as node
    Dim blnSwitch As Boolean
    Dim rng As Range

    For Each rng In ActiveSheet.UsedRange
        If Application.WorksheetFunction.IsText(rng) Then
            i = i + 1
        End If
    Next rng

    Set oWorkSheet = ThisWorkbook.Worksheets("Sheet1")
    sName = oWorkSheet.Name
    lCols = i

    iFileNum = FreeFile
    Open "C:\temp\test2.xml" For Output As #iFileNum

    Print #iFileNum, "<?xml version=""1.0""?>"
    Print #iFileNum, "<" & sName & ">" ' add sheet name to xml file as First Node
    i = 1
    Do Until i = lCols + 1
        Print #iFileNum, " <" & oWorkSheet.Cells(1, i).Text & ">" & Trim(oWorkSheet.Cells(2, i).Value) & "</" & oWorkSheet.Cells(1, i).Text & ">"
        i = i + 1
    Loop

    Print #iFileNum, "</" & sName & ">"

    Close #iFileNum
    MsgBox ("Complete")
ErrorHandler:
    If iFileNum > 0 Then Close #iFileNum
    Exit Sub
End Sub

This process is working perfectly to create the tag names I want, and inserting the text entered. The problem arises where I need to insert an attachment which is stored in one of the cells using the following little chunk of code:

Set rng = Range("AH2")  'Name the cell in which you want to place the attachment
rng.RowHeight = 56
On Error Resume Next
fpath = Application.GetOpenFilename("All Files,*.*", Title:="Select file", MultiSelect:=True)
For i = 1 To UBound(fpath)
    rng.Select
    rng.ColumnWidth = 12
    ActiveSheet.OLEObjects.Add _
    Filename:=fpath(i), _
    Link:=False, _
    DisplayAsIcon:=True, _
    IconFileName:="excel.exe", _
    IconIndex:=0, _
    IconLabel:=extractFileName(fpath(i))
    Set rng = rng.Offset(0, 1)
Next i
MsgBox ("Document Uploaded")

For some reason, the document is not appearing in its relevant tag. Does anyone know where I am going wrong, or if I am attempting the impossible!

1 Answers

You have to declare variable type of OleObject:

Dim ol As OLEObject

Then, inside a for next loop:

Set ol = ActiveSheet.OLEObjects.Add(....)
With ol
    .Top = rng.Top
    .Left = rng.Left
End With

For further details, please see: vba macro to embed OLEobject based on cell

Related