Как скопировать текстовый и нетекстовый контент из буфера обмена и вставить его в поле описания REQ в HP Quality Center?

Question

Используя объекты Word в VBA, я открываю документ Word, а затем перебираю все элементы списка (имена заголовков) с различными стилями заголовков, представленными на панели навигации Word.

Для каждого заголовка я извлекаю название заголовка и его содержание.

Теперь для каждого заголовка я хочу создать REQ в ALM, где именем REQ будет имя заголовка, а содержимым описания REQ будут данные, содержащиеся в заголовке (данные могут быть текстовыми или html или изображениями или смешанными).

Я добился успеха до того момента, когда я должен скопировать данные, хранящиеся для каждого заголовка, но сообщу, что не могу понять, как вставить этот контент в описание REQ при создании нового требования.

Пожалуйста, найдите ниже код:

1. Открыть текстовый документ, используя VBA:

    Sub Main()
            Dim strFile As String
            Dim oWord As Word.Application
            Dim oWdoc As Word.Document
            Dim oPar As Word.Paragraph
            Dim rng As Word.Range
            strFile = "C:\Users\SQVA\Desktop\My_Work\MyTest3.docx"
            'Set oWord = CreateObject("Word.Application")
            Set oWord = New Word.Application
            Set oWdoc = oWord.Documents.Open(strFile)
        Call Get_Heading_Name(oWord, oWdoc, strFile, rng)
        Call Close_Word(oWord, oWdoc)
    End Sub

2. Перейдите к каждому документу "Заголовок в Word" и получите содержимое заголовка и содержимое заголовка:

Sub Get_Heading_Name(oWord As Word.Application, oWdoc As Word.Document, strFile As String, rng As Word.Range)
    oWord.Visible = True
    Dim astrHeadings As Variant
    Dim strText As String
    Dim intItem As Integer
    Set rng = oWdoc.Content
    astrHeadings = _
    oWdoc.GetCrossReferenceItems(wdRefTypeHeading)
    For intItem = LBound(astrHeadings) To UBound(astrHeadings)
            strText = Trim$(astrHeadings(intItem))
            'Debug.Print CStr(strText)
            'Debug.Print astrHeadings(intItem).
            Dim my_String As String
            Dim intLevel
            If CStr(strText) <> "" Then
                my_String = Right(strText, Len(strText) - InStr(strText, " "))
                intLevel = GetLevel(CStr(astrHeadings(intItem)))
                oWdoc.Range(0, 0).Select
                With oWord.Selection.Find
                    .Style = oWdoc.Styles("Heading " & intLevel)
                    .Text = my_String
                    If .Execute Then
                        'Debug.Print "Found"
                        Call SelectHeadingandContent(oWdoc, oWord)


                    'oWord.ShowClipboard
                    'Call Create_Folder_Requirements(strText, oWord.Selection.Copy)
                    ''  Debug.Print TypeName(oWord.Selection.Copy)
                    ''  Debug.Print IsObject(oWord.Selection.Copy)
                    ''  Debug.Print VarType(oWord.Selection.Copy)
                    ''  Debug.Print IsEmpty(oWord.Selection.Copy)
                            Dim td As New TDConnection
                            Dim iscp As ISupportCopyPaste
                            'Dim clipboard
                            **oWord.Selection.Copy**

                            td.InitConnectionEx "http://XXXX:8080/qcbin"
                            td.Login "XXXX", "XXXX"
                            td.Connect "POC", "Empty_Project"
                            Dim RFact As ReqFactory
                            Dim myreq As Req
                            Dim myreq1 As Req
                            Dim dt As String
                            dt = Format(CStr(Now), "yyy_mm_dd_hh_mm")
                            Set iscp = td.ReqFactory
                            Set RFact = td.ReqFactory
                            Set myreq = RFact.AddItem(-1)
                            myreq.TypeId = "Folder"
                            myreq.Name = "Folder" & dt
                            myreq.Field("RQ_REQ_COMMENT") = "Parent Folder"
                            myreq.Post
                            Set myreq1 = RFact.AddItem(myreq.ID)
                            myreq1.TypeId = "Folder"
                            myreq1.Name = strText
                            'myreq1.Paragraph = iscp.PasteFromClipBoard(clipboard, myreq1.ID)
                            myreq1.Field("RQ_REQ_COMMENT") =
                            ' = PasteFromClipBoard(myreq1.ID)
                            'myreq1.Field("RQ_REQ_COMMENT") = Trim(CStr(ThisWorkbook.Sheets("Sheet1").Range("B" & j).Value))
                            myreq1.Post
                            td.DisconnectProject
                            td.ReleaseConnection
                            Set myreq = Nothing
                            Set myreq1 = Nothing
                            Set RFact = Nothing
                            Set iscp = Nothing
                            Set td = Nothing
                End If
            End With
        End If
Next intItem
End Sub
 Код для прохождения всех заголовков и выбора содержимого заголовка 

Private Function GetLevel(strItem As String) As Integer
    ' Return the heading level of a header from the
    ' array returned by Word.
    ' The number of leading spaces indicates the
    ' outline level (2 spaces per level: H1 has
    ' 0 spaces, H2 has 2 spaces, H3 has 4 spaces.

    Dim strTemp As String
    Dim strOriginal As String
    Dim longDiff As Integer

    ' Get rid of all trailing spaces.
    strOriginal = RTrim$(strItem)

    ' Trim leading spaces, and then compare with
    ' the original.
    strTemp = LTrim$(strOriginal)

    ' Subtract to find the number of
    ' leading spaces in the original string.
    longDiff = Len(strOriginal) - Len(strTemp)
    GetLevel = (longDiff / 2) + 1
End Function


Sub SelectHeadingandContent(oWdoc As Word.Document, oWord As Word.Application)
Dim headStyle 'As Style
' Checks that you have selected a heading. If you have selected multiple paragraphs,checks only the first one. If you have selected a heading, makes sure the whole paragraph is selected and records the style. If not, exits the subroutine.
    If oWdoc.Styles(oWord.Selection.Paragraphs(1).Style).ParagraphFormat.OutlineLevel < wdOutlineLevelBodyText Then
        Set headStyle = oWord.Selection.Paragraphs(oWord.Selection.Paragraphs.Count).Style
        oWord.Selection.Expand wdParagraph
    Else: Exit Sub
    End If
' Turns off screen updating so the the screen does not flicker.
Application.ScreenUpdating = False
' Loops through the paragraphs following your selection, and incorporates them into the selection as long as they have a higher outline level than the selected heading (which corresponds to a lower position in the document hierarchy). Exits the loop if there are no more paragraphs in the document.
       ' Dim My_Text As String
       ' My_Text = ""
        Do While oWdoc.Styles(oWord.Selection.Paragraphs(oWord.Selection.Paragraphs.Count).Next.Style).ParagraphFormat.OutlineLevel > headStyle.ParagraphFormat.OutlineLevel
             'Debug.Print oWord.Selection.Paragraphs(oWord.Selection.Paragraphs.Count).Range.Text
             oWord.Selection.MoveEnd wdParagraph
             ' Debug.Print oWord.Selection.Paragraphs(oWord.Selection.Paragraphs.Count).Range.Text
             ' My_Text = My_Text + vbCr + oWord.Selection.Paragraphs(oWord.Selection.Paragraphs.Count).Range.Text
             If oWord.Selection.Paragraphs(oWord.Selection.Paragraphs.Count).Next Is Nothing Then Exit Do
        Loop


'Debug.Print My_Text
' Turns screen updating back on.
Application.ScreenUpdating = True
End Sub

'Sub Create_Folder_Requirements(strText, oWord.Selection.Copy)

'End Sub

4. Закрыть слово документ:


Sub Close_Word(oWord As Word.Application, oWdoc As Word.Document)
        oWdoc.Close SaveChanges:=wdDoNotSaveChanges
        oWord.Quit
        Set oWdoc = Nothing
        Set oWord = Nothing
End Sub

С уважением, Срихари