Problem whit VBA macros works in Office365 - vba

Question

I faced with problem how macros works after start using Office365. In general macros should fill WORD template tags and bookmarks from txt data file. The problem is somtimes same data from data file doesn't past into template and there isn't any logics. It may be first,last, middele records of table. And more over most of times macros fill all data correctly. In Office2013/2016 all work properly.
Is there any ideas about this?
Macros code
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