vb ppt
场景：详解 vb 控制 ppt解决思路
详解 vb 控制 ppt
详解 vb 控制 ppt
1用 OLe 控件，如何去除 播放时的菜单
"编辑"浏览""帮助"，用设置 MenuBar 无效的方法无法实现屏蔽。
2用 dsoFrame 控件，如何控制翻页 ，不知如何使用接口。
3用 PPT Viewer控件，如何解决黑屏问题，
载入时黑屏，不爽。
注意是让PPT在控件内播放，不是调用PPT 程序
------解决方案--------------------
Option Explicit
Const APP_NAME = "PowerPoint in VB window"
' PowerPoint Constants
Const ppShowTypeSpeaker = 1
' Undocument constant used to display show in a window
' window any PowerPoint command bars
Const ppShowTypeInWindow = 1000
Public oPPTApp As Object
Public oPPTPres As Object
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" _
(ByVal lpClassName As String, _
ByVal lpWindowName As Long) As Long
Private Declare Function SetParent Lib "user32" (ByVal hWndChild As Long, ByVal hWndNewParent As Long) As Long
Private Declare Function SetWindowText Lib "user32" Alias "SetWindowTextA" (ByVal hwnd As Long, ByVal lpString As String) As Long
Private Sub cmdShow_Click(Index As Integer)
Dim screenClasshWnd As Long
On Error Resume Next
Set oPPTApp = CreateObject("PowerPoint.Application")
If Not oPPTApp Is Nothing Then
Set oPPTPres = oPPTApp.Presentations.Open(App.Path & "\安全集成电路开发包.ppt", , , False)
If Not oPPTPres Is Nothing Then
With oPPTPres
Select Case Index
Case Is = 0
With .SlideShowSettings
.ShowType = ppShowTypeSpeaker
With .Run
.Width = frmSS.Width
.Height = frmSS.Height
End With
End With
screenClasshWnd = FindWindow("screenClass", 0&)
SetParent screenClasshWnd, frmSS.hwnd
With Me
.Height = 4545
.SetFocus
End With
Case Is = 1
With .SlideShowSettings
.ShowType = 1000
.Run
End With
Call SetWindowText(FindWindow("screenClass", 0&), APP_NAME)
End Select
End With
Else
MsgBox "Could not open the presentation.", vbCritical, APP_NAME
End If
Else
MsgBox "Could not instantiate PowerPoint.", vbCritical, APP_NAME
End If
End Sub
Private Sub Form_Initialize()
With Me
.ScaleMode = vbPoints
.Caption = APP_NAME
End With
End Sub
Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
On Error Resume Next
lblMessage.Visible = True
DoEvents
If Not oPPTPres Is Nothing Then
oPPTPres.Close
End If
Set oPPTPres = Nothing
If Not oPPTApp Is Nothing Then
oPPTApp.Quit
End If
Set oPPTApp = Nothing
lblMessage.Visible = False
End Sub
详解 vb 控制 ppt
详解 vb 控制 ppt
1用 OLe 控件，如何去除 播放时的菜单
"编辑"浏览""帮助"，用设置 MenuBar 无效的方法无法实现屏蔽。
2用 dsoFrame 控件，如何控制翻页 ，不知如何使用接口。
3用 PPT Viewer控件，如何解决黑屏问题，
载入时黑屏，不爽。
注意是让PPT在控件内播放，不是调用PPT 程序
------解决方案--------------------
Option Explicit
Const APP_NAME = "PowerPoint in VB window"
' PowerPoint Constants
Const ppShowTypeSpeaker = 1
' Undocument constant used to display show in a window
' window any PowerPoint command bars
Const ppShowTypeInWindow = 1000
Public oPPTApp As Object
Public oPPTPres As Object
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" _
(ByVal lpClassName As String, _
ByVal lpWindowName As Long) As Long
Private Declare Function SetParent Lib "user32" (ByVal hWndChild As Long, ByVal hWndNewParent As Long) As Long
Private Declare Function SetWindowText Lib "user32" Alias "SetWindowTextA" (ByVal hwnd As Long, ByVal lpString As String) As Long
Private Sub cmdShow_Click(Index As Integer)
Dim screenClasshWnd As Long
On Error Resume Next
Set oPPTApp = CreateObject("PowerPoint.Application")
If Not oPPTApp Is Nothing Then
Set oPPTPres = oPPTApp.Presentations.Open(App.Path & "\安全集成电路开发包.ppt", , , False)
If Not oPPTPres Is Nothing Then
With oPPTPres
Select Case Index
Case Is = 0
With .SlideShowSettings
.ShowType = ppShowTypeSpeaker
With .Run
.Width = frmSS.Width
.Height = frmSS.Height
End With
End With
screenClasshWnd = FindWindow("screenClass", 0&)
SetParent screenClasshWnd, frmSS.hwnd
With Me
.Height = 4545
.SetFocus
End With
Case Is = 1
With .SlideShowSettings
.ShowType = 1000
.Run
End With
Call SetWindowText(FindWindow("screenClass", 0&), APP_NAME)
End Select
End With
Else
MsgBox "Could not open the presentation.", vbCritical, APP_NAME
End If
Else
MsgBox "Could not instantiate PowerPoint.", vbCritical, APP_NAME
End If
End Sub
Private Sub Form_Initialize()
With Me
.ScaleMode = vbPoints
.Caption = APP_NAME
End With
End Sub
Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
On Error Resume Next
lblMessage.Visible = True
DoEvents
If Not oPPTPres Is Nothing Then
oPPTPres.Close
End If
Set oPPTPres = Nothing
If Not oPPTApp Is Nothing Then
oPPTApp.Quit
End If
Set oPPTApp = Nothing
lblMessage.Visible = False
End Sub