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
|