Insert a text object into the SPSS Viewer

 

Download as .sbs Shows as plain text

 

  1
  2
  3
  4
  5
  6
  7
  8
  9
 10
 11
 12
 13
 14
 15
 16
 17
 18
 19
 20
 21
 22
 23
 24
 25
 26
 27
 28
 29
 30
 31
 32
 33
 34
 35
 36
 37
 38
 39
 40
 41
 42
 43
 44
 45
 46
 47
 48
 49
 50
 51
 52
 53
 54
 55
 56
 57
 58
 59
 60
 61
 62
 63
 64
 65
 66
 67
 68
 69
 70
 71
 72
 73
 74
 75
 76
 77
 78
 79
 80
 81
 82
 83
 84
 85
 86
 87
 88
 89
 90
 91
 92
 93
 94
 95
 96
 97
 98
 99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
'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
Related pages

...

Navigate from here