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
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
'ASSUMPTIONS
	'A syntax window needs to be opened. The script executes only the code into the 
	'designated syntax window.
	'Parameters passed with the SCRIPT command will be sent to the script to execute, but
	'the script invoked by this command can read the parameters by using the Command$ 
	'function, instead of the objSpssApp.ScriptParameter() method as usual.
	'Either SCRIPT and INCLUDE commands, when placed in a macro definition (that is,
	'within DEFINE - !ENDDEFINE) are ignored, and they won't be executed. Other commands
	'in	a macro definition will be executed as usual.
	
'EFFECTS
	'Allows syncronization between scripts and syntax: now a script called with the 
	'SCRIPT command is immediately executed.

'SPSS 7.5 (tested only with SPSS version 10)
	
'Author: Fabrizio Arosio  (spss-scripts@go.to)
'        http://go.to/spss-scripts

' Modified by rlevesque@videotron.ca 2002/01/12 see **** below.

Option Explicit

Const CMD_TERMINATOR="."
Const MIN_CHARS_ID=3
Const CMD_SCRIPT="SCR", CMD_INCLUDE="INC", CMD_DEF1="DEF", CMD_DEF2="!DEF", CMD_ENDDEFINE="!ENDDEFINE"

Function FileExists(ByVal FileName As String) As Boolean
'DESCRIPTION
'  Determines whether a file exists or not
'PARAMETERS
'  FileName (Input): File name to check the existance
'RETURN
'  True if the file whose name is specified by FileName exists; False otherwise
Dim d As Date
	On Error Resume Next
	d=FileDateTime(FileName)
	FileExists= (Err=0)
	On Error GoTo 0
End Function

Sub GetTokens(ByVal Txt As String, ByVal TokSep As String, ByRef Tokens() As String, _
			  ByRef TokensPos() As Integer)
'DESCRIPTION
'  Retrieves from the Txt string all tokens and put them into the Tokens array (0-based).
'  A token is a block of text surrounded by any character contained in the TokSep string.
'  A token does not contain any character listed in the TokSep parameter.
'
'PARAMETERS
'  Txt         (Input)  : The text string from which extract tokens.
'  TokSep      (Input) 	: A string containing token-separating characters.
'  Tokens()    (Output) : A 0-based array of strings containing all found tokens.
'                         The first array element is of index 1.
'  TokensPos() (Output) : A 0-based array of integers containing, for each element, the
'                         starting positionin the Txt string of the corresponding token
'						  element in Tokens() array (having the same index)
Dim i As Integer, Ch As String*1
Dim NewToken As Boolean, NTokens As Integer
	Erase Tokens, TokensPos
	NewToken=True
	NTokens=-1
	For i=1 To Len(Txt)
		Ch=Mid(Txt,i,1)
		If InStr(TokSep,Ch)=0 Then
			If NewToken Then				
				NTokens=NTokens+1
				ReDim Preserve Tokens(0 To NTokens) As String
				ReDim Preserve TokensPos(0 To NTokens) As Integer
				NewToken=False
				TokensPos(NTokens)=i
			End If
			Tokens(NTokens)=Tokens(NTokens)+Ch
		Else
			NewToken=True
		End If
	Next i
End Sub

Function GetUnquotedText(ByVal Txt As String) As String
'DESCRIPTION
'  Returns the text contained in the Txt parameter but without the surrounding 
'  quotes/Double-quotes.
'  If text isn't correctly enclosed in quotes or double-quotes, an empty string 
'  will be returned.
'PARAMETERS
'  Txt (Input): string containing the text enclosed in quotes or double-quotes. 
'               The first character must be a quote or double-quote.
'RETURN
'  The text contained in the Txt parameter but without the surrounding quotes/double-quotes.
'  An empty string if the text isn't correctly enclosed in quotes or double-quotes.
'  If the quoted text contains duplicated charactes equal to the quoting character (" or '),
'  it will be returned without this duplicated char.
'  For example:
'                Txt             |     returned string       |        comment
'    "There's a "quoted"" test"  | There's a "quoted" test   |  enclosed between "  "" -> "
'    'There's a "quoted"" test'  | There's a "quoted"" test  |  enclosed between '  '' -> '
'    'There''s a "quoted"" test' | There's a "quoted"" test  |  enclosed between '  '' -> '
Dim Quote As String*1
Dim i As Integer, Out As String
	Select Case Left(Txt,1)
	Case """"
		Quote=""""
	Case "'"
		Quote="'"
	Case Else
		GetUnquotedText=""
		Exit Function
	End Select
	If Right(Txt,1)=Quote Then
		Out=""
		i=2
		Do
			If Mid(Txt,i,2)=String(2,Quote) Then  'duplicated quote char
				Out=Out+Quote   'returns only one quote char
				i=i+2
			Else
				Out=Out+Mid(Txt,i,1)
				i=i+1
			End If
		Loop Until i>(Len(Txt)-1)
		GetUnquotedText=Out
	Else
		GetUnquotedText=""
		Exit Function		
	End If
End Function

Function GetUnquotedTextLines(Lines() As String)
'DESCRIPTION
'  Returns the text lines contained in Lines() parameter in a single string but without
'  the surrounding quotes/double-quotes.
'  If any text element (line) of the Lines() parameter isn't correctly enclosed in quotes 
'  or double-quotes, an empty string will be returned.
'  Each line (except last one) must end with the + character, in order to specify that the 
'  quoted text continues in the next line. If not, an empty string will be returned.
'  Empty lines are ignored.
'PARAMETERS
'  Lines() (Input): 0-based string array containing in every element the text enclosed in
'                   quotes or double-quotes. Empty lines are ignored.
'RETURN
'  All text lines in the Lines() parameter put together in a single line, without surrounding 
'  quotes/double-quotes.
'  For more information, look at the GetUnquotedText function.
'  An empty string if any Lines() text element isn't correctly enclosed in quotes or 
'  double-quotes OR there isn't the string-continuation character + at the end of each 
'  element, except the last one.
Dim i As Integer, N As Integer
Dim Txt As String, Out As String
	N=UBound(Lines)
	Out=""
	For i=0 To N
		Txt=TabTrim(Lines(i))
		If Txt<>"" Then
			If i<N Then
				If Right(Txt,1)<>"+" Then
					GetUnquotedTextLines=""
					Exit Function
				End If
				'remove the + char
				Txt=Trim(Left(Txt,Len(Txt)-1))
			End If
			Txt=GetUnquotedText(Txt)
			If Txt="" Then Exit Function
			Out=Out+Txt
		End If
	Next i
	GetUnquotedTextLines=Out
End Function

Function TrimEx(ByVal Txt As String, ByVal CharsToRemove As String) As String
'DESCRIPTION
'  Returns the Txt string removed, both on the left and the right side, of any of 
'  the characters contained in the CharsToRemoved parameter string.
'  Extends the standard Trim function by also acting on other characters (CharsToRemove)
'  beside space.
'
'PARAMETERS
'  Txt           (Input): string to be returned without both preceeding and trailing 
'                         characters
'  CharsToRemove (Input): string containing the characters to be removed
'RETURN
'  Txt string without any of both preceeding and trailing characters contained in the 
'  CharsToRemove parameter.
Dim i As Integer, CharToTrash As String*1
Dim Out As String, AnyRemoved As Boolean, Removed As Boolean

	Out=Txt
	
	Do
		AnyRemoved=False
		For i=1 To Len(CharsToRemove)
			CharToTrash=Mid(CharsToRemove,i,1)
			If CharToTrash<>" " Then
				'delete all string's leading and trailing characters contained in CharToTrash
				Do
					Removed=False
				
					'delete the string first/last CharToTrash character if present
					If Left(Out,1)=CharToTrash Then
						Removed=True
						Out=Mid(Out,2)
					End If
					If Right(Out,1)=CharToTrash Then
						Removed=True
						Out=Left(Out,Len(Out)-1)
					End If
					AnyRemoved=AnyRemoved Or Removed
				Loop While Removed 'loop until there is no preceeding/trailing CharToTrash
			Else
				'remove preceeding/trailing spaces
				Txt=Trim(Out)
				AnyRemoved=AnyRemoved Or Txt<>Out
				Out=Txt
			End If
		Next i
	Loop While AnyRemoved 'loop until no characters has been removed in the loop
	TrimEx=Out
End Function

Function TabTrim (ByVal Txt As String) As String
'DESCRIPTION
'  Returns the Txt string without the spaces and tabs both on the left and the right side.
'  Extends the standard Trim functions by acting also on tabs.
'PARAMETERS
'  Txt (Input): string to be returned without both preceeding and trailing spaces/tabs
'RETURN
'  The Txt string without both preceeding and trailing spaces/tabs
	TabTrim=TrimEx(Txt," "+vbTab)
End Function

Function ExtractLine(ByRef Txt As String) As String
'DESCRIPTION
'  Extracts a line of text from the Txt string.
'PARAMETERS
'  Txt (Input/Output): string from which extract a line of text. The resulting string has 
'                      no left spaces and tabs.
'RETURN
'  The extracted line without left and right spaces
Dim Pos As Long, TxtLen As Long
	TxtLen=Len(Txt)
	Pos=InStr(Txt,vbCr) 'find the first CR character
	If Pos=0 Then 'no CR found
		ExtractLine=TabTrim(Txt)
		Txt=""
	Else		
		If Pos<TxtLen Then
			ExtractLine=TabTrim(Left(Txt,Pos-1))  'returns the line without CR and/or LF
			If Mid(Txt,Pos+1,1)=vbLf Then 'verify the sequence CR+LF
				If TxtLen=Pos+1 Then
					Txt=""   'no LF: extract only CR
				Else				
					Txt=LTrim(Mid(Txt,Pos+2)) 'extract both CR and LF
				End If
			Else
				Txt=LTrim(Mid(Txt,Pos+1)) 'no LF: extract only CR
			End If			
		End If
	End If
End Function

Sub ExtractCmdCode(ByRef Txt As String, ByRef CmdCode() As String)
'DESCRIPTION
'  Extracts from the Txt string the first command's code lines.
'  The command's code lines are returned in a string array (0-based) where each
'  element is a line of code.
'  The command termination is identified either with one or more empty lines (a line is 
'  considered empty even when it contains tabs and/or spaces), or with a command-terminator 
'  character (which must be specified with the CMD_TERMINATOR constant. 
'  The command-terminator is removed from the last code line.
'
'PARAMETERS
'  Txt        (Input/Output): string from which extract command's code lines.
'  CmdCode() (Output)       : 0-based string array whose elements represent the code lines.
Dim TxtLine As String, NLines As Integer
Dim Terminated As Boolean
	Erase CmdCode
	'ignore preceeding empty lines
	Do 
		TxtLine=ExtractLine(Txt)
	Loop While TxtLine=""
	
	Txt=TxtLine+vbCrLf+Txt
	
	'extract code lines
	NLines=-1
	Do
		TxtLine=ExtractLine(Txt)
		Terminated=Right(TxtLine,Len(CMD_TERMINATOR))=CMD_TERMINATOR Or TxtLine=""
		If TxtLine<>"" Then
			NLines=NLines+1
			ReDim Preserve CmdCode(0 To NLines) As String
			CmdCode(NLines)=TxtLine
		End If
	Loop Until Terminated
	If TxtLine<>"" Then 'terminated with command terminator
		'removes command terminator
		CmdCode(NLines)=Left(CmdCode(NLines),Len(CmdCode(NLines))-Len(CMD_TERMINATOR))
	End If
End Sub

Sub CodeLinesToTokens(CmdCode() As String, ByVal TokSep As String, _
					  Tokens() As String, Indexes() As Integer, TokensPos() As Integer)
'DESCRIPTION
'  Converts the lines of code contained in the CmdCode 0-based array into an array of tokens.
'  A token is a block of text surrounded by any character contained in the TokSep string.
'  A token does not contain any character listed in the TokSep parameter.
'
'PARAMETERS
'  CmdCode()   (Input) : 0-based array of strings representing code lines.
'  TokSep      (Input) : string containing token-separating characters.
'  Tokens()    (Output): 0-based array of strings containing all command tokens.
'  Indexes()   (Output): 0-based array of integers with as many elements as the Tokens array, 
'                        with each element containing the index of CmdCode array for the 
'					     corresponding Tokens() element.
'  TokensPos() (Output): A 0-based array of integers containing, for each element, the
'                        starting position in the CmdCode() string of the corresponding token
'						 element in Tokens() array (having the same index)
Dim NToks As Integer, TotToks As Integer
Dim t As Integer, i As Integer
Dim Toks() As String, ToksPos() As Integer
	Erase Tokens
	TotToks=-1
	For i=0 To UBound(CmdCode)
		GetTokens CmdCode(i),TokSep,Toks,ToksPos
		NToks=UBound(Toks)
		ReDim Preserve Tokens(0 To TotToks+NToks+1) As String
		ReDim Preserve Indexes(0 To TotToks+NToks+1) As Integer
		ReDim Preserve TokensPos(0 To TotToks+NToks+1) As Integer
		For t=0 To NToks
			Tokens(TotToks+t+1)=Toks(t)
			Indexes(TotToks+t+1)=i
			TokensPos(TotToks+t+1)=ToksPos(t)
		Next t
		TotToks=TotToks+NToks+1
	Next i
End Sub

Sub SendCommand(Cmd() As String)
'DESCRIPTION
'  Sends a syntax command to SPSS to execute. It doesn't wait for the command/procedure 
'  to finish.
'PARAMETERS
'  Cmd()   (Input): 0-based string array whose elements represent the lines of the 
'                   command to send to SPSS.
Dim i As Integer, Txt As String, N As Integer
	Txt=""
	N=UBound(Cmd)
	For i=0 To N
		Txt=Txt+Cmd(i)
		If i<>N Then
			Txt=Txt+vbCrLf
		End If
	Next i
	objSpssApp.ExecuteCommands Txt,False
	
End Sub

Sub ProcessScript(Cmd() As String, Tokens() As String, _
				  LIndexes() As Integer, TokensPos() As Integer)
'DESCRIPTION
'  Executes the SCRIPT command specified by parameters.
'PARAMETERS
'  Cmd()       (Input): 0-based array of strings representing code lines.
'  Tokens()    (Input): 0-based array of strings containing all command tokens.
'  LIndexes()  (Input): 0-based array of integers with as many elements as the Tokens array, 
'                       with each element containing the index of Cmd array for the 
'					    corresponding Tokens() element.
'  TokensPos() (Input): A 0-based array of integers containing, for each element, the
'                       starting position in the Cmd() string of the corresponding token
'					    element in Tokens() array (having the same index)
Dim MacroName As String, Param As String, FullTxt As String
Dim tok As Integer, NTokens As Integer, i As Integer, pidx As Integer
Dim ParamLines() As String, Txt As String
	'waits for SPSS to finish the execution of all commands
	objSpssApp.ExecuteCommands "Execute.",False
	Do While objSpssApp.IsBusy
	Loop
	
	NTokens=UBound(Tokens)
	If NTokens<1 Then
		CmdErr Cmd,"SCRIPT file name missing"
	End If
	'get script file name
	FullTxt=""
	'start from 1 (2nd token): skip the SCRIPT command-name token
	For tok=1 To NTokens
		FullTxt=FullTxt+Tokens(tok)
		MacroName=GetUnquotedText(FullTxt)
		If MacroName<>"" Then
			Exit For
		End If
	Next tok

	If tok>NTokens Then  'no macro enclosed in quotes	
		CmdErr Cmd,"Script file name not correctly enclosed in quotes"		
	End If
	If LIndexes(tok)<>LIndexes(1) Then 'if script name is not on one line
		CmdErr Cmd,"Script file name on more than one line"
	End If
	MacroName=GetUnquotedText(Mid(Cmd(LIndexes(1)),TokensPos(1),TokensPos(tok)+Len(Tokens(tok))-TokensPos(1)))		
	If MacroName="" Then  'no macro name specified	
		CmdErr Cmd,"No script file name specified or script file name not correctly enclosed in quotes"
	End If
	
	'get script parameter
	FullTxt=""
	If tok<NTokens Then  'parameter specified
		If Right(Tokens(NTokens),1)<>")" Then
			CmdErr Cmd,""")"" missing in script parameter"
		End If
		If Left(Tokens(tok+1),1)<>"(" Then
			CmdErr Cmd,"""("" missing in script parameter"
		End If
		tok=tok+1  'next token
		ReDim ParamLines(0 To LIndexes(NTokens)-LIndexes(tok)) As String
		For i=LIndexes(tok) To LIndexes(NTokens)
			pidx=i-LIndexes(tok)
			Txt=TabTrim(Cmd(i))
			If pidx=0 Then 'first parameter line
				ParamLines(pidx)=Mid(Txt,TokensPos(tok)+1)  'remove the '(' char
			Else
				ParamLines(pidx)=Txt
			End If
			If i=LIndexes(NTokens) Then 'last parameter line
				'remove the ')' char
				ParamLines(pidx)= Left(ParamLines(pidx),Len(ParamLines(pidx))-1)
			End If
		Next i
		Param=GetUnquotedTextLines(ParamLines)
		If Param="" Then
			CmdErr Cmd,"Empty ""()"" or badly quoted string in script parameter"
		End If
	End If
	If Not FileExists(MacroName) Then
		CmdErr Cmd,"Script file name '"+MacroName+"' does not exist"
	End If
	On Error Resume Next
	MacroRun MacroName,Param
	If Err<>0 Then
		MsgBox "Script """+MacroName+""" contains errors."+vbCr+ _
			   "Parameters sent"+IIf(Param=""," none",": "+Param)+vbCr+ _
			   "Check the script. Syntax execution stopped.",vbOkOnly Or vbCritical,"SyntaxScript: Script execution error"
		Exit All
	End If
	On Error GoTo 0
End Sub

Function ProcessInclude(Cmd() As String, Tokens() As String, _
				  LIndexes() As Integer, TokensPos() As Integer) As String
'DESCRIPTION
'  Returns the syntax specified in the INCLUDE command.
'PARAMETERS
'  Cmd()       (Input): 0-based array of strings representing code lines.
'  Tokens()    (Input): 0-based array of strings containing all command tokens.
'  LIndexes()  (Input): 0-based array of integers with as many elements as the Tokens array, 
'                       with each element containing the index of Cmd array for the 
'					    corresponding Tokens() element.
'  TokensPos() (Input): A 0-based array of integers containing, for each element, the
'                       starting position in the Cmd() string of the corresponding token
'					    element in Tokens() array (having the same index)
'RETURN
'  A string containing all syntax stored in the file to include.
Const CMD_FILE="FIL"
Dim NTokens As Integer, tok As Integer, i As Integer, Pos As Integer
Dim FileName As String, FullTxt As String, Lines() As String
	NTokens=UBound(Tokens)
	If NTokens<1 Then
		CmdErr Cmd,"INCLUDE file name missing"
	End If
	'INCLUDE [FILE][=] filename
	If UCase(Left(Tokens(1),3))=CMD_FILE Then	'skip the INCLUDE token (having index=0)
		'INCLUDE FILE [=] filename
		Pos=InStr(Tokens(1),"=")
		If Pos>0 And Pos<Len(Tokens(1)) Then  'INCLUDE FILE=filename
			tok=1
			Pos=Pos+1
		Else
			If NTokens<2 Then
				CmdErr Cmd,"INCLUDE file name missing"
			End If
			If Right(Tokens(1),1)="=" Then  'INCLUDE FILE= filename
				tok=2
				Pos=1
			Else
				If Tokens(2)="=" Then  'INCLUDE FILE = filename
					If NTokens<3 Then
						CmdErr Cmd,"INCLUDE file name missing"
					End If
					tok=3
					Pos=1			
				Else
					If Left(Tokens(2),1)="=" Then  'INCLUDE FILE =filename
						tok=2
						Pos=2
					Else   'INCLUDE FILE filename
						tok=2
						Pos=1
					End If
				End If
			End If
		End If
	Else 'INCLUDE filename
		tok=1
		Pos=1 
	End If
	
	'get include file name
	ReDim Lines(0 To LIndexes(NTokens)-LIndexes(tok)) As String
	Lines(0)=Mid(Tokens(tok),Pos)
	FullTxt=FullTxt+Lines(0)
	For i=1 To LIndexes(NTokens)-LIndexes(tok)
		Lines(i)=Cmd(LIndexes(tok)+i)
		FullTxt=FullTxt+Lines(i)
	Next i
	FileName=GetUnquotedTextLines(Lines)
	If FileName="" Then
		If InStr("""'",Left(FullTxt,1))>0 Then
			CmdErr Cmd,"Include file name not correctly enclosed in quotes"
		Else  'file name not enclosed in quotes
			FileName=FullTxt
		End If
	End If
	If Not FileExists(FileName) Then
		CmdErr Cmd,"Include file name '"+FileName+"' does not exist"
	End If
	'read the include file syntax
	FullTxt=""
	i=FreeFile
	Open FileName For Input As #i
	Do While Not EOF(i)
		Line Input #i, FileName
		If FullTxt<>"" Then
			FullTxt=FullTxt+vbCrLf
		End If
		FullTxt=FullTxt+FileName
	Loop
	Close #i
	ProcessInclude=FullTxt
End Function

Sub CmdErr (Cmd() As String, ByVal ErrDescr As String)
'DESCRIPTION
'  Interrupts the syntax execution for the error described in the ErrDescr parameter, 
'  caused by the command whose lines are contained in the Cmd array.
'  Writes the error message to the current output window.
'PARAMETERS
'  Cmd()    (Input): 0-based array of strings representing code lines.
'  ErrDescr (Input): string containing the error description
Const ERR_STR="SyntaxScript ERROR."
Dim i As Integer, n As Integer, e As String, RTF As String, LogStr As String
Dim OutDoc As ISpssOutputDoc, objItem As ISpssItem
	With objSpssApp
		If .Documents.OutputDocCount=0 Then
			Set OutDoc = objSpssApp.NewOutputDoc
			OutDoc.Visible=True
		Else
			Set OutDoc=.GetDesignatedOutputDoc
		End If
	End With
	e="> SyntaxScript ERROR:"+vbCr+"> "+ErrDescr+vbCr
	e=e+"> in command:"+vbCr+"> """
	For i=0 To UBound(Cmd)
		e=e+Cmd(i)
		If i<UBound(Cmd) Then
			e=e+vbCr+"> "
		End If
	Next i
	e=e+""""
	
	'objSpssApp.ExecuteCommands "!SyntaxScript Error!",True 'generates an error in a new Log object
	With OutDoc
		.ClearSelection
		.Items.GetItem(.Items.Count-1).Current=True 'set navigator's last item as the current item
		.InsertTitle "SyntaxScript ERROR", e        'insert the error message
		
		'search for a log text object
		i=.Items.Count-1
		Do
			Set objItem=.Items.GetItem(i)
			If objItem.SPSSType=SPSSLog Then
				Exit Do
			Else
				i=i-1
			End If
		Loop Until i<0
		
		If i<0 Then 'log obj not found
			'invoke an error in order to generate a log text obj
			objSpssApp.ExecuteCommands ERR_STR,True
			'get the log text object
			i=.Items.Count-1
			Do
				Set objItem=.Items.GetItem(i)
				If objItem.SPSSType=SPSSLog Then
					Exit Do
				Else
					i=i-1
				End If
			Loop Until i<0		
		End If
		
		With objItem  'log text obj item
			With .ActivateText
				LogStr=.Text  'preserve log text
				.Text=""      'clear string
				RTF=.RTFText  'store RTF code for empty string
				.Text=LogStr  'restore log text
			End With
			.Deactivate
			If i=(OutDoc.Items.Count-1) Then  'not log continuation
				OutDoc.ClearSelection
				.Selected=True
				OutDoc.Delete
			End If			
		End With	
		Set objItem=.Items.GetItem(.Items.Count-1)  'inserted title element
		With objItem
			With .ActivateText
				.RTFText=RTF  'set same formatting of log text element
				.Text=e       'write the error message with the new format				
			End With
			.Deactivate
			'count number of lines (n) in error message
			i=1
			n=1
			Do
				i=InStr(i,e,vbCr)
				If i>0 Then
					n=n+1
					i=i+1
				End If
			Loop Until i=0
			
			'set error message height
			.Height=.Height*n
		End With
	End With
	Exit All
End Sub

Sub RunSyntax(ByVal Syntax As String)
'DESCRIPTION
'  Executes the syntax contained in the Syntax string parameter.
'  Identifies the SCRIPT command in order to execute it in the right place.
'PARAMETERS
'  Syntax (Input): a string containing the syntax commands to execute.
Dim Cmd() As String, Tokens() As String, LineIndexes() As Integer, TokensPos() As Integer
Dim InDefine As Boolean
	InDefine=False
'	**** Next "Do While" was modified by Ray (former code did not stop when there were blanks at
'	the end of the syntax file).
'	Do while Syntax<>""
	Do While Len(RTrim(Syntax))>2
		ExtractCmdCode Syntax,Cmd
		CodeLinesToTokens Cmd," "+vbTab,Tokens,LineIndexes,TokensPos
		'select commands to act
'		Debug.Print "Cmd=" & Cmd(0)
'		Debug.Print "Select case=" & UCase(Left(Tokens(0),MIN_CHARS_ID))
'		Debug.Print "Remaining Syntax=" & Syntax

		Select Case UCase(Left(Tokens(0),MIN_CHARS_ID))
		Case CMD_DEF1,CMD_DEF2
'			Debug.Print " Case CMD_DEF1" & " " & "Cmd=" & Cmd(0)
			InDefine=True
'			Debug.Print Cmd(0) & vbTab & "  in Define"
			SendCommand Cmd 
		Case IIf(UCase(Left(Tokens(0),Len(CMD_ENDDEFINE)))=CMD_ENDDEFINE,Left(CMD_ENDDEFINE,MIN_CHARS_ID),"")
			InDefine=False
'			Debug.Print Cmd(0) & vbTab & "  in !Enddefine"
			SendCommand Cmd
		Case CMD_SCRIPT
			If Not InDefine Then  'script calls within a macro are ignored
'				Debug.Print Cmd(0)& vbTab & "  CMD_Script"
				ProcessScript Cmd,Tokens,LineIndexes,TokensPos
			End If
		Case CMD_INCLUDE
			If Not InDefine Then  'include file commands within a macro are ignored
				'recursive RunSyntax
'				Debug.Print Cmd(0) & "  Process Include"
				RunSyntax ProcessInclude(Cmd,Tokens,LineIndexes,TokensPos)
			End If
		Case Else
			SendCommand Cmd 
'			Debug.Print Cmd(0) & vbTab & "  Else send command"
		End Select
	Loop
End Sub

Sub Main
	With objSpssApp
		If .Documents.SyntaxDocCount>0 Then
			RunSyntax .GetDesignatedSyntaxDoc.Text
		Else
			MsgBox "No syntax window opened.",vbOkOnly Or vbCritical,"SyntaxScript.Sbs"
		End If		
	End With
End Sub