'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 NItem1 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 NItemUBound(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