вставить вложение в тег XML с помощью VBA

Question

Я использую приведенный ниже код для циклического перемещения по данным в электронной таблице для создания файла XML:

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

Этот процесс прекрасно работает для создания нужных им имен тегов и вставки введенного текста.Проблема возникает, когда мне нужно вставить вложение, которое хранится в одной из ячеек с использованием следующего небольшого фрагмента кода:

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")

По какой-то причине документ не отображается в соответствующем теге.Кто-нибудь знает, где я иду не так, или я пытаюсь сделать невозможное!

Answer 1

Вы должны объявить тип переменной OleObject:

Dim ol As OLEObject

Затем внутри цикла for next:

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

Для получения более подробной информации см .: Макрос vba для встраивания объекта OLE на основе ячейки