Makro ile PDF önizlemesi ve PDF listeleme

[Furkanxalapa]

'EJEMPLO 2' dosyasını sizinle paylaşıyorum

drive.google.com

1) Registrar sayfasındaki soldaki tuşa tıklayıp seçilen pdf dosyasının aynı sayfada gözükmesini istiyorum.
2) Registrar sayfasında Registrar tuşuna basınca pdf dosyasının lista adlı sayfaya kaydolmasını istiyorum
Örnek sayfasında bunları yapmak için yaptığım denemeleri ekledim.
Yardımcı olursanız sevinirim
Şimdiden teşekkürler

 

[Korhan Ayhan]

Merhaba,

PDF görüntüsünü sayfaya eklemek yerine ilgili hücreye PDF dosyasına ulaşmak için link verseniz daha sağlıklı olmaz mı?

Ya da linkte tarif edilen yöntemi deneyebilirsiniz.

Excel'e PDF dosyası ekle Bir Excel Çalışma Sayfasına PDF Dosyası Nasıl Yerleştirilir? Bilgigram

Microsoft'un birbiri ile çok uyumlu çalışan programları var. Excel'e PDF dosyası ekle için neler yapılması gerekir. Kısaca bahsedelim.

bilgigram.com

 

[Furkanxalapa]

Merhaba,

PDF görüntüsünü sayfaya eklemek yerine ilgili hücreye PDF dosyasına ulaşmak için link verseniz daha sağlıklı olmaz mı?

Ya da linkte tarif edilen yöntemi deneyebilirsiniz.

Excel'e PDF dosyası ekle Bir Excel Çalışma Sayfasına PDF Dosyası Nasıl Yerleştirilir? Bilgigram

Microsoft'un birbiri ile çok uyumlu çalışan programları var. Excel'e PDF dosyası ekle için neler yapılması gerekir. Kısaca bahsedelim.

bilgigram.com

Tuşa basınca seçilen pdf resim olarak ilgilo yere kaydete bilir. Çünkü ilerda arama sayfası oluşturcam kodla aranan sayfadaki ilgili pdf(veya resmin) gözükecek.

 

[Korhan Ayhan]

Merhaba,

Öncelikle sistemime "ADOBE ACROBAT DC" programını kurdum.

Sonra dosyanızdaki makroları aşağıdaki gibi değiştirdim.

Dosyanızda deneme yaptım ve olumlu sonuç aldım.

Option Explicit

Private Declare PtrSafe Sub keybd_event Lib "user32" (ByVal bVk As Byte, ByVal _
bScan As Byte, ByVal dwFlags As Long, ByVal dwExtraInfo As Long)

Private Const VK_SNAPSHOT = &H2C

Sub Selected_File()
    Dim DialogBox As FileDialog, My_Picture As Picture, Alan As Range
        
    Set DialogBox = Application.FileDialog(msoFileDialogOpen)
    
    DialogBox.AllowMultiSelect = False
    
    DialogBox.Title = "Select a file"
    
    DialogBox.InitialFileName = "C:\"
    
    DialogBox.Filters.Clear
    
    DialogBox.Filters.Add "PDF Files", "*.pdf"
    
    If DialogBox.Show = -1 Then
        Set Alan = Range("F3:F19")
        
        For Each My_Picture In ActiveSheet.Pictures
            If Not Intersect(My_Picture.TopLeftCell, Alan) Is Nothing Then
                My_Picture.Delete
            End If
        Next
        
        Set Alan = Nothing
        
        ActiveSheet.Range("filePath").Value = DialogBox.SelectedItems(1)
        ActiveWorkbook.FollowHyperlink DialogBox.SelectedItems(1)
        AppActivate VBA.Split(DialogBox.SelectedItems(1), Application.PathSeparator)(1)
        Application.Wait Now + TimeValue("00:00:02")
        keybd_event VK_SNAPSHOT, 1, 0, 0
        SendKeys "%{F4}", True
        Application.Wait Now + TimeValue("00:00:02")
        Range("F3").Select
        ActiveSheet.Paste
        Set My_Picture = Selection
        With My_Picture
            .Name = "My_Picture"
            .ShapeRange.LockAspectRatio = msoFalse
            .ShapeRange.Height = 200
            .ShapeRange.Width = 200
        End With
    End If
End Sub

Sub Kaydet()
    Dim S1 As Worksheet, S2 As Worksheet, My_Picture As Object
    
    Set S1 = Sheets("Registrar")
    Set S2 = Sheets("Lista")
    
    On Error Resume Next
    Set My_Picture = Nothing
    Set My_Picture = S1.Shapes("My_Picture")
    On Error GoTo 0
    
    If Not My_Picture Is Nothing Then
        Application.ScreenUpdating = False
        S1.Range("D3,D5,D7,D9,D11,D13,D15,D17").Copy
        S2.Cells(S2.Rows.Count, 1).End(3)(2, 1).PasteSpecial Paste:=xlPasteValues, Transpose:=True
        My_Picture.Copy
        S2.Select
        S2.Cells(S2.Rows.Count, 1).End(3)(1, 9).Select
        ActiveSheet.Paste
        Set My_Picture = Selection
        With My_Picture
            .Name = "My_Picture"
            .ShapeRange.LockAspectRatio = msoFalse
            .ShapeRange.Height = ActiveCell.Height
            .ShapeRange.Width = ActiveCell.Width
        End With
        S2.Range("A2").Select
        S1.Select
        Application.ScreenUpdating = True
    Else
        MsgBox "Kayıt işlemi için önce PDF dosyasını seçmelisiniz!", vbCritical
    End If
End Sub