Tavafi.ir

TPE

Tavvafi@gmail.com

≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡≡

آنچه که در این نمونه به آن خواهیم پرداخت استفاده از یک Textbox از نوع Developer است.


در این پرزنتیشن، در اسلاید نخست اطلاعات ار کاربر دریافت می شود و در اسلاید دوم اطلاعات دریافت شده نمایش داده می شود و در صورت نیار چاپ می شود.

کد ماکروی موجود در این پرزنتیشن به قرار زیر است:

Option Explicit

Dim gRayValues(1 To 100, 1 To 2) As String

Sub RecordAndProceed(oClickedSh As Shape)
' Records text entered on current slide
Dim x As Long
Dim oSh As Shape
Dim oSl As Slide
Dim bSearchMarkedOnly As Boolean

If ActivePresentation.Tags("SearchOnlyMarkedSlides") = "YES" Then
bSearchMarkedOnly = True
Else
bSearchMarkedOnly = False
End If

On Error Resume Next
For x = 1 To UBound(gRayValues)
If Len(gRayValues(x, 1)) = 0 Then
Exit For
End If
Next

For Each oSh In oClickedSh.Parent.Shapes
If oSh.Type = msoOLEControlObject Then
gRayValues(x, 1) = oSh.Name
gRayValues(x, 2) = oSh.OLEFormat.Object.Text
Debug.Print x & vbTab & gRayValues(x, 1) & vbTab & gRayValues(x, 2)
x = x + 1
End If
Next

' Find and replace text in presentation
' Assumes that each textbox control's name is txtXXXXX
' We'll replace all instances of %XXXXX% with contents of text box txtXXXXX

For Each oSl In ActivePresentation.Slides
' are we searching only marked slides?
If bSearchMarkedOnly Then
' is this slide marked?
If oSl.Tags("MarkedForSearch") = "YES" Then
For Each oSh In oSl.Shapes
With oSh
If .HasTextFrame Then
If .TextFrame.HasText Then
With .TextFrame.TextRange
For x = 1 To UBound(gRayValues)
If InStr(.Text, "%" & Mid$(gRayValues(x, 1), 4) & "%") > 0 Then
If oSh.Tags("SAVED") <> "YES" Then
oSh.Tags.Add "SAVED", "YES"
oSh.Tags.Add "TEXT", .Text
End If
End If
.Text = _
Replace(.Text, _
"%" & Mid$(gRayValues(x, 1), 4) & "%", _
gRayValues(x, 2))
Next
End With ' textrange
End If
End If
End With
Next
End If
Else ' we're searching ALL slides
For Each oSh In oSl.Shapes
With oSh
If .HasTextFrame Then
If .TextFrame.HasText Then
With .TextFrame.TextRange
For x = 1 To UBound(gRayValues)
If InStr(.Text, "%" & Mid$(gRayValues(x, 1), 4) & "%") > 0 Then
If oSh.Tags("SAVED") <> "YES" Then
oSh.Tags.Add "SAVED", "YES"
oSh.Tags.Add "TEXT", .Text
End If
End If
.Text = _
Replace(.Text, _
"%" & Mid$(gRayValues(x, 1), 4) & "%", _
gRayValues(x, 2))
Next
End With ' textrange
End If
End If
End With
Next
End If
Next ' Slide

SlideShowWindows(1).View.GotoSlide (oClickedSh.Parent.SlideIndex + 1)

End Sub

Sub Reset(oClickedSh As Shape)
Dim oSh As Shape
Dim x As Long
Dim oSl As Slide

' clear the text boxes on this slide
For Each oSh In oClickedSh.Parent.Shapes
If oSh.Type = msoOLEControlObject Then
oSh.OLEFormat.Object.Text = ""
End If
Next

' clear the array that holds values
For x = 1 To UBound(gRayValues)
gRayValues(x, 1) = ""
gRayValues(x, 2) = ""
Next

' restore the original text wherever there have been
' text substitutions
Call ResetSubstitutedText

End Sub

Sub PrintMe(oClickedSh As Shape)
' Prints current page to default printer
' Hides the print me button first

Dim oSl As Slide
Dim lSlRange As Long

oClickedSh.Visible = msoFalse

Set oSl = oClickedSh.Parent
lSlRange = oSl.SlideIndex

With ActivePresentation.PrintOptions
.RangeType = ppPrintSlideRange
With .Ranges
.ClearAll
.Add Start:=lSlRange, End:=lSlRange
End With
.NumberOfCopies = 1
.Collate = msoTrue
.OutputType = ppPrintOutputSlides
.PrintHiddenSlides = msoTrue
.PrintColorType = ppPrintColor
.FitToPage = msoTrue
.FrameSlides = msoFalse
End With

ActivePresentation.PrintOut

oClickedSh.Visible = msoTrue

End Sub

Sub MarkPresentationAsSearchOnlyMarked()
' Sets a presentation-wide option to search ONLY slides marked for search/replace
' in RecordAndProceed
' Once this is set, only slides "tagged" with MarkSlideForSearch below will be searched
' (normally we search all slides)

With ActivePresentation
.Tags.Add "SearchOnlyMarkedSlides", "YES"
End With

End Sub
Sub UNMarkPresentationAsSearchOnlyMarked()
' UNDoes the effect of MarkPresentationAsSearchOnlyMarked

With ActivePresentation
.Tags.Add "SearchOnlyMarkedSlides", ""
End With

End Sub

Sub MarkSlideForSearch()
' Marks a slide as a target for search and replace
' when the presentation is marked to search only these slides
Dim oSl As Slide
Dim x As Long

If ActiveWindow.Selection.Type = ppSelectionSlides Then
For x = 1 To ActiveWindow.Selection.SlideRange.Count
With ActiveWindow.Selection.SlideRange(x)
.Tags.Add "MarkedForSearch", "YES"
End With
Next
Else
MsgBox "Please select one or more slides then try again"
End If
End Sub
Sub UNMarkSlideForSearch()
' UNMarks a slide as a target for search and replace

Dim oSl As Slide
Dim x As Long

If ActiveWindow.Selection.Type = ppSelectionSlides Then
For x = 1 To ActiveWindow.Selection.SlideRange.Count
With ActiveWindow.Selection.SlideRange(x)
.Tags.Add "MarkedForSearch", ""
End With
Next
Else
MsgBox "Please select one or more slides then try again"
End If
End Sub

Sub ResetSubstitutedText()

Dim oSh As Shape
Dim oSl As Slide

For Each oSl In ActivePresentation.Slides
For Each oSh In oSl.Shapes
If oSh.Tags("SAVED") = "YES" Then
oSh.TextFrame.TextRange.Text = oSh.Tags("TEXT")
oSh.Tags.Add "SAVED", "RESET"
End If
Next
Next

End Sub