|
|
将下面的代码 放于你提供的附件PPT文件的 模块中！，ppt文件与Excel文件在同一个文件夹中》》》》》
Sub test_PPT()
Dim pptOutput As Presentation, pptLayout As CustomLayout
Dim ExcelFileName As String, path As String, n As Long, arr
Dim conn As Object, Sql As String, fg As Boolean
Set pptOutput = ActivePresentation
If pptOutput.Slides.Count > 1 Then
For i = pptOutput.Slides.Count To 2 Step -1
pptOutput.Slides(i).Delete
Next
End If
Set pptLayout = pptOutput.Slides(1).CustomLayout
path = pptOutput.path: ExcelFileName = "\人员.xlsx"
Set conn = CreateObject("adodb.connection")
conn.Open "Provider=Microsoft.ACE.OLEDB.12.0;extended properties=excel 12.0;data source=" & path & ExcelFileName
Sql = "select * from [" & path & ExcelFileName & "].[房间安排$B:B] where 姓名 is not null"
arr = conn.Execute(Sql).GetRows: conn.Close: Set conn = Nothing
For i = 0 To UBound(arr, 2)
If Not fg Then
With pptOutput.Slides(1)
If .Shapes.Count > 0 Then
.Shapes.Range.Delete
End If
With .Shapes.AddTextbox(1, 80, 200, 400, 1)
With .TextFrame.TextRange
.Text = arr(o, i)
.Font.Size = 115
.Font.Bold = -1
.Font.Underline = 0
.Font.Name = "楷体_GB2312"
.Font.Color = RGB(0, 0, 0)
.ParagraphFormat.Alignment = ppAlignCenter
End With
.Duplicate.IncrementTop 220
.Flip msoFlipVertical
End With
End With
fg = True
Else
With pptOutput.Slides.AddSlide(i + 1, pptLayout)
With .Shapes.AddTextbox(1, 80, 200, 400, 1)
With .TextFrame.TextRange
.Text = arr(o, i)
.Font.Size = 115
.Font.Bold = -1
.Font.Underline = 0
.Font.Name = "楷体_GB2312"
.Font.Color = RGB(0, 0, 0)
.ParagraphFormat.Alignment = ppAlignCenter
End With
.Duplicate.IncrementTop 220
.Flip msoFlipVertical
End With
End With
End If
Next
MsgBox "制作桌牌完成！"
End Sub
|
|
沪公网安备 31011702000001号 沪ICP备11019229号-2
发表于 2018-4-11 14:18
楼主
