Форум им. Зеленого Батискафа

В дальнейшем программа была несколько переделана для ускорения. Вот полный окончательный текст.
Не смог обойтись без одного Goto.

И "для потомков" на работе было составлено небольшое описание программы: http://slil.ru/28745973
 
 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
Форум » Программистские штучки » Транслит на VBA-Excel
	перенос