Question

我正在使用Powerpoint VBA制作漫画节目。

我已经从互联网站点制作了图片下载程序，但它很成功。

问题在于图像的大小。

图片尺寸太大，因此无法使用.Export属性保存图片。

有没有办法在没有分辨率丢失的情况下保存极其庞大的图像？

+如果无法保存大图片，请告诉我在VBA中合并多个图像而不会丢失分辨率。

码

`

Public Sub downWebtoonS(ID As Long, S As Long, F As Long)
On Error Resume Next
Dim i As Long, ldBar As Double
ldBar = ActivePresentation.Slides(mainS).Shapes("loadA").Left
For i = S To F
Call downWebtoon(ID, i, S, F, i)

Call ActivePresentation.Slides(TmpS).Shapes("res").Export("C:\temp\PPT\Webtoon\img" & i & ".png", ppShapeFormatPNG) 'It is the problem

ActivePresentation.Slides(TmpS).Shapes("res").Copy
ActivePresentation.Slides(TmpS).Shapes("res").Delete
ActivePresentation.Slides(mainS).Shapes("loadA").Width = (ActivePresentation.SlideMaster.Width - (ldBar * 2)) / (F - S + 1) * (i - S + 1)
ActivePresentation.Slides(mainS).Shapes("nowStatA").TextFrame.TextRange.Text = (i - S + 1) & " / " & (F - S + 1) & " (" & Int(100 / (F - S + 1) * (i - S + 1)) & "%)"
Next i
Dim wsh As Object
Set wsh = VBA.CreateObject("WScript.Shell")
Dim waitOnReturn As Boolean: waitOnReturn = True
Dim windowStyle As Integer: windowStyle = 0
wsh.Run "cmd /k title PPT & color 1F & echo. Wait a minute... & del C:\temp\PPT\Webtoon\tmp.png & exit", vbHide, waitOnReturn
End Sub


Public Sub downWebtoon(ID As Long, viewNo As Long, S As Long, F As Long, t As Long)
On Error Resume Next
Dim n As Long, i As Long, URL As String, shpTop As Double, ldBar As Double
ldBar = ActivePresentation.Slides(mainS).Shapes("load").Left
Dim shp As Shape
shpTop = 0
n = getImgNo(ID, viewNo)
For i = 0 To n - 1
DoEvents
With ActivePresentation.Slides(TmpS).Shapes.AddShape(msoShapeRectangle, 0, 0, 0, 0)
    .Name = "shp" & i
    .Line.Visible = False
    .Top = shpTop
End With
Set shp = ActivePresentation.Slides(TmpS).Shapes("shp" & i)
URL = getURL(ID, viewNo, i)
shpTop = shpTop + downImg(shp, URL)
If i > 0 Then
ActivePresentation.Slides(TmpS).Shapes.Range(Array("shp" & i, "frm" & i - 1)).Group.Name = "frm" & i
Else
ActivePresentation.Slides(TmpS).Shapes("shp0").Name = "frm0"
End If
ActivePresentation.Slides(mainS).Shapes("load").Width = (ActivePresentation.SlideMaster.Width - (ldBar * 2)) / n * (i + 1)
ActivePresentation.Slides(mainS).Shapes("nowStat").TextFrame.TextRange.Text = i + 1 & "Cut / " & n & "Cut" & " (" & Int((i + 1) / n * 100) & "%)"
ActivePresentation.Slides(mainS).Shapes("loadA").Width = (ActivePresentation.SlideMaster.Width - (ldBar * 2)) / (F - S + 1) * ((t - S) + ((i + 1) / (n)))
ActivePresentation.Slides(mainS).Shapes("nowStatA").TextFrame.TextRange.Text = (t - S + 1) & " / " & (F - S + 1) & " (" & Int(100 / (F - S + 1) * ((t - S) + ((i + 1) / (n)))) & "%)"
DoEvents
Next i
ActivePresentation.Slides(TmpS).Shapes("frm" & n - 1).Name = "res"
End Sub



Public Function downImg(shp As Shape, link As String)
Call DownloadFile(link, "C:\temp\PPT\Webtoon\tmp.png")
shp.Fill.UserPicture "C:\temp\PPT\Webtoon\tmp.png"
shp.Width = WidthImage
shp.height = LoadPicture("C:\temp\PPT\Webtoon\tmp.png").height * (WidthImage / LoadPicture("C:\temp\PPT\Webtoon\tmp.png").Width)
downImg = shp.height
End Function

VBA保存/导出极其巨大的图像

0 个答案: