Ppt的-214188160（80048240）错误。

ning84 · 发表于 2024-2-18 14:14

Set Sld = Slds("A")不成立。

Dim Pres As Presentation, Slds As Slides
Set Pres = Application.ActivePresentation
Set Slds = Pres.Slides
Dim Sld As Slide
For ii = 1 To Slds.Count
Set Sld = Slds(ii)
Sld.Name = "A" & ii
Debug.Print Sld.Name
Next ii
Set Sld = Slds("A1") ''成立
Stop
Set Sld = Slds("A")

复制代码

---------------------------------------------------------------

ning84 · 发表于 2024-2-20 10:16

自己出题自己做PPT的题。

Sub ll()
Dim Pres As Presentation
Set Pres = Application.ActivePresentation
Dim Slds As Slides, Sld As Slide
Set Slds = Pres.Slides
Dim Shp As Shape
For ii = 1 To Slds.Count
With Slds(ii)
Set Shp = .Shapes(2)
Debug.Print Shp.Name, Shp.TextFrame.TextRange.Text
Shp.Name = "MainNote"
Set Shp = .Shapes.AddTextbox(1, 5, 750, 300, 20)
Shp.TextFrame.TextRange.Text = "2024年02月10日星期六出发8:29，结束21:02，香港行12:32。"
Shp.Name = "LeftNote"
With Shp.TextFrame.TextRange
.Font.Size = 15
.Font.Bold = msoCTrue
End With
End With
Next ii
End Sub
''
Sub ll1()
Dim Pres As Presentation
Set Pres = Application.ActivePresentation
Dim Slds As Slides, Sld As Slide
Set Slds = Pres.Slides
Dim Shp As Shape
For ii = 1 To Slds.Count
With Slds(ii)
Set Shp = .Shapes("LeftNote")
With Shp
.Width = 540
.Left = 0
.Top = 750
.TextEffect.Alignment = msoTextEffectAlignmentRight
With .TextFrame.TextRange
.Font.Size = 15
.Font.Bold = msoCTrue
.Text = "2024年02月10日星期六出发8:29，结束21:02，香港行历时12:32。"
End With
End With
With Shp.TextFrame.TextRange
End With
End With
Next ii
End Sub

复制代码

ning84 · 发表于 2024-2-28 18:04

自己出题自己做题

Private Sub ll()
Dim Pres As Presentation
Set Pres = Application.ActivePresentation
Dim Sld As Slide, Slds As Slides
Set Slds = Pres.Slides
For ii = 1 To Slds.Count
Debug.Print Slds(ii).Name, Slds(ii).Shapes(1).Name
Next iia
End Sub

复制代码

ning84 · 发表于 2024-3-2 18:27

自己出题自己做

'''
Sub DictPptSingsDelFile()
Dim T: T = Time
Dim Fso As FileSystemObject, oFolder As Folder, oFile As File
Set Fso = New FileSystemObject
Debug.Print Format(T, "h;mm:ss")
Dim RngDic As Dictionary, SldDic As Dictionary
Dim FileRng As Range, FileDic As Dictionary
Set RngDic = New Dictionary
Set SldDic = New Dictionary
Set FileDic = New Dictionary
Dim Rng As Range, Sht As Worksheet
Set Rng = Selection
Set Sht = Rng.Parent
Set Rng = Sht.Cells(20, 1).CurrentRegion
Rng.Resize(Rng.Rows.Count, 26).Interior.Color = vbRed
Rng.Resize(Rng.Rows.Count, 26).Interior.ColorIndex = xlNone
Dim PathName, oPath, Str
Dim Pres As Presentation, Slds As Slides
Dim Hor As Boolean
Hor = False
''
If Hor = True Then
PathName = ThisWorkbook.Path & "" & Sht.Name & "\Hor" & Sht.Name & ".Ppt"
ElseIf Hor = False Then
PathName = ThisWorkbook.Path & "" & Sht.Name & "\Ver" & Sht.Name & ".Ppt"
End If
Debug.Print PathName
oPath = ThisWorkbook.Path & "" & Sht.Name
Set oFolder = Fso.GetFolder(oPath)
Set oFiles = oFolder.Files
Set Pres = OpenPpt(PathName)
Set Slds = Pres.Slides
Dim Arr, Rr, ii, jj
Dim Sld As Slide
For Each Sld In Slds
Sld.Name = Sld.Shapes(1).Name
SldDic(UCase(Sld.Name)) = "" ''
Next Sld
'''
For Each oFile In oFiles
If InStr(UCase(oFile.Name), "JPG") > 0 Then
'Debug.Print oFile.Name
FileDic(oFile.Name) = ""
Debug.Print oFile.Path
End If
Next oFile
'''
Kk = 1
Set Rng = Sht.Cells(Rng.Row + Rng.Rows.Count + 20, 1).Resize(1000, 10)
'''
Rng.Clear
For ii = 0 To FileDic.Count - 1
Str = UCase(FileDic.Keys(ii))
'Str = Mid(Str, 2, 100)
If Not SldDic.Exists(Str) Then
Sht.Cells(Rng.Row + Kk, 1) = Kk
Sht.Cells(Rng.Row + Kk, 2) = Str
Str = ThisWorkbook.Path & "" & Sht.Name & "" & FileDic.Keys(ii)
Set oFile = Fso.GetFile(Str)
oFile.Move "D:\Tmp"
Kk = Kk + 1
End If
Next ii
'''
'Set oRng = Sht.Cells(Rng.Row + Rng.Rows.Count + Kk - 10, 1).CurrentRegion
Debug.Print Sht.Cells(Rng.Row - 5, 1).Address, Kk
Sht.Cells(Rng.Row - 5, 1) = "=count(" & Rng.Resize(Kk + 2, 1).Address(0, 0) & ")"
Debug.Print Format(Time - T, "h;mm:ss")
'Pres.Save
Debug.Print Format(Time - T, "h;mm:ss")
End Sub
''
'''''''

复制代码

		自动登录	找回密码
密码			免费注册