[应用]电脑演示存入幻灯片
电脑演示存入幻灯片
'共2个文件,以下文件存为ppt.vbp
Type=Exe
Reference=*\G{00020430-0000-0000-C000-000000000046}#2.0#0#.
.\..\..\..\..\WINDOWS\system32\stdole2.tlb#OLE Automation
Reference=*\G{91493440-5A91-11CF-8700-00AA0060263B}#2.8#0#.
.\..\..\..\..\Program Files\Microsoft
Office\OFFICE11\msppt.olb#Microsoft PowerPoint 11.0 Object
Library
Form=ppt.frm
Startup="ppt"
HelpFile=""
Command32=""
Name="screentoppt"
HelpContextID="0"
CompatibleMode="0"
MajorVer=1
MinorVer=0
RevisionVer=0
AutoIncrementVer=0
ServerSupportFiles=0
VersionCompanyName="微软中国"
CompilationType=0
OptimizationType=0
FavorPentiumPro(tm)=0
CodeViewDebugInfo=0
NoAliasing=0
BoundsCheck=0
OverflowCheck=0
FlPointCheck=0
FDIVCheck=0
UnroundedFP=0
StartMode=0
Unattended=0
Retained=0
ThreadPerObject=0
MaxNumberOfThreads=1
[MS Transaction Server] AutoRefresh=1
'以下文件存为ppt.frm
VERSION 5.00
Begin VB.Form ppt
BorderStyle = 0 'None
ClientHeight = 420
ClientLeft = 0
ClientTop = 0
ClientWidth = 4860
LinkTopic = "ppt"
ScaleHeight = 420
ScaleWidth = 4860
ShowInTaskbar = 0 'False
StartUpPosition = 3 '窗口缺省
Begin VB.CommandButton Command3
Caption = "图片输出到幻灯片"
Height = 375
Left = 3120
TabIndex = 2
Top = 0
Width = 1695
End
Begin VB.CommandButton Command2
Caption = "退出"
Height = 375
Left = 1560
TabIndex = 1
Top = 0
Width = 1455
End
Begin VB.CommandButton Command1
Caption = "截屏"
Height = 375
Left = 0
TabIndex = 0
Top = 0
Width = 1455
End
End
Attribute VB_Name = "ppt"
Attribute VB_GlobalNameSpace = False Attribute VB_Creatable = False Attribute VB_PredeclaredId = True Attribute VB_Exposed = False Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long)
As Long
Private Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As
Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long,
ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long,
ByVal ySrc As Long, ByVal dwRop As Long) As Long
Private Declare Function SetWindowPos Lib "user32" (ByVal hwnd As Long, ByVal hWndInsertAfter As Long, ByVal x As Long, ByVal y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long
Private Declare Function DeleteFile Lib "kernel32" Alias "DeleteFileA" (ByVal lpFileName As String) As Long
Private Declare Function GetTickCount Lib "kernel32" () As Long
Private Sub Command1_Click()
Dim i As Integer
Me.Hide
Me.AutoRedraw = True
BitBlt Me.hDC, 0, 0, Screen.Width, Screen.Height, GetDC(0), 0, 0, vbSrcCopy
If Dir(App.Path & "\bmp", vbDirectory) = "" Then
MkDir App.Path & "\bmp"
End If
For i = 1 To 9000
If Dir(App.Path & "\bmp\" & Format(i, "0000") & ".bmp") = "" Then
sFile$ = App.Path & "\bmp\" & Format(i, "0000") & ".bmp"
SavePicture Me.Image, sFile '保存
GoTo Lp1
End If
Next
Lp1:
Me.Show
End Sub
Private Sub Command2_Click()
End
End Sub
Private Sub Command3_Click()
Dim MyApp As PowerPoint.Application Dim MyPres As PowerPoint.Presentation Dim MySlide As PowerPoint.Slide Set MyApp = New PowerPoint.Application MyApp.Visible = True
MyApp.WindowState =
PowerPoint.PpWindowState.ppWindowMinimized Set MyPres = MyApp.Presentations.Add Dim file1 As String
For i = 1 To 9000
file1 = App.Path & "\bmp\" & Format(i, "0000") & ".bmp"
If Dir(file1) <> "" Then
Set MySlide = MyPres.Slides.Add(MyPres.Slides.Count + 1,
PowerPoint.PpSlideLayout.ppLayoutTitleOnly) Call MySlide.Shapes.AddPicture(file1, False, True, 0, 0, 720,
540)
DeleteFile file1
End If
Next
Dim ppt2 As String
ppt2 = App.Path & "\" & GetTickCount & ".ppt"
MyPres.SaveAs ppt2
Dim oSettings As PowerPoint.SlideShowSettings Set oSettings = MyPres.SlideShowSettings MyApp.Assistant.On = False
MsgBox ppt2, vbOKOnly, "幻灯片存储完毕:" oSettings.Run
End Sub
Private Sub Form_Load()
Me.Top = 0
Me.Left = Screen.Width / 2
SetWindowPos Me.hwnd, -1, 0, 0, 0, 0, 3 '置顶 For i = 1 To 9000
file1 = App.Path & "\bmp\" & Format(i, "0000") & ".bmp"
If Dir(file1) <> "" Then
DeleteFile file1
End If
Next
End Sub