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:
Bạn cần đăng nhập để thấy link
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.
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:
'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
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
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
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
