'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