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
'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