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
'Begin Description
'Скрипт заменяет указанные слова, содержащиеся в заголовках, подписях строк и столбцов и сносках
'мобильных таблиц. Правила замены задаются в диалоговом окне пользователем: он указывает слова,
'подлежащие замене в паре с заменяющими словами.
'Есть возможность осуществлять замену нескольких слов за раз, указывая в диалоговом окне список (перечень)
'заменяемых и заменяющих слов.
'Такой список может быть сохранён во внешнем файле для последующего использования.
'Дополнительный флажок в диалоговом окне позволяет пользователю указать, должен ли быть поиск заменяемых слов
'чувствительным к регистру (различать ли при поиске строчные и прописные буквы).
'Пользователь также может ограничить область поиска в таблицах отдельными их частями
'(заголовком, сносками, подписями ячеек).
'Наконец, можно указать, затронет ли действие скрипта все мобильные таблицы в документе,
'либо только выделенные.
'Важно: скрипт заменяет только слова, указанные в списке. Даже если вам требуется заменить только одно слово,
'необходимо включить его в список (запустите скрипт и см. диалоговое окно).
'End Description

'УСЛОВИЯ
	'Документ выдачи открыт в SPSS. Скрипт обрабатывает только текущее окно выдачи (окно назначения).

'РЕЗУЛЬТАТЫ
	'Указанные слова, содержащиеся внутри мобильных таблиц текущего документа выдачи (в заголовках, подписях ячеек, сносках),
	'заменены в соответствии со списком замены.
	
'Создано для версии SPSS 7.5
'Автор: Fabrizio Arosio  (Fabrizio_Arosio@rotta.com)

' Перевод: А. Балабанов, 17.11.2008.
' Проверено: SPSS 15.0.1.1, SPSS 13.0. Внесены исправления (см. комментарии со значками ### - примеч. перев.)


Option Explicit
Const LIST_FILE_EXT="SR"   'определение расширения для файла со списком замены

Const EMPTY_ITEM=" "+vbNullChar
Const PL_TITLE=1, PL_FOOT=2, PL_LABEL=4

'Массивы, содержащие исходные и заменяющие слова
Public Orig() As String, Subst() As String
'Массив со списком для диалогового окна
Public TheList() As String

Sub SetList(atPos As Byte)
'процедура обновления позиции списка
	TheList(atPos)=Orig(atPos+1)+"  ->  "+Subst(atPos+1)
End Sub

Sub LoadList
Dim i As Byte 'счётчик цикла
	ReDim TheList(0 To UBound(Orig)) As String
	For i=1 To UBound(Orig)
		SetList(i-1)
	Next i
	TheList(i-1)=EMPTY_ITEM
End Sub

Function CreateDialog(OnlySelected As Boolean, MatchCase As Boolean, Where As Integer) As Boolean
'Отображение диалогового окна.
'Параметр OnlySelected будет иметь значение True, если пользователь указал работать только с выделенными таблицами.
'Параметр MatchCase будет иметь значение True, если пользователь хочет сделать поиск чувствительным к регистру.
'Параметр Where будет содержать код, обозначающий места поиска в таблицах, указанные пользователем.
ReDim TheList(0) As String
	TheList(0)=EMPTY_ITEM
	Begin Dialog UserDialog 550,329,"Поиск и замена текста в мобильных таблицах",.DialogFunc
		GroupBox 10,0,530,231,"Список замены",.GroupBox2
		Text 20,21,190,14,"Что заменить",.Txt1
		Text 20,63,120,14,"Чем заменить",.Txt2
		TextBox 20,35,510,21,.txtOrig
		TextBox 20,77,510,21,.txtSubst
		GroupBox 10,245,220,70,"Таблицы для поиска",.GroupBox1
		OptionGroup .TablesToReplace
			OptionButton 20,266,160,14,"&Все табл.",.optReplaceAll
			OptionButton 20,287,160,14,"В&ыделенные табл.",.optReplaceSelected
		PushButton 450,273,90,21,"&Заменить",.cmdReplace
		ListBox 20,119,510,77,TheList(),.ListBox
		CancelButton 450,301,90,21,.Quit
		Text 20,105,50,14,"Список",.Text3
		PushButton 20,203,110,21,"&Добавить",.cmdAddtoList
		PushButton 140,203,110,21,"&Удалить",.cmdDelfromList
		PushButton 350,203,90,21,"&Сохранить",.cmdSaveList
		PushButton 450,203,80,21,"За&грузить",.cmdLoadList
		GroupBox 240,238,180,84,"Область поиска",.GroupBox3
		CheckBox 270,259,90,14,"Заг&лавие",.chkOnTitle
		CheckBox 270,301,90,14,"С&носки",.chkOnFoot
		CheckBox 270,280,100,14,"&Подписи",.chkOnLblCells
		CheckBox 440,245,100,14,"&Контр. рег.",.chkCase
	End Dialog
	Dim Dlg As UserDialog
	Dlg.chkOnTitle=1
	Dlg.chkOnFoot=1
	Dlg.chkOnLblCells=1
	CreateDialog=Dialog(Dlg)<>0
	OnlySelected=(Dlg.TablesToReplace=1)
	MatchCase=Dlg.chkCase
	Where=Dlg.chkOnTitle*PL_TITLE Or Dlg.chkOnFoot*PL_FOOT Or Dlg.chkOnLblCells*PL_LABEL
End Function

Sub InitializeList
Dim NItem As Integer
    NItem=UBound(TheList)
    DlgValue "ListBox",NItem
    DlgEnable "cmdDelfromList",False
    DlgEnable "cmdAddtoList",False
End Sub

Function DialogFunc%(DlgItem$, Action%, SuppValue%)
'Слежение за действиями пользователя в диалоговом окне
Static NItem As Integer, NumItems As Integer
Dim i As Integer, Num As Integer, FileName As String
    Select Case Action%
    Case 1 ' Инициализация диалога
		InitializeList
    Case 2 ' Изменение значения или нажатие кнопки
	    DialogFunc% = True 'не выходить из диалога
        Select Case DlgItem$
        Case "ListBox"  'выбран элемент списка
        	NItem=DlgValue ("ListBox")
	    	If NItem<UBound(TheList) Then        	
	        	DlgText "TxtOrig",Orig(NItem+1)
	        	DlgText "TxtSubst",Subst(NItem+1)
	    	Else
	        	DlgText "TxtOrig",""
	        	DlgText "TxtSubst",""
        	End If
	    Case "cmdAddtoList"  'нажата кнопка добавления в список
	    	If NItem=UBound(TheList) Then
	    		NItem=NItem+1
	    		ReDim Preserve Orig(1 To NItem) As String
	    		ReDim Preserve Subst(1 To NItem) As String
	    		ReDim Preserve TheList(0 To NItem) As String
	    		Orig(NItem)=DlgText("txtOrig")
	    		Subst(NItem)=DlgText("txtSubst")
				SetList(NItem-1)
				TheList(NItem)=EMPTY_ITEM
	        	DlgText "TxtOrig",""
	        	DlgText "TxtSubst",""				
			Else
	    		Orig(NItem+1)=DlgText("txtOrig")
	    		Subst(NItem+1)=DlgText("txtSubst")
				SetList(NItem)
	    	End If
	    	DlgListBoxArray "ListBox",TheList()
	    	DlgValue "ListBox",NItem
	    Case "cmdDelfromList"	 'нажата кнопка удаления из списка
    		For i=NItem+1 To UBound(Orig)-1
    			Orig(i)=Orig(i+1)
    			Subst(i)=Subst(i+1)
    			SetList(i-1)
    		Next i
    		TheList(i-1)=TheList(i)
    		If UBound(Orig)>1 Then
	    		ReDim Preserve Orig(1 To UBound(Orig)-1) As String
	    		ReDim Preserve Subst(1 To UBound(Subst)-1) As String
	    	Else
	    		Erase Orig,Subst
	    	End If
	    	ReDim Preserve TheList(0 To UBound(TheList)-1) As String
	    	DlgListBoxArray "ListBox",TheList()
	    	DlgValue "ListBox",NItem
	    Case "cmdSaveList"    'нажата кнопка сохранения списка в файл
	    	FileName=GetFilePath(,LIST_FILE_EXT,,"Сохранение списка замены",3)
	    	If FileName<>"" Then
		    	Num=FreeFile()
		    	Open FileName For Output As #Num
		    	Write #Num, UBound(Orig)
		    	For i=1 To UBound(Orig)
		    		Write #Num, Orig(i),Subst(i)
		    	Next i
		    	Close #Num
		    End If
	    Case "cmdLoadList"   'нажата кнопка загрузки списка из файла
	    	FileName=GetFilePath(,LIST_FILE_EXT,,"Загрузка списка замены",0)
	    	If FileName<>"" Then
		    	Num=FreeFile()
		    	Open FileName For Input As #Num
		    	Input #Num,NItem
		    	ReDim Orig(1 To NItem) As String
		    	ReDim Subst(1 To NItem) As String
		    	ReDim TheList(0 To NItem) As String
		    	For i=1 To NItem
		    		Input #Num,Orig(i),Subst(i)
		    		SetList(i-1)
		    	Next i
		    	Close #Num
		    	LoadList	    	
		    	DlgListBoxArray "ListBox",TheList()
		    	InitializeList
		    End If
        Case "cmdReplace"    'Нажата кнопка "Заменить"
        	DialogFunc% = False 'выход из диалога
        Case "Quit"          'Нажата кнопка "Отмена"
        	DialogFunc% = False 'выход из диалога
        End Select
	Case 3 ' изменение текстового поля, или поля со списком
    Case 4 ' изменение фокуса
    Case 5 ' простой
    	'заполнение полей, снятие/установка флажков
    	If NItem<UBound(TheList) Then        	
    		If NumItems<>UBound(TheList) Then
	        	DlgText "TxtOrig",Orig(NItem+1)
	        	DlgText "TxtSubst",Subst(NItem+1)
	        	NumItems=UBound(TheList)
	        End If
    		DlgText "cmdAddtoList","Исп&равить"
    		DlgEnable "cmdDelfromList",True
    	Else
    		If NumItems<>UBound(TheList) Then
	        	DlgText "TxtOrig",""
	        	DlgText "TxtSubst",""
	        	NumItems=UBound(TheList)
	        End If
        	DlgText "cmdAddtoList","&Добавить"
        	DlgEnable "cmdDelfromList",False
    	End If
		DlgEnable "cmdAddtoList", Not(DlgText("TxtOrig")="" And DlgText("TxtSubst")="")
    	DlgEnable "cmdSaveList", UBound(TheList)>0
    	DlgEnable "cmdReplace", UBound(TheList)>0
    	DialogFunc% = True
    End Select
End Function

Sub Main
Dim objItems As ISpssItems, objPivot As PivotTable
Dim Selected() As Integer
Dim ItemIndex As Integer, NSelected As Integer
Dim OnlySelected As Boolean, MatchCase As Boolean, WhereToChange As Integer

	'создание и запуск диалога
    If Not CreateDialog(OnlySelected,MatchCase,WhereToChange) Then Exit Sub
    
    'проверка результата диалога с пользователем
    If UBound(TheList)=0 Then
    	MsgBox "Нечего заменять: список пуст
    	Exit Sub
    End If
    
    If WhereToChange=0 Then
    	MsgBox "Не указаны места поиска и замены"
    	Exit Sub
    End If
    
	'Продолжаем выполнять программу только если есть хотя бы один документ выдачи
	If objSpssApp.Documents.OutputDocCount > 0 Then
	   'Получение ссылки на набор объектов в текущем документе выдачи
	   Set objItems = objSpssApp.GetDesignatedOutputDoc.Items
	Else
	        MsgBox "Отсутствует документ выдачи"
	        Exit Sub
	End If

    'Создание индекса (перечня) мобильных таблиц
    NSelected=0
    For ItemIndex=0 To objItems.Count-1
    	With objItems.GetItem(ItemIndex)
	        If .SPSSType=SPSSPivot And (.Selected Or Not OnlySelected) Then
	        	NSelected=NSelected+1
	        	ReDim Preserve Selected(1 To NSelected) As Integer
	        	Selected(NSelected)=ItemIndex
	        End If
	    End With
    Next ItemIndex
    
    If NSelected=0 Then
    	MsgBox "В окне результатов отсутствуют таблицы для изменения"
    	Exit Sub
    End If

	'Изменения (поиск/замена) во всех выделенных мобильных таблицах окна результатов
    For ItemIndex=1 To NSelected
    	With objItems.GetItem(Selected(ItemIndex))
			Set objPivot=.ActivateTable
			objPivot.UpdateScreen=False
			
			If WhereToChange And PL_TITLE Then
				'изменения в заголовке
				objPivot.TitleText=GetNewLabel(objPivot.TitleText,MatchCase)
			End If
			
			If WhereToChange And PL_FOOT Then
				'изменения в сносках
				ModFootnotes objPivot.FootnotesArray,MatchCase
			End If
			
			If WhereToChange And PL_LABEL Then
				'изменения в подписях столбцов
				ModLabelsArrayCells objPivot.ColumnLabelArray,MatchCase
				
				'изменения в подписях строк
				ModLabelsArrayCells objPivot.RowLabelArray,MatchCase
			End If
					
			objPivot.UpdateScreen=True
			.Deactivate
		End With
	Next ItemIndex
End Sub

Sub ModFootnotes(ByVal objFootArray As ISpssFootnotes, ByVal MatchCase As Boolean)
'Изменения в сносках
Dim NCell As Long
	With objFootArray
		For NCell=0 To objFootArray.Count-1
			.ValueAt(NCell)=GetNewLabel(.ValueAt(NCell),MatchCase)
		Next NCell	
	End With
End Sub 

Sub ModLabelsArrayCells(ByVal objLabelArray As ISpssLabels, ByVal MatchCase As Boolean)
'Поиск/замена во всех ячейках указанного диапазона
Dim Rows As Long, Cols As Long, NotDisplayed As Boolean

	'поиск всех ячеек с подписями в указанном диапазоне
	NotDisplayed=False
	With objLabelArray
		For Rows=0 To .NumRows-1
			For Cols=0 To .NumColumns-1
				'изменения текста в ячейке только если та не пуста
				If Not IsNull(.ValueAt(Rows,Cols)) Then
					'проверка, отображается ли ячейка
					If Rows>0 Then
						If Not IsNull(.ValueAt(Rows-1,Cols)) Then
							NotDisplayed=.ValueAt(Rows-1,Cols)=.ValueAt(Rows,Cols)
						End If
					End If
					If Cols>0 Then
						If Not IsNull(.ValueAt(Rows,Cols-1)) Then
							NotDisplayed=NotDisplayed Or .ValueAt(Rows,Cols-1)=.ValueAt(Rows,Cols)
						End If
					End If
					'делаем замену текста в ячейке только если ячейка отображается и не является пустой
					If .ValueAt(Rows,Cols)<>"" And Not NotDisplayed Then
						'приписывание новой подписи
						.ValueAt(Rows,Cols)=GetNewLabel(.ValueAt(Rows,Cols),MatchCase)
					End If
				End If
			Next Cols
		Next Rows
	End With
End Sub

Function GetNewLabel(ByVal OldLabel As String, ByVal MatchCase As Boolean) As String
'Функция, возвращающая новую подпись, заменяющую прежнюю подпись
Dim TextPos As Integer, StartPos As Integer, i As Integer
Dim ModLabel As String
	ModLabel=OldLabel
	StartPos=1 '### вставлено 1 вместо 0
	For i=1 To UBound(Orig)
		Do 
			If MatchCase Then 'поиск с учётом регистра
				TextPos=InStr(StartPos,ModLabel,Orig(i))
			Else 'поиск без учёта регистра
				TextPos=InStr(StartPos,UCase(ModLabel),UCase(Orig(i)))
			End If
			
			If TextPos>0 Then
				ModLabel=Left(ModLabel,TextPos-1)+Subst(i)+Mid(ModLabel,TextPos+Len(Orig(i)),Len(ModLabel)-TextPos-Len(Orig(i))+1)
				StartPos=TextPos+Len(Subst(i)) '### удалено -1 в конце инструкции
			End If
		Loop Until TextPos=0
	Next i
	GetNewLabel=ModLabel
End Function