Tạo slide và insert image vào slide từ excel

Euler

Mod
Thành viên BQT
Input:
File excel như thế này.
Bạn cần đăng nhập để thấy hình ảnh


Và file powerpoint trên đó có shape1.
Bạn cần đăng nhập để thấy hình ảnh


Output:
Chụp ảnh trên excel từ [B6:AF25] tạo ra ảnh 1.jpg (tên tùy ý)
Dán ảnh này vào trang slide theo thứ tự zoom size như sau.
Bạn cần đăng nhập để thấy hình ảnh


Các chủ đề liên quan:
 

vbano1

SMod
Thành viên BQT
Step 1:
VBA Range convert to image
Mã:
Sub SelectedRangeToImage()
    Dim tmpChart As Chart, n As Long, shCount As Long, sht As Worksheet, sh As Shape
    Dim fileSaveName As Variant, pic As Variant
    Dim myFn As String
    
    myFn = ThisWorkbook.Path & Application.PathSeparator & "1.jpg"
    'Create temporary chart as canvas
    Set sht = ThisWorkbook.Sheets(1)
    ThisWorkbook.Sheets(1).Range("B6:AF25").Select
    Selection.Copy
    sht.Pictures.Paste.Select
    Set sh = sht.Shapes(sht.Shapes.Count)
    Set tmpChart = Charts.Add
    tmpChart.ChartArea.Clear
    tmpChart.Name = "PicChart" & (Rnd() * 10000)
    Set tmpChart = tmpChart.Location(Where:=xlLocationAsObject, Name:=sht.Name)
    tmpChart.ChartArea.Width = sh.Width
    tmpChart.ChartArea.Height = sh.Height
    tmpChart.Parent.Border.LineStyle = 0
    'Paste range as image to chart
    sh.Copy
    tmpChart.ChartArea.Select
    tmpChart.Paste
    'Save chart image to file
    'fileSaveName = Application.GetSaveAsFilename(fileFilter:="Image (*.jpg), *.jpg")
    'If fileSaveName <> False Then
      'tmpChart.Export Filename:=fileSaveName, FilterName:="jpg"
       tmpChart.Export myFn
    'End If
    'Clean up
    sht.Cells(1, 1).Activate
    sht.ChartObjects(sht.ChartObjects.Count).Delete
    sh.Delete
End Sub
Tham khảo:

Về yêu cầu zoom ảnh, zoom theo đường chéo, sẽ có hai trường hợp, gặp cạnh dưới như hình ở bài 1. Trường hợp còn lại là gặp cạnh bên như hình dưới đây.
Bạn cần đăng nhập để thấy hình ảnh
 

tuhocvba

Administrator
Thành viên BQT
Step 2: Nghiên cứu chèn ảnh vào slide.
Ở code này, nó tạo ra một file slide mới và chèn bức ảnh đã tồn tại vào slide, đặt ở vị trí được chỉ định.
Để chạy code, yêu cầu thiết định thư viện cho Excel: Vào Tools -> References...
Bạn cần đăng nhập để thấy hình ảnh

Mã:
Public Sub InsertPic()
Dim applPP As PowerPoint.Application, prsntPP As PowerPoint.Presentation, TitlePage As PowerPoint.Slide

    Set applPP = New PowerPoint.Application
    applPP.Visible = True
    Set prsntPP = applPP.Presentations.Add
    Set TitlePage = prsntPP.Slides.Add(Index:=1, Layout:=ppLayoutTitle)  'ppLayoutBlank: sẽ cho slide trắng
    prsntPP.SaveAs ("D:\VBA\vidu.pptx")

        Dim oSlide As PowerPoint.Slide
        Dim oPicture As PowerPoint.Shape

        Set oSlide = prsntPP.Slides(1)

       Set oPicture = oSlide.Shapes.AddPicture("D:\VBA\1.jpg", _
            msoFalse, msoTrue, 1, 2, 200, 300)
        'Doan code tren da thiet dinh buc anh  duoc dat trong mot khung co chieu rong 200, chieu cao 300
        'Doan code duoi day tra ve kich thuoc thuc cua anh voi do zoom 0.9
        oPicture.ScaleHeight 0.9, msoTrue
        oPicture.ScaleWidth 0.9, msoTrue
       
       'Doan code nay dat lai vi tri anh, kich thuoc toi mep trai cua slide va kich thuoc toi mep tren cua slide
        With prsntPP.PageSetup
            oPicture.Left = (.SlideWidth \ 2) - (oPicture.Width \ 2)
            oPicture.Top = (.SlideHeight \ 2) - (oPicture.Height \ 2)
        End With
End Sub
Kết quả sẽ được file slide có tên là vidu.pptx có nội dung như sau:
Bạn cần đăng nhập để thấy hình ảnh

Với thông số Layout:=ppLayoutBlank, ta sẽ được kết quả như sau:
Bạn cần đăng nhập để thấy hình ảnh

Các thông số Left, Top được diễn giải theo như sau:
Bạn cần đăng nhập để thấy hình ảnh

Các thông số của phương thức AddPicture thực sự không hiểu lắm, tham khảo thêm ở đây:
Mã:
https://docs.microsoft.com/en-us/office/vba/api/powerpoint.shapes.addpicture
Đoạn code trên được tham khảo từ đây-vốn dĩ không chạy được, sau khi sửa thông số 200,300 như code trên thì đã chạy được:
Mã:
https://stackoverflow.com/questions/31653192/how-to-add-a-picture-to-a-powerpoint-slide-from-excel
Một bài viết hay về các bước tạo slide:
Mã:
https://answers.microsoft.com/en-us/msoffice/forum/all/vba-to-remove-title-box/46e88656-03e0-4dc7-8c38-7ce91cc8b874
Mã:
'Step 1:  Declare your variables
Dim pp As PowerPoint.Application
Dim ppPres As PowerPoint.Presentation
Dim PPSlide As PowerPoint.Slide
Dim xlwksht As Excel.Worksheet
Dim MyRange As String
   Dim MyTitle As String


  
'Step 2: Open PowerPoint, add a new presentation and make visible
Set pp = New PowerPoint.Application
Set ppPres = pp.Presentations.Add
pp.Visible = True

'Step 3: Set the ranges for your data and title
MyRange = "A1:R64"

'Step 4: Start the loop through each worksheet
For Each xlwksht In ActiveWorkbook.Worksheets



'Step 5:  Copy the range as picture
xlwksht.Range(MyRange).CopyPicture _
Appearance:=xlScreen, Format:=xlPicture

'Step 6: Count slides and add new slide as next available slide number
SlideCount = ppPres.Slides.Count
Set PPSlide = ppPres.Slides.Add(SlideCount + 1, ppLayoutTitleOnly)
PPSlide.Select

'Step 7: Paste the picture and adjust its position
PPSlide.Shapes.Paste.Select
pp.ActiveWindow.Selection.ShapeRange.Align msoAlignCenters, True
pp.ActiveWindow.Selection.ShapeRange.Top = 88
pp.ActiveWindow.Selection.ShapeRange.Left = 23
pp.ActiveWindow.Selection.ShapeRange.Width = 220
pp.ActiveWindow.Selection.ShapeRange.Height = 400

'Step 8: Add the title to the slide then move to next worksheet
   PPSlide.Shapes.Title.TextFrame.TextRange.Text = MyTitle


    Next xlwksht

'Step 9: Memory Cleanup
pp.Activate
Set PPSlide = Nothing
Set ppPres = Nothing
Set pp = Nothing



End Sub
 

vbano1

SMod
Thành viên BQT
Step 3: Vì yêu cầu là sử dụng template ppt có sẵn nên code sẽ như dưới đây.
Mã:
Sub TestCode()
'Declare
Dim oPA As PowerPoint.Application
Dim oPP As PowerPoint.Presentation
Dim oPS As PowerPoint.Slide
Dim oShape As PowerPoint.Shape
Dim oPicture As PowerPoint.Shape
Dim ExistingPPT As String
Dim MyPicture As String
'Set path and fielname of existing PowerPoint
ExistingPPT = "C:\VBA\Presentation1.pptx" 'make sure presentation has one blank slide.
 
'Set path and filename of picture to be imported into ppt
MyPicture = "C:\VBA\1.jpg"
 
'Open Existing PowerPoint
Set oPA = CreateObject("PowerPoint.Application")
With oPA
    'Open existing PowerPoint (THIS BLOCK WORKS)
    .Visible = True
Set oPP = .Presentations.Open(ExistingPPT)
    .ActiveWindow.View.GotoSlide (1) 'this line makes testing easier otherwise not required
Set oPS = oPP.Slides(1)
   'Add Picture (e.g. import it into PPT) (THIS BLOCK DOES NOT WORK)
    Set oShape = oPS.Shapes.AddPicture(MyPicture, msoFalse, msoTrue, 1, 1, -1, -1) '(Filename, LinkToFile, SaveWithDocument, Left, Top, Width, Height)
 
   'Size Picture
    Set oPicture = oPS.Shapes(oPS.Shapes.Count)
'The next two line are not needed using -1 (True) when adding already did this
   ' oPicture.ScaleHeight 1, msoTrue
   ' oPicture.ScaleWidth 1, msoTrue
    oPicture.LockAspectRatio = True
    oPicture.Width = 750 '750 is arbitrary
 
   'Center picture
    With oPA.ActivePresentation.PageSetup
        oPicture.Left = (.SlideWidth \ 2) - (oPicture.Width \ 2)
        oPicture.Top = (.SlideHeight \ 2) - (oPicture.Height \ 2)
    End With
End With
 
End Sub
Nguồn tham khảo:
 

tuhocvba

Administrator
Thành viên BQT
Step 4: Kết thúc
Mã:
Sub TestCode()
'Declare
Dim oPA As PowerPoint.Application
Dim oPP As PowerPoint.Presentation
Dim oPS As PowerPoint.Slide
Dim oShape As PowerPoint.Shape
Dim oPicture As PowerPoint.Shape
Dim ExistingPPT As String
Dim MyPicture As String

'Set path and fielname of existing PowerPoint
ExistingPPT = "C:\VBA\Presentation1.pptx" 'make sure presentation has one blank slide.
 
'Set path and filename of picture to be imported into ppt
MyPicture = "C:\VBA\1.jpg"

'Open Existing PowerPoint
Set oPA = CreateObject("PowerPoint.Application")
With oPA
    'Open existing PowerPoint (THIS BLOCK WORKS)
    .Visible = True
Set oPP = .Presentations.Open(ExistingPPT)
    .ActiveWindow.View.GotoSlide (1) 'this line makes testing easier otherwise not required
Set oPS = oPP.Slides(1)
   'Add Picture (e.g. import it into PPT) (THIS BLOCK DOES NOT WORK)
    Set oShape = oPS.Shapes.AddPicture(MyPicture, msoFalse, msoTrue, 1, 1, -1, -1) '(Filename, LinkToFile, SaveWithDocument, Left, Top, Width, Height)
 
   'Size Picture
    Set oPicture = oPS.Shapes(oPS.Shapes.Count)
'The next two line are not needed using -1 (True) when adding already did this
'    oPicture.ScaleHeight oPP.Slides(1).Shapes("Rectangle 3").Width, msoTrue
'    oPicture.ScaleWidth oPP.Slides(1).Shapes("Rectangle 3").Height, msoTrue
    oPicture.LockAspectRatio = True

    oPicture.Width = oPP.Slides(1).Shapes("Rectangle 3").Width  'Anh duoc phong to sao cho chieu to sao cho chieu rong bang nhau thi thoi. tuhocvba sua code
    
   'Center picture
    With oPA.ActivePresentation.PageSetup
        oPicture.Left = oPP.Slides(1).Shapes("Rectangle 3").Left 'tuhocvba sua code
        oPicture.Top = oPP.Slides(1).Shapes("Rectangle 3").Top 'tuhocvba sua code
    End With
End With
    

End Sub
 

vbano1

SMod
Thành viên BQT
Giả sử thay đổi đề bài một chút, tức là ảnh được kéo vừa vặn vào shape.
Bạn cần đăng nhập để thấy hình ảnh


Khi đó code sẽ như sau:
Mã:
Sub TestCode()
'Declare
Dim oPA As PowerPoint.Application
Dim oPP As PowerPoint.Presentation
Dim oPS As PowerPoint.Slide
Dim oShape As PowerPoint.Shape
Dim oPicture As PowerPoint.Shape
Dim ExistingPPT As String
Dim MyPicture As String
Dim w1 As Double
Dim h1 As Double
Dim t1 As Double
Dim l1  As Double


'Set path and fielname of existing PowerPoint
ExistingPPT = "C:\Users\jpnfriend.net\Desktop\VBA\Presentation1.pptx" 'make sure presentation has one blank slide.

'Set path and filename of picture to be imported into ppt
MyPicture = "C:\Users\jpnfriend.net\Desktop\VBA\1.jpg"


'Open Existing PowerPoint
Set oPA = CreateObject("PowerPoint.Application")
With oPA
'Open existing PowerPoint (THIS BLOCK WORKS)
.Visible = True
Set oPP = .Presentations.Open(ExistingPPT)
.ActiveWindow.View.GotoSlide (1) 'this line makes testing easier otherwise not required
w1 = oPP.Slides(1).Shapes("Rectangle 3").Width
h1 = oPP.Slides(1).Shapes("Rectangle 3").Height
l1 = oPP.Slides(1).Shapes("Rectangle 3").Left
t1 = oPP.Slides(1).Shapes("Rectangle 3").Top
Set oPS = oPP.Slides(1)
'Add Picture (e.g. import it into PPT) (THIS BLOCK DOES NOT WORK)
Set oShape = oPS.Shapes.AddPicture(MyPicture, msoFalse, msoTrue, l1, t1, -1, -1) '(Filename, LinkToFile, SaveWithDocument, Left, Top, Width, Height)

'Size Picture
    Set oPicture = oPS.Shapes(oPS.Shapes.Count)

   'Center picture
With oPicture
.LockAspectRatio = msoFalse 'khong giu lai ti le anh width/height
.ZOrder msoSendToFront 'anh hien len truoc, neu la Back: thi anh nam o phia sau
.AlternativeText = MyPicture
.Width = w1 'thiet dinh chieu rong
.Height = h1 'thiet dinh chieu cao
End With
End With
End Sub
 
Top