'Begin Description
	'Скрипт для экспорта файла данных SPSS в Pulsar или Galileo от PulseTrain (UlterSystems)
	'(http://www.pulsetrain.com/solutions/application/pulsar.htm)
	'
	'Бета-версия/0.16
	'
	'Этот скрипт основан на другом скрипте: Export2Triple-S.sbs, версии 1.1
	'от Криса Джонсона (Chris Johnson, Merlinco Ltd, UK, http://www.merlinco.co.uk)
	'Все лучшие идеи - его, все баги - мои.
	'
	'Следующая версия Пульсара, насколько я знаю, будет поддерживать последний формат Triple-S, основанный на XML,
	'так что потребность в этом скрипте исчезнет. Тогда нужно будет использовать вместо него Export2Triple-S.sbs.
	'Так что это - временное, переходное решение.
'End Description

'УСЛОВИЯ
	'Скрипт создаёт файлы .VAR, .DAT и .CSS для чтения через Pulsar или Galileo
	'из любого валидного файла данных SPSS. Возможности этого скрипта ограничены,
	'так что предполагается, что пользователь знаком с синтаксисом определений переменных и классов
	'программы Pulsar для окончательного редактирования выходных файлов.

'ОГРАНИЧЕНИЯ
	'Экспортированные переменные всегда будут относиться к классу "default".
	'Невозможен экспорт в папки, содержащие в названии нелатинские символы (кириллицу, например)
	'Вопросы можете адресовать мне по E-mail (по-русски, по-немецки, по-английски).

'SPSS 10.0

'Автор:: Александр Бугаков / Alexander Bougakov
'E-mail:  Sanja@Bougakov.com

'ИЗМЕНЕНИЯ В ДАННОЙ ВЕРСИИ:
	'Добавлена поддержка директивы I_SCALES для VAR-файлов
	'Теперь вы можете вычислять статистики среднего и дисперсии для категориальных переменных,
	'если задействуете опцию 'add integer and real scales to the Regular Tables'
	'в окне "Options" программы Pulsar.

'ИЗВЕСТНЫЕ ПРОБЛЕМЫ:
	'Из-за возможной ошибки в SPSS Sax Basic, свойство objSpssApp.ScriptParameter(N)
	'не будет срабатывать при N > 0, так что в скрипт можно передать только один параметр.
	'Спасибо Крису Джонсону за этот комментарий.
	'
	'Так как метод SendKeys в Sax Basic может конфликтовать с программой Punto Switcher
	'(http://www.punto.ru/switcher/) и прочими программами, которые пытаются установить
	'"правильную" раскладку, когда вы печатаете, может потребоваться приостановить работу таких
	'программ на время выполнения скрипта.

'Скрипт создан по заказу GfK MR Russia (http://www.gfk.ru)
'Не разрешается какое-либо коммерческое использование данного скрипта без разрешения компании GfK.

'Перевод: А. Балабанов, 21.01.2009 (комментарии автора на русском языке сохранены).
'Размещение: http://www.spsstools.ru/Scripts/ImportExport/ExportToPulsarSRVv016.txt (.sbs).
'Проверено: SPSS 15.0.0.

'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

Sub Main()
   On Error GoTo EndOfSub
   
   Const sProjectName As String = "Скрипт экспорта из SPSS в Pulsar"
   Const sTarget = "Pulsar v.3.12"
   
   'Следующие две строки - для Visual Studio:
   'Dim objSpssApp As spsswin.Application
   'Set objSpssApp = GetObject(, "SPSS.Application")

   Dim bSuccess ' Флаг - экспорт завершён успешно
   Dim bUserCancelled ' Юзер нажал "Отмена"
   Dim sExportTo ' Куды экспортируем?

   Dim objData As ISpssDataDoc
   Dim objSpssOutputDoc As ISpssOutputDoc
   
   Dim sSurveyName As String ' Название сарвея
   Dim sSurveyFullName As String ' Полное название сарвея

   Dim Index As Long ' Индекс текущей переменной
   Dim NumVars As Long ' Число переменных
   Dim NumCases As Long ' Число кейсов в переменной
   Dim pNames As Variant ' Массив для хранения имён переменных
   Dim pLabels As Variant ' Массив для хранения имён лейблов
   Dim pMsmtLevels As Variant ' Массив для хранения типов переменных 
   Dim pLabelCounts As Variant ' Массив для хранения числа лейблов в переменной
   Dim pTypes As Variant ' Массив для хранения типов переменных
   Dim pFormats As Variant  ' Массив для хранения форматов переменных
   Dim pWidths As Variant  ' Массив для хранения ширин переменных
   Dim pFracs As Variant  ' Массив для хранения ширины десятичной части
   Dim pColumnWidths As Variant  ' Массив для хранения ширин колонок
   Dim pJust As Variant  ' Массив для хранения инфы о выравнивании текста в ячейке
   Dim pValLabels As Variant  ' Массив для хранения лейблов переменных
   Dim pValues As Variant  ' Массив для хранения значений, сопоставленных лейблам

   Dim startTime As Date ' Начало обработки
   Dim stopTime As Date ' Конец обработки

   Dim currIndent As String	' Табуляторы для отступов
   Dim Options As String ' Опции экспорта
   Dim IsSingle As Boolean  ' Если тип переменной - Single
   Dim isCharacter As Boolean  ' Если тип переменной - Character
   Dim isInteger As Boolean  ' Если тип переменной - Integer
   Dim currPos As Long ' Текущая позиция в файле данных
   Dim WtVar As String ' Переменная, по которой идёт взвешивание (ежели есть)
   Dim Universe As String ' Размер Universe - по умолчанию равен числу строк в файле данных
   Dim Range_Min As String ' Минимальное значение для колич. переменных
   Dim Range_Max As String ' ...и макс. значение
   Dim objOutputItems As ISpssItems
   Dim objOutputItem As ISpssItem
   Dim sComment As String	
   Dim WeightVar As Boolean	' Переменная, по которой производится взвешивание
   Dim NumNeg As Long
   Dim NegativeValues As Boolean
   
   ' Берём текущий SPSS Data document
   Set objData = objSpssApp.Documents.GetDataDoc(0)

   ' Если название папки, куда экспортируем, название сарвея и комментарий, переданы в качестве параметра скрипту, не мучаем юзера лишними вопросами:
   'sExportTo       = objSpssApp.ScriptParameter (0)
   'sSurveyName     = objSpssApp.ScriptParameter (1)
   'sSurveyFullName = objSpssApp.ScriptParameter (2)

   'Universe        = objSpssApp.ScriptParameter (3)
   Universe = CStr(objData.GetNumberOfCases)

   If Len(sExportTo) = 0 Then
      Dim sDefaultPath As String
      sDefaultPath = Left(objData.GetDocumentPath,Len(objData.GetDocumentPath)-4) & ".var"
      sExportTo = InputBox("Укажите путь к существующей (!) папке для экспорта файлов. Имя папки должно включать только латинские символы.",sProjectName,sDefaultPath)
      ' Вдруг юзер нажал Cancel?
      If Len(sExportTo) = 0 Then
      	bUserCancelled = True
      	GoTo EndOfSub
      End If
   End If

    Dim sFilename As String
    sFilename = Left(sExportTo,Len(sExportTo)-4)
    While (InStr(sFilename, "\\") <> 0)
      sFilename = Mid(sFilename, InStr(sFilename, "\\") + 1)
    Wend

   If Len(sSurveyName) = 0 Then
      sSurveyName = sFilename
      sSurveyName = InputBox("Введите краткое имя обследования (символы без пробелов, не может начинаться с цифры):",sProjectName,sSurveyName)
      ' Вдруг юзер нажал Cancel?
      If Len(sSurveyName) = 0 Then
      	bUserCancelled = True
      	GoTo EndOfSub
      End If
   End If

   If Len(sSurveyFullName) = 0 Then
      sSurveyFullName = sFilename
      sSurveyFullName = InputBox("Описание обследования?",sProjectName,sSurveyFullName)
      ' Вдруг юзер нажал Cancel?
      If Len(sSurveyFullName) = 0 Then
      	bUserCancelled = True
      	GoTo EndOfSub
      End If
   End If

   'Поехали...

    'Открываем аутпут
    If objSpssApp.Documents.OutputDocCount = 0 Then ' открываем новый документ результатов
       Set objSpssOutputDoc=objSpssApp.NewOutputDoc
    Else
       'Открываем текущий аутпут
       Set objSpssOutputDoc=objSpssApp.Documents.GetOutputDoc(0)
    End If
    
    objSpssOutputDoc.Visible=True
    Set objOutputItems = objSpssOutputDoc.Items
    If objOutputItems.Count()=0 Then
      Set objOutputItem = objOutputItems.GetItem(objOutputItems.Count())
    Else
      Set objOutputItem = objOutputItems.GetItem(objOutputItems.Count()-1)
    End If
    objOutputItem.Current=True
    
    'Вставляем заголовок
    objSpssOutputDoc.InsertHeading(sProjectName)
    Set objOutputItem = objOutputItems.GetItem(objOutputItems.Count()-1)
    objOutputItem.Current=True
    objSpssOutputDoc.Promote
    objSpssOutputDoc.InsertTitle("Title",sProjectName)

    'Засекаем время:
    startTime = Now()

    'Грузим данные о переменных SPSS:
    Call objData.GetVariableInfo(pNames, pLabels, pTypes, pMsmtLevels, pLabelCounts)
    Call objData.GetVariableFormats(pFormats, pWidths, pFracs)
    
    'Определяем число переменных
    NumVars = objData.GetNumberOfVariables
    
    'Проверяем, взвешивается ли файл
    WtVar=objData.GetWeightingVariable(False)

    'Открываем VAR-файл для аутпута
    Open sExportTo For Output As #1
    
    'Открываем лог
    Open Left(sExportTo,Len(sExportTo)-4) & ".LOG" For Output As #2
    Print #2,sTarget & " Схема данных для " & Left(sExportTo,Len(sExportTo)-4) & ".DAT"
    Print #2
    Print #2,"ПЕРЕМ.  " & vbTab & "ТИП " & vbTab & "ШИРИНА" & vbTab & "НАЧ.    " & vbTab & "КОНЕЦ   " & vbTab & "ФОРМАТ  " & vbTab & "КОММЕНТ. "
    Print #2,"--------" & vbTab & "----" & vbTab & "------" & vbTab & "-----   " & vbTab & "------  " & vbTab & "------  " & vbTab & "-------  "

    'Пишем заголовок:
    Print #1 , "-- Survey description file " & Left(sExportTo,Len(sExportTo)-4) & ".var" 
    Print #1 , "-- for " & sTarget & "  Generated by " & sProjectName
    Print #1 , "-- " & Format(Date,"dd-mm-yyyy") & " at " & Format(Time,"hh:nn:ss")
    Print #1

    'Открываем файл под классы:
    Open Left(sExportTo,Len(sExportTo)-4) & ".CSS" For Output As #5
    Print #5 , "CLASS DEFAULT Is "
    Print #5 , "	TITLE " & Chr(34) & "Default class" & Chr(34) & ", "
    Print #5 , "End CLASS; "
    'Print #5 , "CLASS MISC Is "
    'Print #5 , "	TITLE " & Chr(34) & "Служебные переменные" & Chr(34) & ", "
    'Print #5 , "End CLASS; "
    Close #5 ' - нефиг файл держать открытым

    'Перебираем одна за одной переменные:
    currPos=1
    For i=0 To NumVars-1
    Print #1 ' Пустая строчка - так, для красоты
    
    'Инициализация значений временных переменных
      WeightVar=False
      Options=""
      IsSingle = False
      isCharacter=False
      isInteger=False
      
    'Определяем тип переменной
      Select Case pFormats(i)
       Case SpssPrintFormatF ' считаем численным только формат FormatF - все остальные - строковыми
         If pLabelCounts(i) = 0 Then ' Нет лейблов - считаем численной
           isInteger=True
         Else ' Лейблы есть - считаем строковой
           IsSingle=True
           'Обегаем все лейблы внутри переменной
           Call objData.GetVariableValueLabels (i, pValues, pValLabels)
           NumNeg=0
           NegativeValues=False
           For K=0 To pLabelCounts(i)-1
             If Len(pValLabels(k))=0 Then
               pValLabels(k)=Str(pValues(k))
             End If
           'Ловим отрицательные значения
             If pValues(k) <=0 Then
               If pValues(k) <> 0 Then
                 NumNeg=NumNeg+1
               End If
               NegativeValues=True
             End If
           Next k
           If pFracs(i) <> 0 Or (NegativeValues And NumNeg >= 1 ) Or (NegativeValues And pLabelCounts(i)=1) Then 
           ' особый случай - не можем экспортировать как single, будем как Real
             isInteger=True
           End If
         End If

         'Ведётся ли взвешивание по этой переменной?
         If pNames(i)=WtVar Then
           isInteger=True
           WeightVar=True
         End If
       Case Else ' все остальные переменные считаем строковыми
           isCharacter = True
       End Select

       'Имя переменной:
       If pLabels(i)="" Then
         pLabels(i)=pNames(i)
       End If

       If isCharacter Then
       'Пишем лог:
         Call WriteLog(2,Format(pNames(i)),"C",Format(pWidths(i),"0"),Format(currPos,"0"),Format(currPos+pWidths(i)-1,"0"),"A" & Format(pWidths(i),"0") ,GetFormats(pFormats(i)))
         'Величина элемента
         Call WriteSRVOpen(1,"CHARACTER " & pNames(i) & " IS",currIndent)
         'Пошли писать данные о переменной:
         Call Titles(pLabels(i), pNames(i), currIndent, currPos, pWidths(i))
         Call WriteSRVComment(1,"Element size is: " & Format(pWidths(i),"0"),currIndent)
         Call WriteSRVClose(1,"END CHARACTER; ",currIndent)
       End If
       If Not isCharacter Then
         'Если переменная не строковая, пишем лейблы
         If isInteger Then' если количественный, то range
           Call getMin_MaxVal(pWidths(i),pFracs(i),Range_Min,Range_Max)
           'Options=" from=""" & Range_Min & """ to=""" & Range_Max & """"
           'Call WriteSRV(1,"range " & Options,currIndent)
           If WeightVar Then
             Call WriteSRVOpen(1,"REAL " & pNames(i) & " IS",currIndent)
           Else
             Call WriteSRVOpen(1,"INTEGER " & pNames(i) & " IS",currIndent)
           End If
           'Пошли писать данные о переменной:
           Call Titles(pLabels(i), pNames(i), currIndent, currPos, pWidths(i))
           Call WriteSRV(1,"RANGE " & Range_Min & ".." & Range_Max & ", ",currIndent)
           Call WriteSRVComment(1,"Element size is: " & Format(pWidths(i),"0"),currIndent)
           If WeightVar Then
             Call WriteSRVClose(1,"END REAL; ",currIndent)
           Else
             Call WriteSRVClose(1,"END INTEGER; ",currIndent)
           End If
       End If


         If IsSingle Then
         Call WriteSRVOpen(1,"SINGLE " & pNames(i) & " IS",currIndent)
         ' Для каждого лейбла
         Call Titles(pLabels(i), pNames(i), currIndent, currPos, pWidths(i))
         Call WriteSRVComment(1,"Element size is: " & Format(pWidths(i),"0"),currIndent)
         Call WriteSRVOpen(1,"CATEGORIES IS",currIndent)
         Dim Iscales As String
		 Iscales = ""
           For K=0 To pLabelCounts(i)-1
             fmt="0"
             If pFracs(i) > 0 Then
               fmt="0." & String$(pFracs(i),"0")
             End If
             Call WriteSRV(1,"DATUM IS " & Chr(34) & Replace(pValLabels(k),Chr(34),Chr(34) & Chr(34)) & Chr(34) & "=" & Format(pValues(k),fmt) & ", ",currIndent) 'Пишем каждый лейбл
             If Format(pValues(k),fmt) = "99" Then
				If Iscales = "" Then
	             	Iscales = Iscales & "0"
	            Else
	             	Iscales = Iscales & ", 0"
	            End If
             Else
				If Iscales = "" Then
					Iscales = Iscales & Format(pValues(k),fmt)
	            Else
					Iscales = Iscales & ", " & Format(pValues(k),fmt)
	            End If
             End If
           Next K
         'закрываем блок categories
         Call WriteSRVClose(1,"END CATEGORIES, ",currIndent)
         'Пишем I_SCALES 
         Call WriteSRV(1,"I_SCALES (" & Iscales & "), ",currIndent) 'Пишем I_SCALES
		 Iscales = ""
         Call WriteSRVClose(1,"END SINGLE; ",currIndent)
         End If

         'Пишем лог:
         If IsSingle And Not isInteger Then
           If Not NegativeValues Then
             Call WriteLog(2,Format(pNames(i)),"S",Format(pWidths(i),"0"),Format(currPos,"0"),Format(currPos+pWidths(i)-1,"0"),"F" & Format(pWidths(i),"0") &  "."  & Format(pFracs(i),"0"),"")
           Else ' Одиночное нулевое значение
             Call WriteLog(2,Format(pNames(i)),"S",Format(pWidths(i),"0"),Format(currPos,"0"),Format(currPos+pWidths(i)-1,"0"),"F" & Format(pWidths(i),"0") &  "."  & Format(pFracs(i),"0"),"zero-value")
           End If
         End If
         If IsSingle And isInteger Then
           If WeightVar Then
             Call WriteLog(2,Format(pNames(i)),"Q",Format(pWidths(i),"0"),Format(currPos,"0"),Format(currPos+pWidths(i)-1,"0"),"F" & Format(pWidths(i),"0") &  "."  & Format(pFracs(i),"0"),"weight-labelled")
           Else
             Call WriteLog(2,Format(pNames(i)),"Q",Format(pWidths(i),"0"),Format(currPos,"0"),Format(currPos+pWidths(i)-1,"0"),"F" & Format(pWidths(i),"0") &  "."  & Format(pFracs(i),"0"),"labelled")
           End If
         End If
         If isInteger And Not IsSingle Then
           If WeightVar Then
             Call WriteLog(2,Format(pNames(i)),"Q",Format(pWidths(i),"0"),Format(currPos,"0"),Format(currPos+pWidths(i)-1,"0"),"F" & Format(pWidths(i),"0") &  "."  & Format(pFracs(i),"0"),"weight")
           Else
             Call WriteLog(2,Format(pNames(i)),"Q",Format(pWidths(i),"0"),Format(currPos,"0"),Format(currPos+pWidths(i)-1,"0"),"F" & Format(pWidths(i),"0") &  "."  & Format(pFracs(i),"0"),"")
           End If
         End If
       End If
       'увеличиваем позицию
       currPos=currPos+pWidths(i)
     Next i

    ' конец VAR-файла

    Print #1
    Print #1 , "SURVEY " & sSurveyName & " Is "
    Print #1 , "	TITLE " & Chr(34) & sSurveyFullName & Chr(34) & ", "
    If Trim(WtVar) <> "" Then
          Print #1 , "	WEIGHT IS "
          Print #1 , "		TITLE " & Chr(34) & "Weights are defined by " & Trim(WtVar) & " variable" & Chr(34) & ", "
          Print #1 , "		UNIVERSE " & Universe & ", "
          Print #1 , "		VARIABLE " & Chr(34) & Trim(WtVar) & Chr(34) & ", "
          Print #1 , "	END WEIGHT; "
    Else
          Print #1 , "	WEIGHT IS "
          Print #1 , "		TITLE " & Chr(34) & "All weights are equal to 1" & Chr(34) & ", "
          Print #1 , "		UNIVERSE " & Universe & ", "
          Print #1 , "		VARIABLE " & Chr(34) & "DUMMY_WEIGHT" & Chr(34) & ", "
          Print #1 , "	END WEIGHT; "
    End If
    Print #1 , "END SURVEY; "

    'If Trim(WtVar) = "" Then
          Print #1
          Print #1 , "REAL DUMMY_WEIGHT IS "
          Print #1 , "	TITLE " & Chr(34) & "Dummy weight variable" & Chr(34) & ", "
          Print #1 , "	CLASSES (DEFAULT), "
          Print #1 , "	COMPUTE 1.0, "
          Print #1 , "END REAL; "
          Print #1
    'End If

    Print #1
    Print #1 , "-- End of survey description file. "
    
    ' а теперь сохраняем файл с данными:
    strCommand="WRITE OUTFILE='" & Left(sExportTo,Len(sExportTo)-4) & ".DAT' NoTable/ all."
    strcommand=strcommand & vbCrLf & "Execute."
    ' запускаем команду на выполнение (пользуемся асинхронной обработкой)
    objSpssApp.ExecuteCommands strCommand, False
	Do
      DoEvents
    Loop Until Not objSpssApp.IsBusy
    bSuccess = True ' Флажок

    
    Open (Left(sExportTo,Len(sExportTo)-4) & ".srv") For Output As #6
    
    Print #6 , ";----------------------------------------------------------------------------"
    Print #6 , ";         Survey  description  file                                          "
    Print #6 , ";----------------------------------------------------------------------------"
    Print #6 , "[Survey]"
    Print #6 , ""
    Print #6 , "Title=" & sSurveyFullName & " "
    Print #6 , "Type=Pulsar survey"
    Print #6 , "DataPath="
    Print #6 , "UserPath="
    Print #6 , ""
    Print #6 , "[Weights]"
    If Trim(WtVar) <> "" Then
      Print #6 , "Weights are defined by " & Trim(WtVar) & " variable = " & Universe & ", " & Trim(WtVar)
    Else
      Print #6 , "All weights are equal to 1 = " & Universe & ", dummy_weight"
    End If
    Print #6 , ""
    Print #6 , "[DataFiles]"
    Print #6 , "VAR=" & sFilename & ".var"
    Print #6 , "DAT=" & sFilename & ".dat"
    Print #6 , "CSS=" & sFilename & ".css"
    Print #6 , "VMM=" & sFilename & ".vmm"
    Print #6 , "TMM=" & sFilename & ".tmm"
    Print #6 , "FMM=" & sFilename & ".fmm"
    Print #6 , "TXX=" & sFilename & ".txx"
    Print #6 , "CMM=" & sFilename & ".cmm"
    Print #6 , ""
    Print #6 , "[Titles]"
    Print #6 , "VAR=Variables definitions"
    Print #6 , "DAT=Flat data"
    Print #6 , "CSS=Classes definitions"
    Print #6 , "VMM=Logical schema"
    Print #6 , "TMM=Transposed schema"
    Print #6 , "FMM=Flat schema"
    Print #6 , "TXX=Transposed data"
    Print #6 , "CMM=Classes schema"
    Print #6 , ""
    Print #6 , "[Accessors]"
    Print #6 , "DACTRAN=TMM, TXX, Transposed data accessor"
    Print #6 , "DACFLAT=FMM, DAT, Flat data accessor"
    Print #6 , ""
    Print #6 , ";----------------------------------------------------------------------------"
    Close #6 ' - нефиг файл держать открытым
 
EndOfSub:
    'Вежливо возвращаем память системе:
    On Error Resume Next
    Set objSpssApp = Nothing
    Close #1
    Close #2
    On Error GoTo 0

    If bSuccess = True Then
      objSpssOutputDoc.Visible=True
      'Вставляем лог в аутпут:
      SendKeys "%IF~" & Left(sExportTo,Len(sExportTo)-4) & ".log " & "~" ,True 
      stopTime = Now() ' Останавливаем секундомер
   	  sMsg = "Файл был успешно экспортирован в " & sExportTo & vbCrLf & "(Процесс занял " & Format((stopTime - startTime), "nn:ss") & ")" & vbCrLf & "Данные сохранены в " & Left(sExportTo,Len(sExportTo)-4) & ".DAT"
   	  MsgBox sMsg,,sProjectName
    Else
   	  If bUserCancelled = False Then MsgBox "Упс.. у нас проблемы - экспортировать те получилось :-(",,sProjectName
    End If
End Sub

Sub Titles(pLabelsi As Variant, pNamesi As Variant, currIndent As Variant, currPos As Variant, pWidthsi As Variant)
       'Лейблы переменной:
       If Trim(pLabelsi) <> "" Then
	       Call WriteSRV(1,"TITLE "  & Chr(34) &  CStr(Replace(Trim(pLabelsi),Chr(34),Chr(34) & Chr(34))) & Chr(34) &  ", ",CStr(currIndent))
	   Else
	       'Если лейбла нет, подставим имя переменной
	       Call WriteSRV(1,"TITLE "  & Chr(34) &  CStr(Replace(Trim(pNamesi),Chr(34),Chr(34) & Chr(34))) & Chr(34) &  ", ",CStr(currIndent))
	   End If
       'Вычисляем позицию в файле данных:
       Options = ""
       Options=Format(currPos,"0")
       If pWidthsi <> 1 Then
         Options=Options & ".." & Format(currPos+pWidthsi-1,"0")
       End If
       'Пишем данные о положении переменной в dat-файле
       Call WriteSRV(1,"LOCATION " & Options & ", ",CStr(currIndent))
       Call WriteSRV(1,"CLASSES (Default)" & ", ",CStr(currIndent))
       Options=""
End Sub


Sub WriteSRV(Fn As Integer,tag As String,currIndent As String)
   Print #Fn,currIndent & "" & tag
End Sub

Sub WriteSRVOpen(Fn As Integer,tag As String,currIndent As String)
    Print #Fn,currIndent & tag
    currIndent=currIndent & vbTab
End Sub

Sub WriteSRVClose(Fn As Integer,tag As String,currIndent As String)
   If Len(currIndent)>0 Then
     currIndent=Left(currIndent,Len(currIndent)-1)
   End If
   Print #Fn,currIndent & tag
End Sub

Sub WriteSRVComment(Fn As Integer,tag As String,currIndent As String)
   Print #Fn,currIndent & "-- " & Replace(tag,"--","  ") & " "
End Sub

Sub getMin_MaxVal(width As Variant,dp As Variant,Range_Min As String,Range_Max As String)
   Dim work As String
   work=String$(width,"9")
   Range_Max=work
   If width = 1 Then
     Range_Min="0"
   Else
     Range_Min="-" & Left(work,Len(work)-1)
   End If
   If dp > 0 Then
     Range_Min=Left(Range_Min,width-dp-1) & "." & String$(dp,"9")
     Range_Max=Left(Range_Max,width-dp-1) & "." & String$(dp,"9")
   End If
End Sub

Sub WriteLog(Fn As Integer,string1 As String,string2 As String,string3 As String,string4 As String,string5 As String,string6 As String,string7 As String)
   string1= PadtoLen(string1,8)
   string2= PadtoLen(string2,4)
   string3= PadtoLen(string3,5)
   string4= PadtoLen(string4,8)
   string5= PadtoLen(string5,8)
   string6= PadtoLen(string6,8)
   Print #Fn,string1 & vbTab & string2 & vbTab & string3 & vbTab & string4 & vbTab & string5 & vbTab & string6 & vbTab & string7
End Sub

Function PadtoLen(InString As String,maxlen As Integer) As String
   Dim i
   i=Len(InString)
   If i < maxlen Then
     PadtoLen=InString & String(maxlen-i," ")
   Else
     PadtoLen=Left(InString,maxlen)
   End If
End Function

Function GetFormats(FormatCode As Variant) As String
   Select Case FormatCode
     Case	SpssPrintFormatA
       GetFormats="" ' cтроковый формат - ok
     Case	SpssPrintFormatAhex
       GetFormats="hex"
     Case	SpssPrintFormatComma
       GetFormats="comma"
     Case	SpssPrintFormatDollar
       GetFormats="dollar"
     Case	SpssPrintFormatF
       GetFormats="" ' численный формат - ok
     Case	SpssPrintFormatIb
       GetFormats="binary"
     Case	SpssPrintFormatPibhex
       GetFormats="binary"
     Case	SpssPrintFormatP
       GetFormats="binary"
     Case    SpssPrintFormatPib
       GetFormats="binary"
     Case	SpssPrintFormatPk
       GetFormats="binary"
     Case	SpssPrintFormatRb
       GetFormats="binary"
     Case	SpssPrintFormatRbhex
       GetFormats="binary"
     Case	SpssPrintFormatZ
       GetFormats="zoned"
     Case	SpssPrintFormatN
       GetFormats="integer"
     Case	SpssPrintFormatE
       GetFormats="sci not"
     Case	SpssPrintFormatDate
       GetFormats="date"
     Case	SpssPrintFormatTime
       GetFormats="time"
     Case	SpssPrintFormatDatetime
       GetFormats="datetime"
     Case	SpssPrintFormatAdate
       GetFormats="date"
     Case	SpssPrintFormatJdate
       GetFormats="date"
     Case	SpssPrintFormatDtime
       GetFormats="time"
     Case	SpssPrintFormatWkday
       GetFormats="date"
     Case	SpssPrintFormatMonth
       GetFormats="date"
     Case	SpssPrintFormatMoyr
       GetFormats="date"
     Case	SpssPrintFormatQyr
       GetFormats="date"
     Case	SpssPrintFormatWkyr
       GetFormats="date"
     Case	SpssPrintFormatPct
       GetFormats="percent"
     Case	SpssPrintFormatDot
       GetFormats="dot"
     Case	SpssPrintFormatCca
       GetFormats="currency"
     Case	SpssPrintFormatCcb
       GetFormats="currency"
     Case	SpssPrintFormatCcc
       GetFormats="currency"
     Case	SpssPrintFormatCcd
       GetFormats="currency"
     Case	SpssPrintFormatCce
       GetFormats="currency"
     Case	SpssPrintFormatEdate
       GetFormats="date"
     Case	SpssPrintFormatSdate
       GetFormats="date"
     Case Else
       GetFormats="unknown"
   End Select
End Function