'Begin Description 'Inserts a text object using SendKeys to trigger the Insert>Text menu. 'End Description Sub Main Dim objOutput As ISpssOutputDoc If objSpssApp.Documents.OutputDocCount = 0 Then objSpssApp.NewOutputDoc End If Set objOutput = objSpssApp.GetDesignatedOutputDoc '****************************************** 'demonstration of how to use InsertText and SetCurrentItem Call SetCurrentItem (objOutput, objOutput.Items.Count - 1) InsertText objOutput, "Here is the first new item." Call SetCurrentItem (objOutput, objOutput.Items.Count - 1) InsertText objOutput, "Here is the second new item." Call SetCurrentItem (objOutput, 1) InsertText objOutput, "Here is the third item, which has been inserted after item 1." 'Note that calling SetCurrentItem with a bad argument will set Current to last(or first). Call SetCurrentItem (objOutput, objOutput.Items.Count + 1) InsertText objOutput, "This item will be inserted last, " & vbCrLf _ & "in spite of programmer error. " & vbCrLf _ & "Note that multiple lines of text won't be visible, " & vbCrLf _ & "until the Text item is resized. " Dim i As Long 'if the text is more than one line, we may need to resize the item. i = GetCurrentItem(objOutput) If i >= 0 Then With objOutput.Items.GetItem(i) 'if it's not a text object, then it's not the item we just inserted... If .SPSSType = SPSSText Then 'multiply the original height by the number of lines .Height = 4 * .Height 'could add a constant as well End If End With End If End Sub 'Adds a new text item after the current item 'requires: SetCurrentItem and GetCurrentItem Sub InsertText(objOutput As ISpssOutputDoc, strText As String) '****************************************** 'use SetCurrentItem to guarantee placement. 'If not set, the new text will be inserted 'after whatever item is current. 'To always make the last item current, uncomment the following: 'Call SetCurrentItem (objOutput, objOutput.Items.Count - 1) '****************************************** 'Add the new text item 'Making the output visible will also raise the window to be foremost, 'so keystrokes from SendKeys will go to the intended window. objOutput.Visible = True 'trigger the menu item Insert>Text SendKeys "%IX" 'use "%IX~" in 7.5.2 '****************************************** 'Add text to the new item 'The inserted object will be Current... if we wait long enough. Wait 1 'Give it one second before asking for the Current item. i = GetCurrentItem(objOutput) If i >= 0 Then Set objItem = objOutput.Items.GetItem(i) If objItem.SPSSType = SPSSText Then Set objText = objItem.ActivateText 'if there's already text, we've got the wrong object If objText.Text = "" Then objText.Text = strText End If objItem.Deactivate End If End If End Sub 'companion to GetCurrentItem Sub SetCurrentItem(objOutput As ISpssOutputDoc, ByVal lngItem As Long) On Error Resume Next 'ignore errors Dim objItems As ISpssItems Dim lngCount As Long Dim i As Long Set objItems = objOutput.Items lngCount = objItems.Count 'force the item set to be a legal value; set it to first or last 'comment out or modify the following to change this behavior i = lngItem If (i >= lngCount) Then i = lngCount - 1 If (i < 0) Then i = 0 objItems.GetItem(i).Current = True 'Debug.Print "Item set: " & lngItem End Sub 'companion to SetCurrentItem Function GetCurrentItem(objOutput As ISpssOutputDoc) As Long 'returns the item number of the current item as the function result 'returns a negative number if no item found, or on any error 'caller is responsible for checking that result is >= 0 On Error GoTo ErrorHandler Dim objItems As ISpssItems Dim objItem As ISpssItem Dim i As Long Set objItems = objOutput.Items 'chances are, the Current item will be near the end, so count backwards For i = objItems.Count - 1 To 0 Step -1 If objItems.GetItem(i).Current Then GetCurrentItem = i Exit Function End If Next ErrorHandler: 'if we didn't find an item or any other problem GetCurrentItem = -1 End Function