Plaatje via macro in koptekst

[ceebee]

Hoe kan ik via een macro een (benoemd) plaatje opnemen in alle aanwezige
kopteksten en
Hoe kan ik via een macro een (benoemd) plaatje verwijderen uit alle
aanwezige kopteksten.

 

[joost verdaasdo]

Hai,

Dit lijkt een makkelijke vraag maar dat is het zeker niet..(veel valkuilen)

Dus:
* Is dit een bestaand document?
* Zijn de kop/voetteksten gekoppeld?
* Wat versta jij onder een benoemd plaatje? (Gewoon het pad naar een afbeelding?)
* Moet het plaatje nog geresized worden?
* Moet het plaatje op een bepaalde locatie komen in het document?

* En het verwijderen op zich kan ook al veel variteiten opleveren om rekening mee te houden!

Heb je hier overal een antwoord op en je levert (een) plaatje en een document waarin het plaatje op de juiste plaats in de koptekst staat dan wil ik best eens een poging voor je wagen..

Ik hoor het wel! :thumb:

 

[ceebee]

Extra info, Joost.
Plaatje heeft vaste afmetingen, maar moet interne shape-naam krijgen. Plaatsing weet ik hoe dat moet via de macro, want het moet inderdaad op vaste plaats komen.
Bij verwijderen stel ik me voor dat ik een loop afwerk, waarin alle kopteksten aan bod komen. Als daarin een plaatje met interne naam voorkomt, moet dit verwijderd worden.
Kopteksten kunnen gekoppeld zijn, maar kopteksten kunnen ook nieuwe zijn in nieuwe secties.

Code, die ik tot nu heb geproduceerd:
Sub Huisstijl_logo()
If Documents.Count >= 1 Then
Selection.HomeKey Unit:=wdStory
If ActiveWindow.View.SplitSpecial <> wdPaneNone Then
ActiveWindow.Panes(2).Close
End If
If ActiveWindow.ActivePane.View.Type = wdNormalView Or ActiveWindow. _
ActivePane.View.Type = wdOutlineView Then
ActiveWindow.ActivePane.View.Type = wdPrintView
End If
ActiveWindow.ActivePane.View.SeekView = wdSeekCurrentPageHeader
Selection.InlineShapes.AddPicture FileName:= _
"G:\Templates\wstmmm1.gif", LinkToFile:=False, _
SaveWithDocument:=True
Selection.MoveLeft Unit:=wdCharacter, Count:=1, Extend:=wdExtend
Selection.InlineShapes(1).ConvertToShape.Select
Selection.ShapeRange.Name = "logo"
Selection.ShapeRange.Fill.Visible = msoFalse
Selection.ShapeRange.Fill.Transparency = 0#
Selection.ShapeRange.Line.Weight = 0.75
Selection.ShapeRange.Line.DashStyle = msoLineSolid
Selection.ShapeRange.Line.Style = msoLineSingle
Selection.ShapeRange.Line.Transparency = 0#
Selection.ShapeRange.Line.Visible = msoFalse
Selection.ShapeRange.LockAspectRatio = msoTrue
Selection.ShapeRange.Height = 83.35
Selection.ShapeRange.Width = 197.85
Selection.ShapeRange.PictureFormat.Brightness = 0.5
Selection.ShapeRange.PictureFormat.Contrast = 0.5
Selection.ShapeRange.PictureFormat.ColorType = msoPictureAutomatic
Selection.ShapeRange.PictureFormat.CropLeft = 0#
Selection.ShapeRange.PictureFormat.CropRight = 0#
Selection.ShapeRange.PictureFormat.CropTop = 0#
Selection.ShapeRange.PictureFormat.CropBottom = 0#
Selection.ShapeRange.RelativeHorizontalPosition =
wdRelativeHorizontalPositionPage
Selection.ShapeRange.RelativeVerticalPosition =
wdRelativeVerticalPositionPage
Selection.ShapeRange.Left = CentimetersToPoints(1.5)
Selection.ShapeRange.Top = CentimetersToPoints(1)
Selection.ShapeRange.LockAnchor = False
Selection.ShapeRange.WrapFormat.AllowOverlap = True
Selection.ShapeRange.WrapFormat.Side = wdWrapBoth
Selection.ShapeRange.WrapFormat.DistanceTop = CentimetersToPoints(0)
Selection.ShapeRange.WrapFormat.DistanceBottom = CentimetersToPoints(0)
Selection.ShapeRange.WrapFormat.DistanceLeft = CentimetersToPoints(0.32)
Selection.ShapeRange.WrapFormat.DistanceRight = CentimetersToPoints(0.32)
Selection.ShapeRange.WrapFormat.Type = wdWrapTight
ActiveWindow.ActivePane.View.SeekView = wdSeekMainDocument
Application.WindowState = wdWindowStateNormal
ActiveWindow.WindowState = wdWindowStateNormal
Else
MsgBox "Er is geen actief document!"
End If
End Sub

Op zich werkt dit, behalve als ik de macro in de map opstarten plaats. Dan krijg ik de melding dat er iets is met With object (geen regelnummercode).

Bedankt

 

[joost verdaasdo]

Hai,

Sjeemienee..wat een lap code...
Ik zal mij er eens doorheen worstelen en een antwoord plaatsen.! :thumb:

 

[ceebee]

Valt wel mee

Valt wel mee, Joost.
Deze code krijg je automatisch als je een macro maakt, die in een koptekst een afbeelding plaats en die vervolgens op een vaste plek zet.

 

[joost verdaasdo]

Hai,

Het was vooral als grapje bedoeld...(had al gezien dat deze macro opgenomen is)

 

[joost verdaasdo]

Hai,

Nou heb hier toch wel even over na moeten denken! (er zijn ook zoveel variaties te bedenken in secties en kopteksten..)

Maar goed volgens mij moet je er hier mee komen:

Const sPic  As String = "C:\Documents and Settings\Admin\My Documents\My Pictures\logo\hills.jpg"
'Const sPic  As String = "G:\Templates\wstmmm1.gif" 'deze is voor jou!
Const sBm   As String = "bmPic"

Sub Logo()
Dim oSec     As Word.Section
Dim oHead    As Word.HeaderFooter
Dim oShape   As Word.Shape
Dim iCnt     As Integer
Dim sName    As String

If Documents.Count = 0 Then Exit Sub
Application.ScreenUpdating = False

  For Each oSec In ActiveDocument.Sections
    If oSec.Index > 0 And oSec.Index <= ActiveDocument.Sections.Count Then
        For Each oHead In oSec.Headers
          Set oShape = oHead.Shapes.AddPicture(sPic)
                With oShape
                    .Name = CStr("Pic" & iCnt)
                    .LockAspectRatio = msoTrue
                    .Height = 83.35
                    .Width = 197.85
                    .RelativeHorizontalPosition = wdRelativeHorizontalPositionPage
                    .RelativeVerticalPosition = wdRelativeVerticalPositionPage
                    .Left = CentimetersToPoints(1.5)
                    .Top = CentimetersToPoints(1)
                    .WrapFormat.AllowOverlap = True
                    .WrapFormat.Side = wdWrapBoth
                    .WrapFormat.DistanceTop = CentimetersToPoints(0)
                    .WrapFormat.DistanceBottom = CentimetersToPoints(0)
                    .WrapFormat.DistanceRight = CentimetersToPoints(0.32)
                    .WrapFormat.Type = wdWrapTight
                End With
            iCnt = iCnt + 1
        Next
    End If
  Next
  Set oShape = Nothing
End Sub

Sub DeleteLogo()
Dim oSec1     As Word.Section
Dim oHead1    As Word.HeaderFooter
Dim oShape1   As Word.Shape

If Documents.Count = 0 Then Exit Sub
Application.ScreenUpdating = False

  For Each oSec1 In ActiveDocument.Sections
    If oSec1.Index > 0 And oSec1.Index <= ActiveDocument.Sections.Count Then
        For Each oHead1 In oSec1.Headers
            For Each oShape1 In oHead1.Shapes
                If Left(oShape1.Name, 3) = "Pic" Then
                    oShape1.Delete
                End If
            Next
        Next
    End If
  Next
End Sub

Deze wandelt alle secties door en daar aangekomen door alle kopteksten heen en zet het logo neer volgens jou specs's

De knop Delete haalt ze weer weg..

Zie bijlage (met twee extra knoppen in de menubalk) voor het voorbeeld!
Je moet alleen even de constante sPic even wissen en degene waarbij jou pad staat moet je even apostrof weghalen (UnComment)....dit om de locatie van jou foto aan te geven!

Success! :thumb:

 

[ceebee]

Fantastisch

:thumb: Het werkt als een speer:thumb:

 

[joost verdaasdo]

Re: Fantastisch

Geplaatst door ceebee
:thumb: Het werkt als een speer:thumb:

Kijk dat horen we graag!

Jij happy ik happy...graag gedaan! :thumb: