Instagram Hashtag Hk.

[dnmtnk]

Merhaba arkadaşlar. insagram hashtag sayfasındaki paylaşım sayısını excele yazdırmak istediğim bir kod var ancak gönderi sayısı bulunamadı şeklinde yazdırıyor, yani veriyi çekemiyor. Hatayı nerede yapıyorum var mı yardımcı olabilecek?

Sub HashtagSayfaGonderiSayilari()

    Dim DosyaAdi As String
    Dim DosyaYolu As String
    Dim DosyaTamAdi As String
    Dim DosyaIcerik As String
    Dim Satirlar() As String
    Dim hashtag As Variant
    Dim Satir As Long
    Dim GonderiSayisi As String
    
    ' Hashtag verilerinin bulunduğu dosyanın tam yolunu ve adını belirtin
    DosyaYolu = "C:\Users\PC02\Desktop\Hashtag\" ' Dosya yolunu güncelleyin
    DosyaAdi = "hashtags.txt" ' Dosya adını güncelleyin
    DosyaTamAdi = DosyaYolu & DosyaAdi
    
    ' Dosyanın var olup olmadığını kontrol edin
    If Dir(DosyaTamAdi) = "" Then
        MsgBox DosyaAdi & " dosyası bulunamadı!"
        Exit Sub
    End If
    
    ' Dosyanın içeriğini oku
    Open DosyaTamAdi For Input As #1
    DosyaIcerik = Input$(LOF(1), #1)
    Close #1
    
    ' Satırları diziye aktar
    Satirlar = Split(DosyaIcerik, vbCrLf)
    
    ' Verileri Excel'e yazdır
    Satir = 1
    For Each hashtag In Satirlar
        ' Hashtag verisi boş değilse işleme devam et
        If Trim(hashtag) <> "" Then
            GonderiSayisi = GetHashtagGonderiSayisi(hashtag)
            Cells(Satir, 1).Value = hashtag
            Cells(Satir, 2).Value = GonderiSayisi
            Satir = Satir + 1
        End If
    Next hashtag
    
    MsgBox "İşlem tamamlandı!"
    
End Sub

Function GetHashtagGonderiSayisi(ByVal hashtag As String) As String

    Dim url As String
    Dim HTMLContent As New HTMLDocument
    Dim GonderiSayisi As String
    
    url = "https://www.instagram.com/explore/tags/" & Replace(hashtag, "#", "")
    
    ' XMLHTTP nesnesini oluştur
    Dim XMLReq As Object
    Set XMLReq = CreateObject("MSXML2.XMLHTTP")
    
    ' İstek gönder
    XMLReq.Open "GET", url, False
    XMLReq.send
    
    ' Yanıtı al ve HTML içeriği olarak ayarla
    HTMLContent.body.innerHTML = XMLReq.responseText
    
    ' Gönderi sayısını içeren elementi bul
    Dim GonderiSayisiElem As Object
    Set GonderiSayisiElem = HTMLContent.getElementsByClassName("_ac2a")(0)
    
    ' Gönderi sayısını döndür
    If Not GonderiSayisiElem Is Nothing Then
        GetHashtagGonderiSayisi = GonderiSayisiElem.getElementsByTagName("span")(0).innerText
    Else
        GetHashtagGonderiSayisi = "Gönderi sayısı bulunamadı."
    End If
    
    ' Nesneleri temizle
    Set XMLReq = Nothing
    Set HTMLContent = Nothing

End Function

 

[Murat OSMA]

Merhaba,
Bu kodları deneyiniz.

Dim GonderiSayisi, satir
Sub HashtagSayfaGonderiSayilari()

    Dim DosyaAdi As String
    Dim DosyaYolu As String
    Dim DosyaTamAdi As String
    Dim DosyaIcerik As String
    Dim Satirlar() As String
    Dim hashtag As Variant
   
    ' Hashtag verilerinin bulunduğu dosyanın tam yolunu ve adını belirtin
    DosyaYolu = Environ("USERPROFILE") & "\Desktop\" ' Dosya yolunu güncelleyin
    DosyaAdi = "hashtags.txt" ' Dosya adını güncelleyin
    DosyaTamAdi = DosyaYolu & DosyaAdi
   
    ' Dosyanın var olup olmadığını kontrol edin
    If Dir(DosyaTamAdi) = "" Then
        MsgBox DosyaAdi & " dosyası bulunamadı!"
        Exit Sub
    End If
   
    ' Dosyanın içeriğini oku
    Open DosyaTamAdi For Input As #1
    DosyaIcerik = Input$(LOF(1), #1)
    Close #1
   
    ' Satırları diziye aktar
    Satirlar = Split(DosyaIcerik, vbCrLf)
   
    ' Verileri Excel'e yazdır
    satir = 1
    For Each hashtag In Satirlar
        ' Hashtag verisi boş değilse işleme devam et
        If Trim(hashtag) <> "" Then
            GonderiSayisi = GetHashtagGonderiSayisi(hashtag)
            Cells(satir, 1).Value = hashtag
            satir = satir + 1
        End If
    Next hashtag
   
    MsgBox "Islem tamamlandi!"
   
End Sub

Function GetHashtagGonderiSayisi(ByVal hashtag As String) As String

    Dim url As String
    Dim HTMLContent As New HTMLDocument
    url = "https://www.instagram.com/explore/tags/" & Replace(hashtag, "#", "")
   
    ' XMLHTTP nesnesini oluştur
    Dim XMLReq As Object
    Set XMLReq = CreateObject("MSXML2.XMLHTTP")
   
    ' İstek gönder
    XMLReq.Open "GET", url, False
    XMLReq.send
   
    ' Yanıtı al ve HTML içeriği olarak ayarla
    HTMLContent.body.innerHTML = XMLReq.responseText
    al = Split(HTMLContent.body.innerHTML, """om-et""><meta name=""description"" content='")
    GonderiSayisi = Replace(Split(al(1), " ")(0), "&nbsp;", "")
    Cells(satir, 2).Value = GonderiSayisi
    ' Nesneleri temizle
    Set XMLReq = Nothing
    Set HTMLContent = Nothing

End Function