İnternettten indirilen Pfd dosyasının makroyla kaydetme

[dragon44760]

Ekli dosyada bulunan kodlarla dosya içersindeki bilgileri internette yayınlanan foruma(programa) girerek oradan pdf formatında bilgi almaktayım (kaydetmekteyim). Lakin bilgileri girdikten sonra listele dediğimde kaydet'e tıklatıyorum ve ekteki "Farklı Kaydet Ekranı.bmp" dosyasında olduğu gibi Farklı Kaydet diyalog penceresi açılmaktadır. Açılan diyalog penceresinde bulunan dosya adı bölümüne excel sayfamdaki (Sheets("Atama İşlemleri").Cells(ActiveCell.Row, 1).Value) hücresindeki adla kaydetmesini sağlayamıyorum.


Dosya adı bölümüne Sheets("Atama İşlemleri").Cells(ActiveCell.Row, 1).Value nasıl yazdırabilirim_?

Not: Tüm sorun aşağıdaki kodda koyu kırmızı olan bölümde.

Declare Function apiShowWindow Lib "user32" Alias "ShowWindow" _
            (ByVal hwnd As Long, ByVal nCmdShow As Long) As Long
Global Const SW_MAXIMIZE = 3
Global Const SW_SHOWNORMAL = 1
Global Const SW_SHOWMINIMIZED = 2
Dim SWs As New SHDocVw.ShellWindows
Dim IE As SHDocVw.InternetExplorer
Sub Ayr_Kat()
     For Each IE In SWs
     If Left(IE.LocationURL, 4) = "http" Then
     Set HTML_Body = IE.document.GetElementsByTagName("Body").Item(0)
     Set HTML_Tables = HTML_Body.GetElementsByTagName("Table")
     Set MyTable = HTML_Tables(1)
     Set HTML_bottom = HTML_Body.GetElementsByTagName("bottom")
     If Cells(ActiveCell.Row, 2) = "" Then
     MsgBox "Giriş İşlemleri Bitti.!", vbOKOnly + vbInformation, "BİTTİ..!"
     Exit Sub
     End If
     On Error GoTo ErrHandler:
     apiShowWindow IE.hwnd, SW_SHOWNORMAL
     apiShowWindow IE.hwnd, SW_MAXIMIZE
     HTML_Body.all.etkPbik.Value = Sheets("Atama İşlemleri").Cells(ActiveCell.Row, 2).Value
     HTML_Body.all.etkPbik.Focus
     SendKeys "{TAB}", True
     Application.Wait Now + TimeValue("00:01:50")
     Set HTML_Body = IE.document.GetElementsByTagName("Body").Item(0)
     Set HTML_Tables = HTML_Body.GetElementsByTagName("Table")
     Set MyTable = HTML_Tables(1)
     Set HTML_bottom = HTML_Body.GetElementsByTagName("bottom")
     HTML_Body.all.txtDstBrlkod.Value = Sheets("Atama İşlemleri").Cells(ActiveCell.Row, 22).Value
     HTML_Body.all.txtDstBrlkod.Focus
     SendKeys "{TAB}", True
     Application.Wait Now + TimeValue("00:00:18")
     Set HTML_Body = IE.document.GetElementsByTagName("Body").Item(0)
     Set HTML_Tables = HTML_Body.GetElementsByTagName("Table")
     Set MyTable = HTML_Tables(1)
     Set HTML_bottom = HTML_Body.GetElementsByTagName("bottom")
     'Sheets("Atama İşlemleri").Cells(ActiveCell.Row, 32).Value = Format(Now, "dd")
     'Sheets("Atama İşlemleri").Cells(ActiveCell.Row, 33).Value = Format(Now, "mm")
     'Sheets("Atama İşlemleri").Cells(ActiveCell.Row, 34).Value = Format(Now, "yyyy")
     'HTML_Body.all.ScmBldTrh_scmGun.Value = Sheets("Atama İşlemleri").Cells(ActiveCell.Row, 32).Value
     'HTML_Body.all.ScmBldTrh_scmAy.Value = Sheets("Atama İşlemleri").Cells(ActiveCell.Row, 33).Value
     'HTML_Body.all.ScmBldTrh_scmYil.Value = Sheets("Atama İşlemleri").Cells(ActiveCell.Row, 34).Value
     HTML_Body.all.txtShsYllMkt.Value = Sheets("Atama İşlemleri").Cells(ActiveCell.Row, 23).Value
     HTML_Body.all.txtAileYllMkt.Value = Sheets("Atama İşlemleri").Cells(ActiveCell.Row, 254).Value
     HTML_Body.all.ScmShhIzn.Value = Sheets("Atama İşlemleri").Cells(ActiveCell.Row, 25).Value
     HTML_Body.all.ScmYllIzn.Value = Sheets("Atama İşlemleri").Cells(ActiveCell.Row, 26).Value
     HTML_Body.all.txtIznGun.Value = Sheets("Atama İşlemleri").Cells(ActiveCell.Row, 27).Value
     HTML_Body.all.ScmYllMzrIzn.Value = Sheets("Atama İşlemleri").Cells(ActiveCell.Row, 28).Value
     HTML_Body.all.txtMzrIznGun.Value = Sheets("Atama İşlemleri").Cells(ActiveCell.Row, 29).Value
     'HTML_Body.all.txtTynEmrSys.Value = Sheets("Atama İşlemleri").Cells(1, 256).Value
     HTML_Body.all.ScmIlsKsmTrh_scmGun.Value = Sheets("Atama İşlemleri").Cells(ActiveCell.Row, 35).Value
     HTML_Body.all.ScmIlsKsmTrh_scmAy.Value = Sheets("Atama İşlemleri").Cells(ActiveCell.Row, 36).Value
     HTML_Body.all.ScmIlsKsmTrh_scmYil.Value = Sheets("Atama İşlemleri").Cells(ActiveCell.Row, 37).Value
     HTML_Body.all.scmRprTur_0.Focus
     SendKeys "{TAB}", True
     SendKeys "{ENTER}", True
     Sheets("Atama İşlemleri").Cells(ActiveCell.Row, 31).Value = 1
     
     Application.Wait Now + TimeValue("00:00:36")
     Application.SendKeys "{LEFT}", True 'kaydet butonuna gel
     SendKeys "{ENTER}", True 'Kaydete tıkla
     Application.Wait Now + TimeValue("00:00:36")
     [COLOR="Red"][B]Sheets("Atama İşlemleri").Cells(ActiveCell.Row, 1).Copy
     Application.OnKey "^v", True
     'EnableControl 22, True ' Yapıştır[/B][/COLOR]     
     SendKeys "{ENTER}", True
     ActiveCell.Offset(1, 0).Select
     
     'Application.Wait Now + TimeValue("00:00:06")
     'Run "Ayr_Kat"
     GoTo SafeExit:
ErrHandler:
     MsgBox "Bağlantı hızınız yetersiz veya siteye zaten login durumdasınız." _
     & vbCrLf & "Başka bir neden de;" & vbCrLf & Err.Description, vbCritical, "Dikkat...!"
     IE.Visible = True
SafeExit:
     Set HTML_Body = Nothing
     Set HTML_Tables = Nothing
     Set MyTable = Nothing
     Set IE = Nothing
End If
Next
End Sub

 

[dragon44760]

Soruma cevap verecek yok mu_?

Cevap verirseniz sevinirim...

 

[Korhan Ayhan]

Selamlar,

Kullandığınız web sitesi olmadığı için kodunuzu tam test edemedim ama şu şekilde bir çözüm önerebilirim. Sendkeys komutu ile alanlar arası geçiş yapıyorsunuz. Kaydet tuşuna gelmeden önce eklediğiniz resimdeki dosya adı bölümünü sendkeys komutu ile seçtirdikten sonra dosya adını yazdırırsanız sanırım sorunu çözebilirsiniz.

Aşağıdakine benzer bir komut işinizi görebilir.

SendKeys "{TAB}", True
SendKeys Sheets("Atama İşlemleri").Cells(ActiveCell.Row, 1)

 

[dragon44760]

Teşekkürler...

Sayın Korhan AYHAN yine uzmanlığınızı gösterdiniz yani...

Hiç aklıma gelmemiş bir yöntemle işi hallettiniz. Bilgi paylaşımınız için minnattarım.

SendKeys Sheets("Atama İşlemleri").Cells(ActiveCell.Row, 1)

Mükemmel oldu...