Locking word to run macro

ajwilliams77 · #1 07-12-2018, 07:37 AM

Hi,

I am new to VBA and trying my best to learn "on the job". I have managed to create a simple macro that adds logos and watermarks and save to a file location which is working correctly. However, if there is more than one word document open and they change focus to the other document while the macro is running, the code runs against the document now in focus (which is not what we want).

Is there a way to lock word while the macro is being run in order to prevent the user from selecting a different document?

Many thanks,

Andrew

macropod · #2 07-12-2018, 07:39 AM

You can do that by setting a reference to what is initially the active document, then do everything that that reference. We'd need to see your code to say exactly what changes you'd need to make, though.

ajwilliams77 · #3 07-12-2018, 08:12 AM

Thanks for the response macropod.

My code is built into procedures and I have cut out parts to show the main issues:

Code:

Private Sub BD_RemoveExistingImages()
    On Error GoTo Error_Trap
    Dim ThisImage As InlineShape
    Dim mySection As Section
    Dim myHF As HeaderFooter
    Dim RngSel As Range
    
    With ActiveDocument
        Set RngSel = Selection.Range
        iView = ActiveWindow.View.Type
        For Each mySection In ActiveDocument.Sections()
            For Each myHF In mySection.Headers
                If myHF.Range.InlineShapes.Count > 0 Then
                    ' just in case there is more than one image
                    For Each ThisImage In myHF.Range.InlineShapes
                        ThisImage.Delete
                    Next
                End If
                myHF.Range.Select
                WordBasic.RemoveWatermark
            Next
            For Each myHF In mySection.Footers
                myHF.Range.Select
                WordBasic.RemoveWatermark
            Next
        Next
    End With
    
    RngSel.Select
    ActiveWindow.View.Type = iView
    Set RngSel = Nothing
    Application.ScreenUpdating = True
    
    Exit Sub
    
Error_Trap:
    MsgBox "Error in BD_RemoveExistingImages code" & vbCrLf & vbCrLf & Err.Number & " - " & Err.Description & vbCrLf & vbCrLf, , "ERROR!"
    End
End Sub
Private Sub BD_AddLogo(ByVal SrcePath As String)
    On Error GoTo Error_Trap
    
    Dim PecentSize As Integer
    Dim SHP As InlineShape
    PercentSize = 21
    ActiveWindow.ActivePane.View.SeekView = wdSeekCurrentPageHeader
         
    Set SHP = Selection.InlineShapes.AddPicture(FileName:=SrcePath, _
                                LinkToFile:=False, _
                                SaveWithDocument:=True)
    'SHP.ScaleHeight = PercentSize
    'SHP.ScaleWidth = PercentSize
        
    Selection.ParagraphFormat.Alignment = wdAlignParagraphCenter
    ActiveWindow.ActivePane.View.SeekView = wdSeekMainDocument
    
    Exit Sub
    
Error_Trap:
    MsgBox "Error in BD_AddLogo code" & vbCrLf & vbCrLf & Err.Number & " - " & Err.Description & vbCrLf & vbCrLf, , "ERROR!"
    End
End Sub
Private Sub BD_CreateDuplicate()
    On Error GoTo Error_Trap
    With ActiveDocument
      With .Sections.First
        For Each HdFt In .Headers
            Set SHP = HdFt.Shapes.AddTextEffect(msoTextEffect1, _
            "Duplicate", "Arial", 1, False, False, 0, 0)
          With SHP
            .Name = "DuplicateWaterMarkObject" & Format(Now, "YYMMDD") & Format(HdFt.Index, "00")
            .Visible = False
            .TextEffect.NormalizedHeight = False
            .Line.Visible = False
            .Fill.Visible = True
            .Fill.Solid
            .Fill.ForeColor.RGB = RGB(192, 192, 192)
            .Fill.Transparency = 0.5
            .Rotation = 315
            .LockAspectRatio = True
            .Height = InchesToPoints(2.42)
            .Width = InchesToPoints(6.04)
            .WrapFormat.AllowOverlap = True
            .WrapFormat.Side = wdWrapNone
            .WrapFormat.Type = 3
            .RelativeHorizontalPosition = wdRelativeVerticalPositionMargin
            .RelativeVerticalPosition = wdRelativeVerticalPositionMargin
            .Left = wdShapeCenter
            .Top = wdShapeCenter
            .Visible = True
          End With
          .Range.FormattedText.ShowAll = False
        Next
      End With
      With .ActiveWindow.View
        .ShowMarkupAreaHighlight = False
        .ShowComments = False
        .ShowRevisionsAndComments = False
      End With
      .FormattingShowClear = True
    End With
    Set SHP = Nothing
    
    Exit Sub
    
Error_Trap:
    MsgBox "Error in BD_CreateDuplicate code" & vbCrLf & vbCrLf & Err.Number & " - " & Err.Description & vbCrLf & vbCrLf, , "ERROR!"
    End
End Sub
Private Sub BD_SaveDuplicate(ByVal ColPath As String, ByVal DocName As String)
    On Error GoTo Error_Trap
         
    ActiveWindow.ActivePane.View.SeekView = wdSeekMainDocument
    ActiveDocument.ExportAsFixedFormat OutputFileName:= _
        ColPath & DocName, _
        ExportFormat:=wdExportFormatPDF, OpenAfterExport:=False, OptimizeFor:= _
        wdExportOptimizeForPrint, Range:=wdExportAllDocument, Item:= _
        wdExportDocumentContent, IncludeDocProps:=False, KeepIRM:=True, _
        CreateBookmarks:=wdExportCreateNoBookmarks, DocStructureTags:=True, _
        BitmapMissingFonts:=True, UseISO19005_1:=False
    
    Exit Sub
    
Error_Trap:
    MsgBox "Error in BD_SaveDuplicate code" & vbCrLf & vbCrLf & Err.Number & " - " & Err.Description & vbCrLf & vbCrLf, , "ERROR!"
    End
End Sub
Sub BD_CreateFile(control As IRibbonControl)
    On Error GoTo Error_Trap

    Dim LogoPath, ColPath, DocName
          
    Selection.HomeKey Unit:=wdStory
       
    DocName = Replace(ActiveDocument.Name, ".BIL", "")
    LogoPath = 'C:\Logo\'
    ColPath = 'C:\Files\'
 
    Call BD_RemoveExistingImages
    Call BD_AddLogo(LogoPath)
    Call BD_CreateDuplicate
    Call BD_SaveDuplicate(ColPath, DocName)
       
    Exit Sub
    
Error_Trap:
    MsgBox "Error in Create file code" & vbCrLf & vbCrLf & Err.Number & " - " & Err.Description & vbCrLf & vbCrLf, , "ERROR!"
    End
End Sub

macropod · #4 07-12-2018, 05:09 PM

Try:

Code:

Option Explicit
Dim Doc As Document

Sub BD_CreateFile(control As IRibbonControl)
    On Error GoTo Error_Trap
    Dim LogoPath As String, ColPath As String, DocName As String
    
    LogoPath = "?"
    ColPath = "?"
    Set Doc = ActiveDocument
    DocName = Replace(Doc.Name, ".BIL", "")
 
    Call BD_RemoveExistingImages
    Call BD_AddLogo(LogoPath)
    Call BD_CreateDuplicate
    Call BD_SaveDuplicate(ColPath, DocName)
    Exit Sub
    
Error_Trap:
    MsgBox "Error in Create file code" & vbCrLf & vbCrLf & Err.Number & " - " & Err.Description & vbCrLf & vbCrLf, , "ERROR!"
    End
End Sub

Private Sub BD_RemoveExistingImages()
    On Error GoTo Error_Trap
    Dim mySection As Section
    Dim myHF As HeaderFooter
    Dim i As Long
    
    With Doc
        For Each mySection In .Sections()
            For Each myHF In mySection.Headers
                With myHF.Range
                    ' just in case there is more than one image
                    Do While .InlineShapes.Count > 0
                        .InlineShapes(1).Delete
                    Loop
                    For i = .ShapeRange.Count To 1 Step -1
                        With .ShapeRange(i)
                            If InStr(.Name, "WaterMark") > 0 Then .Delete
                        End With
                    Next
                End With
            Next
            For Each myHF In mySection.Footers
                With myHF.Range
                    For i = .ShapeRange.Count To 1 Step -1
                        With .ShapeRange(i)
                            If InStr(.Name, "WaterMark") > 0 Then .Delete
                        End With
                    Next
                End With
            Next
        Next
    End With
    Application.ScreenUpdating = True
    Exit Sub
    
Error_Trap:
    MsgBox "Error in BD_RemoveExistingImages code" & vbCrLf & vbCrLf & Err.Number & " - " & Err.Description & vbCrLf & vbCrLf, , "ERROR!"
End Sub

Private Sub BD_AddLogo(ByVal SrcePath As String)
    On Error GoTo Error_Trap
    Dim myHF As HeaderFooter
    
    With Doc.Sections.First
        If .Headers(wdHeaderFooterFirstPage).Exists Then
            Set myHF = .Headers(wdHeaderFooterFirstPage)
        ElseIf .Headers(wdHeaderFooterEvenPages).Exists Then
            Set myHF = .Headers(wdHeaderFooterEvenPages)
        Else
            Set myHF = .Headers(wdHeaderFooterPrimary)
        End If
        With myHF.Range
            .InlineShapes.AddPicture FileName:=SrcePath, LinkToFile:=False, SaveWithDocument:=True
            .ParagraphFormat.Alignment = wdAlignParagraphCenter
        End With
    End With
    Exit Sub
    
Error_Trap:
    MsgBox "Error in BD_AddLogo code" & vbCrLf & vbCrLf & Err.Number & " - " & Err.Description & vbCrLf & vbCrLf, , "ERROR!"
    End
End Sub

Private Sub BD_CreateDuplicate()
    On Error GoTo Error_Trap
    Dim myHF As HeaderFooter
    Dim Shp As Shape
    
    With Doc.Sections.First
        For Each myHF In .Headers
            If myHF.Exists Then
                Set Shp = HdFt.Shapes.AddTextEffect(msoTextEffect1, "Duplicate", "Arial", 1, False, False, 0, 0)
                With Shp
                    .Name = "DuplicateWaterMarkObject" & Format(Now, "YYMMDD") & Format(HdFt.Index, "00")
                    .Visible = False
                    .TextEffect.NormalizedHeight = False
                    .Line.Visible = False
                    .Fill.Visible = True
                    .Fill.Solid
                    .Fill.ForeColor.RGB = RGB(192, 192, 192)
                    .Fill.Transparency = 0.5
                    .Rotation = 315
                    .Height = InchesToPoints(2.42)
                    .Width = InchesToPoints(6.04)
                    .LockAspectRatio = True
                    .WrapFormat.AllowOverlap = True
                    .WrapFormat.Side = wdWrapNone
                    .WrapFormat.Type = wdWrapNone
                    .RelativeHorizontalPosition = wdRelativeVerticalPositionMargin
                    .RelativeVerticalPosition = wdRelativeVerticalPositionMargin
                    .Left = wdShapeCenter
                    .Top = wdShapeCenter
                    .Visible = True
                End With
            End If
        Next
    End With
    Set Shp = Nothing
    Exit Sub
    
Error_Trap:
    MsgBox "Error in BD_CreateDuplicate code" & vbCrLf & vbCrLf & Err.Number & " - " & Err.Description & vbCrLf & vbCrLf, , "ERROR!"
    End
End Sub

Private Sub BD_SaveDuplicate(ByVal ColPath As String, ByVal DocName As String)
    On Error GoTo Error_Trap
         
    Doc.ExportAsFixedFormat OutputFileName:=ColPath & DocName, _
        ExportFormat:=wdExportFormatPDF, OpenAfterExport:=False, _
        OptimizeFor:=wdExportOptimizeForPrint, Range:=wdExportAllDocument, _
        Item:=wdExportDocumentContent, IncludeDocProps:=False, KeepIRM:=True, _
        CreateBookmarks:=wdExportCreateNoBookmarks, DocStructureTags:=True, _
        BitmapMissingFonts:=True, UseISO19005_1:=False
    Exit Sub
    
Error_Trap:
    MsgBox "Error in BD_SaveDuplicate code" & vbCrLf & vbCrLf & Err.Number & " - " & Err.Description & vbCrLf & vbCrLf, , "ERROR!"
    End
End Sub

I've added a few tweaks to reduce screen flicker.

ajwilliams77 · #5 07-13-2018, 03:13 AM

That is great, thank you macropod.

I has to change the ActiveDocument in the final procedure (good test that I am paying attention), but this is doing exactly what I needed. Many thanks for taking the time to help me out and also showing me different (and I assume better) way of writing the code I already had.

Similar Threads
Thread	Thread Starter	Forum	Replies	Last Post
Word Tables and Locking Text	robertj	Word	8	08-19-2015 03:21 PM
Locking Text Box Position - Word Mac 2011	citizenzen	Word	3	02-01-2013 12:24 PM
Locking settings on word	Man	Word	1	03-27-2012 07:32 AM
locking out word	joe	Word	0	11-19-2009 02:09 AM
Locking a Word Document	Coach_Patrick	Word	1	11-06-2008 12:00 PM