(2008-10-04 16:46:11, Size: 38 KB, Downloads: 46)
这个附件来自于Excel Home论坛
7楼，
运行幻灯片后单击上面的对象即可将其放大，我很想知道这样的效果是怎样实现的？希望熟悉VBA的老师指点一下。本人对VBA是一窍不通的。
下载该文件用PPT打开后，我通过工具／宏／VB编辑器看到了许多代码，内容如下：
Public nClick As Integer
Public sldH As Single
Public sldW As Single
Public iShp As Shape
Public oWidth() As Single
Public oHeight() As Single
Public oSize() As Single
Public oLeft() As Single
Public oTop() As Single
Public nShp As Integer
Public idx As Integer
Public Ratio As Integer
Public pAuthor As String
Public tFrameFound As Boolean
Public nSlide As Integer
Public tSlide As Integer
Sub LoadSlide(ByVal nsld As Integer)
With ActivePresentation.Slides(nsld)
nShp = .Shapes.Count
ReDim oWidth(nShp)
ReDim oHeight(nShp)
ReDim oTop(nShp)
ReDim oLeft(nShp)
ReDim oSize(nShp)
Dim n As Integer
n = 0
For Each iShp In .Shapes
If iShp.Name <> "tFrame" Then
n = n + 1
iShp.Name = "Temp" & n
End If
Next
n = 0
For Each iShp In .Shapes
If iShp.Name <> "tFrame" Then
n = n + 1
iShp.Name = "TextBox" & n
If iShp.Type = 1 Or iShp.Type = 13 Then
iShp.ActionSettings(ppMouseClick).Action = ppActionRunMacro
iShp.ActionSettings(ppMouseClick).Run = "EnLarge"
Else
iShp.ActionSettings(ppMouseClick).Action = ppActionNone
End If
ElseIf iShp.Name = "tFrame" Then
tFrameFound = True
iShp.ActionSettings(ppMouseClick).Action = ppActionRunMacro
iShp.ActionSettings(ppMouseClick).Run = "EndShow"
End If
Next
End With
If Not tFrameFound Then
With ActivePresentation.Slides(nSlide).Shapes.AddShape(Type:=1, Left:=0, Top:=0, Width:=sldW, Height:=sldH)
.Name = "tFrame"
.Fill.Visible = msoFalse
.Fill.Solid
.Fill.Transparency = 1#
.Line.Weight = 4.5
If tSlide > nSlide Then
.ActionSettings(ppMouseClick).Action = ppActionRunMacro
.ActionSettings(ppMouseClick).Run = "NextSlide"
Else
.ActionSettings(ppMouseClick).Action = ppActionRunMacro
.ActionSettings(ppMouseClick).Run = "EndShow"
End If
.ZOrder msoSendBackward
.ZOrder msoSendToBack
End With
End If
End Sub
Sub NextSlide()
DeleteShapes nSlide
nSlide = nSlide + 1
DeleteShapes nSlide
LoadSlide nSlide
With SlideShowWindows(1)
.View.GotoSlide (.Presentation.Slides(nSlide).SlideIndex)
End With
End Sub
Sub EnLarge(ByVal oShp As Shape)
idx = Mid(oShp.Name, 8)
With ActivePresentation.Slides(nSlide)
If nClick = 0 Then
nClick = 1
oWidth(idx) = .Shapes("TextBox" & idx).Width
oHeight(idx) = .Shapes("TextBox" & idx).Height
oLeft(idx) = .Shapes("TextBox" & idx).Left
oTop(idx) = .Shapes("TextBox" & idx).Top
oShp.Width = Ratio * oWidth(idx)
oShp.Height = Ratio * oHeight(idx)
If oShp.Type = 1 Then
oSize(idx) = .Shapes("TextBox" & idx).TextFrame.TextRange.Font.Size
oShp.TextFrame.TextRange.Font.Size = Ratio * oSize(idx)
End If
If (sldW - oShp.Left) < oShp.Width Then
oShp.Left = sldW - oShp.Width - 2
Else
oShp.Left = oLeft(idx)
End If
If (sldH - oShp.Top) < oShp.Height Then
oShp.Top = sldH - oShp.Height - 2
Else
oShp.Top = oTop(idx)
End If
oShp.ZOrder msoBringToFront
oShp.ZOrder msoBringForward
For i = 1 To .Shapes.Count
If .Shapes(i).Name <> "TextBox" & idx Then .Shapes(i).ActionSettings(ppMouseClick).Action = ppActionNone
Next i
Else
For i = 1 To .Shapes.Count
If InStr(.Shapes(i).Name, "TextBox") Then
If .Shapes(i).Type = 1 Or .Shapes(i).Type = 13 Then
.Shapes(i).ActionSettings(ppMouseClick).Action = ppActionRunMacro
.Shapes(i).ActionSettings(ppMouseClick).Run = "EnLarge"
End If
ElseIf .Shapes(i).Name = "tFrame" Then
If tSlide > nSlide Then
.Shapes(i).ActionSettings(ppMouseClick).Action = ppActionRunMacro
.Shapes(i).ActionSettings(ppMouseClick).Run = "NextSlide"
Else
.Shapes(i).ActionSettings(ppMouseClick).Action = ppActionRunMacro
.Shapes(i).ActionSettings(ppMouseClick).Run = "EndShow"
End If
End If
Next i
oShp.Left = oLeft(idx)
oShp.Top = oTop(idx)
oShp.Width = oWidth(idx)
oShp.Height = oHeight(idx)
If oShp.Type = 1 Then oShp.TextFrame.TextRange.Font.Size = oSize(idx)
nClick = 0
End If
End With
End Sub
Sub Load()
Dim tFile As String
Set fs = CreateObject("Scripting.FileSystemObject")
pTitle = ActivePresentation.Slides(1).Shapes("Load").TextFrame.TextRange.Text
With Application.ActivePresentation
tFile = Mid(.FullName, 1, InStrRev(.FullName, ".")) & "txt"
.BuiltInDocumentProperties.Item("Title").Value = pTitle
tSlide = .Slides.Count
End With
With Application.ActivePresentation.PageSetup
sldW = .SlideWidth
sldH = .SlideHeight
End With
nClick = 0
Ratio = 3
pAuthor = "黄再源"
tFrameFound = False
nSlide = 2
If fs.FileExists(tFile) Then
Dim TextLine
Dim HeadLine
Dim f
f = FreeFile()
Open tFile For Input As #f
Do While Not EOF(f)
Line Input #f, TextLine
TextLine = Trim(TextLine)
If Len(TextLine) > 0 Then
If Left(TextLine, 1) = "[" Then
HeadLine = LCase(TextLine)
Else
If HeadLine = "[author]" Then
pAuthor = TextLine
ElseIf HeadLine = "[ratio]" Then
If IsNumeric(TextLine) Then Ratio = TextLine
End If
End If
End If
Loop
Close #f
End If
With Application.ActivePresentation
.BuiltInDocumentProperties.Item("Author").Value = pAuthor
End With
LoadSlide nSlide
With SlideShowWindows(1)
.View.GotoSlide (.Presentation.Slides(nSlide).SlideIndex)
End With
End Sub
Sub DeleteShapes(ByVal nsld As Integer)
With ActivePresentation.Slides(nsld)
For Each iShp In .Shapes
If iShp.Name = "tFrame" Then iShp.Cut
Next
End With
End Sub
Sub EndShow()
DeleteShapes nSlide
With SlideShowWindows(1)
.View.GotoSlide (.Presentation.Slides(1).SlideIndex)
.View.Exit
End With
End Sub
Sub NameShape()
On Error GoTo AbortNameShape
Dim Name$
If ActiveWindow.Selection.ShapeRange.Count = 1 Then
Name$ = ActiveWindow.Selection.ShapeRange(1).Name
Name$ = InputBox$("Give this shape a name", "Shape Name", Name$)
If Name$ <> "" Then
ActiveWindow.Selection.ShapeRange(1).Name = Name$
End If
Else
MsgBox "Only 1 Shape is allowed to be selected"
Exit Sub
End If
Exit Sub
AbortNameShape:
MsgBox "No Shapes Selected"
End Sub
我想知道的是：能否借用这些代码将自动放大功能移植到其他演示文稿中？我对VBA的用法真的是一窍不通不通，希望能尽可能介绍得详细些。小弟地此先行谢过了？
[ 本帖最后由 zhll365 于 2009-10-31 09:31 编辑 ]