Excel Hyperlink İndirme ve İsimlendirme

[voyager52]

Arkadaşlar merhaba. Bir sorunum var ve içinden çıkamadım. Bir listede (14bin küsür adet) ilaç isimleri ve karşılarında prospektüs linkleri var. Bu linkler hyperlink olarak duruyor. Bunları indirirken aşağıdaki kodu kullanıyorum. Bu kodu sitedeki başka bir soruya verilen koddan evirdim. Yalnız hyperlinklerin bazılarını indirme başarılı dese dahi 2kb dosya boyutunda bırakarak bozuk dosya olarak indiriyor. Manuel olarak elle denediğimde dosya linkten direk iniyor ama koddan inmiyor. Örnek olarak aşağıdaki linkten inmiyor;

https://titck.gov.tr/storage/Archive/2019/kubKtAttachments/TİTCK A-FERİN SİNÜS SENDİKA UYGUN KT.pdf_584b3fa2-4340-48a2-9ee3-854cdbdbd33e.pdf

Linkin şu kısmında büyük türkçe harf ve boşluk var;

"TİTCK A-FERİN SİNÜS SENDİKA UYGUN KT"

Buradaki "İ", ve boşluk problem yaratıyor diye düşünerek boşluk olan kısımları "%20% ile değiştirdim. "İ" için birşey yapamadım çünkü bu şekilde link girince açılıyor. Bunları yapmama rağmen düzelmedi. 14k dosyadan 1.5k kadarı inmiyor. Belki şu kısımda 2 kere ".pdf" olmasından ötürüdür ama onu d nasıl düzelteceğimi biilmiiyorum;

"TİTCK A-FERİN SİNÜS SENDİKA UYGUN KT.pdf_584b3fa2-4340-48a2-9ee3-854cdbdbd33e.pdf"

Her ne kadar boşluk da olsa 2 kere pdf de olsa türkçe karakterler de olsa excelde tıklanınca iniyor ama bu kod ile sorun oluyor. Çözemedim bir türlü. Yardım edebilir misiniz?

Const FolderName As String = "F:\Deneme_Web\"

Sub titck()

 Set ws = ActiveWorkbook.Sheets("sayfa1")
 lLastRow = ws.Range("E" & Rows.Count).End(xlUp).Row

 Set oXMLHTTP = CreateObject("MSXML2.XMLHTTP.6.0")
 Set oBinaryStream = CreateObject("ADODB.Stream")
 adTypeBinary = 1
 oBinaryStream.Type = adTypeBinary

 For i = 2 To lLastRow
  sPath = FolderName & ws.Range("B" & i).Value & ".pdf"
  sURI = ws.Range("E" & i).Value

  On Error GoTo HTTPError
  oXMLHTTP.Open "GET", sURI, False
  oXMLHTTP.Send
  aBytes = oXMLHTTP.responsebody
  On Error GoTo 0

  oBinaryStream.Open
  oBinaryStream.Write aBytes
  adSaveCreateOverWrite = 2
  oBinaryStream.SaveToFile sPath, adSaveCreateOverWrite
  oBinaryStream.Close

  ws.Range("F" & i).Value = "1"

NextRow:
 Next

 Exit Sub

HTTPError:
 ws.Range("F" & i).Value = "2"
 Resume NextRow

End Sub

 

[voyager52]

Arkadaşlar indirilmeyenlerin hepsinde orjinal linkte boşluk olması gibi bir problem var. Sanırım boşluktan ötürü oluyor. Zaten yukarıda verdiğim linki bu site de boşluktan sonra link olarka algılamadı. İşin ilginç yanı excel de hyperlink olarak verildiğinde veya yukardaki linki kopyalayıp browserların adres çubuğuna kopyaladığınızda açması fakat vba ile bu kodu açamamak.

 

[voyager52]

Arkadaşlar boşlukları olan linki nasıl vba ya tanıtırız bir bilgisi olan var mı? Araştırıyorum ama bulamadım bir türlü.

 

[yunus788]

Sadece boşluk değil türkçe karakterlerde problem oluyor. Mesela verdiğiniz linki chrome a yapıştırınce chrome otomatik düzeltip şu hale getiriyor.

https://titck.gov.tr/storage/Archive/2019/kubKtAttachments/TİTCK A-FERİN SİNÜS SENDİKA UYGUN KT.pdf_584b3fa2-4340-48a2-9ee3-854cdbdbd33e.pdf

Bu haliyle excel indirebiliyor. Belki nette araştırarak bunu otomatik çevirecek çözümler bulabilirsiniz.


Forum da linki gene otomatik eski haline getirmiş

.https://titck.gov.tr/storage/Archive/2019/kubKtAttachments/T%C4%B0TCK%20A-FER%C4%B0N%20S%C4%B0N%C3%9CS%20SEND%C4%B0KA%20UYGUN%20KT.pdf_584b3fa2-4340-48a2-9ee3-854cdbdbd33e.pdf baştaki noktayı eklemeyince otomatik düzeltiyor.

 

[voyager52]

@yunus788 hocam teşekkür ederim, dediklerinden sonra uyandım, çözümü buldum.

Başına gelen olursa diye çözümü de yazayım, ki kesin gelir, çok karşılaşılan bir durum. Linklerdeki şu verileri değiştirmeniz gerekli;

Türkçe Karakterlerin HTML/UTF-8 Karşılığı
ı %C4%B1
ç %C3%A7
ş %C5%9F
ö %C3%B6
ü %C3%BC
ğ %C4%9F
İ %C4%B0
Ç %C3%87
Ş %C5%9E
Ö %C3%96
Ü %C3%9C
Ğ %C4%9E
Boşluk için ise; %20

Linklerdeki bukarakterleri değiştirdiğiniz/dönüştürdüğünüz taktirde herşey düzeliyor.