Extract Information From a Text Output

 

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
'This script is called by the syntax file "Extract info from Text Output.SPS" 
' See that syntax for description of purposes of this script
' http://pages.infinit.net/rlevesqu/index.htm

'********************************************************* 
'Save the following to a file named "Extract info from Text Output.SBS": 
'********************************************************* 
Option Explicit

Sub Main 

	Dim objOutput As ISpssOutputDoc 
	If objSpssApp.Documents.OutputDocCount > 0 Then 
		Set objOutput = objSpssApp.GetDesignatedOutputDoc 
		Else 
		MsgBox "You need to run SYSFILE INFO first", vbExclamation 
	End If 

	Call TrimInfoText(objOutput)  

End Sub 

'****************************
'  Keep only section between "File Type:" and "Variable Information:"
'
Sub TrimInfoText(objOutput As ISpssOutputDoc)
'****************************
	Dim objItems As ISpssItems 
	Dim objItem As ISpssItem 
	Dim objText As ISpssrtf 
	Dim strText As String 
	
	Dim lngCount As Long 	'number of items in the navigator 
	Dim i As Long 			'for-loop index 
	On Error GoTo Oopps
	
	Set objItems = objOutput.Items 
	lngCount = objItems.Count 
	
	' Find and activate the text 
	For i = lngCount - 1 To 0 Step -1 
		Set objItem = objItems.GetItem(i) 
		Debug.Print objItem.SPSSType
		If objItem.SPSSType = SPSSText Then 
			Set objText = objItem.ActivateText 
			Exit For 
		End If 
	Next 
	
	If objText Is Nothing Then 'couldn't find the Text
		MsgBox "Run SYSFILE INFO before calling this sub",vbExclamation
		Exit Sub 
	End If 

	' Get the current text
	strText = objText.Text
	
	' Delete section from "Variable Information:"
	If InStr(strText,"Variable Information:")>1 Then
		strText = RTrim(Left(strText,InStr(strText,"Variable Information:")-1))
		Else
		MsgBox "The most recent Text Output is not a raw SYSFILE INFO output!", vbCritical, "Error"
	End If
	' Delete section before "File Type:" then assign value to output text
	strText = Mid(strText,InStr(strText,"File Type:"))
	objText.Text = strText
	objItem.Deactivate 
	Exit Sub
	
	Oopps:
	Select Case Err.Number
		Case Else
			Debug.Print "Error # " & Err.Number & " " & Err.Description
			MsgBox "An unexpected error occured. The script will end.", vbCritical
			Exit Sub
	End Select		
End Sub
Related pages

...

Navigate from here