#1
|
|||
|
|||
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 |
#2
|
||||
|
||||
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 [Fmr MS MVP - Word] |
#3
|
|||
|
|||
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 |
#4
|
||||
|
||||
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
__________________
Cheers, Paul Edstein [Fmr MS MVP - Word] |
#5
|
|||
|
|||
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. |
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 |