I have the code to save the image in the word file. I use VBA Word but it gives an error. Please help me.
Sub SaveImage()
Set clipboard = New DataObject
Set Doc = ActiveDocument
i = 1
For Each Shp In Doc.InlineShapes
If Shp.Type = msoLinkedPicture Or Shp.Type = msoPicture Or Shp.Type = wdInlineShapePicture Then
Shp.Select
Shp.Range.CopyAsPicture
clipboard.GetFormat (2) 'jpg,bmp
strFile = "C:\Newfolder\file" & i & ".jpg"
SavePicture clipboard.getdata, strFile
i = i + 1
End If
Next
End Sub
Related
Using below code for saving MS Word images and converting into base64.
When exporting the image it adds some borders.
Original Image
after export
If singleline.Range.InlineShapes.Count > 0 Then
Dim shp1 As InlineShape
Dim mchart1 As Shape
Set shp1 = singleline.Range.InlineShapes(1)
shp1.Select
Selection.Copy
Set mchart1 = ActiveDocument.Shapes.AddChart(xl3DAreaStacked, , , shp1.Width, shp1.Height)
mchart1.Chart.ChartData.Workbook.Application.Quit
mchart1.Chart.Paste
mchart1.Chart.Export ("c:\here\" + CStr(i) + ".png")
mchart1.Chart.Delete
b64strng = ConvertFileToBase64("c:\here\" + CStr(i) + ".png")
Kill "c:\here\" + CStr(i) + ".png"
End If
Is there any fix or Alternative to export images?
I don't see any difference between your screenshots, possibly because of the dark browser background. Is the border visible after the Export command, or after the ConvertFileToBase64 function?
It appears you're trying to export a non-chart graphic by using a chart kludge. You'll get better results by enlisting PowerPoint to do the graphics export. Here's a sample macro that shows how to export Word graphics from PowerPoint. You can modify this to export a single Shape or ShapeRange (your graphic) instead of a complete slide.
Public Sub ExportMap()
Dim pptPres As PowerPoint.Presentation
Dim pptSlide As PowerPoint.Slide
Dim pptShapeRange As PowerPoint.ShapeRange
Dim Path$, File$
Dim oRange As Range
Application.ScreenUpdating = False
If ActiveDocument.ProtectionType = wdAllowOnlyFormFields Then
ActiveDocument.Unprotect
End If
myDate$ = Format(Date, "m-d-yyyy")
Set pptApp = CreateObject("PowerPoint.Application")
Path$ = ActiveDocument.Path & Application.PathSeparator
File$ = "WorldMap " & myDate$ & ".png"
Set pptPres = pptApp.Presentations.Add(msoFalse)
Set oRange = ActiveDocument.Bookmarks("WholeMap").Range
oRange.CopyAsPicture
Set pptSlide = pptPres.Slides.Add(1, ppLayoutBlank)
On Error Resume Next
With pptPres.PageSetup
.SlideSize = 7
.SlideWidth = 1150
.SlideHeight = 590
End With
Set pptShapeRange = pptSlide.Shapes.PasteSpecial(ppPasteEnhancedMetafile, Link:=msoFalse)
With pptShapeRange
.Top = .Top + 6
' .Left = .Left + 510
End With
pptSlide.Export Path$ & File$, "PNG"
pptApp.Quit
Set pptPres = Nothing
Set pptApp = Nothing
Set pptSlide = Nothing
If ActiveDocument.ProtectionType = wdNoProtection Then
ActiveDocument.Protect Type:=wdAllowOnlyFormFields, noreset:=True
End If
Application.ScreenUpdating = True
MsgBox "All done! Check the folder containing this template for a file called '" & File$ & "'."
End Sub
I have an existing piece of code (see below) for importing a batch of photos and creating a slide show. At present, the code is creating these slides on a blank background with a title only. How can I modify it so it will choose a specific slide layout from the Master slides? I know it has something to do with this line in the code:
Set oSld = ActivePresentation.Slides.Add(ActivePresentation.Slides.Count + 1, ppLayoutTitleOnly)
I looked here and tried some ideas but I just keep getting bugs: Applying layout to a slide from specific Master
Here's the full program:
Sub ImportStuffFromTextFile()
Dim strTemp As String
Dim strPath As String
Dim strFileSpec As String
Dim oSld As Slide
Dim oPic As Shape
Dim fs As Object
Dim f As Object
Dim PicDesc() As String
Dim strFile As String
Dim fd As FileDialog
Set fd = Application.FileDialog(msoFileDialogFilePicker)
With fd
.Filters.Add "Text Files", "*.txt"
.AllowMultiSelect = False
.InitialFileName = ActivePresentation.Path
If .Show = -1 Then
strFile = .SelectedItems.Item(1)
End If
If strFile = "" Then Exit Sub
End With
Set fs = CreateObject("Scripting.FileSystemObject")
Set f = fs.OpenTextFile(strFile, 1, 0)
Do While Not f.AtEndOfStream
PicDesc = Split(f.readline, Chr(9))
Set oSld = ActivePresentation.Slides.Add(ActivePresentation.Slides.Count + 1, ppLayoutTitleOnly)
Set oPic = oSld.Shapes.AddPicture(FileName:=PicDesc(0), _
LinkToFile:=msoFalse, _
SaveWithDocument:=msoTrue, _
Left:=0, _
Top:=0)
If oSld.Shapes.HasTitle Then
oSld.Shapes.Title.TextFrame.TextRange.Text = PicDesc(1)
With oPic
.Height = 469.875
.Width = 626.325
.Left = ActivePresentation.PageSetup.SlideWidth / 2 - .Width / 2
.Top = oSld.Shapes.Title.Top + oSld.Shapes.Title.Height + 7
End With
End If
Set oPic = Nothing
Set oSld = Nothing
Loop
Set f = Nothing
Set fs = Nothing
End Sub
When you say you keep getting bugs, what do you mean?
Are you getting error messages? If so, what are the error numbers/descriptions? Where does the code break?
If not, and you're getting 'bugs', what should the final output look like and how does this differ from that?
I would say that one big unknown here is the text file input. According to your code, it seems as though it needs to have a series of filenames and corresponding picture descriptions on each line of the text file, separated by a tab. Critically, it must be a tab and not 2 spaces or 4 spaces or 10 spaces or a hyphen ... it must be a tab. Is that the structure of the text file you're using as input?
PowerPoint treats built-in layouts differently than custom ones. You can't call a custom layout by name. Instead, you have to loop through each custom layout to find the one that has the right name, then use it:
Sub AddSlideFromCustomLayout()
Dim oLayout As CustomLayout
Dim oSlide As Slide
For Each oLayout In ActivePresentation.SlideMaster.CustomLayouts
If oLayout.Name = "Custom Layout Name" Then
Set oSlide = ActivePresentation.Slides.AddSlide(ActivePresentation.Slides.Count + 1, oLayout)
End If
Next oLayout
End Sub
Here's your listing with the code replacing the Set oSld line:
Sub ImportStuffFromTextFile()
Dim oLayout As CustomLayout
Dim strTemp As String
Dim strPath As String
Dim strFileSpec As String
Dim oSld As Slide
Dim oPic As Shape
Dim fs As Object
Dim f As Object
Dim PicDesc() As String
Dim strFile As String
Dim fd As FileDialog
Set fd = Application.FileDialog(msoFileDialogFilePicker)
With fd
.Filters.Add "Text Files", "*.txt"
.AllowMultiSelect = False
.InitialFileName = ActivePresentation.Path
If .Show = -1 Then
strFile = .SelectedItems.Item(1)
End If
If strFile = "" Then Exit Sub
End With
Set fs = CreateObject("Scripting.FileSystemObject")
Set f = fs.OpenTextFile(strFile, 1, 0)
Do While Not f.AtEndOfStream
PicDesc = Split(f.readline, Chr(9))
For Each oLayout In ActivePresentation.SlideMaster.CustomLayouts
If oLayout.Name = "Custom Layout Name" Then
Set oSld = ActivePresentation.Slides.AddSlide(ActivePresentation.Slides.Count + 1, oLayout)
End If
Next oLayout
Set oPic = oSld.Shapes.AddPicture(FileName:=PicDesc(0), LinkToFile:=msoFalse, SaveWithDocument:=msoTrue, Left:=0, Top:=0)
If oSld.Shapes.HasTitle Then
oSld.Shapes.Title.TextFrame.TextRange.Text = PicDesc(1)
With oPic
.Height = 469.875
.Width = 626.325
.Left = ActivePresentation.PageSetup.SlideWidth / 2 - .Width / 2
.Top = oSld.Shapes.Title.Top + oSld.Shapes.Title.Height + 7
End With
End If
Set oPic = Nothing
Set oSld = Nothing
Loop
Set f = Nothing
Set fs = Nothing
End Sub
I usually use this one couple times for converting charts to image in PPT. But this time, when running this code, it shown " Error 242, Subject Required"
Anyone master of VBA can help me fix it?
Here the code:
`Sub EnumChartsInPresentation()
Dim sld As Slide
Dim shp As Shape
Dim ctr As Long
For Each sld In ActivePresentation.Slides
For ctr = sld.Shapes.Count To 1 Step -1
If GetShapeType(sld.Shapes(ctr)) = msoChart Then
Call ConvertChartToImage(sld, sld.Shapes(ctr))
End If
Next
Next
End Sub
Function GetShapeType(shp As Shape) As MsoShapeType
If shp.Type = msoPlaceholder Then
If shp.PlaceholderFormat.ContainedType = msoChart Then
GetShapeType = msoChart
Exit Function
End If
End If
GetShapeType = shp.Type
End Function
Sub ConvertChartToImage(sld As Slide, shp As Shape)
Dim shpChartImage As Object
shp.Copy
DoEvents
Set shpChartImage = sld.Shapes.PasteSpecial(ppPastePNG)
With shpChartImage
.Left = shp.Left
.Top = shp.Top
Do While shp.ZOrderPosition < shpChartImage.ZOrderPosition
Call shpChartImage.ZOrder(msoSendBackward)
Loop
shp.Visible = False
'shp.Delete
'Set shp = Nothing
End With
End Sub`
I'm trying to write a batch find and replace code for Power Point slides in VBA but I'm getting the following error: Compile Error Method or data member not found.
The debugger is highlighting Shapes in PP.Shapes on line 13.
I do not have much experience with VBA. I gathered ideas from:
* Getting Started with VBA in PowerPoint 2010 (Office Dev Center)
* Power Point VBA-Find & Replace (YouTube)
* "Simple Macro to import slides from a file" # (VBA Express Forum)
Sub BatchFindReplace()
Dim shp As Shape
Dim strFileName As String
Dim strFolderName As String
Dim PP As Presentation
'Directory
strFolderName = "C:\Users\Emma\Desktop\temp1"
strFileName = Dir(strFolderName & "\*.ppt*")
Do While Len(strFileName) > 0
Set PP = Presentations.Open(strFolderName & "\" & strFileName)
'Find and Replace Code
For Each shp In PP.Shapes
If shp.HasTextFrame Then
If shp.TextFrame.HasText Then
shp.TextFrame.TextRange.Text = Replace(shp.TextFrame.TextRange.Text, "W", "kkk")
End If
End If
Next
PP.Close
strFileName = Dir
Loop
End Sub
The property .Shapes is not a member of Presentation but of Slide
'~~> Open the relevant powerpoint file
Set PP = Presentations.Open(strFolderName & "\" & strFileName)
'~~> Change this to the relevant slide which has the shape
Set PPSlide = PP.Slides(1)
For Each shp In PPSlide.Shapes
Debug.Print shp.Name
Next shp
If you want to work with all shapes in all slides then you will have to loop through slides.
Dim sld As Slide
'~~> Open the relevant powerpoint file
Set PP = Presentations.Open(strFolderName & "\" & strFileName)
For Each sld In PP.Slides
For Each shp In sld.Shapes
Debug.Print shp.Name
Next shp
Next
I would like to loop through all the ppt from a folder and delete a string if found in any textbox in any slide.
I am new to working with powerpoint slides hence need some tips and advice how to work with it.
Option Compare Text
Option Explicit
Sub Test()
Dim Sld As Slide, Shp As Shape
Dim strFileName As String
Dim strFolderName As String
Dim PP As Presentation
Dim strf As String
'String to be deleted.
strf = InputBox("Enter the string.", "Delete String from PPT.", "AAAAA")
'Opens a PowerPoint Document from Excel
Dim objPPT As Object
Set objPPT = CreateObject("PowerPoint.Application")
objPPT.Visible = True
'set default directory here if needed
strFolderName = "C:\Users\Desktop\Files"
strFileName = Dir(strFolderName & "\*.ppt*")
Do While Len(strFileName) > 0
objPPT.Presentations.Open strFolderName & "\" & strFileName
objPPT.Presentations.Activate
For Each Sld In ActivePresentation.Slides 'Error - ActiveX Component can't create object.
For Each Shp In Sld.Shapes
Select Case Shp.Type
Case MsoShapeType.msoTextBox
Debug.Print Sld.Name, Shp.Name, Shp.TextFrame.TextRange.Text
Case Else
Debug.Print Sld.Name, Shp.Name, "This is not a text box"
End Select
Next Shp
Next Sld
objPPT.Presentations.Close
strFileName = Dir
Loop
End Sub
As you are running the macro in Excel, you forgot to say where the ActivePresentation is from. It should work if you have objPPT.ActivePresentation.Slides. Anyway, you can try below revised code:
'Option Compare Text
Option Explicit
Sub Test()
'Dim Sld As Slide, Shp As Shape ' <-- Excel doesn't know Slide if Reference not added
Dim Sld As Object, Shp As Object
Dim strFileName As String
Dim strFolderName As String
'Dim PP As Presentation
Dim PP As Object ' Use this Presentation Object!
Dim strf As String
'String to be deleted.
strf = InputBox("Enter the string.", "Delete String from PPT.", "AAAAA")
'Opens a PowerPoint Document from Excel
Dim objPPT As Object
Set objPPT = CreateObject("PowerPoint.Application")
objPPT.Visible = True ' <-- don't need this, for debug only
'set default directory here if needed
strFolderName = "C:\Users\Desktop\Files"
strFileName = Dir(strFolderName & "\*.ppt*")
Do While Len(strFileName) > 0
'objPPT.Presentations.Open strFolderName & "\" & strFileName
Set PP = objPPT.Presentations.Open(strFolderName & "\" & strFileName)
'objPPT.Presentations.Activate
PP.Activate ' <-- don't need this, for debug only
'For Each Sld In ActivePresentation.Slides 'Error - ActiveX Component can't create object.
' Should work if it's "objPPT.ActivePresentation.Slides"
For Each Sld In PP.Slides
For Each Shp In Sld.Shapes
With Shp
Select Case .Type
Case MsoShapeType.msoTextBox
If InStr(1, .TextFrame.TextRange.Text, strf, vbTextCompare) > 0 Then
Debug.Print Sld.Name, .Name, .TextFrame.TextRange.Text
Else
Debug.Print Sld.Name, .Name, """" & strf & """ not found in text body"
End If
Case Else
Debug.Print Sld.Name, .Name, "This is not a text box"
End Select
End With
Next Shp
Next Sld
'objPPT.Presentations.Close
PP.Close
Set PP = Nothing
strFileName = Dir
Loop
End Sub
UPDATE - To allow processing files already opened and some tweaks:
Option Explicit
Sub Test()
Const strFolderName = "C:\Users\Desktop\Files\"
Dim objPPT As Object, PP As Object, Sld As Object, Shp As Object
Dim strFileName As String
Dim strf As String
'String to be deleted.
strf = InputBox("Enter the string.", "Delete String from PPT.", "AAAAA")
If Len(Trim(strf)) = 0 Then Exit Sub ' Exit if blank text returned
'Opens a PowerPoint Document from Excel
Set objPPT = CreateObject("PowerPoint.Application")
'set default directory here if needed
strFileName = Dir(strFolderName & "*.ppt*")
Do While Len(strFileName) > 0
On Error Resume Next
' Try to get existing one with same name
Set PP = objPPT.Presentations(strFileName)
' If not opened, try open it
If PP Is Nothing Then Set PP = objPPT.Presentations.Open(strFolderName & strFileName)
On Error GoTo 0
' Process the Presentation Slides if it's opened
If PP Is Nothing Then
Debug.Print "Cannot open file! """ & strFolderName & strFileName & """"
Else
Application.StatusBar = "Processing PPT file: " & PP.FullName
Debug.Print String(50, "=")
Debug.Print "PPT File: " & PP.FullName
For Each Sld In PP.Slides
For Each Shp In Sld.Shapes
With Shp
If .Type = MsoShapeType.msoTextBox Then
If InStr(1, .TextFrame.TextRange.Text, strf, vbTextCompare) > 0 Then
Debug.Print Sld.Name, .Name, .TextFrame.TextRange.Text
Else
Debug.Print Sld.Name, .Name, """" & strf & """ not found in text body"
End If
End If
End With
Next Shp
Next Sld
PP.Close ' Close the Presentation
Set PP = Nothing
End If
strFileName = Dir
Loop
Application.StatusBar = False
' Quit PowerPoint app
objPPT.Quit
Set objPPT = Nothing
End Sub
I cannot explain the error you are getting. I also would have expected the code to work. Yet, I stumbled upon this problem before and found the following solution which (strangely) works:
Option Compare Text
Option Explicit
Sub Test()
Dim Sld As Long, Shp As Long
Dim strFileName As String
Dim strFolderName As String
Dim PP As PowerPoint.Presentation
Dim strf As String
'String to be deleted.
strf = InputBox("Enter the string.", "Delete String from PPT.", "AAAAA")
'Opens a PowerPoint Document from Excel
Dim objPPT As PowerPoint.Application
Set objPPT = New PowerPoint.Application
objPPT.Visible = True
'set default directory here if needed
strFolderName = "C:\Users\Desktop\Files"
strFileName = Dir(strFolderName & "\*.ppt*")
Do While Len(strFileName) > 0
Set PP = objPPT.Presentations.Open(strFolderName & "\" & strFileName)
'objPPT.Presentations.Activate
For Sld = 1 To PP.Slides.Count
For Shp = 1 To PP.Slides.Item(Sld).Shapes.Count
With PP.Slides.Item(Sld).Shapes.Item(Shp)
Select Case .Type
Case MsoShapeType.msoTextBox
Debug.Print .Name, .Name, .TextFrame.TextRange.Text
Case Else
Debug.Print .Name, .Name, "This is not a text box"
End Select
End With
Next Shp
Next Sld
PP.Close
Set PP = Nothing
strFileName = Dir
Loop
objPPT.Quit
Set objPPT = Nothing
End Sub
Note: this solution uses early binding instead of late binding. So, you will need to add a reference to Microsoft PowerPoint xx.x Object Library.