Is there an Alternative to using the LoadPicture("bmp_or_icon_file_path") to loading Images in Excel 2007 VBA - image

I have an Excel 2007 Worksheet with many buttons and labels that act as menu options (i.e. user clicks the buttons, labels with images) and is presented with forms, or some thing else.
These images / icons for the buttons and labels are loaded in VBA by assigning the Picture property of the Control and calling LoadPicture() method with the full image file path as parameter, like So.
With SomeFormObject
.cmdOpenFile.Picture = LoadPicture("F:\projectname\images\fileopen.BMP")
End With
This method of loading images for buttons, other controls is causing 2 issues.
1) It creates a dependency on the image files and physical location for every user, so if a user does not have the drive mapped and files present, the VBA fails with runtime error of file or path not found.
2)
The app gets very slow if the images are on a shared drive (which is the case)
I want to eliminate both issues and somehow load icons, images into control internally, without any external dependencies on external image files.
What is the best way to achieve this in Excel 2007 VBA?
I could not file any Visual Basic 6.0 / Visual Studio style "Resource File Editor" / feature with which to accomplish this.
Please advice! thank you
-Shiva #
mycodetrip.com

I really hope that there is a easier way to do this, but this is the only one I found:
The Idea is:
You keep the Pictures embedded in a Sheet and every time you want to set the pictures for the Command you export them from your worksheet to a file and load them through LoadPicture. The only way to export an embedded Picture through VBA that I found is by making it a Chart first.
The following code is based on 'Export pictures from Excel' from johnske
Option Explicit
Sub setAllPictures()
setPicture "Picture 18", "CommandButtonOpen"
setPicture "Picture 3", "CommandButtonClose"
End Sub
Sub setPicture(pictureName As String, commandName As String)
Dim pictureSheet As Worksheet
Dim targetSheet As Worksheet
Dim embeddedPicture As Picture
Dim pictureChart As Chart
Dim MyPicture As String
Dim PicWidth As Long
Dim PicHeight As Long
Set pictureSheet = Sheets("NameOfYourPictureSheet") ' <- to Change '
Set targetSheet = Sheets("NameOfYourSheet") ' <- to Change '
Set embeddedPicture = pictureSheet.Shapes(pictureName).OLEFormat.Object
With embeddedPicture
MyPicture = .Name
PicHeight = .ShapeRange.Height
PicWidth = .ShapeRange.Width
End With
Charts.Add
ActiveChart.Location Where:=xlLocationAsObject, Name:=pictureSheet.Name
Set pictureChart = ActiveChart
embeddedPicture.Border.LineStyle = 0
With pictureChart.Parent
.Width = PicWidth
.Height = PicHeight
End With
With pictureSheet
.Select
.Shapes(MyPicture).Copy
With pictureChart
.ChartArea.Select
.Paste
End With
.ChartObjects(1).Chart.Export Filename:="temp.jpg", FilterName:="jpg"
End With
pictureChart.Parent.Delete
Application.ScreenUpdating = True
targetSheet.Shapes(commandName).OLEFormat.Object.Object.Picture = LoadPicture("temp.jpg")
Set pictureChart = Nothing
Set embeddedPicture = Nothing
Set targetSheet = Nothing
Set pictureSheet = Nothing
End Sub
Sub listPictures()
' Helper Function to get the Names of the Picture-Shapes '
Dim pictureSheet As Worksheet
Dim sheetShape As Shape
Set pictureSheet = Sheets("NameOfYourSheet")
For Each sheetShape In pictureSheet.Shapes
If Left(sheetShape.Name, 7) = "Picture" Then Debug.Print sheetShape.Name
Next sheetShape
Set sheetShape = Nothing
Set pictureSheet = Nothing
End Sub
To Conclude:
Loading the Images from a Mapped Networked Drive seems less messy, and there shouldn't be that much of a speed difference.

2 alternatives i can think of: form.img.picture=pastepicture , and = oleobjects("ActiveXPictureName").object.picture.

Related

VBA download and embed images using url from adjacent cell

I've attempted the solution in the following.
Inserting an Online Picture to Excel with VBA
Unfortunately I get a run-time error '1004'
"Unable to get the Insert property of the Picture class"
which stops on the following code :
Set myPicture = ActiveSheet.Pictures.Insert(pic)
Could this be due to my Office version 2016 (64bit) ?
If not, are there any suggestions of how I might get embed images to adjacent cells in column AK using the image urls from column AJ ?
Thanks in advance
There's some evidence that Excel has trouble downloading from AWS, and I've recreated your issue using the URL you mentioned. In this case, if I were on a deadline I'd put in this fall-back method when the first one fails: download the file, then insert it into the document, then delete the file.
directDownloadFailed:
Dim FileNum As Long
Dim TempFile As String
Dim FileData() As Byte
Dim WHTTP As Object
Set WHTTP = CreateObject("WinHTTP.WinHTTPrequest.5.1")
WHTTP.Open "GET", imgURL, False
WHTTP.Send
FileData = WHTTP.ResponseBody
Set WHTTP = Nothing
FileNum = FreeFile
TempFile = "path\to\save\img.jpg"
Open TempFile For Binary Access Write As #FileNum
Put #FileNum, 1, FileData
Close #FileNum
Set img = ActiveSheet.Pictures.Insert(TempFile)
SetAttr TempFile, vbNormal
Kill TempFile
GoTo resumeProcessingImg
#keydemographic
I appreciate the response and that definitely sounds like an option but I cannot get that code to work or incorporate it into the code I'm using. I get a compile error "Label Not defined" on GoTo resumeProcessingImg
The following will download and embed the images into the cells but the code stops once it gets to the s3 aws image urls.
I'll try a few other ways to incorporate your code but I'm not having much luck with it so far.
This is my test file
Sub URL2IMG()
Dim pic As String 'path of pic
Dim myPicture As Picture 'embedded pic
Dim rng As Range 'range over which we will iterate
Dim cl As Range 'iterator
Set rng = Range("b2:b12") '<~~ as needed, Modify range to where the images are to be embedded.
For Each cl In rng
pic = cl.Offset(0, -1) '<~~ defines image link URL in column to the left of the embedded column
Set myPicture = ActiveSheet.Pictures.Insert(pic)
'you can play with the following to manipulate the size & position of the picture.
With myPicture
.ShapeRange.LockAspectRatio = msoFalse
' currently this shrinks the picture to fit inside the cell.
.Width = cl.Width
.Height = cl.Height
.Top = Rows(cl.Row).Top
.Left = Columns(cl.Column).Left
End With
Next
End Sub

Is there a way to read images from a folder and save it in powerpoint

I have approx. 100 images , I want to read those images, do the resizing and save it in a power point using matlab, Is it way to save those images in a power point giving title to each slide.
I am reading images using this code:
for i = 1:numel(pngfiles)
im{i} = imread(pngfiles{i});
imrgb{i} = rgb2gray(im{i});
imrgb_z{i} = imrgb{i}(160:350,280:450);
end
It seems to me that the best approach would be to use a VBA script inside Powerpoint, rather than manipulating ppt from Matlab. The steps would be
Create your list of images in a folder - using a sensible naming scheme
Open Powerpoint; go to the VBA editor (Alt-F11) and add a module with the following lines of code in it (note - this is taken straight from https://stackoverflow.com/a/5038907/1967396 with minimal edits):
-
Sub CreatePictureSlideshow( )
Dim presentation
Dim layout
Dim slide
Dim FSO
Dim folder
Dim file
Dim folderName
Dim fileType
' Set this to point at the folder you wish to import JPGs from
' Note: make sure this ends with a backslash \
fileType = ".jpg" ' <<< change this to the type you want
folderName = "c:\somedirectory\" ' <<< change this to the directory you want
' setup variables
Set presentation = Application.ActivePresentation
' choose the layout you want: e.g. if the title needs a particular format
Set layout = Application.ActivePresentation.SlideMaster.CustomLayouts(1)
Set FSO = CreateObject("Scripting.FileSystemObject")
' Retrieve the folder's file listing and process each file
Set folder = FSO.GetFolder(folderName)
For Each file In folder.Files
' Filter to only process JPG images
If LCase(Right(file.Name), 4)) = fileType Then
' Create the new slide and delete any pre-existing contents
Set slide = presentation.Slides.AddSlide(presentation.Slides.count + 1, layout)
While slide.Shapes.count > 0
slide.Shapes(1).Delete ' <<< You might not want to do this is you want to keep the title placeholder
Wend
' Add the picture
slide.Shapes.AddPicture folderName + file.Name, False, True, 10, 10
' Optional: create a textbox with the filename on the slide for reference
' alternatively, add text to the title shape
Dim textBox
Set textBox = slide.Shapes.AddTextbox(msoTextOrientationHorizontal, 10, 10, 200, 200)
textBox.TextFrame.TextRange.Text = file.Name ' <<< or whatever "title" you wanted
End If
Next
End Sub
You can modify this further to get the title in the format you want, etc.
you could try this:
Is there an example of using MATLAB to create PowerPoint slides?
For example:
% before the following, you have to create the ppt as explained, see link above!
% I prefer using some name instead of i or j
for img_ind = 1:numel(pngfiles)
% this depends on the ppt-version (see link above)-> here for 2007 and higher
mySlide = Presentation.Slides.Add(1,'ppLayoutBlank')
% Note: Change the image file full path names to where you save them
Image1 = mySlide.Shapes.AddPicture('<full path>\name_of_image(img_ind).png','msoFalse','msoTrue',100,20,500,500)
end
% then you have to save it, see link above!
In your case, I guess you have to save the image first as shown in the example:
print('-dpng','-r150','<full path>\test1.png')
edit
This will only work when using Matlab on Windows, because COM is needed. See comments on Floris answer!
Coming late to this party: Here's a "Matlab Pick of the Week" tool:
http://www.mathworks.com/matlabcentral/fileexchange/30124-smart-powerpoint-exporter
Take note of some of the comments at that page, as apparently the tool has not been updated in a few years.

Using VBA to change Picture

I am trying to use VBA to automate the Change Picture function when you right click a Shape in Excel/Word/Powerpoint.
However, I am not able to find any reference, can you assist?
So far as I know you can't change the source of a picture, you need to delete the old one and insert a new one
Here's a start
strPic ="Picture Name"
Set shp = ws.Shapes(strPic)
'Capture properties of exisitng picture such as location and size
With shp
t = .Top
l = .Left
h = .Height
w = .Width
End With
ws.Shapes(strPic).Delete
Set shp = ws.Shapes.AddPicture("Y:\our\Picture\Path\And\File.Name", msoFalse, msoTrue, l, t, w, h)
shp.Name = strPic
shp.ScaleHeight Factor:=1, RelativeToOriginalSize:=msoTrue
shp.ScaleWidth Factor:=1, RelativeToOriginalSize:=msoTrue
You can change the source of a picture using the UserPicture method as applied to a rectangle shape. However, you will need to resize the rectangle accordingly if you wish to maintain the picture's original aspect ratio, as the picture will take the dimensions of the rectangle.
As an example:
ActivePresentation.Slides(2).Shapes(shapeId).Fill.UserPicture ("C:\image.png")
'change picture without change image size
Sub change_picture()
strPic = "Picture 1"
Set shp = Worksheets(1).Shapes(strPic)
'Capture properties of exisitng picture such as location and size
With shp
t = .Top
l = .Left
h = .Height
w = .Width
End With
Worksheets(1).Shapes(strPic).Delete
Set shp = Worksheets(1).Shapes.AddPicture("d:\pic\1.png", msoFalse, msoTrue, l, t, w, h)
shp.Name = strPic
End Sub
what I do is lay both images on top of eachother, and assign the macro below to both images. Obviously i've named the images "lighton" and "lightoff", so make sure you change that to your images.
Sub lightonoff()
If ActiveSheet.Shapes.Range(Array("lighton")).Visible = False Then
ActiveSheet.Shapes.Range(Array("lighton")).Visible = True
Else
ActiveSheet.Shapes.Range(Array("lighton")).Visible = False
End If
End Sub
What I've done in the past is create several image controls on the form and lay them on top of each other. Then you programmatically set all images .visible = false except the one you want to show.
In Word 2010 VBA it helps to change the .visible option for that picture element you want to change.
set the .visible to false
change the picture
set the .visilbe to true
that worked for me.
I tried to imitate the original function of 'Change Picture' with VBA in PowerPoinT(PPT)
The code below tries to recover following properties of the original picture:
- .Left, .Top, .Width, .Height
- zOrder
- Shape Name
- HyperLink/ Action Settings
- Animation Effects
Option Explicit
Sub ChangePicture()
Dim sld As Slide
Dim pic As Shape, shp As Shape
Dim x As Single, y As Single, w As Single, h As Single
Dim PrevName As String
Dim z As Long
Dim actions As ActionSettings
Dim HasAnim As Boolean
Dim PictureFile As String
Dim i As Long
On Error GoTo ErrExit:
If ActiveWindow.Selection.Type <> ppSelectionShapes Then MsgBox "Select a picture first": Exit Sub
Set pic = ActiveWindow.Selection.ShapeRange(1)
On Error GoTo 0
'Open FileDialog
With Application.FileDialog(msoFileDialogFilePicker)
.AllowMultiSelect = False
.Filters.Clear
.Filters.Add "Picture File", "*.emf;*.jpg;*.png;*.gif;*.bmp"
.InitialFileName = ActivePresentation.Path & "\"
If .Show Then PictureFile = .SelectedItems(1) Else Exit Sub
End With
'save some properties of the original picture
x = pic.Left
y = pic.Top
w = pic.Width
h = pic.Height
PrevName = pic.Name
z = pic.ZOrderPosition
Set actions = pic.ActionSettings 'Hyperlink and action settings
Set sld = pic.Parent
If Not sld.TimeLine.MainSequence.FindFirstAnimationFor(pic) Is Nothing Then
pic.PickupAnimation 'animation effect <- only supported in ver 2010 above
HasAnim = True
End If
'insert new picture on the slide
Set shp = sld.Shapes.AddPicture(PictureFile, False, True, x, y)
'recover original property
With shp
.Name = "Copied_ " & PrevName
.LockAspectRatio = False
.Width = w
.Height = h
If HasAnim Then .ApplyAnimation 'recover animation effects
'recover shape order
.ZOrder msoSendToBack
While .ZOrderPosition < z
.ZOrder msoBringForward
Wend
'recover actions
For i = 1 To actions.Count
.ActionSettings(i).action = actions(i).action
.ActionSettings(i).Run = actions(i).Run
.ActionSettings(i).Hyperlink.Address = actions(i).Hyperlink.Address
.ActionSettings(i).Hyperlink.SubAddress = actions(i).Hyperlink.SubAddress
Next i
End With
'delete the old one
pic.Delete
shp.Name = Mid(shp.Name, 8) 'recover name
ErrExit:
Set shp = Nothing
Set pic = Nothing
Set sld = Nothing
End Sub
How to use:
I suggest you to add this macro into the Quick Access Toolbar list.
(Goto Option or Right-click on the Ribbon menu))
First, select a Picture on the slide which you want to change.
Then, if the FileDialog window opens, choose a new picture.
It's done. By using this method, you can bypass the 'Bing Search and One-Drive Window' in ver 2016 when you want to change a picture.
In the code, there might(or should) be some mistakes or something missing.
I'd appreciate it if somebody or any moderator correct those errors in the code.
But mostly, I found that it works fine.
Also, I admit that there are still more properties of the original shape to recover - like the line property of the shape, transparency, pictureformat and so on.
I think this can be a beginning for people who want to duplicate those TOO MANY properties of a shape.
I hope this is helpful to somebody.
i use this code :
Sub changePic(oshp As shape)
Dim osld As Slide
Set osld = oshp.Parent
osld.Shapes("ltkGambar").Fill.UserPicture (ActivePresentation.Path & "\" & oshp.Name & ".png")
End Sub
I'm working in Excel and VBA. I can't overlay images because I have multiple sheets of a variable number and each sheet has the images, so the file would get huge if, say 20 sheets had all 5 images I want to animate.
So I used a combination of these tricks listed here:
1) I inserted an RECTANGLE shape at the location and size I wanted:
ActiveSheet.Shapes.AddShape(msoShapeRectangle, 1024#, 512#, 186#, 130#).Select
Selection.Name = "SCOTS_WIZARD"
With Selection.ShapeRange.Fill
.Visible = msoTrue
.UserPicture "G:\Users\ScotLouis\Documents\My Spreadsheets\WordFind Wizard\WordFind Wizard 1.jpg"
.TextureTile = msoFalse
End With
2) Now to animate (change) the picture, I only need to change the Shape.Fill.UserPicture:
ActiveSheet.Shapes("SCOTS_WIZARD").Fill.UserPicture _
"G:\Users\ScotLouis\Documents\My Spreadsheets\WordFind Wizard\WordFind Wizard 2.jpg"
So I've accomplished my goal of only having 1 picture per sheet (not 5 as in my animation) and duplicating the sheet only duplicates the active picture, so the animation continues seamlessly with the next picture.
![Please find attached code.
First create a shape in PPT and run the code]1

How to call a visio macro from a stencil

i have written some Macros for Visio. Now I copied these to a Stencil called Macros.vss
How can I call my Macros now?
It all depends on what the macros do and how you'd like to call them. I'm going to assume they're simply macros that will execute something within the active Visio page.
By default in Visio VBA, any public subs with no arguments get added to the Visio Tools->Macros menu, in a folder named by the document holding the macros (in this case Macros) and then separated into folders by module name. If you're the only person using the macros then you probably don't need to do anything else.
However, since you put them in a vss file I'll assume you'd like to distribute them to other people.
There's something funny (and by funny I mean irritating) about Visio and how toolbars and buttons work, when added programmatically. Unfortunately, when you create a toolbar using the UIObject and Toolbar and ToolbarItem classes, Visio is going to assume the code you're calling resides in the active drawing, and cannot be in a stencil. So I can give you a little guidance on using those classes, but basically it consists of distributing a .vst template along with your .vss files, with just a single required sub in the .vst file.
So, instead of using a custom toolbar, you can attach code to shape masters in your .vss file that execute the code when they get dropped on a drawing document (using CALLTHIS and the EventDrop event in the shapesheet). With this method I just have a sub that gets called using callthis that takes a shape object as an argument, executes some code, then deletes the shape (if I don't want it around anymore).
And lastly, you can manipulate the Visio UI programmatically to add a toolbar and buttons for your macros. Below is some sample code, basically the way I do it with a solution I developed. As I mentioned above, the most important part of using this method is to have a document template (.vst) that holds a sub (with the below code it must be named RunStencilMacro) that takes a string as an argument. This string should be the "DocumentName.ModuleName.SubName". This sub must take the DocumentName out of the string, and get a Document object handle to that document. Then it must do ExecuteLine on that document with the ModuleName.SubName portion. You'll have to step through the code and figure some things out, but once you get the hang of what's going on it should make sense.
I'm not sure of any other ways to execute the macros interactively with VBA. I think exe and COM addons may not have this issue with toolbars...
Private Sub ExampleUI()
Dim UI As Visio.UIObject
Dim ToolbarSet As Visio.ToolbarSet
Dim Toolbars As Visio.Toolbars
Dim Toolbar As Visio.Toolbar
Dim ToolbarItems As Visio.ToolbarItems
Dim ToolbarItem As Visio.ToolbarItem
Dim TotalToolBars As Integer
Dim Toolbarpos As Integer
Const ToolbarName = "My Toolbar"
' Get the UIObject object for the toolbars.
If Visio.Application.CustomToolbars Is Nothing Then
If Visio.ActiveDocument.CustomToolbars Is Nothing Then
Set UI = Visio.Application.BuiltInToolbars(0)
Else
Set UI = Visio.ActiveDocument.CustomToolbars
End If
Else
Set UI = Visio.Application.CustomToolbars
End If
Set ToolbarSet = UI.ToolbarSets.ItemAtID(visUIObjSetDrawing)
' Delete toolbar if it exists already
TotalToolBars = ToolbarSet.Toolbars.Count
For i = 1 To TotalToolBars
Set Toolbar = ToolbarSet.Toolbars.Item(i - 1)
If Toolbar.Caption = ToolbarName Then
Toolbar.Visible = False
Toolbar.Delete
Exit For
End If
Next
' create toolbar
Set Toolbar = ToolbarSet.Toolbars.Add
Toolbar.Caption = ToolbarName
Dim IconPos As Long ' counter to determine where to put a button in the toolbar
IconPos = IconPos + 1
Dim IconFunction As String
IconFunction = """Macros.Module1.SubName"""
Set ToolbarItem = Toolbar.ToolbarItems.AddAt(IconPos)
With ToolbarItem
.AddOnName = "RunStencilMacro """ & IconFunction & """"
.Caption = "Button 1"
.CntrlType = Visio.visCtrlTypeBUTTON
.Enabled = True
.state = Visio.visButtonUp
.Style = Visio.visButtonIcon
.Visible = True
.IconFileName ("16x16IconFullFilePath.ico")
End With
' Now establish the position of this toolbar
With Toolbar
.Position = visBarTop 'Top overall docking area
.Left = 0 'Puts it x pixels from the left
.RowIndex = 13
.Protection = visBarNoCustomize
Toolbar.Enabled = True
.Visible = True
End With
Visio.Application.SetCustomToolbars UI
Visio.ActiveDocument.SetCustomToolbars UI
End Sub

Run VBA on any PowerPoint to change the LanguageID

I'm trying to create a toolbar with a button that will change the LanguageID for all shapes and text boxes in a PowerPoint document to EnglishUS. This is to fix a problem where if someone spell-checks a document using another language (in this instance, French), that language is embedded into the .ppt file itself. When another user tries to spell-check the same area using another language, say English, the words the spell checker suggests are in the original language. For instance, it tried to correct the word 'specified' to 'specifie', a French word. From what I've read, the only way to fix this language issue is with a VBscript, and the only way to run a VBscript in Powerpoint without embedding it into a .ppt and loading that file every time is by creating an add-in with a toolbar button to run the macro, also using VBS. Below is the code which I've taken from various sources, and when I tried to put it together, it didn't work (although it did compile). If someone could take a look, I'm sure its a simple syntax error or something like that, it would be a HUGE help. Thanks in advance!!
By the way if anyone knows an easier way to run a macro in PPT without having to open a certain PPT every time, I'm ALL ears.
and now, the script:
Sub Auto_Open()
Dim oToolbar As CommandBar
Dim oButton As CommandBarButton
Dim MyToolbar As String
''# Give the toolbar a name
MyToolbar = "Fix Language"
On Error Resume Next
''# so that it doesn't stop on the next line if the toolbar's already there
''# Create the toolbar; PowerPoint will error if it already exists
Set oToolbar = CommandBars.Add(Name:=MyToolbar, _
Position:=msoBarFloating, Temporary:=True)
If Err.Number <> 0 Then
''# The toolbar's already there, so we have nothing to do
Exit Sub
End If
On Error GoTo ErrorHandler
''# Now add a button to the new toolbar
Set oButton = oToolbar.Controls.Add(Type:=msoControlButton)
''# And set some of the button's properties
With oButton
.DescriptionText = "Fix Language for Spell Check"
''# Tooltip text when mouse if placed over button
.Caption = "Click to Run Script"
''# Text if Text in Icon is chosen
.OnAction = "Button1"
''# Runs the Sub Button1() code when clicked
.Style = msoButtonIcon
''# Button displays as icon, not text or both
.FaceId = 59
End With
''# Repeat the above for as many more buttons as you need to add
''# Be sure to change the .OnAction property at least for each new button
''# You can set the toolbar position and visibility here if you like
''# By default, it'll be visible when created
oToolbar.Top = 150
oToolbar.Left = 150
oToolbar.Visible = True
NormalExit:
Exit Sub ''# so it doesn't go on to run the errorhandler code
ErrorHandler:
''# Just in case there is an error
MsgBox Err.Number & vbCrLf & Err.Description
Resume NormalExit:
End Sub
Sub Button1()
''# This is the code to replace the LanguageID throughout the ppt
Option Explicit
Public Sub ChangeSpellCheckingLanguage()
Dim j As Integer, k As Integer, scount As Integer, fcount As Integer
scount = ActivePresentation.Slides.Count
For j = 1 To scount
fcount = ActivePresentation.Slides(j).Shapes.Count
For k = 1 To fcount
If ActivePresentation.Slides(j).Shapes(k).HasTextFrame Then
ActivePresentation.Slides(j).Shapes(k) _
.TextFrame.TextRange.LanguageID = msoLanguageIDEnglishUS
End If
Next k
Next j
End Sub
End Sub
The answer is quite obvious if it is not clear yet.
As you can see the sub Button1() encapsulates another sub. Thus, I advise you to remove the call ChangeSpellingCheckingLanguage and the last End sub, then your code will work.
This may be an incredibly late answer, but I just solved this problem using VBScript (which can be run outside of powerpoint). The script as written will change the language of each powerpoint file in a given directory (and subdirectories) to English. Here's the script:
Option Explicit
'microsoft office constants
Const msoTrue = -1
Const msoFalse = 0
Const msoLanguageIDEnglishUS = 1033
Const msoGroup = 6
'starting folder (current folder)
Const START_FOLDER = ".\"
'valid powerpoint file extensions
Dim FILE_EXTENSIONS : FILE_EXTENSIONS = Array("pptx", "pptm", "ppt", "potx", "potm", "pot")
'desired language for all Text
Dim DESIRED_LANGUAGE : DESIRED_LANGUAGE = msoLanguageIDEnglishUS
'VBScript file system objects for starting folder
Dim objFSO : Set objFSO = CreateObject("Scripting.FileSystemObject")
Dim objStartingFolder : Set objStartingFolder = objFSO.GetFolder(START_FOLDER)
IterateContainingItems objStartingFolder
'recursive subroutine to iterate each file in specified folder and all subfolders
Sub IterateContainingItems(objCurrentFolder)
Dim colFiles : Set colFiles = objCurrentFolder.Files
Dim objCurrentFile
For Each objCurrentFile in colFiles
ReportInfo(objCurrentFile)
Next
Dim colFolders : Set colFolders = objCurrentFolder.SubFolders
Dim objNextFolder
For Each objNextFolder in colFolders
IterateContainingItems objNextFolder
Next
End Sub
'subroutine executed for every file iterated by IterateContainingItems subroutine
Sub ReportInfo(objCurrentFile)
Dim strPathToFile
strPathToFile = objFSO.GetAbsolutePathName(objCurrentFile.Path)
If isPowerpointFile(strPathToFile) Then
Dim objPowerpointApp, objPresentations, objPresentation, objSlides, intSlideCount
set objPowerpointApp = CreateObject("Powerpoint.Application")
set objPresentations = objPowerpointApp.Presentations
Set objPresentation = objPresentations.Open(strPathToFile, msoFalse, msoFalse, msoFalse)
Set objSlides = objPresentation.Slides
intSlideCount = objSlides.Count
ResetLanguage objPresentation
objPresentation.Save
objPresentation.Close
objPowerpointApp.Quit
End If
End Sub
'check if given filepath specifies a powerpoint file as described by the "constant" extension array
Function isPowerpointFile(strFilePath)
Dim strExtension, found, i
strExtension = objFSO.GetExtensionName(strFilePath)
found = false
for i = 0 to ubound(FILE_EXTENSIONS)
if FILE_EXTENSIONS(i) = strExtension then
found = true
exit for
end if
next
isPowerpointFile = found
End Function
'finds every shape in the entire document and attempts to reset its LanguageID
Sub ResetLanguage(objCurrentPresentation)
Dim objShape
'change shapes from presentation-wide masters
If objCurrentPresentation.HasHandoutMaster Then
For Each objShape in objCurrentPresentation.HandoutMaster.Shapes
ChangeLanguage objShape
Next
End If
If objCurrentPresentation.HasNotesMaster Then
For Each objShape in objCurrentPresentation.NotesMaster.Shapes
ChangeLanguage objShape
Next
End If
If objCurrentPresentation.HasTitleMaster = msoTrue Then
For Each objShape in objCurrentPresentation.TitleMaster.Shapes
ChangeLanguage objShape
Next
End If
'change shapes from each design's master
Dim tempDesign
For Each tempDesign in objCurrentPresentation.Designs
For Each objShape in tempDesign.SlideMaster.Shapes
ChangeLanguage objShape
Next
Next
'change shapes from each slide
Dim tempSlide
For Each tempSlide in objCurrentPresentation.Slides
For Each objShape in tempSlide.Shapes
ChangeLanguage objShape
Next
If tempSlide.hasNotesPage Then
For Each objShape in tempSlide.NotesPage.Shapes
ChangeLanguage objShape
Next
End If
Next
End Sub
'if the given shape contains a text element, it checks and corrects the LanguageID
'if the given shape is a group, it iterates through each element in the group
Sub ChangeLanguage(objShape)
If objShape.Type = msoGroup Then
Dim objShapeGroup : Set objShapeGroup = objShape.GroupItems
Dim objShapeChild
For Each objShapeChild in objShapeGroup
ChangeLanguage objShapeChild
Next
Else
If objShape.HasTextFrame Then
Dim intOrigLanguage : intOrigLanguage = objShape.TextFrame.TextRange.LanguageID
If Not intOrigLanguage = DESIRED_LANGUAGE Then
If objShape.TextFrame.TextRange.Length = 0 Then
objShape.TextFrame.TextRange.Text = "[PLACEHOLDER_TEXT_TO_DELETE]"
End If
objShape.TextFrame.TextRange.LanguageID = DESIRED_LANGUAGE
If objShape.TextFrame.TextRange.Text = "[PLACEHOLDER_TEXT_TO_DELETE]" Then
objShape.TextFrame.TextRange.Text = ""
End If
End If
End If
End If
End Sub
To run it, just copy and paste the code into a text editor and save it as "script_name.vbs" in the directory with your powerpoint files. Run it by double clicking the script and waiting.
To load a macro every time PowerPoint is opened, you will want to create a PowerPoint AddIn. Microsoft has provided step-by-step guide for Office XP. For Office 2007 and newer, AFAIK the following steps will do that:
Save file as *.ppam into the directory it suggests (%APPDATA%\Microsoft\AddIns)
Open the Settings (click the office button in the top left corner and select "PowerPoint Options"), select the "Add-Ins" page, choose "PowerPoint Add-Ins" in the drop-down behind "Manage" and click the "Go" button. A dialog opens. Selecting "Add New" brings up a file picker dialog. You should be able to select the file there.
You can also use the Office Custom UI Editor to create ribbons.
However, I have already created such a Language Fixer Add-In for current versions of PowerPoint, and I have put it up for free download for personal use: PowerPoint Language Fixer by Jan Schejbal

Resources