Soru Resmi Hücreye Sığdırma

[okan32]

Arkadaşlar kolay gelsin. Hayırlı Cumalar!
Aşağıdaki kod ile Userformu sayfaya kaydediyorum. Fakat yazdırma alanını taşıyor. Kodda nasıl bir düzenleme yaparsam yazdırma alanına tam olarak resmi sığdırır. Yardımlarınızı bekliyorum.

Private Declare Sub keybd_event Lib "user32" (ByVal bVk As Byte, _
                                              ByVal bScan As Byte, _
                                              ByVal dwFlags As Long, _
                                              ByVal dwExtraInfo As Long)
Private Const VK_LMENU = &HA4
Private Const VK_SNAPSHOT = &H2C
Private Const VK_CONTROL = &H11
Private Const VK_V = &H56
Private Const VK_0x79 = &H79
Private Const KEYEVENTF_EXTENDEDKEY = &H1
Private Const KEYEVENTF_KEYUP = &H2

Private Sub CommandButton1_Click()
Dim sAppOs As String, wks As Worksheet
sAppOs = Application.OperatingSystem

    Application.DisplayAlerts = False
    Application.ScreenUpdating = False

    If Mid(sAppOs, 18, 2) = "NT" Then
        Call keybd_event(VK_LMENU, VK_V, KEYEVENTF_EXTENDEDKEY, 0)
        Call keybd_event(VK_SNAPSHOT, VK_0x79, KEYEVENTF_EXTENDEDKEY, 0)
        Call keybd_event(VK_LMENU, VK_V, KEYEVENTF_EXTENDEDKEY Or KEYEVENTF_KEYUP, 0)
        Call keybd_event(VK_SNAPSHOT, VK_0x79, KEYEVENTF_EXTENDEDKEY Or KEYEVENTF_KEYUP, 0)
    Else
        Call keybd_event(VK_SNAPSHOT, 0, KEYEVENTF_EXTENDEDKEY, 0)
        Call keybd_event(VK_SNAPSHOT, 0, KEYEVENTF_EXTENDEDKEY Or KEYEVENTF_KEYUP, 0)
    End If

DoEvents
Unload Me
Set wks = ActiveWorkbook.Sheets(1)
Application.Goto wks.Range("A1")

    With ActiveSheet
        With .PageSetup
            .LeftMargin = Application.InchesToPoints(0)
            .RightMargin = Application.InchesToPoints(0)
            .TopMargin = Application.InchesToPoints(0)
            .BottomMargin = Application.InchesToPoints(0)
            .HeaderMargin = Application.InchesToPoints(0)
            .FooterMargin = Application.InchesToPoints(0)
            .CenterHorizontally = True
            .CenterVertically = True
            .Orientation = xlLandscape
        End With
        ActiveSheet.Shapes.SelectAll
        Selection.Delete
            .Paste
            If MsgBox("Önizleme Yapılsınmı", vbYesNo, "ALİ KOÇ") = vbNo Then
            Unload Me
            Sheets("LİSTE").Select
            Exit Sub
             Else
            ActiveWindow.SelectedSheets.PrintPreview
          
  
        Application.ScreenUpdating = True
        Application.DisplayAlerts = True
      
        End If
        End With
End Sub

 

[halit3]

Aşağıdaki kırmızı yeri kodunuzda bulun ve ondan sonraki bölümü ekleyiniz.

.Paste

Adres = ActiveSheet.PageSetup.PrintArea
Selection.Top = Range(Adres).Top + 1
Selection.Left = Range(Adres).Left + 1
Selection.ShapeRange.LockAspectRatio = msoFalse
Selection.ShapeRange.Height = Range(Adres).Height - 2
Selection.ShapeRange.Width = Range(Adres).Width - 2

 

[okan32]

Halit3 hocam çok teşekkür ederim.Gayet güzel oldu