giúp em làm đồng hồ đếm ngược pp (1 người xem)

Liên hệ QC

Người dùng đang xem chủ đề này

gamegamegamegame

Thành viên hoạt động
Tham gia
5/6/15
Bài viết
144
Được thích
5
Sub dem_nguoc()


'Ma nguon duoc viet boi Bui Quang Hien

Dim oshp As Shape


Dim oshpRng As ShapeRange


Dim osld As Slide


Dim oeff As Effect


Dim i As Integer


Dim Iduration As Integer


Dim Istep As Integer


Dim dText As Date


Dim texttoshow As String


On Error GoTo errhandler


If ActiveWindow.Selection.ShapeRange.Count > 1 Then


MsgBox "Hay chon mot doi tuong la shape!"


Exit Sub


End If


Set osld = ActiveWindow.Selection.SlideRange(1)


Set oshp = ActiveWindow.Selection.ShapeRange(1)


oshp.Copy


'**************************************************


Istep = 1 'thoi gian nhay tung hinh


Iduration = 120 'so giay can dem


'**************************************************


For i = Iduration To 0 Step -Istep


Set oshpRng = osld.Shapes.Paste


With oshpRng


.Left = oshp.Left


.Top = oshp.Top


End With


dText = CDate(i \ 3600 & ":" & ((i Mod 3600) \ 60) & ":" & (i Mod 60))


If Iduration < 60 Then


texttoshow = Format(dText, "Ss")


Else


If Iduration < 3600 Then


texttoshow = Format(dText, "Nn:Ss")


Else


texttoshow = Format(dText, "Hh:Nn:Ss")


End If


End If


'Ma nguon duoc viet boi Bui Quang Hien

oshpRng(1).TextFrame.TextRange = texttoshow


Set oeff = osld.TimeLine.MainSequence _


.AddEffect(oshpRng(1), msoAnimEffectFlashOnce, , msoAnimTriggerAfterPrevious)


oeff.Timing.Duration = Istep


Next i


oshp.Delete


Exit Sub


errhandler:


MsgBox "**ERROR** - Ban chua chon doi tuong?"


'Ma nguon duoc viet boi Bui Quang Hien

End Sub
em tìm được một tai lieu trên mang về đồng hồ điểm ngược
không biết đoạn code trên có thể làm cho slide1 nhảy qua slide khác đc ko
xin mọi người góp ý giúp
 
Lần chỉnh sửa cuối:
Const Slide_Number = 1
Const Thoi_Gian = 10
Sub Dem_Nguoc()
Dim Ngung As Boolean, Dem As Integer, Gio_Cu As Single, Gio_Moi As Single, N As Integer
Ngung = False
Dem = Thoi_Gian
Gio_Cu = Int(Timer)
N = ActivePresentation.Slides(Slide_Number).Shapes.Count
ActivePresentation.Slides(Slide_Number).Shapes(N).TextFrame.TextRange.Text = Format(Dem, "00")
Do While Not Ngung
DoEvents
Gio_Moi = Int(Timer)
If Gio_Moi > Gio_Cu Then
Dem = Dem - 1
Gio_Cu = Gio_Moi
ActivePresentation.Slides(Slide_Number).Shapes(N).TextFrame.TextRange.Text = Format(Dem, "00")
If Dem = 0 Then
Ngung = True
End If
End If
Loop
End Sub




thêm một code này nữa của một thầy giáo trên mạng
nhưng ko hiểu sau nếu ko cài cái này vào
Private Sub CommandButton1_Click()
Dem_Nguoc
End Sub
thi code ko hieu
nhưng xóa CommandButton1_Click rồi run macro thì nó chạy
xin mọi người giải thích giúp em
 
Upvote 0
Web KT

Bài viết mới nhất

Back
Top Bottom