Форум » Программистские штучки » Транслит на VBA-Excel » Ответить
Транслит на VBA-Excel
administrator: Т.к. делать надо было дешево,быстро и сердито, таблица транслитерации размещена прямо на листе Сначала идут заглавные и прописные буквы в ДОС-кодировке, затем только заглавные для Win-кодировки Собственно текст: [pre2] Function Translit(SourceLine) As String Dim Lflag, dosflag As Boolean, nlet, ncol, nrow As Integer, ResultLine, RusChr, LatChr As String ncol = Application.ActiveCell.Column 'квази-push nrow = Application.ActiveCell.Row Lflag = False: dosflag = False ResultLine = "" nlet = 0 While Len(SourceLine) > nlet nlet = nlet + 1 RusChr = Mid(SourceLine, nlet, 1) If Asc(RusChr) > 127 Then 'ведь латиница не нуждается в перекодировке Select Case Asc(RusChr) Case 128 To 175 'DOS-атрибуты If dosflag = False Then nlet = 0 ResultLine = "": RusChr = "" End If dosflag = True Case 192 To 223 If dosflag = True Then nlet = 0 ResultLine = "": RusChr = "" End If dosflag = False End Select If dosflag = False Then 'для работы с Win-кодировкой русская буква делается заглавной, а исходный регистр сохраняется в переменной. If Asc(RusChr) > 223 Then Lflag = True RusChr = UCase(RusChr) End If '------------- Cells(1, 1).Activate 'исключим коллизии If ActiveSheet.Range("a1:a87").Find(RusChr, MatchCase:=True) Is Nothing Then LatChr = RusChr Else ActiveSheet.Range("a1:a87").Find(RusChr, MatchCase:=True).Activate ActiveCell.Offset(0, 1).Select LatChr = Application.ActiveCell.Value If Lflag = True Then LatChr = LCase(LatChr) 'если буква исходная была маленькой (код 224-255 в win) то и выходную тоже маленькой сделаем Lflag = False End If End If Else: LatChr = RusChr End If ResultLine = ResultLine + LatChr '------------- Wend Translit = ResultLine 'вывод результата Cells(nrow, ncol).Activate 'квази-pop End Function [/pre2]
Ответов - 3
Прохожий: Тип переменных слегка неявно указываешь
Прохожий : ActiveCell.Offset(0, 1).Select LatChr = Application.ActiveCell.Value Можно просто LatChr =ActiveCell.Offset(0, 1)
administrator: В дальнейшем программа была несколько переделана для ускорения. Вот полный окончательный текст. Не смог обойтись без одного Goto. И "для потомков" на работе было составлено небольшое описание программы: http://slil.ru/28745973 [pre2] Option Explicit Global chCODflag As Boolean Global globaldosflag As Boolean Sub InPath() 'процедура вызываемая по нажатию кнопки на листе - основная, выбор файлов Application.ScreenUpdating = False Dim flname As Variant 'это потому что по-другому не обрабатываются collection With Application.FileDialog(msoFileDialogFilePicker) .AllowMultiSelect = True .Show .Filters.Add "LAS-файлы", "*.las", 1 For Each flname In .SelectedItems CarotageTranslitter (flname) 'вызов базовой подпрограммы Next End With Application.ScreenUpdating = True MsgBox "Done!" End Sub Sub CarotageTranslitter(flname) 'на входе переменная - имя файла. Dim SourceLine As String, trflag As Boolean, dosflag As Boolean, curveflag As Boolean, DictFlag As Boolean trflag = True: globaldosflag = True: curveflag = False: chCODflag = False DictFlag = Application.ActiveSheet.CheckBox1.Value 'определяет включена или выключена ли словарная замена Open flname For Input As #1 Open Left(flname, Len(flname) - 3) + "tmp" For Output As #2 'временный файличек - имя то же, расширение иное Do While Not EOF(1) Line Input #1, SourceLine If Left(SourceLine, 1) = "~" Then If curveflag = True Then curveflag = False 'это потому, что любой следующий блок после Curve уже не тот. Select Case Mid(SourceLine, 2, 1) Case "C" curveflag = True Case "A" trflag = False End Select End If If trflag = False Then 'как только дойдет до секции ASCII Log data, нуно просто перетранслировать без побуквенного анализа - ставится соотетствующий флаг Print #2, SourceLine Else If curveflag = True And DictFlag = True Then Print #2, Slovar(Translit(SourceLine, chCODflag, False)) Else Print #2, Translit(SourceLine, chCODflag, False) End If End If Loop Close #1 Close #2 If VBAProject.Лист1.OptionButton1.Value = True Then 'опция "поверх исходных файлов" Kill flname Name Left(flname, Len(flname) - 3) + "tmp" As flname 'временный на место исходного файла Else Name flname As Left(flname, Len(flname) - 3) + "old" Name Left(flname, Len(flname) - 3) + "tmp" As flname End If End Sub Function Translit(SourceLine, notcodecheck As Boolean, once As Boolean) As String 'собственно транслит 'второй вызываемый параметр false когда нужно определить кодировку, и true при обходе мимо '(и по логике тождественен глобальному флагу chCODflag). 'Третий параметр true для однократного вызова транслита, false - для поточного '(при однократном вызове не происходит изменения глобального флага chCODflag) Dim Lflag As Boolean, startrusflag As Boolean, dosflag As Boolean Dim nlet As Integer, ncol As Integer, nrow As Integer, nstartrus As Integer Dim ResultLine As String, RusChr As String, LatChr As String ncol = Application.ActiveCell.Column 'квази-push nrow = Application.ActiveCell.Row Lflag = False: startrusflag = False: dosflag = False 'перво-русская станет true при первой русской 'с точки зрения отлова кодировки,дос надежнее ловится на маленьких буквах,поэтому по умолчанию - не он ResultLine = "" nstartrus = 0 nlet = 0 While Len(SourceLine) > nlet nlet = nlet + 1 CycleBegin: RusChr = Mid(SourceLine, nlet, 1) If Asc(RusChr) > 127 Then If startrusflag = False Then 'реакция на первую встречу символа из 2-йполовины таблицы - взвестифлаг и зафиксировать позицию startrusflag = True nstartrus = nlet End If If notcodecheck = False Then '------------------------------------------------------различитель кодировок--------------------------------------- Select Case Asc(RusChr) Case 128 To 144, 161 To 170 'DOS-атрибуты, вообще первоначально стояло 128 to 175. 160 - исключено изза непоняток с некоторыми Win-файлами, по хорошему надо исключить еще 151,171, 144...159,чего уж там If dosflag = False Then nlet = nstartrus ResultLine = Left(SourceLine, nstartrus - 1): 'LatChr = "" 'RusChr = "" dosflag = True GoTo CycleBegin End If Case 192 To 223, 242 To 254 'WIN-атрибуты 192-223,242-224 If dosflag = True Then nlet = nstartrus ResultLine = Left(SourceLine, nstartrus - 1): 'LatChr = "" 'RusChr = "" dosflag = False GoTo CycleBegin End If 'NB, что "сбросы" и в дос- и в вин- части одинаковы.их можно бы объединить,но тогда придется GOTO лепить. либо отдельный sub 'Case Else End Select If once = False Then chCODflag = True globaldosflag = dosflag End If '------------------------------------------------------конец различителя кодировок------------------------------------- Else: If once = False Then dosflag = globaldosflag End If If dosflag = False Then 'для работы с Win-кодировкой русская буква делается заглавной, а исходный регистр сохраняется в переменной. 'If RusChr <> "" And Asc(RusChr) > 223 Then Lflag = True 'первое условие добавлено для обхода сброса кривого If Asc(RusChr) > 223 Then Lflag = True RusChr = UCase(RusChr) End If '------------- Cells(1, 1).Activate 'исключим коллизии If ActiveSheet.Range("a1:a100").Find(RusChr, MatchCase:=True) Is Nothing Then LatChr = RusChr Else ActiveSheet.Range("a1:a100").Find(RusChr, MatchCase:=True).Activate ActiveCell.Offset(0, 1).Select LatChr = Application.ActiveCell.Value If Lflag = True Then LatChr = LCase(LatChr) 'если буква исходная была маленькой (код 224-255 в win) то и выходную тоже маленькой сделаем Lflag = False End If End If Else LatChr = RusChr End If ResultLine = ResultLine + LatChr '------------- Wend Translit = ResultLine 'вот эту строчку единственную я добавил для переноса транслита строки в отдельную ф-кцию Cells(nrow, ncol).Activate 'квази-pop End Function Function Slovar(ResultLine) As String 'словарная замена (должна вызываться _после_ транслитерации) Dim WordToReplace, WordItog, srcc2, tempword As String Cells(2, 8).Activate ' адрес начала словаря WordItog = ResultLine While Application.ActiveCell.Value <> "" WordToReplace = Application.ActiveCell.Value srcc2 = ActiveCell.Offset(0, 1).Value WordItog = Replace(WordItog, Translit(WordToReplace, False, True), srcc2) ActiveCell.Offset(1, 0).Select Wend Slovar = WordItog End Function [/pre2]
полная версия страницы