'Начало описания ' При вызове скриптов из синтаксиса в SPSS существует проблема синхронизации, ' заключающаяся в том, что скрипты выполняются после завершения выполнения ВСЕГО файла синтаксиса, ' в результате чего скрипты делают на то, что от них ожидается. ' Этот скрипт пытается решить проблему. Он читает синтаксис из активного окна ' синтаксиса и передаёт его SPSS на выполнение. В случае, если встречается вызов команды SCRIPT, ' она немедленно выполняется ' Организацией выполнения синтаксиса управляет скрипт, не SPSS. Поэтому ' синтаксис, содержащий вызов скриптов, должен быть запущен на выполнение этим скриптом. ' Команды INCLUDE, которые могут встречаться в синтаксисе, также поддерживаются. ' Как только завершается выполнение синтаксиса, подключаемого через INCLUDE, возобновляется ' выполнение текущего. Поддерживаются также вложенные вызовы INCLUDE. Количество уровней вызова ' ограничивается лишь располагаемым скриптом объёмом оперативной памяти. ' Таким же образом, команды SCRIPT, встречающиеся в синтаксисе, вызванном через INCLUDE, ' немедленно выполняются. ' Скрипт работает как интерпретатор. Он прочитывает каждую строку синтаксиса и, как только ' встречает вызов SCRIPT или INCLUDE, предпринимает соответствующие действия. ' Команды, не распознаваемые скриптом, оставляются для обработки процессору SPSS. 'Конец описания 'УСЛОВИЯ И ОГРАНИЧЕНИЯ 'Требуется открытое окно редактора. Скрипт при запуске выполняет код из активного окна. 'Параметры, передаваемые командой SCRIPT, передаются в вызываемый скрипт, 'однако последний может обращаться к ним с помощью функции Command$ вместо обычного метода 'objSpssApp.ScriptParameter(). 'Команды SCRIPT или INCLUDE, встречающиеся в теле макроса (т.е. 'внутри структуры DEFINE - !ENDDEFINE), игнорируются и не обрабатываются. Прочие команды 'внутри макросов обрабатываются как обычно. 'РЕЗУЛЬТАТ 'Скрипт синхронизирует обработку вызываемого скрипта с вызывающим синтаксисом. 'Теперь команды SCRIPT выполняются немедленно в том месте синтаксиса, где они встретились. 'SPSS 7.5 (проверено только в версии SPSS 10) 'Автор: Fabrizio Arosio (spss-scripts@go.to) ' http://go.to/spss-scripts 'См. также скрипт SyntaxScript2.sbs, который исправляет одну неточность данного скрипта. 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 'ОПИСАНИЕ ' Проверяет наличие файла 'ПАРАМЕТРЫ ' FileName (входной): имя файла для проверки его существования 'РЕЗУЛЬТАТ ' Истина, если файл FileName существует; Иначе - Ложь 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) 'ОПИСАНИЕ ' Делит строку Txt на маркеры и помещает их в массив Tokens(). ' Маркером считается элемент строки, заключённый между символами-разделителями маркеров (из строки TokSep). ' Маркер сам по себе не содержит символов из строки TokSep. ' 'ПАРАМЕТРЫ ' Txt (входящий) : текстовая строка из которой извлекаются маркеры. ' TokSep (входящий) : строка с символами-разделителями маркеров. ' Tokens() (исходящий) : массив с найденными маркерами. ' TokensPos() (исходящий) : массив, содержащий номера символов, с которых начинается маркер в строке Txt. 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 'ОПИСАНИЕ ' Возвращает текст из параметра Txt без кавычек слева и справа. ' Если текст некорретно (несимметрично и т.д.) закавычен, возвращается пустая строка. 'ПАРАМЕТРЫ ' Txt (входящий): строка, содержащая текст, заключённая в кавычки ' Первый символ должен быть " или '. 'РЕЗУЛЬТАТ ' Текст из параметра Txt без окружающих его кавычек. ' Пустая строка, если Txt неправильно закавычен. ' Если кавычки дублируются, текст возвращается без дублирующих кавычек. ' Например: ' Txt | возвращается | комментарий ' "There's a "quoted"" test" | There's a "quoted" test | "" -> " ' 'There's a "quoted"" test' | There's a "quoted"" test | '' -> ' ' 'There''s a "quoted"" test' | There's a "quoted"" test | '' -> ' 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 'дублирующий символ кавычек Out=Out+Quote 'оставляем только одну кавычку 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) 'ОПИСАНИЕ ' Возвращает текстовые строки из массива Lines() без кавычек. ' Если строка из массива Lines() некорректно (несимметрично и т.д.) заключена в кавычки, ' возвращается пустая строка. Обрабатываются обычные (") и одинардные (') кавычки. ' Каждая строка, продолжающаяся на следующей строке (кроме последней), должны иметь символ "+" ' на конце, чтобы обозначить это. Иначе возвращается пустая строка. ' Пустиые строки игнорируются. 'ПАРАМЕТРЫ ' Lines() (входящий): массив строк, элементы которого - строки, заключенные в кавычки. 'РЕЗУЛЬТАТ ' Все текстовые строки из массива Lines() объединяются в одну строку без кавычек. ' См. также функцию GetUnquotedText. ' Возвращается пустая строка если элементы массива Lines() некорректно закавычены ' или нет символа продолжения строки (+) в каждой из строк кроме последней. 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"+" Then GetUnquotedTextLines="" Exit Function End If 'убираем символ + 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 'ОПИСАНИЕ ' Возвращает строку Txt с удалёнными справа и слева символами, содержащимися в ' списке удаляемых символов (строке CharsToRemoved). ' Расширяет стандартную функцию Trim возможностью удаления символов из строки CharsToRemove. ' 'ПАРАМЕТРЫ ' Txt (входящий): строка, в которой нужно избавиться от лишних символов справа и слева ' CharsToRemove (входящий): строка, содержащая список удаляемых символов 'РЕЗУЛЬТАТ ' Строка Txt без символов из строки CharsToRemove справа и слева. 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 'удаляем все начальные и конечные символы, которые присутствуют в CharToTrash Do Removed=False 'удаляем первый/последний символы, которые имеются в CharToTrash, если таковые наличествуют в Txt 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 'повторяем пока не останется символов для удаления справа и слева Else 'удаляем пробелы справа и слева Txt=Trim(Out) AnyRemoved=AnyRemoved Or Txt<>Out Out=Txt End If Next i Loop While AnyRemoved 'повторяем пока в очередном цикле из строки ничего не удаляется TrimEx=Out End Function Function TabTrim (ByVal Txt As String) As String 'ОПИСАНИЕ ' Возвращает строку Txt без пробелов и символов табуляции справа и слева. ' Расширяет стандартную функцию Trim, справляясь также с табуляцией. 'ПАРАМЕТРЫ ' Txt (входящий): строка, из которой нужно удалить пробелы и табуляцию справа и слева 'РЕЗУЛЬТАТ ' Строка Txt без пробелов и табуляции справа и слева TabTrim=TrimEx(Txt," "+vbTab) End Function Function ExtractLine(ByRef Txt As String) As String 'ОПИСАНИЕ ' Извлекает строку кода из строки Txt. 'ПАРАМЕТРЫ ' Txt (входной/выходной): строка, из которой извлекается отдельная строка кода. ' Результатирующая строка не имеет лишних пробелов и табуляций. 'РЕЗУЛЬТАТ ' Извлечённая строка без пробелов слева и справа Dim Pos As Long, TxtLen As Long TxtLen=Len(Txt) Pos=InStr(Txt,vbCr) 'поиск первого символа CR (возврата каретки) If Pos=0 Then 'если не найдено CR ExtractLine=TabTrim(Txt) Txt="" Else If Pos"" Then NLines=NLines+1 ReDim Preserve CmdCode(0 To NLines) As String CmdCode(NLines)=TxtLine End If Loop Until Terminated If TxtLine<>"" Then 'если закончили символом окончания команды 'убираем его 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) 'ОПИСАНИЕ ' Преобразует строки команды из массива CmdCode в массив маркеров (элементов команд). ' Например, команда "FREQ x." преобразуется в маркеры "FREQ" и "x". Это нужно для того, чтобы ' отличать команды вызова скриптов и Include от других команд, распознавать параметры скриптов и т.д. ' Маркер (token) - текстовый блок, который возможно окружён символами из строки TokSep. ' 'ПАРАМЕТРЫ ' CmdCode() (входящий) : массив строк с кодом синтаксиса. ' TokSep (входящий) : строка с символами-раделителями маркеров (пробелы, табуляция и проч.). ' Tokens() (исходящий): массив с маркерами. ' Indexes() (исходящий): массив с номерами строк кода из массива CmdCode, которой принадлежат маркеры. ' TokensPos() (Output): массив со порядковыми номерами символов из строк массива CmdCode(), ' с которых начинаются маркеры из массива Tokens() 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) 'ОПИСАНИЕ ' Посылает команду синтаксиса на исполнение процессору SPSS. ' Не ждёт окончания выполнения команды или процедуры. 'ПАРАМЕТРЫ ' Cmd() (входной): массив строк с командой на выполнение процессором 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) 'ОПИСАНИЕ ' Выполняет команду SCRIPT, переданную сюда в качестве параметра. 'ПАРАМЕТРЫ ' Cmd() (входной): массив со строками кода. ' Tokens() (входной): строковый массив с элементами команд (маркерами). ' LIndexes() (входной): массив с номерами строк, к которым относится маркер, храняшийся ' в предыдущем массиве той же размерности. ' TokensPos() (входной): массив, хранящий начальную позицию маркера в строке из массива Cmd ' имеет ту же размерность, что и Tokens() 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 'ждём пока SPSS закончит выполнение предыдущих команд. На всякий случай принудительно запустим вычисления objSpssApp.ExecuteCommands "Execute.",False Do While objSpssApp.IsBusy Loop NTokens=UBound(Tokens) If NTokens<1 Then CmdErr Cmd,"SCRIPT file name missing" End If 'получим имя файла со скриптом FullTxt="" 'для этого начнём с 1-го (т.е. 2-го, поскольку нумерация элементов массива начинается с '0) маркера: пропустим маркер "SCRIPT" 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 'имя файла со скриптом некорректно заключено в кавычки CmdErr Cmd,"Имя файла со скриптом некорректно заключено в кавычки" End If If LIndexes(tok)<>LIndexes(1) Then 'если имя файла со скриптом занимает более 1 строки CmdErr Cmd,"Имя файла со скриптом занимает более 1 строки" End If MacroName=GetUnquotedText(Mid(Cmd(LIndexes(1)),TokensPos(1),TokensPos(tok)+Len(Tokens(tok))-TokensPos(1))) If MacroName="" Then 'Не задано имя файла скрипта CmdErr Cmd,"Имя файла скрипта не задано или некорректно заключено в кавычки" End If 'получим параметр скрипта, который, возможно, указан FullTxt="" If tok")" Then CmdErr Cmd,""")"" пропущена при задании параметра" End If If Left(Tokens(tok+1),1)<>"(" Then CmdErr Cmd,"""("" пропущена при задании параметра" End If tok=tok+1 'увеличиваем счётчик маркеров 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 'первая строка параметров ParamLines(pidx)=Mid(Txt,TokensPos(tok)+1) 'убираем символ '(' Else ParamLines(pidx)=Txt End If If i=LIndexes(NTokens) Then 'последняя строка параметров 'убираем символ ')' ParamLines(pidx)= Left(ParamLines(pidx),Len(ParamLines(pidx))-1) End If Next i Param=GetUnquotedTextLines(ParamLines) If Param="" Then CmdErr Cmd,"Пустой параметр ""()"" или параметр некорректно заключен в кавычки" End If End If If Not FileExists(MacroName) Then CmdErr Cmd,"Файл скрипта '"+MacroName+"' не найден" End If On Error Resume Next MacroRun MacroName,Param If Err<>0 Then MsgBox "Скрипт """+MacroName+""" содержит ошибки."+vbCr+ _ "Переданы параметры... "+IIf(Param=""," нет",": "+Param)+vbCr+ _ "Проверьте скрипт. Выполнение синтаксиса остановлено.",vbOkOnly Or vbCritical,"SyntaxScript: ошибка выполнения скрипта" 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 'ОПИСАНИЕ ' Возвращает синтаксис, вызываемый командой INCLUDE. 'ПАРАМЕТРЫ ' Cmd() (входящий): массив строк синтаксиса. ' Tokens() (входящий): массив строк с маркерами (элементами) команд. ' LIndexes() (входящий): массив номеров строк, в которых встречаются маркеры из предыдущего массива ' TokensPos() (входящий): массив, содержащий начальные позиции в командах из массива Cmd() ' для всех маркеров из массива Tokens() 'РЕЗУЛЬТАТ ' Строка, содержащая весь синтаксис, подключаемый через команду 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" End If 'вызов имеет следующую структуру: INCLUDE [FILE][=] имя файла If UCase(Left(Tokens(1),3))=CMD_FILE Then 'пропускаем первый маркер ("INCLUDE"), его индекс=0 'INCLUDE FILE [=] filename Pos=InStr(Tokens(1),"=") If Pos>0 And Pos0 Then CmdErr Cmd,"Имя файла, вызываемого через Include, некорректно заключено в кавычки" Else 'имя файла не закавычено FileName=FullTxt End If End If If Not FileExists(FileName) Then CmdErr Cmd,"Файл, вызываемый через Include ( '"+FileName+"'), не найден" End If 'считываем содержимое файла include 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) 'ОПИСАНИЕ ' Прерывает выполнение синтаксиса при переданном описании ошибки ErrDescr, ' вызванной выполнением команды, содержащейся в массиве Cmd. ' Пишет сообщение об ошибке в текущее окно результатов (output) и форматирует его как стандартный лог SPSS 'ПАРАМЕТР ' Cmd() (входящий): массив строк, со строками синтаксиса (индекс начинается с 0). ' ErrDescr (входящий): строка с описанием ошибки 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 " End If Next i e=e+"""" With OutDoc .ClearSelection .Items.GetItem(.Items.Count-1).Current=True 'устанавливаем последний объект в окне результатов как текущий .InsertTitle "SyntaxScript ERROR", e 'и вставляем после него сообщение об ошибке 'поиск текстового объекта с логом 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 'если объект с логом не был найден 'генерируем ошибку чтобы создать элемент лога objSpssApp.ExecuteCommands ERR_STR,True 'обращаемся к объекту с логом 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 'текстовый объект, содержащий лог With .ActivateText LogStr=.Text 'сохраняем существующий текст в логе .Text="" 'очищаем строку RTF=.RTFText 'помещаем код в формате RTF в пустую строку .Text=LogStr 'восстанавливаем лог End With .Deactivate If i=(OutDoc.Items.Count-1) Then 'удаляем искусственно сгенерированный лог, который нужен был лишь для того, чтобы взять из него образец форматирования OutDoc.ClearSelection .Selected=True OutDoc.Delete End If End With Set objItem=.Items.GetItem(.Items.Count-1) 'выделяем заголовок лога With objItem With .ActivateText .RTFText=RTF 'применяем то же форматирование к элементу лога .Text=e 'вставляем сообщение об ошибке End With .Deactivate 'подсчитываем количество строк (n) в сообщении об ошибке 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 'устанавливаем нужную высоту сообщения об ошибке .Height=.Height*n End With End With Exit All End Sub Sub RunSyntax(ByVal Syntax As String) 'ОПИСАНИЕ ' Выполняет синтаксис, содержащийся в переданном параметре Syntax. ' Определяет команду на вызов скрипта SCRIPT чтобы вовремя выполнить её. 'ПАРАМЕТРЫ ' Syntax (входящий): строка, содержащая команды синтаксиса на выполнение. Dim Cmd() As String, Tokens() As String, LineIndexes() As Integer, TokensPos() As Integer Dim InDefine As Boolean InDefine=False Do While Syntax<>"" 'Выбирает очередную команду с помощью функции. ExtractCmdCode Syntax,Cmd 'и делим её на смысловые части (имя команды и параметры, например) CodeLinesToTokens Cmd," "+vbTab,Tokens,LineIndexes,TokensPos 'выбираем тип команды, которую сейчас будем выполнять Select Case UCase(Left(Tokens(0),MIN_CHARS_ID)) Case CMD_DEF1,CMD_DEF2 InDefine=True SendCommand Cmd Case IIf(UCase(Left(Tokens(0),Len(CMD_ENDDEFINE)))=CMD_ENDDEFINE,Left(CMD_ENDDEFINE,MIN_CHARS_ID),"") InDefine=False SendCommand Cmd Case CMD_SCRIPT If Not InDefine Then 'Вызовы скриптов из макросов игнорируются ProcessScript Cmd,Tokens,LineIndexes,TokensPos End If Case CMD_INCLUDE If Not InDefine Then 'команды include из макросов игнорируются 'рекурсивные вызов этой процедуры RunSyntax RunSyntax ProcessInclude(Cmd,Tokens,LineIndexes,TokensPos) End If Case Else SendCommand Cmd End Select Loop End Sub Sub Main 'Проверяет, есть ли открытое окно синтаксиса. Если оно открыто, 'вызывает процедуру RunSyntax, передавая ей в качестве параметра содержание окна синтаксиса. With objSpssApp If .Documents.SyntaxDocCount>0 Then RunSyntax .GetDesignatedSyntaxDoc.Text Else MsgBox "Нет открытого окна синтаксиса.",vbOkOnly Or vbCritical,"SyntaxScript.Sbs" End If End With End Sub