RedrawWindow

'Workbook Module

'Windows XP® Office 2003® Normal Referance List

'1) Name: VBA, Description: Visual Basic For Applications, FullPath: C:\Program Files\Common Files\Microsoft Shared\VBA\VBA6\VBE6.DLL
'2) Name: Excel, Description: Microsoft Excel 11.0 Object Library, FullPath: C:\Program Files\Microsoft Office\OFFICE11\EXCEL.EXE
'3) Name: stdole, Description: OLE Automation, FullPath: C:\WINDOWS\system32\STDOLE2.TLB
'4) Name: Office, Description: Microsoft Office 11.0 Object Library, FullPath: C:\Program Files\Common Files\Microsoft Shared\OFFICE11\MSO.DLL
'5) Name: MSForms, Description: Microsoft Forms 2.0 Object Library, FullPath: C:\WINDOWS\system32\FM20.DLL

Private Sub Workbook_Open()

On Error Resume Next
Saat_Göster Hedef_Hücre:=Range("F12")

End Sub
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)

On Error Resume Next
KillTimer 0, Sayaç
Sayaç = 0

End Sub
Private Sub Workbook_BeforeClose(Cancel As Boolean)

On Error Resume Next
InvalidateRect 0, 0, 0
KillTimer 0, Sayaç
Sayaç = 0

End Sub

'Module1

Option Explicit
Private Type POSITION

X As Long
Y As Long

End Type
Private tP As POSITION, tPt As POSITION
Private Type LOCATION

Left As Long
Top As Long
Right As Long
Bottom As Long

End Type
Private tL As LOCATION
Private Type LOGFONT

fHeight As Long
fWidth As Long
fEscapement As Long
fOrientation As Long
fWeight As Long
fItalic As Byte
fUnderline As Byte
fStrikeOut As Byte
fCharSet As Byte
fOutPrecision As Byte
fClipPrecision As Byte
fQuality As Byte
fPitchAndFamily As Byte
fFaceName As String * 72

End Type
Private tF As LOGFONT
Private Declare Function CreateEllipticRgn Lib "gdi32" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
Private Declare Function CreateFontIndirect Lib "gdi32" Alias "CreateFontIndirectA" (lpLogFont As LOGFONT) As Long
Private Declare Function CreatePen Lib "gdi32" (ByVal nPenStyle As Long, ByVal nWidth As Long, ByVal crColor As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function DrawText Lib "user32" Alias "DrawTextA" (ByVal hdc As Long, ByVal lpStr As String, ByVal nCount As Long, lpRect As LOCATION, ByVal wFormat As Long) As Long
Private Declare Function FindWindow Lib "user32.dll" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function GetDC Lib "user32.dll" (ByVal hwnd As Long) As Long
Private Declare Function GetDeviceCaps Lib "gdi32.dll" (ByVal hdc As Long, ByVal nIndex As Long) As Long
Private Declare Function GetForegroundWindow Lib "user32" () As Long
Public Declare Function InvalidateRect Lib "user32" (ByVal hwnd As Long, lpRect As Long, ByVal bErase As Long) As Long
Public Declare Function KillTimer Lib "user32.dll" (ByVal hwnd As Long, ByVal nIDEvent As Long) As Long
Private Declare Function LineTo Lib "gdi32" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long) As Long
Private Declare Function MoveToEx Lib "gdi32" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long, lpPoint As POSITION) As Long
Private Declare Function RedrawWindow Lib "user32" (ByVal hwnd As Long, ByVal lprcUpdate As Long, ByVal hrgnUpdate As Long, ByVal fuRedraw As Long) As Long
Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare Function SetBkMode Lib "gdi32" (ByVal hdc As Long, ByVal nBkMode As Long) As Long
Private Declare Function SetPixel Lib "gdi32" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long, ByVal crColor As Long) As Long
Private Declare Function SetRect Lib "user32" (lpRect As LOCATION, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
Private Declare Function SetTimer Lib "user32.dll" (ByVal hwnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long
Private i As Long
Private Const PI As Single = 3.14159265358979
Private NWP As Range
Private Sayaç As Long
Private X1 As Long, Y1 As Long, X2 As Long, Y2 As Long, A2 As Long, B2 As Long
Private Nesne As Long
Private Kadran As Long
Private NF As Long
Private mX, mY As Double
Public Sub Saat_Göster(Hedef_Hücre As Range)

If Sayaç = 0 Then

Set NWP = ActiveWindow.VisibleRange.Cells(1, 1)
If Union(Hedef_Hücre, ActiveWindow.VisibleRange).Address <> ActiveWindow.VisibleRange.Address Then

GoTo Hata:

End If
tP = Noktalama(Hedef_Hücre)
Sayaç = SetTimer(0, 0, 1000, AddressOf Saat_Kur)

End If
Exit Sub
Hata:
MsgBox "Hedef hücre görünür değil...", vbCritical

End Sub
Private Sub Saat_Kur()

On Error Resume Next
If GetForegroundWindow = FindWindow("XLMAIN", Application.Caption) Then

If ActiveWindow.VisibleRange.Cells(1, 1).Address <> NWP.Address Then

InvalidateRect 0, 0, 0
DoEvents

End If
Call Saat_Yapma
Call Saat_Ayarlama

End If

End Sub
Private Sub Saat_Yapma()

On Error Resume Next
X1 = tP.X: Y1 = tP.Y
Nesne = GetDC(0)
SetBkMode Nesne, 1
Call Alfabe(Nesne, True)
For Kadran = 0 To 359

For i = 1 To 18

X2 = (64 + i) * Sin(Kadran * PI / 180)
Y2 = (64 + i) * Cos(Kadran * PI / 180)
SetPixel Nesne, X2 + X1, Y2 + Y1, VBA.RGB(0, 0, 255)

Next i
For i = 1 To 12

X2 = (64 + i) * Sin(Kadran * PI / 180)
Y2 = (64 + i) * Cos(Kadran * PI / 180)
SetPixel Nesne, X2 + X1, Y2 + Y1, VBA.RGB(0, 140, 255)

Next i
A2 = 60 * 80 / 100 * Sin(Kadran * PI / 180)
B2 = 60 * 80 / 100 * Cos(Kadran * PI / 180)
SetRect tL, A2 + X1 - 5, B2 + Y1 - 5, A2 + X1 + 5, B2 + Y1 + 5
Select Case Kadran

Case Is = 0: DrawText Nesne, "6", 1, tL, &H1
Case Is = 30: DrawText Nesne, "5", 1, tL, &H1
Case Is = 60: DrawText Nesne, "4", 1, tL, &H1
Case Is = 90: DrawText Nesne, "3", 1, tL, &H1
Case Is = 120: DrawText Nesne, "2", 1, tL, &H1
Case Is = 150: DrawText Nesne, "1", 1, tL, &H1
Case Is = 180: DrawText Nesne, "12", 2, tL, &H1
Case Is = 210: DrawText Nesne, "11", 2, tL, &H1
Case Is = 240: DrawText Nesne, "10", 2, tL, &H1
Case Is = 270: DrawText Nesne, "9", 1, tL, &H1
Case Is = 300: DrawText Nesne, "8", 1, tL, &H1
Case Is = 330: DrawText Nesne, "7", 1, tL, &H1

End Select

Next Kadran

End Sub
Private Sub Saat_Ayarlama()

On Error Resume Next
RedrawWindow 0, 0, CreateEllipticRgn(X1 - 60 * 70 / 100, Y1 - 60 * 70 / 100, X1 + 60 * 70 / 100, Y1 + 60 * 70 / 100), &H1 + &H80
DoEvents
MoveToEx Nesne, X1, Y1, tPt 'Saniye
DeleteObject SelectObject(Nesne, CreatePen(0, 1, vbRed))
LineTo Nesne, X1 + ((60 * 70 / 100) * 0.85 * Sin(VBA.Second(Time) * (2 * PI / 60))), Y1 - ((60 * 70 / 100) * 0.85 * Cos(VBA.Second(Time) * (2 * PI / 60)))
MoveToEx Nesne, X1, Y1, tPt 'Dakika
DeleteObject SelectObject(Nesne, CreatePen(0, 2, vbBlack))
LineTo Nesne, X1 + (60 * 70 / 100) * Sin((VBA.Minute(Time) + (VBA.Second(Time) / 60)) * (2 * PI / 60)) * 0.8, Y1 - (60 * 70 / 100) * Cos((VBA.Minute(Time) + (VBA.Second(Time) / 60)) * (2 * PI / 60)) * 0.8
MoveToEx Nesne, X1, Y1, tPt 'Saat
DeleteObject SelectObject(Nesne, CreatePen(0, 4, vbBlack))
LineTo Nesne, X1 + (60 * 80 / 100) * Sin((VBA.Hour(Time) + (VBA.Minute(Time) / 60)) * (2 * PI / 12)) * 0.5, Y1 - (60 * 80 / 100) * Cos((VBA.Hour(Time) + (VBA.Minute(Time) / 60)) * (2 * PI / 12)) * 0.5
Set NWP = ActiveWindow.VisibleRange.Cells(1, 1)
ReleaseDC 0, Nesne

End Sub
Private Function Noktalama(Hücre As Range) As POSITION

On Error Resume Next
Nesne = GetDC(0)
mX = Hücre.Left + (Hücre.Width / 2)
mY = Hücre.Top + (Hücre.Height / 2)
With Noktalama

.X = ActiveWindow.PointsToScreenPixelsX((mX) * (GetDeviceCaps(Nesne, 88) / 72 * ActiveWindow.Zoom / 100))
.Y = ActiveWindow.PointsToScreenPixelsY((mY) * (GetDeviceCaps(Nesne, 90) / 72 * ActiveWindow.Zoom / 100))

End With
ReleaseDC 0, Nesne

End Function
Private Sub Alfabe(Seçilen_Nesne As Long, Optional Koyuluk As Boolean)

On Error Resume Next
With tF

.fFaceName = "Arial" & VBA.Chr$(0)
.fHeight = 12
.fWidth = 6
.fWeight = VBA.IIf(Koyuluk, 100, 100)

End With
NF = CreateFontIndirect(tF)
DeleteObject SelectObject(Seçilen_Nesne, NF)

End Sub
'Sub References_List()

' On Error Resume Next
' Dim Eleman, No
' No = 1
' For Each Eleman In ThisWorkbook.VBProject.References

' Sheets(1).Cells(No, 1) = No & ") Name: "
' Sheets(1).Cells(No, 2) = Eleman.Name
' Sheets(1).Cells(No, 3) = ", Description: "
' Sheets(1).Cells(No, 4) = Eleman.Description
' Sheets(1).Cells(No, 5) = ", FullPath: "
' Sheets(1).Cells(No, 6) = Eleman.FullPath
' No = No + 1

' Next Eleman

'End Sub