دعوة لتجربة التعديل لجلب الوقت والتاريخ من جهاز على الشبكة المحلية

[ابو جودي]

هذه الدوال كانت تعمل على النواة 32 بدون اى مشاكل ولكن لم تعمل مع النواة 64

تمت التعديلات اللازمة على الكود للعمل على النواتان 32,64 بيت

تم التجربة الشخصية والتأكد من فاعلية هذه التعديلات على ويندوز 64 بيت اوفيس 64 بيت 

فضلا وليس امرا فى انتظار ارائكم والردود بعد التجربة على انوية مختلفة للتأكد من فاعلية التعديل 

 

Option Compare Database
Option Explicit

#If Win64 Then
    ' Declare functions for 64-bit Windows
    Private Declare PtrSafe Function NetRemoteTOD Lib "Netapi32.dll" ( _
        bServer As Any, pBuffer As LongPtr) As Long
    Private Declare PtrSafe Function NetApiBufferFree Lib "Netapi32.dll" (ByVal lpBuffer As LongPtr) As Long
#Else
    ' Declare functions for 32-bit Windows
    Private Declare Function NetRemoteTOD Lib "Netapi32.dll" ( _
        bServer As Any, pBuffer As Long) As Long
    Private Declare Function NetApiBufferFree Lib "Netapi32.dll" (ByVal lpBuffer As Long) As Long
#End If

#If VBA7 Then
    ' Declare functions for VBA7 (Office 2010 and later)
    Private Declare PtrSafe Function GetTimeZoneInformation Lib "kernel32" (lpTimeZoneInformation As TIME_ZONE_INFORMATION) As Long
    Private Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As LongPtr)
#Else
    ' Declare functions for earlier versions of VBA
    Private Declare Function GetTimeZoneInformation Lib "kernel32" (lpTimeZoneInformation As TIME_ZONE_INFORMATION) As Long
    Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
#End If

' Define custom data types for SYSTEMTIME, TIME_ZONE_INFORMATION, and TimeOfDayInfo
Private Type SYSTEMTIME
    wYear As Integer
    wMonth As Integer
    wDayOfWeek As Integer
    wDay As Integer
    wHour As Integer
    wMinute As Integer
    wSecond As Integer
    wMilliseconds As Integer
End Type

Private Type TIME_ZONE_INFORMATION
    Bias As Long
    StandardName(32) As Integer
    StandardDate As SYSTEMTIME
    StandardBias As Long
    DaylightName(32) As Integer
    DaylightDate As SYSTEMTIME
    DaylightBias As Long
End Type

Private Type TimeOoDayInfo
    tod_elapsedt As Long
    tod_msecs As Long
    tod_hours As Long
    tod_mins As Long
    tod_secs As Long
    tod_hunds As Long
    tod_timezone As Long
    tod_tinterval As Long
    tod_day As Long
    tod_month As Long
    tod_year As Long
    tod_weekday As Long
End Type

' Constant for success code
Private Const NERR_SUCCESS As Long = 0

' Constant for default time indicating failure
Private Const DEFAULT_TIME As Date = #12:00:00 AM#

Public myIP As String

' Function to get Time Of Day from a remote server
Private Function GetTOD(ByVal Server As String) As Date
    #If VBA7 Then
        Dim lngBufPtr As LongPtr
    #Else
        Dim lngBufPtr As Long
    #End If

    Dim bytServer() As Byte
    Dim todReturned As TimeOoDayInfo
    Dim success As Boolean

    On Error Resume Next

    ' Convert server string to null-terminated byte array
    bytServer = Trim$(Server) & vbNullChar

    ' Call NetRemoteTOD function and check for success
    success = NetRemoteTOD(bytServer(0), lngBufPtr) = NERR_SUCCESS

    On Error GoTo 0

    If success Then
        ' Copy memory and free buffer
        CopyMemory todReturned, ByVal lngBufPtr, LenB(todReturned)
        NetApiBufferFree lngBufPtr

        ' Calculate date and time from TimeOoDayInfo structure
        With todReturned
            GetTOD = DateAdd("n", _
                             -.tod_timezone, _
                             DateSerial(.tod_year, .tod_month, .tod_day) _
                           + TimeSerial(.tod_hours, .tod_mins, .tod_secs))
        End With
    Else
        ' Return default time in case of failure
        GetTOD = DEFAULT_TIME
    End If
End Function

' Subroutine to get remote time and display a message
Public Function GetRemoteTime(ByVal ServerIP As String)
    
    Dim d As Date
    ' Call GetTOD function with a sample IP address
    d = GetTOD(ServerIP)

    ' Check if the returned time is the default time indicating failure
    If d = DEFAULT_TIME Then
        ' Display an error message
        MsgBox "Failed to get remote time. Please check the IP address or ensure the server is reachable.", vbExclamation
    Else
        ' Print the remote time to the Debug window
        GetRemoteTime = d
        Debug.Print d
    End If
End Function


Sub Test_setIP()
    myIP = "192.168.0.133"
    Call GetRemoteTime(myIP)
End Sub

طبعا لابد من تعديل الـ Ip  بجهاز اخر على الشبكة المحلية 

myIP = "192.168.0.133"

[ابوخليل]

صباح الخير ابا جودي

ستكون الردود هنا شحيحة ، لأن التجربة ستكون لمن يملك أو يعمل على شبكة محلية

[ابو جودي]

8 دقائق مضت, ابوخليل said:

صباح الخير ابا جودي

ستكون الردود هنا شحيحة ، لأن التجربة ستكون لمن يملك أو يعمل على شبكة محلية

صباح الخيرات 

كان يسأل عنه من قبل بعض الاخوة الاحباب