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
Option Explicit

Sub Main
' This script converts the syntax of the Designated Syntax Window into
' the corresponding script format. The resulting syntax, is pasted at the end
' of the Designated Syntax Window.
' Requirements:
' Single and double quotes cannot be used in the same line of syntax
' The last line of syntax must end with a carriage return.

' Raynald Levesque 2003/07/13.

	Dim objSyntaxDoc As ISpssSyntaxDoc
	Dim strLine As String
	Dim strSynCmd As String
	Dim intPos As Integer
	Dim strScript As String
	Set objSyntaxDoc=objSpssApp.GetDesignatedSyntaxDoc
	Debug.Clear
	Call test	'Used to test resulting script

	strSynCmd = objSyntaxDoc.Text
	Debug.Print strSynCmd
	intPos = InStr(strSynCmd,vbCrLf)
	strScript = vbCrLf & "**** Script version of above syntax." & vbCrLf & vbCrLf & _
		"Dim strCmd as string" & vbCrLf
	While intPos > 0	'need to replace double quotes by single quotes & skip empty lines
		strLine = Left(strSynCmd, intPos -1)
		Debug.Print Len(strLine)
		strSynCmd = Mid(strSynCmd, intPos + 2)
		intPos = InStr(strSynCmd, vbCrLf)
		strScript = strScript & "strCmd = strCmd & " & QuoteLine(strLine) & " & vbCrLf" & vbCrLf

	Wend
	Debug.Print strSynCmd
	objSyntaxDoc.Text = objSyntaxDoc.Text & strScript & vbCrLf & _
		"objSpssApp.ExecuteCommands (strCmd,False)"

End Sub

Sub test ()

End Sub

Function QuoteLine(strText As String) As String
	Const strDoubleQuote As String =Chr(34)
	Const strSingleQuote As String =Chr(39)
	strText=Replace$(strText,strDoubleQuote,strSingleQuote)
	QuoteLine = strDoubleQuote & strText & strDoubleQuote
End Function