DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
Altın Üyelik Hakkında Bilgi
evet yaptım. normal excel sayfasına yapıştırdım çalıştı. Ama kendi yazdığım excele ekledim...
merhaba,
12 nolu mesajdaki kodların bulunduğu yere aşağıdaki kırmızı bölümü ekleyin.
[COLOR="Red"]ie.document.all("cphMaster_btnKaydet").Click[/COLOR]
End If
'ie.Quit: Set ie = Nothing
End With
ben tıklamayı chrome üzerinden yapınca hemen indirmeye başlamıştı, internet explorerda kontrol etmemişim. Aç, kaydet, farklı kaydet iletişim kutusu için bir çözüm arıyorum şu an kusura bakma.
şu yöntemi denediniz mi?
Merhaba,
Dim saveInFolder As String, saveAsFilename As String
saveInFolder = "C:\my\folder\"
saveAsFilename = "test_" & Format(Now, "yyyymmdd_HhNnSs")
Download_File URL, saveInFolder, saveAsFilename
.ie.Document.all("ctl00$cphMaster$btnSorgu").Click
Do Loop Until ie.ReadyState = 4
Application.Wait (Now + TimeValue("00:00:01"))
'Koordinat indir Linki tıkla,
[B][COLOR="Red"] ie.document.all("cphMaster_btnKaydet").Click
Do Loop Until ie.ReadyState = 4
[/COLOR][/B]
Set tbl = ie.Document.getElementsByTagName("table")(5) '5. tablo arama sonuçlarının olduğu tablo
Set trs = tbl.getElementsByTagName("tr")(1)
Set tds = trs.getElementsByTagName("td")Merhaba,hangi kodu kullanıyorsun bilemicem ama halit3 ün yazdığını tavsiye ederim çok sağlam
şunu dener misin? tabi önce bi tane download manager programı kurman gerek indirme işleminin otomatik olarak başlaması için. sadece ilave yapman gereken yerin kodlarını yazıyorum.
[B]Public Sub Main_Download()[/B]
URL = "http://www.nrldc.org/WBS/injsch.aspx" 'erişmek istediğin URL bu mu?
saveInFolder = "C:\" 'kayıt yolu mevcut mu
[B]Private Sub IE_Navigate_and_Download[/B]
aşağıdaki javascript parselsorgu sitesinin ama başında yorum olan nrldc.org sitesinin burayı düzelt.
.Navigate "javascript:__doPostBack('ctl00$cphMaster$btnKaydet ','')"
'.Navigate "javascript:__doPostBack('downloadncr','')"
[B]Private Sub File_Download_Click_Save() [/B]
Dim hWnd, [COLOR="Red"]hWnd_button[/COLOR] As Long
'aşağıdaki kırmızı ile olan düzeltmelere dikkat et. hWnd ile hWnd_button farklı.
'Kaydet yazısı da TR olarak değişti. eskisinde Save As yazıyordu.
'Find the child Save button
[COLOR="red"]hWnd_button[/COLOR] = FindWindowEx([COLOR="red"]hWnd[/COLOR], 0, "Button", "[COLOR="red"]&Kaydet[/COLOR]")
Debug.Print " Save button "; Hex(hWnd_button)
End If
If hWnd_button Then
'Click the Save button
SetForegroundWindow hWnd_button
Sleep 600 'this sleep is required and 600 milliseconds seems to be the minimum that works
SendMessage hWnd_button, BM_CLICK, 0, 0öncelikle bu yöntemi dener misiniz?
24 Nolu mesajdaki sayfa2 deki kodları bununla değiştirin.
Private Declare Function ShowWindow Lib "user32" (ByVal hWnd As Long, ByVal nCmdShow As Long) As Long
Sub verial1()
Dim URL As String
Dim IE As Object
yeni_dosya_adı = ActiveWorkbook.Name
Range("c2:k2").ClearContents
ReDim veri(13)
ReDim yer(13)
yer(1) = "cphMaster_rblSorguTip"
yer(2) = "cphMaster_rblSorguTip_0"
yer(3) = "cphMaster_rblSorguTip_1"
yer(4) = "cphMaster_tblIdariSorguAlan"
yer(5) = "cphMaster_IlLabelYatay"
yer(6) = "cphMaster_IlceLabelYatay"
yer(7) = "cphMaster_MahalleLabelYatay"
yer(8) = "cphMaster_AdaLabelYatay"
yer(9) = "cphMaster_ParselLabelYatay"
yer(10) = "cphMaster_btnSorgu"
yer(11) = "cphMaster_tblMesaj"
yer(12) = "cphMaster_lMesaj"
yer(13) = "cphMaster_map"
URL = "https://parselsorgu.tkgm.gov.tr/"
Set IE = CreateObject("InternetExplorer.Application")
With IE
.Navigate URL
.Visible = 1
ShowWindow IE.hWnd, 1
Do Until IE.ReadyState = 4: DoEvents: Loop
Do While IE.Busy: DoEvents: Loop
On Error Resume Next
Set objInputs = IE.document.getElementsByTagName("*")
sat2 = 0
For Each nesne In objInputs
If Val(Len(nesne.ID)) > 0 Then
deg3 = nesne.ID
If deg3 Like "*" & "cphMaster" & "*" = True Then
deg1 = 0
For m = 1 To 13
If Trim(nesne.ID) = yer(m) Then
deg1 = 1
Exit For
End If
Next
If deg1 = 0 Then
'MsgBox nesne.ID
sat2 = sat2 + 1
veri(sat2) = nesne.ID 'Trim(Replace(nesne.ID, "_", " "))
End If
End If
End If
Next nesne
If sat2 > 0 Then
For t = 1 To sat2
deg3 = veri(t)
If deg3 Like "*" & "cphMaster" & "*" = True Then
If t = 1 Then
hucre = Trim(Cells(1, "b").Text)
ElseIf t = 2 Then
hucre = Trim(Cells(2, "b").Text)
ElseIf t = 3 Then
hucre = Trim(Cells(3, "b").Text)
ElseIf t = 4 Then
hucre = Trim(Cells(4, "b").Text)
ElseIf t = 5 Then
hucre = Trim(Cells(5, "b").Text)
End If
For r = 1 To Val(IE.document.all(deg3).Length)
If hucre = Trim(IE.document.all(deg3)(r).Text) Then
son5 = r
'MsgBox hucre & Chr(10) & Trim(ie.document.all(deg3)(r).Text)
IE.document.all(deg3).selectedIndex = son5
Exit For
End If
Next r
IE.document.all(deg3).onchange
Application.Wait (Now + TimeValue("00:00:01"))
Do Until IE.ReadyState = 4: DoEvents: Loop
Do While IE.Busy: DoEvents: Loop
End If
Next t
Application.Wait (Now + TimeValue("00:00:01"))
IE.document.all("cphMaster_btnSorgu").Click
Do Until IE.ReadyState = 4: DoEvents: Loop
Do While IE.Busy: DoEvents: Loop
Application.Wait (Now + TimeValue("00:00:01"))
Set t = IE.document.getElementsByTagName("table").Item(5)
For j = 0 To 8 't.Cells.Length - 1
Cells(2, j + 3) = t.Rows(1).Cells(j).innerText
Next
Application.Wait (Now + TimeValue("00:00:01"))
[COLOR="Red"]IE.document.all("cphMaster_btnKaydet").Click
Application.Wait (Now + TimeValue("00:00:01"))
SendKeys "{LEFT}", True
Application.Wait (Now + TimeValue("00:00:01"))
SendKeys "{LEFT}", True
Application.Wait (Now + TimeValue("00:00:01"))
SendKeys ("{Enter}"), True
[/COLOR]
End If
'ie.Quit: Set ie = Nothing
End With
Windows(yeni_dosya_adı).Activate
MsgBox "işlem tamam"
End SubBu dosyada (verial1) düğmesine basınca web sitesindeki veriyi alıyor ve dosya olarak kayıt ediyor.
ilgili linki yeniden deneyiniz link çalışıyor düzelttim.