Is there any way to access the size of a content control. In a Word document, I've added a Picture Content Control and resized it. In code, I delete the image and the content control automatically resizes. Is there way a to set the size in code? Is there a way to specify the default size of a Picture Content Control so that when there is no image, it uses that size?
contentField.range.InlineShapes.Item(1).Delete
I use this function to set the image and size of a content control image:
Private Function insertPicture(tgtDoc As Word.Document, varname As String, file As String, Optional picH As Double = -1)
Dim tcc As ContentControl, ccList As ContentControls
Set ccList = tgtDoc.SelectContentControlsByTitle(varname)
If ((varname <> "") And (Dir(file) <> "")) Then
For Each tcc In ccList
If tcc.Type = wdContentControlPicture Then
Debug.Print "inserting image from " & file
Dim picShape As InlineShape
Set picShape = tgtDoc.InlineShapes.AddPicture(file, True, True, tcc.Range)
picShape.LockAspectRatio = msoTrue
If picH > -1 Then
picShape.height = picH
End If
End If
Next tcc
Else
Debug.Print "No value set for " & varname
End If
End Function
Related
I am not a programmer so not sure what to do here. I would like an option of adding an image file in a Microsoft Word document userform for MAC. I had used a code earlier which works perfectly in Windows but it doesnt work for MAC and gives a 5948 error. I had added a field for the image in the userform with a button to add the image and the final submit button. The add button should allow the user to insert any size image from the local folder.
The code I was using is given below:
Dim ImagePath As String
Private Sub CMDAddImage_Click()
Dim objFileDialog As Office.FileDialog
Set objFileDialog = Application.FileDialog(MsoFileDialogType.msoFileDialogFilePicker)
With objFileDialog
.AllowMultiSelect = False
.ButtonName = "File Picker"
.Title = "File Picker"
If (.Show > 0) Then
End If
If (.SelectedItems.Count > 0) Then
Call MsgBox(.SelectedItems(1))
ImagePath = .SelectedItems(1)
End If
End With
Image1.Picture = LoadPicture(ImagePath)
End Sub
And the code in submit button was:
Dim objWord
Dim objDoc
Dim objShapes
Dim objSelection
'Set objSelection = ActiveDocument.Sections
'objSelection.TypeText (vbCrLf & "One Picture will be inserted here....")
ActiveDocument.Bookmarks("Field04").Select
Set objShapes = ActiveDocument.InlineShapes
objShapes.AddPicture (ImagePath)
End
End Sub
Can someone please help me edit the code for mac. In mac it does not allow to add the file.
You should check out the suggestion made by #JohnKorchok in a comment to your previous question - insert an image Content Control in your document instead, and throw away the VBA.
But if you need to keep using VBA and a UserForm...
Application.FileDialog is not available on Mac.
Application.GetOpenFileName is not avaialble from Word (it's an Excel thing).
Application.Dialogs does not do the same thing as GetOpenFileName so the user experience will be rather different, but at its simplest, you can use it like this:
With Application.Dialogs(wdDialogFileOpen)
' .Display = -1 for "OK" ("Open" in this case)
' .Display = 0 for "Cancel"
' (THere are other possible return values
' but I do not think they are applicable here)
If .Display = -1 Then
ImagePath = .Name
End If
End With
or if you prefer, the lengthier
Dim dlg As Word.Dialog
Set dlg = Application.Dialogs(wdDialogFileOpen)
With dlg
If .Display = -1 Then
ImagePath = .Name
End If
End With
Set dlg = Nothing
However, this dilaog does not let you specify file types or any kind of filtering, a starting folder etc. Attempts to set Finder search criteria via something like
.Name = "(_kMDItemFileName = ""*.jpg"")"
.Update
before the .Display either can't work or need different syntax.
Further, the Apple dialog may start with its
own filtering set up so the user will have to click Options to enable All Files. You don't know what file type the user will choose so you will need to deal with that.
An alternative is to invoke Applescript. For this, it appears that you can still use the VBA MacScript command, which means that you can put all the script in your VBA file. If that does not work, then unfortunately you have to use AppleScriptTask which would require you to work some more on the Script and install the script in the correct folder on every Mac where you need this feature.
Here's the code I used - you would probably need to wrap everything up in another function call and use conditional compilation or other tests to call the correct routine depending on whether the code is running on Mac or Windows
Private Sub CMDAddImage_Click()
Dim s As String
Dim sFileName As String
On Error Resume Next
s = ""
' set this to some other location as appropriate
s = s & "set thePictureFoldersPath to (path to pictures folder)" & vbNewLine
s = s & "set applescript's text item delimiters to "",""" & vbNewLine
s = s & "set theFile to ¬" & vbNewLine
' add the image file types you want here
s = s & "(choose file of type {""png"",""jpg""} ¬" & vbNewLine
s = s & "with prompt ""Choose an image to insert."" ¬" & vbNewLine
s = s & "default location alias thePictureFoldersPath ¬" & vbNewLine
s = s & "multiple selections allowed false) as string" & vbNewLine
s = s & "set applescript's text item delimiters to """"" & vbNewLine
' choose file gives as an AFS path name (with colon delimiters)
' get one Word 2016/2019 will work with
s = s & "posix path of theFile"
sFileName = MacScript(s)
If sFileName <> "" Then
' Maybe do some more validation here
ImagePath = sFileName
Image1.Picture = LoadPicture(ImagePath)
End If
End Sub
I'm completely new to macros and I'm trying to do the following:
Import all images from a folder on the harddrive into a Word file - each having its own page and being resized to fill the page (A4 portrait) while still keeping its ratio.
I already managed to do the "import" part with each image gettings its own page with this code:
Sub BilderImport()
Dim Path As String
Dim Img As Object
Dim fs As Object
Dim f As Object
Dim fc As Object
Dim i As Integer
Dim fsize As Integer
Path = "C:\tmp"
Set fs = CreateObject("Scripting.FileSystemObject")
Set f = fs.GetFolder(Path)
Set ff = f.Files
i = 0
fsize = ff.Count
For Each Img In ff
If Right(Img.Name, 4) = ".bmp" Or Right(Img.Name, 4) = ".jpg" Or Right(Img.Name, 4) = ".gif" Or Right(Img.Name, 4) = ".png" Then
i = i + 1
Selection.InlineShapes.AddPicture FileName:=Img
Selection.InsertBreak Type:=wdLineBreak 'Add file name below every img
Selection.TypeText Text:=Img.Name
If i < fsize Then 'No line break after the last img
Selection.InsertBreak Type:=wdPageBreak 'Inserts line break after every img
End If
End If
Next
End Sub
A problem I've now come across: Word also adds a line break after every image and if an image is already pretty tall, this line break jumps to the next page, which adds an extra empty page because of the break I already add.
How do I prevent that or check for it?
Try:
Sub BilderImport()
Dim Path As String
Dim fs As Object
Dim ff As Variant
Dim Img As Variant
Dim i As Long
Dim fsize As Long
Path = "C:\tmp"
Set fs = CreateObject("Scripting.FileSystemObject")
Set ff = fs.GetFolder(Path).Files
i = 0
fsize = ff.Count
With ActiveDocument
For Each Img In ff
Select Case Right(Img.Name, 4)
Case ".bmp", ".jpg", ".gif", ".png"
i = i + 1
.Characters.Last.InlineShapes.AddPicture FileName:=Img
.Characters.Last.InsertBefore Chr(11) & Img.Name & Chr(12) End Select
Next
'No page break after last pic
.Characters.Last.Previous.Delete
End With
End Sub
There are two approaches how to solve it. I would prefer a combination of both:
If you are resizing the images, resize them just a bit smaller (accounting for the extra line break)
set the font size to 0 or 1 and set paragraph to tiny line height before adding the pictures
Depending on the image size, the second point would be enough.
There is the third possibility: You would have to check the page count before entering the image and after. But this would slow the whole macro down.
I have been tasked with building an automated powerpoint to show new employees during onboarding. I decided to use the text-to-speech function of PPT to narrate the show. I came to the realization that this would require code, so I searched and found some code to use. When I start it within VBA, it runs. However, when in presentation mode, it doesn't fire the code. After hours of searching, I can't seem to find what I've done wrong. Any help is greatly appreciated.
Function SpeakThis(myPhrase As String)
Dim oSpeaker As New SpeechLib.SpVoice
'Set speech properties
oSpeaker.Volume = 100 ' percent
oSpeaker.Rate = 0.1 ' multiplier
oSpeaker.SynchronousSpeakTimeout = 1
oSpeaker.AlertBoundary = SVEWordBoundary
If Not myPhrase = "" Then oSpeaker.Speak myPhrase, SVSFDefault
End Function
Sub OnSlideShowPageChange()
Dim text As String
Dim intSlide As Integer
intSlide = ActiveWindow.Selection.SlideRange.SlideIndex
text = ActivePresentation.Slides(intSlide).NotesPage.Shapes.Placeholders(2).TextFrame.TextRange.text
SpeakThis text
End Sub
To get the current slide index, you can use the following:
In Slide View mode: ActiveWindow.View.Slide.SlideIndex
In Slide Show mode: ActivePresentation.SlideShowWindow.View.Slide.SlideIndex
For this to work in presentation mode, change
intSlide = ActiveWindow.Selection.SlideRange.SlideIndex
to
intSlide = ActivePresentation.SlideShowWindow.View.Slide.SlideIndex
Note that this throws an error if not in presentation mode.
EDIT: In simplified form, you could also do this:
Sub OnSlideShowPageChange(ByVal Wn As SlideShowWindow)
SpeakThis Wn.View.Slide.NotesPage.Shapes.Placeholders(2).TextFrame.TextRange.text
End Sub
Here I introduce MY work-around which can meet what you want.
Actually, you can save above TTS sound into an .wav file
which can be inserted and played on entering each slide.
Since you want to play some narration sound on each slide,
I suggest you to convert all the notes into .wav files and insert them as normal audio effects.
To automate the process, I wrote some code.
First, to save each note in an .wav file (given the slide index)
'save the slide's note in a .wav file
'You need to add reference to 'Microsoft Speech Object Library' (*required*)
Function SaveTTSWav(idx As Long)
Const SAFT48kHz16BitStereo = 39
Const SSFMCreateForWrite = 3
Dim oSpeaker As New SpeechLib.SpVoice
Dim oStream As New SpeechLib.SpFileStream
oStream.Format.Type = SAFT48kHz16BitStereo
'filename to save: ex) note1.wav
oStream.Open ActivePresentation.Path & "\note" & idx & ".wav", SSFMCreateForWrite, False
oSpeaker.Volume = 100 '%
oSpeaker.Rate = 1 '1x speed
oSpeaker.SynchronousSpeakTimeout = 1
oSpeaker.AlertBoundary = SVEWordBoundary
Set oSpeaker.AudioOutputStream = oStream
oSpeaker.Speak ActivePresentation.Slides(idx).NotesPage.Shapes.Placeholders(2).TextFrame.TextRange.text, SVSFNLPSpeakPunc
oStream.Close
End Function
Then, Insert the 'note(X).wav' files in each slide and add animation effects to them:
'insert the .wav and make it play automatically
Function AddTTSMedia(idx As Long)
Dim sld As Slide
Dim shp As Shape
Dim eft As Effect
Dim wavfile As String
wavfile = ActivePresentation.Path & "\note" & idx & ".wav"
If Len(Dir(wavfile)) = 0 Then Exit Function
Set sld = ActivePresentation.Slides(idx)
Set shp = sld.Shapes.AddMediaObject2(wavfile, False, True, 0, 0, 20, 20)
'shp.Name = Mid(wavfile, InStrRev(wavfile, "\") + 1) '.wav filename
Set eft = sld.TimeLine.MainSequence.AddEffect(shp, msoAnimEffectMediaPlay, , msoAnimTriggerWithPrevious)
eft.MoveTo 1 'make it the first effect
With eft.EffectInformation.PlaySettings 'shp.AnimationSettings.PlaySettings
.HideWhileNotPlaying = True
.PauseAnimation = False
.PlayOnEntry = True
.StopAfterSlides = 1
End With
'Kill wavfile
End Function
Finally, make it happen on every slide:
Sub Add_TTS_Notes()
Dim sld As Slide
'Remove previously inserted note sounds
RemoveNoteWav
For Each sld In ActivePresentation.Slides
'save the note to an .wav file
SaveTTSWav sld.SlideIndex
'add the .wav file onto the slide
AddTTSMedia sld.SlideIndex
Next sld
'ActivePresentation.Save
End Sub
In addition, if you want to cancel and remove all note sounds from your presentation,
you can run the following code manually:
'remove all .wav media(s) in each slide
Sub RemoveNoteWav()
Dim sld As Slide
Dim i As Long
For Each sld In ActivePresentation.Slides
For i = sld.Shapes.Count To 1 Step -1
If sld.Shapes(i).Name Like "note*.wav" Then sld.Shapes(i).Delete
Next i
Next sld
End Sub
All you have to do is to copy all codes above onto your PPT's VBE editor and to run the main macro named "Add_TTS_Notes". It'll take some time to save some TTS sound files.
It will save the notes on all slides in .wav files, insert them on their slides and make them play automatically on each slide. After the job, you can remove VBA codes and save your ppt file as a .pptx or .ppsx which is more handy than a .pptm file since it doesn't require any security agreement.
I'm using PowerPoint 2016, and in my case, I've needed to modify Konahn's codes as below in SaveTTSWav function.
'Dim oSpeaker As New SpeechLib.SpVoice
Dim oSpeaker As Object Set
oSpeaker = CreateObject("SAPI.Spvoice")
&
'Dim oStream As New SpeechLib.SpFileStream
Dim oStream As Object Set
oStream = CreateObject("SAPI.SpFileStream")
I have tried a number of different solutions to trying to insert an image into a document template. I have had a couple successes but not with desired effects. Basically, I am just trying to insert an image at the top of a document above all other content. The image should at best move the rest of the content down the page, and not on top of anything.
With objDoc
Dim filePath As String = Path.Combine(appPath, fileName)
If Not filePath = "" Then
Dim img As Image = Image.FromFile(filePath)
Dim imgX As Integer = img.Width
Dim imgY As Integer = img.Height
'insert picture here
End If
End With
Replacing the comment above with the following, I have had success...sort of. The following will insert the image into the header. But the image will get scaled in very odd ways, regardless of defining the image parameters.
.PageSetup.DifferentFirstPageHeaderFooter = True
.Sections(1).Headers(Word.WdHeaderFooterIndex.wdHeaderFooterPrimary).Shapes.AddPicture(
FileName:=filePath,
LinkToFile:=False,
SaveWithDocument:=True,
Left:=0,
Top:=0,
Width:=imgX,
Height:=imgY
).ConvertToInlineShape()
The following will insert the image, underneath the header and on top of text. Trying to convert it to an inlineshape throws an exception. Giving the canvass a 0,0 start in this case ignores the template margins and puts the image to the left edge of the sheet. Even if I were to shift it to the right and get the text to shift down, it's still not desirable as there is too much white space at the top.
Dim objCanvas As Word.Shape = objWordApp.ActiveDocument.Shapes.AddCanvas(Left:=0, Top:=0, Width:=imgX, Height:=imgY)
objCanvas.CanvasItems.AddPicture(FileName:=filePath, LinkToFile:=False, SaveWithDocument:=True)
The rest of the following were attempts at what I found sifting through msdn and various other outlets. None of these show any image at all.
'.InlineShapes.AddPicture(filePath, Type.Missing, Type.Missing, Type.Missing)
'Dim objRng As Word.Range = .Range()
'objRng.InlineShapes.AddPicture(filePath)
'Dim objInlineShape As Word.InlineShape = objWordApp.Selection.InlineShapes.AddPicture(
' FileName:=filePath,
' LinkToFile:=False,
' SaveWithDocument:=True
')
'objInlineShape.LockAspectRatio = Microsoft.Office.Core.MsoTriState.msoTrue
'objInlineShape.Width = imgX
'objInlineShape.Height = imgY
'.Application.Selection.InlineShapes.AddPicture(filePath)
'Dim objRng As Word.Range = .Sections(1).Range()
'objRng.InlineShapes.AddPicture(filePath)
'
'Dim objInlineShape As Word.InlineShape = .InlineShapes.AddPicture(filePath)
'Dim objShape As Word.Shape = objInlineShape.ConvertToShape()
'objDoc.Bookmarks.Item("\startofdoc").Range.InlineShapes.AddPicture(filePath)
The document itself is just four tables with some formatting. What the heck am I doing wrong?
The following code is from one of my VB.Net add-ins.
rng = rng.Rows(1).Cells(1).Range
rng.Delete()
rng.Collapse(Word.WdCollapseDirection.wdCollapseEnd)
rng.InlineShapes.AddPicture(.SelectedItems(i))
It is adding an image into a table cell. The "SelectItems(i)" reference is to the image file that the user has selected from a msoFileDialogFilePicker function, and you can change that to any known file path for your image. I am posting it to show you an example of actual code.
Getting your image to the top of the document is as simple as setting the insert range to that location. This following code will do it.
Dim rng as Word.Range
rng = ActiveDocument.Content
rng.Collapse(Word.WdCollapseDirection.wdCollapseStart)
rng.InlineShapes.AddPicture(Your Path)
I am developing a script to format an Outlook template and send it by clicking on a button.
The main goal is to use Single Line Spacing and 0pt on After/Before Spacing, and to convert all the Content Controls (such as ComboBoxes) on my template to Text/String.
Sub FormatAndSend()
Dim CurrentMessage As Outlook.MailItem
If TypeName(Application.ActiveWindow) = "Inspector" Then
Set CurrentMessage = Application.ActiveWindow.CurrentItem
If CurrentMessage.To = "" Then
If CurrentMessage.CC = "" Then
If CurrentMessage.BCC = "" Then Exit Sub
End If
End If
CurrentMessage.HTMLBody = Replace(CurrentMessage.HTMLBody, vbCr, vbCrLf)
'Workaround to Remove Line Spacing (not working)
'&
'Convert Content Control selected values to String ...
CurrentMessage.Send
Set CurrentMessage = Nothing
End If
End Sub
Is there an easier way to format the existing template? I have tried already several things, such as replacing with ASCII chars, HTML elements, keywords, ...
Also, is it possible to convert Content Control selected values to normal text?
I managed to get my problem solved by using regex to remove the OOXML elements and by changing the CSS properties.
Dim regX As Object
Set regX = CreateObject("VBScript.RegExp")
regX.Global = True
regX.MultiLine = True
regX.IgnoreCase = False
regX.Pattern = "<\/?w:[A-z].*?>"
CurrentMessage.HTMLBody = regX.Replace(CurrentMessage.HTMLBody, "")
CurrentMessage.HTMLBody = Replace(CurrentMessage.HTMLBody, "<p class=MsoNormal>", _
& "<p class=MsoNormal style='margin:0;line-height:0;'>")
Set regX = Nothing