Miscrosoft has Blocking The Macro Sometimes and disabling the macros

[srikanth sare]

Hi
The Below code is working perfectly. However sometimes the macros are disabled.
I tried adding the location in trust center it is not accepting to add the specified location

It is actually occuring due to Temporary file of Word Document.

And the macro is taking more time to run is there any way to reduce

Application.run TurnOff And on will do the Calculation, Scrren updating, events and display alerts

Option Explicit

Sub SendReminders()
    Dim lastRow, CustRow, CustCol, TempRow, DaysSince, FrDays, ToDays As Long
    Dim TempRng, FoundTempRng As Range
    Dim ColFormat, NEWFLDR, MyPath, myFile, DocLoc, VarFormat, VarName, VarValue, TempName, FileName, Subj, Mess, username, Propath As String
    Dim WordDoc, WordApp, OutApp, OutMail, FileSystem, File As Object
    Dim WordContent As Word.Range
    
    username = Environ("Username")
    If username = "sri CA nth Sare" Then
        Propath = "J:\SARVAHITHA OFFICE\SARVAHITHA OFFICE\DEFAULT NOTICE\"
    ElseIf username = "SARVAHITA" Then
        Propath = "F:\DRIVE\DEFAULT NOTICE\"
    Else
        MsgBox "Invalid username."
        Exit Sub
    End If
    
    With Sheet1
        Application.Run "TurnOff"
        FrDays = .Range("L3").Value ' Set From Days
        ToDays = .Range("N3").Value ' Set To Days

        On Error Resume Next ' If Word is already running
        Set WordApp = GetObject("Word.Application")
        If Err.Number <> 0 Then
            Err.Clear
            Set WordApp = CreateObject("Word.Application")
        End If ' Work Running Check
        WordApp.Visible = False ' Make the application visible to the user

        NEWFLDR = ThisWorkbook.Path & "\" & "DEFAULT" & Format(Date, " DD-MM-YYYY")
        If Dir(NEWFLDR, vbDirectory) = "" Then
           MkDir NEWFLDR
        End If

        lastRow = .Range("D9999").End(xlUp).Row
        For CustRow = 10 To lastRow
            If Sheet1.Range("F3").Value = "NO" Then
                If .Range("C" & CustRow).Value = "ü" Then
R:
                    DaysSince = .Range("M" & CustRow).Value
                    TempName = .Range("Y" & CustRow).Value ' Template name
                    Set TempRng = Sheet2.Range("LetterTemplates")
                    Set FoundTempRng = TempRng.Find(TempName, , xlValues, xlWhole)
                    If Not FoundTempRng Is Nothing Then ' Template Found
                        TempRow = FoundTempRng.Row
                        DocLoc = Propath & TempName   'Sheet2.Range("F" & TempRow).Value ' Word Document Filename
                        Set WordDoc = WordApp.Documents.Open(FileName:=DocLoc, ReadOnly:=False) ' Open Template
                        If Sheet1.Range("F3").Value = "YES" Then
                            If DaysSince >= FrDays And DaysSince <= ToDays Then
S:
                                For CustCol = 4 To 24 ' Move Through 9 Columns
                                    If .Cells(7, CustCol).Value = "General" Then
                                        VarFormat = "General"
                                    Else
                                        VarFormat = .Cells(8, CustCol).Value ' Determine Variable Format
                                    End If
                                    VarName = .Cells(9, CustCol).Value ' Determine Variable Name
                                    VarValue = .Cells(CustRow, CustCol).Value ' Determine Variable Value
                                    With WordDoc.Content.Find
                                        .Text = VarName
                                        .Replacement.Text = Application.WorksheetFunction.Text(VarValue, VarFormat)
                                        .Wrap = wdFindContinue
                                        .Execute Replace:=wdReplaceAll ' Find & Replace all instances
                                    End With
                                Next CustCol
                                    FileName = NEWFLDR & "\" & .Range("G" & CustRow).Value & ".docx"
                                    WordDoc.SaveAs FileName
                                    WordDoc.Close False
                                .Range("Z" & CustRow).Value = TempName ' Template Name
                                .Range("AA" & CustRow).Value = Now
                                End If
                        Else
                            GoTo S
                        End If
                    End If
                End If
            Else
                GoTo R
            End If
        Next CustRow
        WordApp.Quit
    End With
    
    Set WordApp = CreateObject("Word.Application")
    WordApp.Visible = False

    Set WordDoc = WordApp.Documents.Open(Propath & "DUMMY.docx", ReadOnly:=False)
    
    With WordDoc.PageSetup
        .TextColumns.SetCount NumColumns:=1
        .TextColumns.EvenlySpaced = True
        .TextColumns.LineBetween = False
        .Orientation = wdOrientPortrait
        .TopMargin = WordDoc.CentimetersToPoints(1.5)
        .BottomMargin = WordDoc.CentimetersToPoints(1.5)
        .LeftMargin = WordDoc.CentimetersToPoints(2.7)
        .RightMargin = WordDoc.CentimetersToPoints(2.7)
    End With
    
    MyPath = NEWFLDR & "\"
    myFile = Dir(MyPath & "*.docx", vbNormal + vbReadOnly + vbHidden)
    While myFile <> ""
        With WordDoc.Bookmarks("\ENDOfDoc").Range
            .InsertFile FileName:=MyPath & myFile, ConfirmConversions:=False, Link:=False, Attachment:=False
            .InsertBreak Type:=wdSectionBreakNextPage  'wdSectionBreakNextPage = 2
        End With
        myFile = Dir()
    Wend
    WordDoc.Characters(1).Delete
    
    FileName = MyPath & "MERGED " & Format(Now, "DD-MM-YYYY hh.mm.ss") & ".pdf" ' Create full filename & Path with current workbook location, Last Name & First Name
    
    With WordDoc
        .ExportAsFixedFormat OutputFileName:=FileName, ExportFormat:=wdExportFormatPDF
        .SaveAs MyPath & "MERGED " & Format(Now, "DD-MM-YYYY hh.mm.ss") & ".docx"
        .Close True
        .Quit
    End With
    
    Set FileSystem = CreateObject("Scripting.FileSystemObject")
    
    For Each File In FileSystem.GetFolder(MyPath).Files
        If LCase(FileSystem.GetExtensionName(File)) = "docx" And Not InStr(1, File.Name, "MERGED", vbTextCompare) > 0 Then
            File.Delete
        End If
    Next File

    Set WordDoc = Nothing
    Set WordApp = Nothing
    Set FileSystem = Nothing
    Application.Run "TurnOn"
End Sub

 

[ranman256]

try enabling macros via set Trust center settings
menu:
File,
options,
trust center, (left pane)
trust center settings btn, (right pane)


Macro Settings,(left pane)
Enable all macros


(bottom)
Trusted Locations,(left pane)
always 1st: check ALLOW TRUSTED LOCATIONS ON MY NETWORK
click ADD NEW LOCATION btn
add folder and check subfolders


OK all the way out

 

[srikanth sare]

try enabling macros via set Trust center settings
menu:
File,
options,
trust center, (left pane)
trust center settings btn, (right pane)


Macro Settings,(left pane)
Enable all macros


(bottom)
Trusted Locations,(left pane)
always 1st: check ALLOW TRUSTED LOCATIONS ON MY NETWORK
click ADD NEW LOCATION btn
add folder and check subfolders


OK all the way out

Hi,
@ ranman256
Thank you for the reply
I have followed all your suggestion

Error is occuring while running VBA Macros creating multiple words and that too due to temporary files created by the word documents then iget the popup as shown in the image above.
i have press ESC instead of disabling the macros everytime.

 

[NdNoviceHlp]

There is no need to create 2 Word applications with this code. The 1st application you quit but the 2nd one you are quitting the Worddoc not the WordApp. I suspect that your error is related. If you run your code you will see the orphaned Word process in the task manager and this will be your tmp doc that you are getting the error msg from. HTH. Dave

 

[srikanth sare]

There is no need to create 2 Word applications with this code. The 1st application you quit but the 2nd one you are quitting the Worddoc not the WordApp. I suspect that your error is related. If you run your code you will see the orphaned Word process in the task manager and this will be your tmp doc that you are getting the error msg from. HTH. Dave

Hi,

NdNoviceHlp​

Thank you, your suggestion has cleared all the errors.
Is there any way to make code to work faster? apart from this i have already incorporated all these Application.run TurnOff And on will do the Calculation, Scrren updating, events and display alerts
to generate 15 word documents it takes around 2 minutes.

 

[NdNoviceHlp]

Hi srikanth. To begin with, use only 1 Word application. The page setup is likely a lengthy process. Perhaps use a template doc that already has the page set up completed. Perhaps if you summarize what you're trying to achieve there may be more suggestions as 2 minutes seems awfully long for 15 docs. Dave