Export Data from SPSS to Pulsar Beta 0.16

'Begin Description
	'Script for exporting SPSS data file to Pulsar or Galileo by PulseTrain (UlterSystems)
	'(http://www.pulsetrain.com/solutions/application/pulsar.htm)
	'
	'Version beta/0.16
	'
	'This script is based on Export2Triple-S.sbs version : 1.1
	'by Chris Johnson, Merlinco Ltd, UK, http://www.merlinco.co.uk
	'All cool ideas and solutions are his, bugs are mine.
	'
	'The next version of Pulsar, AFAIK, will support latest XML-based Triple-S format,
	'so this script will not be necessary - use Export2Triple-S.sbs instead.
	'This one is a temporary transitional solution.
'End Description

'ASSUMPTIONS
	'This script creates VAR, DAT and CSS files to be read from Pulsar or Galileo
	'from any valid SPSS datafile. Since the capabilities of this script are limited,
	'the user should know the syntax of Pulsar's valiable and class definition files
	'to edit the resulting files.

'LIMITATIONS
	'Exported variables will always belong to "default" class.
	'Can not export files to the folders containing non-latin characters (Russian, for example)
	'All comments to this script are in Russian. Sorry, folks, but I have no time to
	'translate them :-) Instead, feel free to ask me by Email if you've got questions -
	'I know Russian, German and English to respond to your feedback, if any.

'SPSS 10.0

'Author: Alexander Bougakov
'Email:  Sanja@Bougakov.com, Alexander.Bougakov@gfk.ru

'CHANGES IN THIS VERSION:
	'Added support for the I_SCALES directive of the VAR-files
	'Now you can calculate mean and variance statistics on the categorical variables
	'if you will enable 'add integer and real scales to the Regular Tables' option
	'in the Pulsar's "Options" window.

'KNOWN BUGS:
	'Due to the bug with the SPSS' Sax Basic the objSpssApp.ScriptParameter(N)
	'will not work with the N > 0 and you won't be able to call this script from
	'application's menu. Thanks to Chris Johnson for this note.
	'
	'Since SPSS' SendKeys method is not compatible with Punto Switcher
	'(http://www.punto.ru/switcher/) and other tools, which are trying
	'to 'guess' the correct keyboard layout when you are typing, you may
	'be required to suspend such applications while running this script.

'This script was written for GfK MR Russia (http://www.gfk.ru)
'You can not use this script for any commercial purposes without permission from GfK.


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

Sub Main()
   On Error GoTo EndOfSub
   
   Const sProjectName As String = "SPSS to Pulsar Export Script"
   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("Please specify the existing (!) empty folder for output files. Folder name should be in Roman characters.",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("Enter the brief name for survey (characters only, no spaces, number can't be the first character):",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("Survey's description?",sProjectName,sSurveyFullName)
      ' Âäðóã þçåð íàæàë Cancel?
      If Len(sSurveyFullName) = 0 Then
      	bUserCancelled = True
      	GoTo EndOfSub
      End If
   End If

   'Ïîåõàëè...

    'Îòêðûâàåì àóòïóò
    If objSpssApp.Documents.OutputDocCount = 0 Then ' open new output document
       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 & " Export Map for " & Left(sExportTo,Len(sExportTo)-4) & ".DAT"
    Print #2
    Print #2,"VARIABLE" & vbTab & "Type" & vbTab & "WIDTH" & vbTab & "START   " & vbTab & "FINISH  " & vbTab & "Format  " & vbTab & "COMMENT "
    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