问题惠特vba宏在Office365工作365

Question

我遇到了宏开始使用Office365之后的问题。在一般而言，宏应填充TXT数据文件中的单词模板标签和书签。问题在于，来自数据文件的相同数据没有过去，也没有任何逻辑。它可能是第一个，最后，中间的桌子记录。在大多数情况下，宏可以正确填充所有数据。在Office2013/2016中，所有工作都正常工作。

对此有什么想法吗？

宏代码

   Option Explicit

  Type t_Ar

    Col() As String

  End Type

 

  Dim isAutoOpen As String, _

      WITHOUT_OLE As String, _

      USE_JAR As String, _

      UseUnicode As String, fs, f

     

Private Function GetFullPath(FullName As String) As String

  Dim NameParts, Res As String, i As Integer

  NameParts = Split(FullName, Application.PathSeparator)

  Res = NameParts(0)

  For i = 1 To UBound(NameParts) - 1

    Res = Res + Application.PathSeparator + NameParts(i)

  Next

  GetFullPath = Res

End Function

 

Sub AutoOpen()

  Dim FileNameData As String, FullPathMacros As String, ParsName, Cnt As Integer, _

    AppMacros As Application, DocMacros As Document

 

'Stop

  isAutoOpen = "X"

 

  Set AppMacros = Application

  Set DocMacros = AppMacros.ActiveDocument

 

  'Mac косячит, вместо Path возвращает FullName

'  FullPathMacros = Application.ActiveDocument.Path

  FullPathMacros = GetFullPath(DocMacros.FullName)

 

  ParsName = Split(DocMacros.Name, "_")

  Cnt = UBound(ParsName)

  If Cnt = 3 Then

    If ParsName(0) = "ZWWW" And ParsName(1) = "MACROS" And ParsName(2) = "WORD" Then

     

      If AppMacros.Documents.Count > 1 Then

'        AppMacros.ActiveWindow.Visible = False

      Else

        AppMacros.Visible = False

      End If

     

      ParsName = Split(ParsName(3), ".")

      FileNameData = FullPathMacros + AppMacros.PathSeparator + "ZWWW_DATA_" + ParsName(0) + ".txt"

     

      FillVariables FileNameData, DocMacros

   

      If WITHOUT_OLE = "X" Then

        If AppMacros.Documents.Count > 1 Then

          DocMacros.Close

        Else

          AppMacros.Quit

        End If

      End If

    End If

  End If

  isAutoOpen = ""

End Sub

 

Private Function isFileUnicode(NameFileData As String) As Boolean

  Dim b1 As Byte, b2 As Byte

  isFileUnicode = False

  On Error Resume Next

  Open NameFileData For Random Access Read As #5 Len = 1

   Get #5, 1, b1

   Get #5, 2, b2

  Close #5

  If b1 = 0 Or b2 = 0 Then

    isFileUnicode = True

  End If

End Function

 

Private Sub OpenFileData(FileData As String)

  Dim CodePageTxt As Integer

 

  If UseUnicode <> "X" Then

    Open FileData For Input As #1

  Else

    CodePageTxt = -2

    If UseUnicode = "X" Then

      CodePageTxt = -1

    End If

    Set fs = CreateObject("Scripting.FileSystemObject")

    Set f = fs.OpenTextFile(FileData, 1, 0, CodePageTxt)

  End If

End Sub

 

Private Sub CloseFileData()

  If UseUnicode <> "X" Then

    Close #1

  Else

    f.Close

  End If

End Sub

 

Private Function isEndOfFileData() As Boolean

  If UseUnicode <> "X" Then

    isEndOfFileData = EOF(1)

  Else

    isEndOfFileData = f.AtEndOfStream

  End If

End Function

 

Private Function ReadLineData() As String

  Dim Ln As String

  If UseUnicode <> "X" Then

    Line Input #1, Ln

  Else

    Ln = f.ReadLine

  End If

  ReadLineData = Ln

End Function

 

Sub MakeFullDir(FullName As String)

  Dim ArrName, NewDir As String, Cnt As Integer

 

  ArrName = Split(FullName, Application.PathSeparator)

 

  On Error Resume Next

  Err.Clear

 

  Cnt = 0

  Do While Cnt < UBound(ArrName)

    If NewDir = "" Then

      NewDir = ArrName(Cnt)

    Else

      NewDir = NewDir + Application.PathSeparator + ArrName(Cnt)

    End If

    Err.Clear

    ChDir NewDir

    If Err.Number <> 0 Then

      Err.Clear

      MkDir NewDir

    End If

    Cnt = Cnt + 1

  Loop

End Sub

 

Public Sub FillVariables(ByVal FileData As String, ByVal DocTempl) ' As Document

  UserFormProgress.UserFormProgressShow FileData, DocTempl

End Sub

 

Public Sub ZWWW_FillVariables(ByVal FileData As String, ByVal DocTempl) ' As Document

  Dim fs, f, _

      Ln As String, r As Range, Ofs As Range, _

      Ar() As t_Ar, i As Long, Cnt As Long, _

      value, CurrRange As Range, _

      RowsCount As Long, _

      MACROSNAME, ErrNumber, VarError, _

      Doc As Document, _

      RangeStart, RangeEnd, RangeSize, _

      NewStart, NewEnd, NewSize, _

      RangeTempl, b As Bookmark, Dupl As Range, Fd As Find, _

      CheckSpel, CheckGram, PasteAdjTblFormat As Boolean

'      FileData As String

'      QTable As QueryTable,

  Dim Param, _

      ProgressStep As Long, _

      Psw As String, _

      ResDialogPrint, _

      TEMP_NAME As String, _

      FILE_NAME As String, _

      FILE_PATH As String, _

      FULL_NAME As String, _

      MACROS_NAME As String, _

      DEBUG_MODE As String, _

      CLOSE_FORM As String, _

      PRINTDIALOG As String, _

      PROTECT_WB As String, _

      StartTime As Date, _

      CurrentTime As Date

 

  StartTime = Time * 100000

  CurrentTime = StartTime

 

  If isFileUnicode(FileData) Then

    UseUnicode = "X"

  Else

    UseUnicode = ""

  End If

 

  RowsCount = 1


  ErrNumber = 0

 

  With Application

    Set Doc = .ActiveDocument

    .DisplayAlerts = wdAlertsNone

    .ScreenUpdating = False

  End With

  With Options

    CheckSpel = .CheckSpellingAsYouType

    CheckGram = .CheckGrammarAsYouType

    .CheckSpellingAsYouType = False

    .CheckGrammarAsYouType = False

  End With

 

  OpenFileData FileData

 

  Ln = ReadLineData()

 

  Cnt = Ln

 

  Do While Not isEndOfFileData() And Cnt > 0

 

    Cnt = Cnt - 1

   

    Ln = ReadLineData()

   

    Param = Split(Ln, Chr(9))

   

    If UBound(Param) = 1 Then

      Select Case Param(0)

        Case "TEMP_NAME"

          TEMP_NAME = Param(1)

          FULL_NAME = GetFullPath(Application.ActiveDocument.FullName) + Application.PathSeparator + TEMP_NAME

          FULL_NAME = Replace(FULL_NAME, "\", Application.PathSeparator)

          FULL_NAME = Replace(FULL_NAME, "/", Application.PathSeparator)

        Case "FILE_NAME"

          FILE_NAME = Param(1)

        Case "FILE_PATH"

          FILE_PATH = Param(1)

          FILE_PATH = Replace(FILE_PATH, "\", Application.PathSeparator)

          FILE_PATH = Replace(FILE_PATH, "/", Application.PathSeparator)

        Case "WITHOUT_OLE"

          WITHOUT_OLE = Param(1)

          On Error Resume Next

          Open Application.ActiveDocument.Path + Application.PathSeparator + Application.ActiveDocument.Name + ".err" For Input As #2

          If Err.Number = 0 Then

            WITHOUT_OLE = "X"

            Close #2

          Else

            Err.Clear

          End If

          On Error GoTo 0

        Case "USE_JAR"

          USE_JAR = Param(1)

        Case "MACROSNAME"

          MACROS_NAME = Param(1)

        Case "DEBUG_MODE"

          DEBUG_MODE = Param(1)

        Case "CLOSE_FORM"

          CLOSE_FORM = Param(1)

        Case "PRINTDIALOG"

          PRINTDIALOG = Param(1)

        Case "PROTECT"

          PROTECT_WB = Param(1)

      End Select

    End If

  Loop

 

  

  If DEBUG_MODE = "X" Then

    Application.Visible = True

    Stop

  End If

 

  If isAutoOpen = "X" And WITHOUT_OLE = "" Then

    CloseFileData

   

    Exit Sub

  End If

 

  If (WITHOUT_OLE = "X" Or USE_JAR = "X") And FULL_NAME <> "" Then

'    Dim App As New Word.Application

    Dim App As Word.Application

   

    If Left(UCase(Application.System.OperatingSystem), 7) = "WINDOWS" Then

      Set App = New Application

    Else

      Set App = Application

    End If

   

    App.Documents.Open FULL_NAME

    Set DocTempl = App.ActiveDocument

   

    'сбросить Режим чтения в Word 2013,

    'т.к. не заполняются колонтитулы

    If DocTempl.ActiveWindow.View.ReadingLayout = True Then

      'недостаточно сбросить Режим чтения,

      'т.к. 2013 переводит в режим Черновик

      DocTempl.ActiveWindow.View.Type = wdPrintView

    End If

  Else

    Set App = DocTempl.Application

  End If

 

  

  DocTempl.Activate

 

  Set Doc = App.ActiveDocument

 

  PasteAdjTblFormat = App.Options.PasteAdjustTableFormatting

  App.Options.PasteAdjustTableFormatting = False

 

  

 

 

  If DEBUG_MODE = "X" Then

    App.Visible = True

    App.ScreenUpdating = True

  Else

    App.ScreenUpdating = False

    App.DisplayAlerts = wdAlertsNone

  End If

 

  Cnt = 0

  i = 0

 

  Do While Not isEndOfFileData()

    i = i + 1 'f.Line

   

    Ln = ReadLineData()

   

    ReDim Preserve Ar(1 To i) As t_Ar

    Ar(i).Col = Split(Ln, Chr(9), 6, vbBinaryCompare)

  Loop

 

  CloseFileData

 

  ProgressStep = UBound(Ar, 1) / 10

  If ProgressStep > 50 Then

    ProgressStep = 50

  End If

  If ProgressStep < 1 Then

    ProgressStep = 1

  End If

 

  Err.Clear

  ErrNumber = 0

 

  Set r = Doc.Range

 

  VarError = 0

  i = 0

  Do While Not i >= UBound(Ar, 1)

    i = i + 1

   

    App.ScreenUpdating = True

    If DEBUG_MODE = "X" Then

      App.ScreenUpdating = True

    Else

      App.ScreenUpdating = False

    End If

   

    'If i Mod ProgressStep = 0 Then

    CurrentTime = Time * 100000 - StartTime

    If CurrentTime > 1 Then

      CurrentTime = Time * 100000

      StartTime = CurrentTime

     

      Dim ScrUpd As String

     

      If DEBUG_MODE = "X" Then

        ScrUpd = ", ScreenUpdating = "

        If App.ScreenUpdating Then

          ScrUpd = ScrUpd + "true"

        Else

          ScrUpd = ScrUpd + "false"

        End If

      End If

      ProgressBar i, UBound(Ar, 1), FULL_NAME + ScrUpd

    End If

       

    With Ar(i)

'      VarName = .Col(0)

'      VarNum = .Col(1)

'      FindText = .Col(2)

'      Value = .Col(5)

   

'    ErrNumber = 0

    On Error Resume Next

    If .Col(0) = "" Then

      Set r = Doc.Range

      ErrNumber = Err.Number

    Else

      If .Col(0) <> "*" Then

        'At new VarName

        Set b = Doc.Bookmarks(.Col(0))

        Set r = b.Range

        Set CurrRange = r.Duplicate

        ErrNumber = Err.Number

       

        If ErrNumber = 0 Then

          r.Copy

          'RowsCount = r.Rows.Count

          RangeStart = r.Start

          RangeEnd = r.End

          RangeSize = RangeEnd - RangeStart

          Doc.UndoClear

        End If

     

        If DEBUG_MODE = "X" Then

          b.Select

          r.Select

          CurrRange.Select

        End If

     

      End If

     

      If ErrNumber = 0 Then

        If .Col(1) <> "*" Then

          'At new VarNum

          If .Col(1) <> 0 Then

            r.Move 10, 1 'RowsCount

           

            If DEBUG_MODE = "X" Then

              r.Select

            End If

           

            If .Col(3) = "V" Then

              Err.Clear

              Set RangeTempl = Doc.Bookmarks(.Col(5)).Range

              VarError = Err.Number

            

              If DEBUG_MODE = "X" Then

                RangeTempl.Select

              End If

             

              If VarError = 0 Then

                NewStart = RangeTempl.Start

                NewEnd = RangeTempl.End

                RangeTempl.Copy

                r.PasteAndFormat wdListCombineWithExistingList '(wdFormatOriginalFormatting)

         

                NewSize = NewEnd - NewStart

                NewStart = r.Start

                NewEnd = NewStart + NewSize

                r.End = NewEnd

             

                If DEBUG_MODE = "X" Then

                  r.Select

                End If

              End If

            Else

              Set RangeTempl = CurrRange 'b.Range

              RangeTempl.Copy

              r.PasteAndFormat wdListCombineWithExistingList '(wdFormatOriginalFormatting)

             

              b.Start = CurrRange.Start

              b.End = CurrRange.End

              NewStart = r.Start

              NewEnd = NewStart + RangeSize

              r.End = NewEnd

               

              If DEBUG_MODE = "X" Then

                r.Select

              End If

            End If

          End If

          Doc.UndoClear

        End If

      End If

    End If

   

    If ErrNumber = 0 Then

      If .Col(2) = "" Then

        If .Col(3) = "" Or .Col(3) = "S" Then

          If DEBUG_MODE = "X" Then

            r.Select

          End If

          r.Text = .Col(5)

        ElseIf .Col(3) = "M" Then

          Err.Clear

          Set Dupl = r.Duplicate

               

          If DEBUG_MODE = "X" Then

            Dupl.Select

          End If

         

          'MacrosName = "'" + ActiveWorkbook.Name + "'" + "!" + .Col(5)

          'MACROSNAME = .Col(5)

          'App.Run MACROSNAME, Dupl

          'If Err.Number <> 0 Then

          '  App.Run MACROSNAME

          'End If

          RunUserMacros App, .Col(5), Dupl

        End If

      Else

        If .Col(3) = "S" Then

          If DEBUG_MODE = "X" Then

            r.Select

          End If

          Set Fd = r.Find

          Fd.Execute FindText:=.Col(2), replacewith:=.Col(5), Replace:=wdReplaceAll

        End If

      End If

    End If

    End With

    Err.Clear

  Loop

  Doc.UndoClear

 

  

  i = 0

  Do While Not i >= UBound(Ar, 1)

    i = i + 1

    With Ar(i)

      If (.Col(0) <> "" And .Col(0) <> "*" And _

          Val(.Col(1)) <> 0 And .Col(1) <> "*") Then

        Err.Clear

        Set b = Doc.Bookmarks(.Col(0))

        If Err.Number = 0 Then

          Set r = b.Range

          If DEBUG_MODE = "X" Then

            r.Select

          End If

          r.Delete

          Set r = b.Range

          If Err.Number = 0 Then

            If DEBUG_MODE = "X" Then

              r.Select

            End If

            r.Cells.Delete

          End If

        End If

      End If

      If .Col(3) = "V" Then

        Err.Clear

        Set b = Doc.Bookmarks(.Col(5))

        If Err.Number = 0 Then

          Set r = b.Range

          If DEBUG_MODE = "X" Then

            r.Select

          End If

          r.Delete

          Set r = b.Range

          If Err.Number = 0 Then

            If DEBUG_MODE = "X" Then

              r.Select

            End If

            r.Cells.Delete

          End If

        End If

      ElseIf .Col(3) = "D" Then

        Err.Clear

        Set b = Doc.Bookmarks(.Col(0))

        If Err.Number = 0 Then

          Set r = b.Range

          If DEBUG_MODE = "X" Then

            r.Select

          End If

          r.Delete

          Set r = b.Range

          If Err.Number = 0 Then

            If DEBUG_MODE = "X" Then

              r.Select

            End If

            r.Cells.Delete

          End If

        End If

      End If

    End With

  Loop

  Doc.UndoClear

 

  With App

    .ScreenUpdating = True

    .DisplayAlerts = wdAlertsAll

  End With

  With Options

    .CheckSpellingAsYouType = CheckSpel

    .CheckGrammarAsYouType = CheckGram

    .PasteAdjustTableFormatting = PasteAdjTblFormat

  End With

 

  If WITHOUT_OLE = "X" Or USE_JAR = "X" Then

    If PROTECT_WB = "X" Then

      Err.Clear

      Psw = Time

      Doc.Protect Type:=3, noreset:=False, Password:=Psw

      If Err.Number <> 0 Then

        Err.Clear

        Doc.Protect Type:=1, noreset:=False, Password:=Psw

      End If

    End If

   

    Dim New_FULL_NAME As String, ErrSave, Saved_as_PDF As Boolean

    New_FULL_NAME = FILE_PATH + FILE_NAME

    If UCase(FULL_NAME) <> UCase(New_FULL_NAME) And FILE_NAME <> "" Then 'New_FULL_NAME <> ""

      MakeFullDir New_FULL_NAME

 

      If File_as_PDF(New_FULL_NAME) Then

        Doc.Save

        ErrSave = Save_as_PDF(Doc, New_FULL_NAME)

        If ErrSave = 0 Then

          Saved_as_PDF = True

        End If

      Else

        Err.Clear

        Doc.SaveAs FileName:=New_FULL_NAME

        ErrSave = Err.Number

        If ErrSave <> 0 Then

          Doc.Save

        End If

      End If

    Else

      Doc.Save

    End If

     

        

    App.DisplayAlerts = True

    App.ScreenUpdating = True

   

    If CLOSE_FORM <> "X" Then

      If Not Saved_as_PDF Then

        With App

          .DisplayAlerts = True

          .ScreenUpdating = True

          .Visible = True

        End With

      Else

        Open_as_PDF New_FULL_NAME

      End If

    End If

   

    If PRINTDIALOG = "X" Then

      If Not Saved_as_PDF Then

        ResDialogPrint = App.Dialogs.Item(wdDialogFilePrint).Show

      End If

    End If

   

    If CLOSE_FORM = "X" Or _

      PRINTDIALOG = "X" Or _

      Saved_as_PDF Then

      App.Quit

    End If

   

  End If

End Sub

 

Sub RunUserMacros(App, Val, Rng)

  Dim MACROSNAME As String, Param1 As String, it_Params, Cnt As Integer

         

  

  it_Params = Split(Val, Chr(9), 2, vbBinaryCompare)

  Cnt = UBound(it_Params)

  On Error Resume Next

  Err.Clear

   

  If Cnt >= 1 Then

    MACROSNAME = it_Params(0)

    Param1 = it_Params(1)

   

    App.Run MACROSNAME, Rng, Param1

    If Err.Number <> 0 Then

      App.Run MACROSNAME, Param1

    End If

  Else

    MACROSNAME = Val

    App.Run MACROSNAME, Rng

    If Err.Number <> 0 Then

      App.Run MACROSNAME

    End If

  End If

  Err.Clear

End Sub

 

Sub ProgressBar(LenPart, LenAll, Txt)

  UserFormProgress.LabelText.Caption = Txt

  UserFormProgress.LabelProgress.Width = (LenPart / LenAll) * UserFormProgress.FrameProgress.Width

'  UserFormProgress.Show

  UserFormProgress.Repaint

  DoEvents

End Sub