Makro ile Tarih Alma

[aoeflatun]

Excel sayfasında herhangi bir hücreye "=bugün()" yazdığımızda bugünkü tarihi veriyor. Ekranın altındaki saat kısmından tarihi değiştirince excelde değişiyor.

Bilgisayarın tarihini değiştirsen dahi (alt köşeden) bugünkü tarihi verecek bir makro arıyorum.
Yardımlarınız için teşekkür ederim.

 

[systran]

bilgisayarda internet varsa dediğiniz olabilir, internet yoksa mümkün değil, çünkü bugün() fonksiyonu sistem tarihine bakar.
internet varsa aşağıdaki kodları bir modul içine kopyalayın. formül olarak istediğiniz hücreye =gerçek_bugün() giriniz.

Function gerçek_bugün()
'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'
'
'   The GetiNetTime macro is written by Karthikeyan T.
'
'   Please Note: Original code adjusted here for setting Indian Standard Time,
'   India Standard Time (IST) = GMT+5:30
'   Time adjusted for BST by setting  the 'Hr' variable = 1 to get GMT+1
'
'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'

Dim ws
Dim http
Dim GMT_Time, NewNow, NewDate, NewTime, Hr, Mn ', Sc

'Below line wont work since clock providers changed the URL.
'Const GMTTime As String = "http://wwp.greenwichmeantime.com/time/scripts/clock-8/runner.php"


'Updated URL to fetch internet time ***
'Macro updated Date & Time: 27-Oct-12 1:07 PM

Const GMTTime As String = "http://wwp.greenwichmeantime.com/time-zone/europe/turkey/ankara/"

On Error Resume Next
Set http = CreateObject("Microsoft.XMLHTTP")

http.Open "GET", GMTTime & Now(), False, "", ""
http.Send

GMT_Time = http.getResponseHeader("Date")
GMT_Time = Mid$(GMT_Time, 6, Len(GMT_Time) - 9)


'NewNow = DateAdd("h", Hr, GMT_Time) 'Adding 5 Hours to GMT.
'NewNow = DateAdd("n", Mn, NewNow)   'Adding 30 Minutes to GMT.
'NewNow = DateAdd("s", Sc, NewNow)  'Adding 0 Seconds to GMT.

'MsgBox "Current Date & Time is:  GMT " & GMT_Time, vbOKOnly, "GetiNetTime"
gercek_bugün = GMT_Time
'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'
'
'   If you want to insert the new date & time in excel worksheet just unquote
'   the following lines,
'
'   Sheets("Sheet1").Select
'   Range("A1").Select
'   ActiveCell.Value = NewNow
'
'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'

'Insert current date & time in cell on selected worksheet.
'Sheets("Sheet1").Select        'Select worksheet as you like
'Range("A1").Select             'Change the destination as you like
'ActiveCell.Value = NewNow

'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'
'
'   If you want to change the system time just unquote the following lines,
'
'   Set ws = CreateObject("WScript.Shell")
'   NewDate = DateValue(NewNow)
'   NewTime = Format(TimeValue(NewNow), "hh:mm:ss")
'   ws.Run "%comspec% /c time " & NewTime, 0
'   ws.Run "%comspec% /c date " & NewDate, 0
'   Set ws = Nothing
'
'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'*'

'Set ws = CreateObject("WScript.Shell")
'Split out date.
'NewDate = DateValue(NewNow)

'Split out time.
'NewTime = Format(TimeValue(NewNow), "hh:mm:ss")

'Run DOS Time command in hidden window.
'ws.Run "%comspec% /c time " & NewTime, 0

'Run DOS Date command in hidden window.
'ws.Run "%comspec% /c date " & NewDate, 0

Cleanup:
'Set ws = Nothing
Set http = Nothing


End Function

kodun orjinali:
http://stackoverflow.com/questions/16190812/pickup-time-from-internet-servers-vba-excel

İLAVE: tam olarak düzgün çalışmıyor ama sorunun çözümü için fikir olabilir.

 

[aoeflatun]

Teşekkür

Yardımlarınız için teşekkür ederim. İnternet olduğu halde hala dediğim problemi çözemedim.

 

[Murat OSMA]

Şu kodları deneyin;

[FONT="Trebuchet MS"]Public Function istanbul()
    Set http = CreateObject("MsXml2.XmlHttp")
    Set doc = CreateObject("HtmlFile")
    http.Open "get", "[COLOR="Red"]http://tr.thetimenow.com/turkey/istanbul[/COLOR]", False
    SendKeys "{ENTER}"
    http.send
    doc.write http.responsetext
    http.abort
    istanbul = doc.getelementbyid("[COLOR="red"]main_time[/COLOR]").innertext
    doc.Close
    Set doc = Nothing: Set http = Nothing
End Function[/FONT]

Hücreye =istanbul() yazın.