Microsoft Office Forums

Go Back   Microsoft Office Forums > Microsoft Word > Word VBA

Reply
 
LinkBack Thread Tools Display Modes
  #1  
Old 07-12-2018, 07:37 AM
ajwilliams77 ajwilliams77 is offline Windows 7 32bit Office 2010 32bit
Novice
 
Join Date: Jul 2018
Posts: 3
ajwilliams77 is on a distinguished road
Default Locking word to run macro

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
Reply With Quote
  #2  
Old 07-12-2018, 07:39 AM
macropod's Avatar
macropod macropod is online now Windows 7 64bit Office 2010 32bit
Administrator
 
Join Date: Dec 2010
Location: Canberra, Australia
Posts: 18,249
macropod is a splendid one to beholdmacropod is a splendid one to beholdmacropod is a splendid one to beholdmacropod is a splendid one to beholdmacropod is a splendid one to beholdmacropod is a splendid one to beholdmacropod is a splendid one to beholdmacropod is a splendid one to behold
Default

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.
__________________
Cheers,
Paul Edstein
[MS MVP - Word]
Reply With Quote
  #3  
Old 07-12-2018, 08:12 AM
ajwilliams77 ajwilliams77 is offline Windows 7 32bit Office 2010 32bit
Novice
 
Join Date: Jul 2018
Posts: 3
ajwilliams77 is on a distinguished road
Default

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

Last edited by macropod; 07-12-2018 at 04:12 PM. Reason: Added code tags
Reply With Quote
  #4  
Old 07-12-2018, 05:09 PM
macropod's Avatar
macropod macropod is online now Windows 7 64bit Office 2010 32bit
Administrator
 
Join Date: Dec 2010
Location: Canberra, Australia
Posts: 18,249
macropod is a splendid one to beholdmacropod is a splendid one to beholdmacropod is a splendid one to beholdmacropod is a splendid one to beholdmacropod is a splendid one to beholdmacropod is a splendid one to beholdmacropod is a splendid one to beholdmacropod is a splendid one to behold
Default

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.
__________________
Cheers,
Paul Edstein
[MS MVP - Word]
Reply With Quote
  #5  
Old 07-13-2018, 03:13 AM
ajwilliams77 ajwilliams77 is offline Windows 7 32bit Office 2010 32bit
Novice
 
Join Date: Jul 2018
Posts: 3
ajwilliams77 is on a distinguished road
Default

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.
Reply With Quote
Reply

Thread Tools
Display Modes


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


All times are GMT -7. The time now is 01:56 AM.


Powered by vBulletin® Version 3.8.1
Copyright ©2000 - 2018, Jelsoft Enterprises Ltd.
SEO by vBSEO ©2011, Crawlability, Inc.
MSOfficeForums.com is not affiliated with Microsoft