Soru Vba internet bağlantısı

[Cengizhantr06]

Merhaba iyi aksamlar herkese
Vba da açılış da internet bağlantısı yoksa dosya açılmasın
Böyle bir kod varmı acaba yardımcı olur musunuz?

 

[ÖmerBey]

Merhaba,
Boş bir modüle kopyaladıktan sonra kaydedip kapatınız.

Private Declare Function InternetGetConnectedState Lib "wininet.dll" _
(ByRef dwflags As Long, ByVal dwReserved As Long) As Long

Public Function GetInternetConnectedState() As Boolean
  GetInternetConnectedState = InternetGetConnectedState(0&, 0&)
End Function

Sub Auto_Open()
If GetInternetConnectedState = False Then
    ThisWorkbook.Close 0
End If
End Sub

Kaynak:

Check for active internet connection

Wrote a small app that accesses a bunch of search websites and puts the results in a word document, which gets run a few hundred times a day. It saves individual search results in a number of local

stackoverflow.com

 

[ÖmerBey]

64 bit hata olmaması için sanırım şöyle olacak:

#If VBA7 Then
    Private Declare PtrSafe Function InternetGetConnectedState Lib "wininet.dll" _
    (ByRef dwflags As LongPtr, ByVal dwReserved As LongPtr) As LongPtr
#Else
    Private Declare Function InternetGetConnectedState Lib "wininet.dll" _
    (ByRef dwflags As Long, ByVal dwReserved As Long) As Long
#End If

 

[Cengizhantr06]

Merhaba,
Boş bir modüle kopyaladıktan sonra kaydedip kapatınız.

Private Declare Function InternetGetConnectedState Lib "wininet.dll" _
(ByRef dwflags As Long, ByVal dwReserved As Long) As Long

Public Function GetInternetConnectedState() As Boolean
  GetInternetConnectedState = InternetGetConnectedState(0&, 0&)
End Function

Sub Auto_Open()
If GetInternetConnectedState = False Then
    ThisWorkbook.Close 0
End If
End Sub

Kaynak:

Check for active internet connection

Wrote a small app that accesses a bunch of search websites and puts the results in a word document, which gets run a few hundred times a day. It saves individual search results in a number of local

stackoverflow.com

Çok teşekkür ederim Ömer bey

 

[Cengizhantr06]

64 bit için sanırım şöyle olacak:

Private Declare PtrSafe Function InternetGetConnectedState Lib "wininet.dll" _
(ByRef dwflags As LongPtr, ByVal dwReserved As LongPtr) As LongPtr

Excel 32 bit ama Windows 64 bit hangisini kullanacağız Ömer bey ?

 

[ÖmerBey]

Önemli olan Excel versiyonu.
3 nolu mesajdaki kodu değiştirdim. Her ikisi için de kullanılabilir. (Tabi hata yapmadıysam. 64 bitte denemedim)

 

[Cengizhantr06]

Önemli olan Excel versiyonu.
3 nolu mesajdaki kodu değiştirdim. Her ikisi için de kullanılabilir. (Tabi hata yapmadıysam. 64 bitte denemedim)

Çok teşekkür ederim Ömer bey deneyince haber ederim işiniz rast gelsin hayırlı akşamlar

 

[ÖmerBey]

Rica ederim,
İyi dilekleriniz için de ben teşekkür ederim.
Hayırlı akşamlar, hayırlı çalışmalar...

 

[Cengizhantr06]

@ÖmerBey şöyle bişey yapabilirmiyiz

Sub demo()

Dim saat1 As Date

Dim saat2 As Date

saat1 = "15/10/2005"

saat2 = Date

If saat2 > saat1 Then

MsgBox ("Süreniz dolmuş üzgünüm.")

ActiveWorkbook.Close

End If

MsgBox ("Kullanım için " & saat1 - saat2 & " gününüz kalmıştır.") If sure1 = sure2 Then

MsgBox "Bu gün SON GÜN"

End If

End Sub

Bu kod tarihi sorgusunu internet tarihine göre baz alabilirmi mesala internet bağlantısı yoksa yine kapansın bilgisayar tarihi değilde internet tarihi baz alsın olurmu böyle bir kod

 

[ÖmerBey]

Bu kod tarihi sorgusunu internet tarihine göre baz alabilirmi mesala internet bağlantısı yoksa yine kapansın bilgisayar tarihi değilde internet tarihi baz alsın olurmu böyle bir kod

Olur ama ne kadar kullanışlı olur bilemem.
Örnek olarak aşağıdaki kodu paylaşıyorum, siz denersiniz.
Yeni bir dosya açıp ThisWorkbook kod kısmına kopyalayıp kaydedip kapatınız...

Private Sub Workbook_Open()
    Dim trh1 As Date
    Dim trh2 As Date
  
    On Error GoTo hata:
    trh1 = DateValue("25/12/2024")
  
    Set xmlHTTPReq = CreateObject("MSXML2.XMLHTTP")
    Set htmlDoc = CreateObject("HTMLFILE")

    strURL = "https://www.timeanddate.com/"
    With xmlHTTPReq
            .Open "GET", strURL, False
            .Send
        If .Status = 200 Then
            htmlDoc.body.innerHTML = .responsetext
            trh2 = DateValue(htmlDoc.getelementbyId("ij2").innertext)
            If trh2 > trh1 Then
                MsgBox ("Süreniz dolmuş üzgünüm.")
                ThisWorkbook.Close 0
            ElseIf trh2 = trh1 Then
                MsgBox "Bu gün son gün"
            Else
                MsgBox ("Kullanım için " & trh1 - trh2 & " gününüz kalmıştır.")
            End If
        Else
            ThisWorkbook.Close 0
        End If
    End With
Exit Sub
hata:
ThisWorkbook.Close 0
End Sub

Not: Bu tür uygulamalar çok kararlı çalışmaz. Bu yüzden sadece örnek olması açısından paylaşıyorum, herhangi bir hata oluşması durumunda yardımcı olamam.
İyi çalışmalar...

 

[Cengizhantr06]

Olur ama ne kadar kullanışlı olur bilemem.
Örnek olarak aşağıdaki kodu paylaşıyorum, siz denersiniz.
Yeni bir dosya açıp ThisWorkbook kod kısmına kopyalayıp kaydedip kapatınız...

Private Sub Workbook_Open()
    Dim trh1 As Date
    Dim trh2 As Date
 
    On Error GoTo hata:
    trh1 = DateValue("25/12/2024")
 
    Set xmlHTTPReq = CreateObject("MSXML2.XMLHTTP")
    Set htmlDoc = CreateObject("HTMLFILE")

    strURL = "https://www.timeanddate.com/"
    With xmlHTTPReq
            .Open "GET", strURL, False
            .Send
        If .Status = 200 Then
            htmlDoc.body.innerHTML = .responsetext
            trh2 = DateValue(htmlDoc.getelementbyId("ij2").innertext)
            If trh2 > trh1 Then
                MsgBox ("Süreniz dolmuş üzgünüm.")
                ThisWorkbook.Close 0
            ElseIf trh2 = trh1 Then
                MsgBox "Bu gün son gün"
            Else
                MsgBox ("Kullanım için " & trh1 - trh2 & " gününüz kalmıştır.")
            End If
        Else
            ThisWorkbook.Close 0
        End If
    End With
Exit Sub
hata:
ThisWorkbook.Close 0
End Sub

Not: Bu tür uygulamalar çok kararlı çalışmaz. Bu yüzden sadece örnek olması açısından paylaşıyorum, herhangi bir hata oluşması durumunda yardımcı olamam.
İyi çalışmalar...

Olsun Ömer bir deneyelim emeğinize sağlık çok çok teşekkür ederim

 

[Cengizhantr06]

@ÖmerBey kod güzel çalıştı süper lakin sizden son ricam şu iki kodu ekleyebilirmiyiz uğraştım yapamadım
son gün olunca aşağıdaki gibi kutu acılıp şifre girince dosya çalışmaya devam etsin

sifre = InputBox("Giriş için Şifre Girmelisiniz.", _
"Yetkili Kişi", "Proğrama girmek İçin Şifre giriniz.")
If sifre = "123" Then
MsgBox "Şifre doğru"



ondan sonrada şu kodlar çalışma kitabı içindeki work open içindeki kodu siliyor ve dosya lisanslanmış gibi normal kullanıma devam edecek


On Error Resume Next
i = 0

For Each moduller In ActiveWorkbook.VBProject.VBComponents
i = i + 1

If ActiveWorkbook.VBProject.VBComponents(i).Name = "BuÇalışmaKitabı" Then
ThisWorkbook.VBProject.VBComponents("BuÇalışmaKitabı").CodeModule.DeleteLines 1, _
ThisWorkbook.VBProject.VBComponents("BuÇalışmaKitabı").CodeModule.CountOfLines
End If


Next moduller