Microsoft Office Excel ® Kod Kılavuzu

Microsoft Office Excel® Code Guide

1 Kasım 2009 Pazar

Analog and digital time to run on the page

'Module1

Option Explicit
'Örnek Saat Kadranı [Example Clock Face];
'http://3.bp.blogspot.com/-Cl2FNVk0KcE/UQFJU-E3akI/AAAAAAAADRQ/nnL4m_rjuQs/s1600/Kadran_01.bmp
'http://1.bp.blogspot.com/-hc9AO7VcT-I/UQFJZRXjUVI/AAAAAAAADRY/BKmbTcxgV7g/s1600/Kadran_02.bmp
'http://4.bp.blogspot.com/-kMJ2Dfgfays/UQFJbYyovtI/AAAAAAAADRg/gltNV0bi5j8/s1600/Kadran_03.bmp
'http://4.bp.blogspot.com/-VHr2gq46iGA/UQFJcBCfYJI/AAAAAAAADRk/TJX4-Jp5DnY/s1600/Kadran_04.bmp

'http://2.bp.blogspot.com/-QfFalweC0ZE/UQFJl01GUoI/AAAAAAAADSA/LHZTob3nRbM/s1600/Kadran_05.bmp
'http://2.bp.blogspot.com/-iY64KWPxHrY/UQFJewYK_VI/AAAAAAAADRw/kAnJgsdaR1o/s1600/Kadran_06.bmp
'http://4.bp.blogspot.com/-Jsh1Z0rJp7Q/UQFJjg6A_VI/AAAAAAAADR4/bC_UybNnFZE/s1600/Kadran_07.bmp
'http://3.bp.blogspot.com/-TmrR6F1sO1Y/UQFJtbKhDGI/AAAAAAAADSI/FIZ7GbGwJPU/s1600/Kadran_08.bmp

Dim Durum As Boolean
Sub Analog_Start() 'Analog Saati Yap ve Başlat
    On Error Resume Next
    Durum = False
    ActiveSheet.Shapes("AnalogSaat").Delete
    Call Analog_Create
    With ActiveSheet.Shapes("AnalogSaat")
        .GroupItems(2).Rotation = 0
        .GroupItems(3).Rotation = 0
        .GroupItems(4).Rotation = 0
    End With
    Durum = True
    Call Analog_Run
End Sub
Sub Analog_Stop() 'Analog Saati Durdur

    On Error Resume Next
    Durum = False
    Call Analog_Run
End Sub
Private Sub Analog_Run() 'Çalıştır

    On Error Resume Next
    If Durum = False Then End
    With ActiveSheet.Shapes("AnalogSaat")
        .GroupItems(2).Rotation = (VBA.Second(VBA.Time) * 6) - (15 * 6)
        .GroupItems(3).Rotation = (VBA.Minute(VBA.Time) * 6) - (15 * 6)
        .GroupItems(4).Rotation = (VBA.Hour(VBA.Time) * 30) - (15 * 30) + (VBA.Minute(VBA.Time) / 60) * 30
        .GroupItems(5).TextEffect.Text = VBA.Time
    End With
    DoEvents
    Application.OnTime Now + TimeValue("00:00:1"), "Analog_Run"
End Sub
Private Sub Analog_Create() 'Analog Saati Yap

    On Error Resume Next
    ActiveSheet.Shapes.AddShape(msoShapeOval, 194.25, 263.25, 142.5, 154.5).Name = "Kadran"
    With ActiveSheet.Shapes("Kadran")
        With .Fill
            .Visible = msoFalse
            .Solid
            .Transparency = 0#
            .Visible = msoTrue
            .UserPicture "D:\Kadran_04.bmp"
            .ForeColor.RGB = RGB(232, 232, 232)
            .BackColor.RGB = RGB(255, 255, 255)
        End With
        With .Line
            .Weight = 0#
            .DashStyle = msoLineSolid
            .Style = msoLineSingle
            .Transparency = 0#
            .Visible = msoTrue
            .ForeColor.RGB = RGB(232, 232, 232)
            .BackColor.RGB = RGB(255, 255, 255)
        End With
        .LockAspectRatio = msoFalse
        .Height = 113.25
        .Width = 113.25
        .Rotation = 0#
    End With
    ActiveSheet.Shapes.AddLine(193.5, 319.5, 301.5, 319.5).Name = "Saniye"
    With ActiveSheet.Shapes("Saniye")
        With .Line
            .Weight = 0.75
            .DashStyle = msoLineSolid
            .Style = msoLineSingle
            .Transparency = 40#
            .Visible = msoTrue
            .ForeColor.RGB = RGB(255, 0, 0)
            .BackColor.RGB = RGB(255, 255, 255)
            .BeginArrowheadStyle = msoArrowheadNone
            .EndArrowheadStyle = msoArrowheadOpen
        End With
        .LockAspectRatio = msoFalse
        .Height = 0.75
        .Width = 69#
        .Rotation = 0#
    End With
    ActiveSheet.Shapes.AddLine(193.5, 319.5, 301.5, 319.5).Name = "Dakika"
    With ActiveSheet.Shapes("Dakika")
        With .Line
            .Weight = 0.75
            .DashStyle = msoLineSolid
            .Style = msoLineSingle
            .Transparency = 40#
            .Visible = msoTrue
            .ForeColor.RGB = RGB(0, 0, 255)
            .BackColor.RGB = RGB(255, 255, 255)
            .BeginArrowheadStyle = msoArrowheadNone
            .EndArrowheadStyle = msoArrowheadOpen
        End With
        .LockAspectRatio = msoFalse
        .Height = 0#
        .Width = 69#
        .Rotation = 0#
    End With
    ActiveSheet.Shapes.AddLine(193.5, 319.5, 301.5, 319.5).Name = "Saat"
    With ActiveSheet.Shapes("Saat")
        With .Line
            .Weight = 0.75
            .DashStyle = msoLineSolid
            .Style = msoLineSingle
            .Transparency = 40#
            .Visible = msoTrue
            .ForeColor.RGB = RGB(0, 0, 0)
            .BackColor.RGB = RGB(255, 255, 255)
            .BeginArrowheadStyle = msoArrowheadNone
            .EndArrowheadStyle = msoArrowheadOpen
        End With
        .LockAspectRatio = msoFalse
        .Height = 0#
        .Width = 69#
        .Rotation = 0#
    End With
    ActiveSheet.Shapes.AddTextEffect(msoTextEffect10, "01:01:01", "Arial Black", 18#, msoFalse, msoFalse, 661.5, 315.75).Name = "DigitalSaat"
    With ActiveSheet.Shapes("DigitalSaat")
        With .Line
            .Weight = 0.75
            .DashStyle = msoLineSolid
            .Style = msoLineSingle
            .Transparency = 0#
            .Visible = msoTrue
            .ForeColor.RGB = RGB(232, 232, 232)
            .BackColor.RGB = RGB(255, 255, 255)
        End With
        With .Fill
            .Visible = msoFalse
            .Solid
            .Transparency = 0#
            .Visible = msoTrue
            .UserPicture ""
            .ForeColor.RGB = RGB(255, 255, 255)
            .BackColor.RGB = RGB(255, 255, 255)
        End With
        .LockAspectRatio = msoFalse
        .Height = 17.25
        .Width = 113
        .Rotation = 0#
    End With
    With ActiveSheet.Shapes("Saniye")
        .Left = ActiveSheet.Shapes("Kadran").Left + (ActiveSheet.Shapes("Kadran").Width - .Width) / 2
        .Top = ActiveSheet.Shapes("Kadran").Top + (ActiveSheet.Shapes("Kadran").Height - .Height) / 2
    End With
    With ActiveSheet.Shapes("Dakika")
        .Left = ActiveSheet.Shapes("Kadran").Left + (ActiveSheet.Shapes("Kadran").Width - .Width) / 2
        .Top = ActiveSheet.Shapes("Kadran").Top + (ActiveSheet.Shapes("Kadran").Height - .Height) / 2
    End With
    With ActiveSheet.Shapes("Saat")
        .Left = ActiveSheet.Shapes("Kadran").Left + (ActiveSheet.Shapes("Kadran").Width - .Width) / 2
        .Top = ActiveSheet.Shapes("Kadran").Top + (ActiveSheet.Shapes("Kadran").Height - .Height) / 2
    End With
    With ActiveSheet.Shapes("DigitalSaat")
        .Left = ActiveSheet.Shapes("Kadran").Left
        .Top = ActiveSheet.Shapes("Kadran").Top + ActiveSheet.Shapes("Kadran").Height
    End With
    With ActiveSheet.Shapes
        .Range(Array("Kadran", "Saniye", "Dakika", "Saat", "DigitalSaat")).Group.Name = "AnalogSaat"
        .Range(Array("AnalogSaat")).Select
        .Range(Array("DigitalSaat")).Select
        Selection.ShapeRange.Shadow.Type = msoShadow21
        .Range(Array("Kadran")).Select
        Selection.ShapeRange.Shadow.Type = msoShadow21
        .Range(Array("Saniye")).Select
        With Selection.ShapeRange
            .ThreeD.BevelTopType = msoBevelCircle
            .ThreeD.BevelTopInset = 6
            .ThreeD.BevelTopDepth = 6
            .Shadow.Type = msoShadow21
        End With
        .Range(Array("Dakika")).Select
        With Selection.ShapeRange
            .ThreeD.BevelTopType = msoBevelCircle
            .ThreeD.BevelTopInset = 6
            .ThreeD.BevelTopDepth = 6
            .Shadow.Type = msoShadow21
        End With
        .Range(Array("Saat")).Select
        With Selection.ShapeRange
            .ThreeD.BevelTopType = msoBevelCircle
            .ThreeD.BevelTopInset = 6
            .ThreeD.BevelTopDepth = 6
            .Shadow.Type = msoShadow21
        End With
        Range("A1").Select
    End With
End Sub

Hiç yorum yok:

Blog Arşivi

Bu gadget'ta bir hata oluştu

Bu Blogda Ara

Contributor

Contributor
Mustafa ULUSARAÇ İstanbul, TÜRKİYE
free counters
T. C. Central Bank Indicative Exchange Rates
Currency Exchange Rate Widget,Currency Converter Widget
Borsa İstanbul