Good day! So its quiet a simple logic i want to add a picture as a default background for different sections. Like A3 portrait format has one, Landscape another, and so on. I keep on getting the 5941 Error in the code section below. Apologies for the code arrangement as it keeps on formatting it.
Application.Templates.LoadBuildingBlocks
Dim objDocument As Document
Dim objSection As Section
For i = 1 To Selection.Information(wdActiveEndPageNumber) Step 1
Set objDocument = ActiveDocument
For Each objSection In objDocument.Sections
With objSection.PageSetup
If .Orientation = wdOrientPortrait Then
'A4 portrait
If .PageHeight > CentimetersToPoints(22) And .PageHeight < CentimetersToPoints(30) And .PageWidth < CentimetersToPoints(30) Then
'In this portion, below, my code is highlighted. however if I change i to any digit, it seems working just fine. I want it to an iteration but FOR loop does not work, where did i go wrong?
Set MyImage1 = **ThisDocument.Sections(i)**.Headers(wdHeaderFooterPrimary) _
.Range.InlineShapes.AddPicture(ImagePath1).ConvertToShape
MyImage1.WrapFormat.Type = wdWrapBehind
With MyImage1
.RelativeHorizontalPosition = wdRelativeHorizontalPositionPage
.RelativeVerticalPosition = wdRelativeVerticalPositionPage
.Top = wdShapeTop
.Left = wdShapeLeft
.Height = CentimetersToPoints(29.7)
.Width = CentimetersToPoints(21)
End With
'A3 portret
ElseIf .PageHeight > CentimetersToPoints(30) And .PageWidth < CentimetersToPoints(30) Then
Set MyImage7 = ThisDocument.Sections(i).Headers(wdHeaderFooterPrimary) _
.Range.InlineShapes.AddPicture(ImagePath7).ConvertToShape
MyImage7.WrapFormat.Type = wdWrapBehind
With MyImage7
.RelativeHorizontalPosition = wdRelativeHorizontalPositionPage
.RelativeVerticalPosition = wdRelativeVerticalPositionPage
.Top = wdShapeTop
.Left = wdShapeLeft
.Height = CentimetersToPoints(42)
.Width = CentimetersToPoints(29.7)
End With
ElseIf .Orientation = wdOrientLandscape Then
' A4 landscape
ElseIf .PageHeight < CentimetersToPoints(22) And .PageWidth < CentimetersToPoints(30) Then
Set MyImage3 = ThisDocument.Sections(i).Headers(wdHeaderFooterPrimary) _
.Range.InlineShapes.AddPicture(ImagePath3).ConvertToShape
MyImage3.WrapFormat.Type = wdWrapBehind
With MyImage3
.RelativeHorizontalPosition = wdRelativeHorizontalPositionPage
.RelativeVerticalPosition = wdRelativeVerticalPositionPage
.Top = wdShapeTop
.Left = wdShapeLeft
.Height = CentimetersToPoints(21)
.Width = CentimetersToPoints(29.7)
End With
'A3 landscape
ElseIf .PageHeight > CentimetersToPoints(30) And .PageWidth > CentimetersToPoints(30) Then
Set MyImage6 = ThisDocument.Sections(i).Headers(wdHeaderFooterPrimary) _
.Range.InlineShapes.AddPicture(ImagePath6).ConvertToShape
MyImage6.WrapFormat.Type = wdWrapBehind
With MyImage6
.RelativeHorizontalPosition = wdRelativeHorizontalPositionPage
.RelativeVerticalPosition = wdRelativeVerticalPositionPage
.Top = wdShapeTop
.Left = wdShapeLeft
.Height = CentimetersToPoints(29.7)
.Width = CentimetersToPoints(42)
End With
End If
End If
End With
Next
Next
Your code seems rather confused and contains several undeclared variables.
You start off with a loop stepping though a counter of the pages in
the selection. This is unnecessary and should be removed because
there is no connection between the number of pages and the number of
sections in a document.
You are setting objDocument within the initial loop. This means
that objDocument is reset at each pass through the loop. Set
objDocument = ActiveDocument should be moved to the beginning of
your code before the loop begins.
You then loop through the sections in objDocument. This is the only
loop you need in your code.
When you come to adding the image you suddenly switch from
objDocument to ThisDocument. Depending on where the code modules
are located ThisDocument may not be the same document as
objDocument.
You then introduce a further potential source of error with
ThisDocument.Sections(i). As the counter you are using is not
related to the number of sections it is highly likely that
ThisDocument.Sections(i) doesn't exist. You should replace this
with objSection.
Related
I want to take all the articles in Word document and transform them into PowerPoint Presentation.
1 article = 1 slide (if the text does not fit shrink it, else create a new slide).
I managed to recognize each part of the article by its Style in Word. I get text by its style and insert it into a slide and so forth. I retrieve text by paragraphs (Selection.StartOf and EndOf didn't work).
I didn't find a way to avoid overlaying one text over the other.
Maybe I can get what I need by the coordinates of the textframes?
What I have got so far:
For Each StyleInWord In ActiveDocument.Paragraphs
If StyleInWord.Style = "NAME_OF_THE_ARTICLE" Then
wordText0 = StyleInWord.Range
Set pptLayout = pptPres.SlideMaster.CustomLayouts.Add(ppLayoutBlank)
Set pptSlide = pptPres.Slides.AddSlide(1, pptLayout)
If pptPres.Slides(1).Shapes(1).HasTextFrame Then
pptPres.Slides(1).Shapes(1).Delete
End If
With pptPres.PageSetup
.SlideSize = ppSlideSizeCustom
.SlideHeight = CentimetersToPoints(21.008)
.SlideWidth = CentimetersToPoints(28.011)
End With
Set mySlide = pptPres.Slides(1).Shapes.AddTextbox(msoTextOrientationHorizontal, CentimetersToPoints(1.31), CentimetersToPoints(3.73), CentimetersToPoints(24.34), CentimetersToPoints(12.57))
With mySlide.TextFrame.TextRange
.Text = wordText0
With .Font
.Size = 11 ' points
.Name = "Arial"
.Bold = msoTrue
End With
End With
End If
If StyleInWord.Style = "DESCRIPTION_OF_THE_ARTICLE" Then
wordText1 = StyleInWord.Range
Set mySlide = pptPres.Slides(1).Shapes.AddTextbox(msoTextOrientationHorizontal, CentimetersToPoints(1.31), CentimetersToPoints(5.73), CentimetersToPoints(24.34), CentimetersToPoints(12.57))
With mySlide.TextFrame
With .TextRange
.Text = wordText1
With .Font
.Size = 11 ' points
.Name = "Arial"
.Bold = msoTrue
End With
End With
End With
End If
If StyleInWord.Style = "MAIN_TEXT_OF_THE_ARTICLE" Then
Set mySlide = pptPres.Slides(1).Shapes.AddTextbox(msoTextOrientationHorizontal, CentimetersToPoints(1.31), CentimetersToPoints(7.73), CentimetersToPoints(24.34), CentimetersToPoints(12.57))
wordText2 = StyleInWord.Range
With mySlide.TextFrame
With .TextRange
.Text = wordText2
With .Font
.Size = 11 ' points
.Name = "Arial"
.Bold = msoTrue
End With
End With
End With
End If
Next StyleInWord
'Here i change the order, so the first slide i create will stay the first by the end of the forEachLoop
i = 1
For i = 1 To pptPres.Slides.Count
pptPres.Slides(i).MoveTo 1
Next i
Each time you add a textbox you set the top position to simply be 2cm lower than the previous one. This takes no account of the height of the previous text box.
There is a very simple solution to this. A text box has properties for both top and height, so just store those in variables. That way you can add each new text box directly below the previous one.
Your code also needs some improvement as some of the presentation setup you are doing should be outside the loop. You should also rename mySlide as pptTextBox so that the variable has a logical name that is consistent with the others.
Set pptLayout = pptPres.SlideMaster.CustomLayouts.Add(ppLayoutBlank) doesn't do what you think it does and is unnecessary. The presentation will already contain a blank layout, helpfully named "Blank", so all you need to do is set a pointer to it, again outside the loop.
'do presentation setup outside the loop
With pptPres.PageSetup
.SlideSize = ppSlideSizeCustom
.SlideHeight = CentimetersToPoints(21.008)
.SlideWidth = CentimetersToPoints(28.011)
End With
'a presentation will already include a blank layout so there is no need to create one
For Each pptLayout In pptPres.SlideMaster.CustomLayouts
If pptLayout.Name = "Blank" Then Exit For
'pptLayout now points to the Blank layout
Next
For Each StyleInWord In ActiveDocument.Paragraphs
If StyleInWord.Style = "NAME_OF_THE_ARTICLE" Then
wordText0 = StyleInWord.Range
Set pptSlide = pptPres.Slides.AddSlide(1, pptLayout)
If pptPres.Slides(1).Shapes(1).HasTextFrame Then
pptPres.Slides(1).Shapes(1).Delete
End If
Set pptTextBox = _
pptPres.Slides(1).Shapes.AddTextbox(msoTextOrientationHorizontal, _
CentimetersToPoints(1.31), CentimetersToPoints(3.73), _
CentimetersToPoints(24.34), CentimetersToPoints(12.57))
With pptTextBox
With .TextFrame.TextRange
.Text = wordText0
With .Font
.Size = 11 ' points
.Name = "Arial"
.Bold = msoTrue
End With
End With
textBoxTop = .Top
textBoxHeight = .Height
End With
End If
If StyleInWord.Style = "DESCRIPTION_OF_THE_ARTICLE" Then
wordText1 = StyleInWord.Range
Set pptTextBox = _
pptPres.Slides(1).Shapes.AddTextbox(msoTextOrientationHorizontal, _
CentimetersToPoints(1.31), textBoxTop + textBoxHeight, _
CentimetersToPoints(24.34), CentimetersToPoints(12.57))
With pptTextBox
With .TextFrame.TextRange
.Text = wordText1
With .Font
.Size = 11 ' points
.Name = "Arial"
.Bold = msoTrue
End With
End With
textBoxHeight = textBoxHeight + .Height
End With
End If
If StyleInWord.Style = "MAIN_TEXT_OF_THE_ARTICLE" Then
Set pptTextBox = _
pptPres.Slides(1).Shapes.AddTextbox(msoTextOrientationHorizontal, _
CentimetersToPoints(1.31), textBoxTop + textBoxHeight, _
CentimetersToPoints(24.34), CentimetersToPoints(12.57))
wordText2 = StyleInWord.Range
With pptTextBox
With .TextFrame.TextRange
.Text = wordText2
With .Font
.Size = 11 ' points
.Name = "Arial"
.Bold = msoTrue
End With
End With
textBoxHeight = textBoxHeight + .Height
End With
End If
Next StyleInWord
'Here i change the order, so the first slide i create will stay the first by the end of the forEachLoop
i = 1
For i = 1 To pptPres.Slides.Count
pptPres.Slides(i).MoveTo 1
Next i
I have basic Macro and VBA knowledge yet cannot get my head around where I am going wrong here. (Code inserted at the bottom) I want my macro to move a selected image into the top centre of the page. The issue I am facing is that it will not work for each image in the document, it works for the first one then no longer performs the task. I am using Microsoft Word 2016.
The main command does what I want it to, I feel my error is within these two lines
Set myDocument = ActiveDocument
With myDocument.Shapes(1)
Whole code;
Sub AlignToCentre()
'
' AlignToCentre
Dim shp As Shape
Set myDocument = ActiveDocument
With myDocument.Shapes(1)
.WrapFormat.Type = wdWrapSquare
.RelativeHorizontalPosition = wdRelativeHorizontalPositionPage
.Left = wdShapeCenter
.RelativeVerticalPosition = wdRelativeVerticalPositionPage
.Top = InchesToPoints(1)
End With
End Sub
If you want this to work with the selected image, and only the selected image, then more like this, where you get the Shape from the current selection.
Note how you should first check to make sure a Shape is selected...
Sub PositionSelectedShape()
Dim sel As word.Selection
Dim shp As word.Shape
Set sel = Selection
If sel.Type = wdSelectionShape Then
Set shp = sel.ShapeRange(1)
With shp
.WrapFormat.Type = wdWrapSquare
.RelativeHorizontalPosition = wdRelativeHorizontalPositionPage
.Left = wdShapeCenter
.RelativeVerticalPosition = wdRelativeVerticalPositionPage
.Top = InchesToPoints(1)
End With
End If
End Sub
Exactly like Kim Raaness has suggested, you need to loop through all shapes of you would like to centre them all.
Try something like this:
Sub AlignToCentre()
'
' AlignToCentre
Dim shp As Shape
Set myDocument = ActiveDocument
For Each shp in myDocument.Shapes
With shp
.WrapFormat.Type = wdWrapSquare
.RelativeHorizontalPosition = wdRelativeHorizontalPositionPage
.Left = wdShapeCenter
.RelativeVerticalPosition = wdRelativeVerticalPositionPage
.Top = InchesToPoints(1)
End With
Next shp
End Sub
I am trying to write subroutines for two different pie shaped chart. One works fine on DataLabel ShowValue and ShowPercentage but on second subroutine I get Run Time Error. here is the code:
Sub Grafik_5()
ActiveSheet.Shapes.AddChart2(251, xlPie).Select
ActiveChart.SetSourceData Source:=Sheets("Grafikler").Range("C7:C9")
ActiveChart.FullSeriesCollection(1).XValues = "=Grafikler!$A$7:$A$9"
With ActiveChart.Parent
.Height = Range("C113:C123").Height
.Width = Range("C113:E113").Width
.Top = Range("c113").Top
.Left = Range("c113").Left
End With
With ActiveChart.SeriesCollection(1).DataLabels
.ShowValue = False
.ShowPercentage = True
End With
End Sub
It gives error on ActiveChart.SeriesCollection(1).DataLabels line
Appreciate all help,
Thanks,
You need to ApplyDatalabels before working with them. This should resolve the error.
Sub Grafik_5()
ActiveSheet.Shapes.AddChart2(251, xlPie).Select
ActiveChart.SetSourceData Source:=Sheets("Grafikler").Range("C7:C9")
ActiveChart.FullSeriesCollection(1).XValues = "=Grafikler!$A$7:$A$9"
With ActiveChart.Parent
.Height = Range("C113:C123").Height
.Width = Range("C113:E113").Width
.Top = Range("c113").Top
.Left = Range("c113").Left
End With
With ActiveChart.SeriesCollection(1)
.ApplyDataLabels
.DataLabels.ShowValue = False
.DataLabels.ShowPercentage = True
End With
End Sub
I'm adding ".jpg" files to my Excel sheet with the code below :
'Add picture to excel
xlApp.Cells(i, 20).Select
xlApp.ActiveSheet.Pictures.Insert(picPath).Select
'Calgulate new picture size
With xlApp.Selection.ShapeRange
.LockAspectRatio = msoTrue
.Width = 75
.Height = 100
End With
'Resize and make printable
With xlApp.Selection
.Placement = 1 'xlMoveAndSize
'.Placement = 2 'xlMove
'.Placement = 3 'xlFreeFloating
.PrintObject = True
End With
I don't know what I am doing wrong but it doesn't get inserted into the right cell, so what should I do to put this picture into a specified cell in Excel?
Try this:
With xlApp.ActiveSheet.Pictures.Insert(PicPath)
With .ShapeRange
.LockAspectRatio = msoTrue
.Width = 75
.Height = 100
End With
.Left = xlApp.ActiveSheet.Cells(i, 20).Left
.Top = xlApp.ActiveSheet.Cells(i, 20).Top
.Placement = 1
.PrintObject = True
End With
It's better not to .select anything in Excel, it is usually never necessary and slows down your code.
Looking at posted answers I think this code would be also an alternative for someone. Nobody above used .Shapes.AddPicture in their code, only .Pictures.Insert()
Dim myPic As Object
Dim picpath As String
picpath = "C:\Users\photo.jpg" 'example photo path
Set myPic = ws.Shapes.AddPicture(picpath, False, True, 20, 20, -1, -1)
With myPic
.Width = 25
.Height = 25
.Top = xlApp.Cells(i, 20).Top 'according to variables from correct answer
.Left = xlApp.Cells(i, 20).Left
.LockAspectRatio = msoFalse
End With
I'm working in Excel 2013. Also realized that You need to fill all the parameters in .AddPicture, because of error "Argument not optional". Looking at this You may ask why I set Height and Width as -1, but that doesn't matter cause of those parameters are set underneath between With brackets.
Hope it may be also useful for someone :)
If it's simply about inserting and resizing a picture, try the code below.
For the specific question you asked, the property TopLeftCell returns the range object related to the cell where the top left corner is parked. To place a new image at a specific place, I recommend creating an image at the "right" place and registering its top and left properties values of the dummy onto double variables.
Insert your Pic assigned to a variable to easily change its name. The Shape Object will have that same name as the Picture Object.
Sub Insert_Pic_From_File(PicPath as string, wsDestination as worksheet)
Dim Pic As Picture, Shp as Shape
Set Pic = wsDestination.Pictures.Insert(FilePath)
Pic.Name = "myPicture"
'Strongly recommend using a FileSystemObject.FileExists method to check if the path is good before executing the previous command
Set Shp = wsDestination.Shapes("myPicture")
With Shp
.Height = 100
.Width = 75
.LockAspectRatio = msoTrue 'Put this later so that changing height doesn't change width and vice-versa)
.Placement = 1
.Top = 100
.Left = 100
End with
End Sub
Good luck!
I have been working on a system that ran on a PC and Mac and was battling to find code that worked for inserting pictures on both PC and Mac. This worked for me so hopefully someone else can make use of it!
Note: the strPictureFilePath and strPictureFileName variables need to be set to valid PC and Mac paths Eg
For PC: strPictureFilePath = "E:\Dropbox\" and strPictureFileName = "TestImage.jpg" and with Mac: strPictureFilePath = "Macintosh HD:Dropbox:" and strPictureFileName = "TestImage.jpg"
Code as Follows:
On Error GoTo ErrorOccured
shtRecipeBrowser.Cells(intDestinationRecipeRowCount, 1).Select
ActiveSheet.Pictures.Insert(Trim(strPictureFilePath & strPictureFileName)).Select
Selection.ShapeRange.Left = shtRecipeBrowser.Cells(intDestinationRecipeRowCount, 1).Left
Selection.ShapeRange.Top = shtRecipeBrowser.Cells(intDestinationRecipeRowCount, 1).Top + 10
Selection.ShapeRange.LockAspectRatio = msoTrue
Selection.ShapeRange.Height = 130
Firstly, of all I recommend that the pictures are in the same folder as the workbook.
You need to enter some codes in the Worksheet_Change procedure of the worksheet. For example, we can enter the following codes to add the image that with the same name as the value of cell in column A to the cell in column D:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim pic As Picture
If Intersect(Target, [A:A]) Is Nothing Then Exit Sub
On Error GoTo son
For Each pic In ActiveSheet.Pictures
If Not Application.Intersect(pic.TopLeftCell, Range(Target.Offset(0, 3).Address)) Is Nothing Then
pic.Delete
End If
Next pic
ActiveSheet.Pictures.Insert(ThisWorkbook.Path & "\" & Target.Value & ".jpg").Select
Selection.Top = Target.Offset(0, 2).Top
Selection.Left = Target.Offset(0, 3).Left
Selection.ShapeRange.LockAspectRatio = msoFalse
Selection.ShapeRange.Height = Target.Offset(0, 2).Height
Selection.ShapeRange.Width = Target.Offset(0, 3).Width
son:
End Sub
With the codes above, the picture is sized according to the cell it is added to.
Details and sample file here : Vba Insert image to cell
I tested both #SWa and #Teamothy solution. I did not find the Pictures.Insert Method in the Microsoft Documentations and feared some compatibility issues. So I guess, the older Shapes.AddPicture Method should work on all versions. But it is slow!
On Error Resume Next
'
' first and faster method (in Office 2016)
'
With ws.Pictures.Insert(Filename:=imageFileName, LinkToFile:=msoTrue, SaveWithDocument:=msoTrue)
With .ShapeRange
.LockAspectRatio = msoTrue
.Width = destRange.Width
.height = destRange.height '222
End With
.Left = destRange.Left
.Top = destRange.Top
.Placement = 1
.PrintObject = True
.Name = imageName
End With
'
' second but slower method (in Office 2016)
'
If Err.Number <> 0 Then
Err.Clear
Dim myPic As Shape
Set myPic = ws.Shapes.AddPicture(Filename:=imageFileName, _
LinkToFile:=msoFalse, SaveWithDocument:=msoTrue, _
Left:=destRange.Left, Top:=destRange.Top, Width:=-1, height:=destRange.height)
With myPic.OLEFormat.Object.ShapeRange
.LockAspectRatio = msoTrue
.Width = destRange.Width
.height = destRange.height '222
End With
End If
I have a shape in a Word document that I need to move to a bookmark location.
I tried to use the "left" and "top" properties, however, this does not work because to my knowledge, bookmark does not have "left" and "right properties.
I have tried to use cut and paste, but this does not work for shapes.
The following is the code to create the shape:
Set shp = ActiveDocument.Content.InlineShapes.AddOLEControl("Forms.CommandButton.1")
With ActiveDocument.InlineShapes(1).OLEFormat.Object
.Caption = "Test"
.Height = 30
.Width = 44
End With
With ActiveDocument.InlineShapes(1).ConvertToShape
.Name = "Test1"
.ZOrder (msoBringInFrontOfText)
End With
Instead of using a bookmark could you use an Absolute Position on the document somewhere?
Dim Test1 As Shape
Set Test1 = ActiveDocument.Shapes("Test1")
With Test1
.RelativeHorizontalPosition = wdRelativeHorizontalPositionPage
.RelativeVerticalPosition = wdRelativeVerticalPositionPage
.Left = InchesToPoints(6.889)
.Top = InchesToPoints(0.374)
End With
End Sub
This is a very old thread, but the basic premise is still valid, and it is possible to insert a control at a bookmarked location (here a bookmark named 'bmShape') using VBA as shown below.
Dim oRng As Range
Dim oShp As InlineShape
Set oRng = ActiveDocument.Bookmarks("bmShape").Range
oRng.Text = ""
Set oShp = oRng.InlineShapes.AddOLEControl("Forms.CommandButton.1")
oRng.End = oRng.End + 1
oRng.Bookmarks.Add "bmShape"
With oShp.OLEFormat.Object
.Caption = "Test"
.Height = 30
.Width = 44
End With
With oShp.ConvertToShape
.Name = "Test1"
.WrapFormat.Type = wdWrapSquare
.WrapFormat.Side = wdWrapBoth
End With