TPE

https://bayanbox.ir/view/263405954590585756/2mobile.png

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


آدرس وب‌سایت‌ها:

پروژه‌های منتشر شده برای عموم (Published):

نمایش و چاپ فارسی DOS

نمایش، ویرایش و چاپ متون فارسی تحت DOS در ویندوز

تبدیل متون Windows به DOS

تبدیل متن فارسی داس به ویندوز اکسلTXLSx

نرم افزار ویرایش DSKKAR00 و DSKWOR00 لیست بیمه

حذف کاراکتر های جدولی از گزارش های تحت DOS

تبدیل متن و جداول گزارش های تحت DOS به Excel

چاپ فرم های ارزشیابی 100 امتیازی کارمندان

حضور و غیاب و موارد انضباطی (ماهناز)

کارنامه ماهانه توصیفی (ماهتوس)

کارنامه ماهانه(ماهکار2)

حفاظت از برنامه نویسی در DOS تحت Windows با قفل‌گذاری روی Flash USB

حفاظت از پروژه‌های Autoplay Media Studio

حفاظت از پروژه‌های SetupFactory

حفاظت از پروژه‌های Multimedia Builder

حفاظت از فیلم ها

حفاظت از فایل‌های PDF ، بر اساس کد‌فعالسازی برای هر فایل متناسب با شماره سریال سخت افزاری

تولید فایل‌های EXE از فایل های PDF بدون امکان چاپ و ذخیره PDF to EXE (pdf2exe)

حفاظت از فایل های پاورپوینت

حفاظت از فایل‌های اکسل Excel، بر اساس تبدیل فایل به EXE

حفاظت از کدهاي برنامه نويسي شده در محيط VBA-Access

تغيير تصوير بک گراند صفحه ورود به Windows 7

بروزآوري آيکن هاي ويندوز Refresh Desktop Icons

فلوچارت و الگوریتم Flowgorithm

تکنیک‌های ماکرونویسی در Powerpoint

نرم افزار نمایش محتوای فایل vcf به خصوص فایل های vcf موبایل

تغییر وضوح اسلاید پاورپوینت در استخراج با فرمت تصویر PNG و JPG

ماشین حساب جبری

ماشین حساب گرافیکی

ماشین حساب هندسی

سامانه نمایش آنلاین کارنامه

دانلود کد PHP نمایش آنلاین کارنامه های PDF

قفل کردن Google Chrome (chromeblocker)

نرم‌افزار تبدیل فایل‌های WEBP به PNG تنها با یک راست کلیک


tavvafi@gmail.com
contact

ارتباط با ما در شبکه‌های اجتماعی داخلی:


scrolltop