Rectification in VBA Script
Dear VBA Experts,
Attached VBA script is being used by me to import images and their information in PPT from a folder, currently its importing one image per slide with related information in PPT.
In the text file from where data (products information's)is being fetched in ppt I have only one path for each product, here i need to import two images per slide for each product. The second images path I can put in the next column of the existing path.
Size dimension for both the images will be different, kindly make the rectification in the attached VBA script as per my requirement.
Any help will be highly appreciated.
Please help.
| Attachment | Size |
|---|---|
| VBA Script.txt | 2.49 KB |
| Product Presentation.jpg | 57.27 KB |
RE: Rectification in VBA Script
Hello,
Try this subroutine:
' ****************************** ' ****************************** '
Sub MySubroutine()
Const ChangeToPixels As Double = (635 / 24)
Dim strPath As String
Dim strFileName As String
Dim strFilePath As String
Dim oFileSystem As FileSystemObject
Dim oFile As TextStream
Dim aProductData() As String
Dim ImageCount As Byte
Dim sngSlideWidth As Single
Dim sngSlideHeight As Single
Dim oSlide As Slide
Dim sngMaxWidth As Single
Dim sngMaxHeight As Single
Dim i As Byte
Dim sngLeft As Single
Dim sngTop As Single
Dim oImageFile As IPictureDisp
Dim sngWidth As Single
Dim sngHeight As Single
Dim oImageShape As Shape
Dim oTextBox As Shape
Dim strProductData As String
On Error GoTo ERROR_HANDLER
' ****************************** ' ****************************** '
' Here can change code to get file name if there is more than one
' ****************************** ' ****************************** '
strPath = ActivePresentation.Path
strFileName = "book1.txt"
strFilePath = strPath & "\" & strFileName
' ****************************** ' ****************************** '
Set oFileSystem = CreateObject("Scripting.FileSystemObject")
Set oFile = oFileSystem.OpenTextFile(strFilePath)
' ****************************** ' ****************************** '
' Comment/Uncomment desired image count or add code for dynamic change
' ****************************** ' ****************************** '
'ImageCount = 1
ImageCount = 2
' ****************************** ' ****************************** '
With ActivePresentation.PageSetup
sngSlideWidth = .SlideWidth
sngSlideHeight = .SlideHeight
End With
Do Until oFile.AtEndOfStream
aProductData = Split(oFile.ReadLine, Chr(9))
Set oSlide = ActivePresentation.Slides.Add( _
ActivePresentation.Slides.Count + 1, ppLayoutBlank)
' ****************************** ' ****************************** '
' Images
' ****************************** ' ****************************** '
sngMaxWidth = (sngSlideWidth - (10 * (ImageCount + 1))) / ImageCount
sngMaxHeight = sngSlideHeight / 2 ' Change if necessary
For i = 0 To (ImageCount - 1)
sngLeft = 10 + ((sngMaxWidth + 10) * i)
sngTop = 10 ' Change if necessary
Set oImageFile = LoadPicture(aProductData(i))
With oImageFile
sngWidth = .Width / ChangeToPixels
sngHeight = .Height / ChangeToPixels
End With
Set oImageShape = oSlide.Shapes.AddPicture( _
FileName:=aProductData(i), _
LinkToFile:=msoFalse, _
SaveWithDocument:=msoTrue, _
Left:=sngLeft, _
Top:=sngTop, _
Width:=sngWidth, _
Height:=sngHeight)
With oImageShape
.LockAspectRatio = msoTrue
.Width = sngMaxWidth
If .Height > sngMaxHeight Then
.Height = sngMaxHeight
End If
End With
Next i
' ****************************** ' ****************************** '
' ****************************** ' ****************************** '
' First Text Box
' ****************************** ' ****************************** '
sngLeft = 10 ' Change if necessary
sngTop = 20 + (sngSlideHeight / 2) ' Change if necessary
sngWidth = sngSlideWidth - 20 ' Change if necessary
sngHeight = 200 ' Change if necessary
Set oTextBox = oSlide.Shapes.AddTextbox( _
Orientation:=msoTextOrientationHorizontal, _
Left:=sngLeft, _
Top:=sngTop, _
Width:=sngWidth, _
Height:=sngHeight)
strProductData = ""
For i = ImageCount To (UBound(aProductData) - 1)
strProductData = strProductData & Chr(13) & aProductData(i)
Next i
strProductData = Right(strProductData, Len(strProductData) - 1)
oTextBox.TextFrame.TextRange.Text = strProductData
' ****************************** ' ****************************** '
' ****************************** ' ****************************** '
' Second Text Box
' ****************************** ' ****************************** '
sngLeft = 0 ' Change if necessary
sngTop = 30 + (sngSlideHeight / 2) + oTextBox.Height ' Change if necessary
sngWidth = sngSlideWidth ' Change if necessary
sngHeight = 40 ' Change if necessary
Set oTextBox = oSlide.Shapes.AddTextbox( _
Orientation:=msoTextOrientationHorizontal, _
Left:=sngLeft, _
Top:=sngTop, _
Width:=sngWidth, _
Height:=sngHeight)
oTextBox.TextFrame.TextRange.Text = aProductData(UBound(aProductData))
' ****************************** ' ****************************** '
Loop
EXIT_SUB:
Set oTextBox = Nothing
Set oImageShape = Nothing
Set oImageFile = Nothing
Set oSlide = Nothing
Set oFile = Nothing
Set oFileSystem = Nothing
Exit Sub
ERROR_HANDLER:
' Some code for error handling
GoTo EXIT_SUB
End Sub
' ****************************** ' ****************************** '
Best regards.
VBA Script
Thank a ton for your quick reply, I have incorporated the VBA script sent by you but it is not working as per my requirement.I am requesting you if you can make the rectification in my existing VBA code that will be great.
Sub ImportABunchWithTextFromFile()
Dim strTemp As String
Dim strPath As String
Dim strFileSpec As String
Dim oSld As Slide
Dim oPic As Shape
strPath = ActivePresentation.Path
Set fs = CreateObject("Scripting.FileSystemObject")
Set f = fs.OpenTextFile(strPath & "\book1.txt", 1, 0) 'book1.txt need to be "Text(Tab delimited)(*.txt)" when saved in Excel
Do While f.AtEndOfStream <> True
picDesc = Split(f.readline, Chr(9))
Set oSld = ActivePresentation.Slides.Add(ActivePresentation.Slides.Count + 1, ppLayoutBlank)
Set oPic = oSld.Shapes.AddPicture(FileName:=picDesc(0), _
LinkToFile:=msoFalse, _
SaveWithDocument:=msoTrue, _
Left:=0, _
Top:=0, _
Width:=0, _
Height:=0)
'next 4 lines define TextBox(TB) position and dimensions in terms of those of slide
TBLeftFromSlideLeft = 20 'this can be changed
TBTopFromSlideTop = 260 'this can be changed
TBWidth = 700 'this can be changed
TBHeight = 500 'this can be changed
Set oDes = oSld.Shapes.AddTextbox(msoTextOrientationHorizontal, _
TBLeftFromSlideLeft, _
TBTopFromSlideTop, _
TBWidth, _
TBHeight)
For a = 1 To 7
myText = myText & Chr(13) & picDesc(a)
Next
myText = Right(myText, Len(myText) - 1)
With oDes
.TextFrame.TextRange.Text = myText
End With
myText = ""
TBLeftFromSlideLeft = 0
TBTopFromSlideTop = 480
TBWidth = 700
TBHeight = 300
Set oDes = oSld.Shapes.AddTextbox(msoTextOrientationHorizontal, _
TBLeftFromSlideLeft, _
TBTopFromSlideTop, _
TBWidth, _
TBHeight)
For a = 9 To 9
myText = myText & Chr(13) & picDesc(a)
Next
myText = Right(myText, Len(myText) - 1)
With oDes
.TextFrame.TextRange.Text = myText
End With
myText = ""
With oPic
.ScaleHeight 1, msoTrue
.ScaleWidth 1, msoTrue
End With
With oPic
Dim appssw, appssh
'next 4 lines set the distance between the image display area margins and the slide margins, image display area width and height
imageTopFromSlideTop = 10 'this can be changed
imageLeftFromSlideLeft = 450 'this can be changed
maxImageWidth = 300 'this can be changed
maxImageHeight = 300 'this can be changed
appssw = maxImageWidth
appssh = maxImageHeight
.LockAspectRatio = msoTrue
If oPic.Width / oPic.Height > appssw / appssh Then
.Width = appssw
.Top = (appssh - oPic.Height) / 2 + imageTopFromSlideTop
.Left = imageLeftFromSlideLeft
Else
.Height = appssh
.Left = (appssw - oPic.Width) / 2 + imageLeftFromSlideLeft / 2
.Top = imageTopFromSlideTop
End If
End With
Set oPic = Nothing
Set oDes = Nothing
Set oSld = Nothing
Loop
Set f = Nothing
Set fs = Nothing
End Sub
RE: VBA Script
Maybe I can help you if I understand what exactly you need. My subroutine do the same slide as like as your attached example image, using data from text file looking that way:
D:\untitled1.jpg D:\untitled2.jpg Category: Sub Category: Type: Brand Name: SKU: Product Title: MRP: Product Description:
D:\untitled3.jpg D:\untitled4.jpg Category: Sub Category: Type: Brand Name: SKU: Product Title: MRP: Product Description:
...
...
My subroutine do the same like yours except that it make slide with two images, and that I rewrite it in the way I think it look more understandable.
If I miss something please provide me with more detailed explanation.
Best regards.
VBA Script
Thank you very much for your response, I would like to enplane my requirement in details so that you can help me.
I have a folder in C drive containing 30000 thousand product images renamed with its respective SKUs numbers (Model Numbers) & in another hand I have an excel file containing all the product information along with images path,images name is same as SKU number (Model Numbers).
As per my requirement I use to select data from excel file including images path and save it in text file named BOOK1 and put into the same folder (Images folder) after this activity i copy the VBA script (sent by me for rectification)& incorporate in the PPT macros. This is the activity through which I use to make the PPT in bulk.
A few days ago I got a requirement from my boss to have two images per slide for each and every SKUs ( Front images & back side images ) all these are books cover images.
I am having already front images of books cover in my master images folder renamed with SKU number (Model numbers) & now I have got all the back side images of books cover renamed as SKU number_1.jpg,where as the front images was renamed as SKU number.jpg.
With The existing VBA script I can change the position & images size dimension.
My requirement is if I put back side images path in the next to the front images path in the text file then it should come in ppt left to front images in same size dimension.
It required then I can send you the PPT ,images folder & the text file.
Kindly help me.
Regards
Santosh
RE: VBA Script
Thank you for that detailed and clear explanation.
As I see, I understand you correct at first time. And my next question to you is to explain me, when run my subroutine in your PPT, what exactly is not corresponding to your requirements. Maybe is a good idea to see your example PPT slide and TXT file, but instead of send me this files you can edit your current topic and reattach the files. Your choice.
One more thing. In your comment you write:
"... My requirement is if I put back side images path in the next to the front images path in the text file then it should come in ppt left to front images in same size dimension. ..."
From that I understand that you want back side image of the book to be on the left side of the slide and front side image of the book to be on the right side of the slide. If this is the thing that not corresponding to your requirements then put the back side images path to first column in your data file and the front side images path to the second, of course if this is not confused in any way your data.
I hope we are close to solve your problem...
Best regards.