Ekran görüntüsünü yazdır butonu

I

ilhanfire

Katılım
2 Haziran 2006
Mesajlar
111
Merhaba arkadaşlar, excelde hazırladığım userform açıldığında 1 butona tıklayarak ekran görüntüsünü yazdırmak istiyorum. forumlarda çok araştırdım fakat kendime göre kod bulamadım. herkes picturebox ile birşeylr yapmaya çalışmış. yada bilgisayara kaydetmeye çalışmış. ben butona tıklandığında direkt yazıcıdan ekran görüntüsünün alınmasını istiyorum. şimdiden teşekkürler.
 
mancubus

mancubus

Destek Ekibi
Destek Ekibi
Katılım
6 Ocak 2010
Mesajlar
2,224
Excel Vers. ve Dili
İŞ: 2021 Win Eng
:)

google'da görüp, ahanda mevzu budur diyerek, direkt link kopyalayınca olmamış. :)

bu link VBA değil, VB (üstelik VB4) için.

VBA'e uyan bölümleri de vardır belki ama onu uzmanları bilir.

el gugıl hazretlerinden yardım isteyeyim. bulursam bir şey paylaşırım.

belk bu arada çözüm bulan olur.
 
mancubus

mancubus

Destek Ekibi
Destek Ekibi
Katılım
6 Ocak 2010
Mesajlar
2,224
Excel Vers. ve Dili
İŞ: 2021 Win Eng
öte yandan...

neden normal bir print işlemi işimizi görmüyor da PrtSrc yapmak istiyoruz...
 
mancubus

mancubus

Destek Ekibi
Destek Ekibi
Katılım
6 Ocak 2010
Mesajlar
2,224
Excel Vers. ve Dili
İŞ: 2021 Win Eng
Kod: 
Private Sub CommandButton1_Click()
    UserForm1.PrintForm
End Sub
ile userform'u yazdırmak mümkün. istenen bu değil, değil mi?
 
halit3

halit3

Uzman
Uzman
Katılım
18 Ocak 2008
Mesajlar
12,852
Excel Vers. ve Dili
2003 excell türkçe
ve
2007 excell türkçe
Alternatif olarak kod ekran görüntüsünü sayfaya alarak yazdırıyor.

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

Private Sub CommandButton1_Click()

Application.VBE.MainWindow.Visible = False
Application.Visible = False

Dim basla
Dim bekle

basla = Timer
bekle = 2
While Timer < basla + bekle
DoEvents
Wend

Dosya_Adı = ActiveWorkbook.Name
Application.WindowState = xlMinimized

On Error Resume Next
Call keybd_event(vbKeySnapshot, 0, 0, 0)
DoEvents

Application.Visible = True
Application.WindowState = xlNormal
Windows(Dosya_Adı).Activate
Range("a1").Select
ActiveSheet.Paste
Selection.ShapeRange.LockAspectRatio = msoTrue

Selection.ShapeRange.Width = 680
Selection.ShapeRange.Height = 440

Application.WindowState = xlMaximized
Application.Visible = True


Worksheets(ActiveSheet.Name).PageSetup.PrintArea = "$A$1:$O$35"
Worksheets(ActiveSheet.Name).PrintOut Copies:=1, Collate:=True

Selection.Cut
Range("a1").Select

End Sub
Not Sayfa ve resim büyüklüğünü kendiniz ayarlayın.
 
mancubus

mancubus

Destek Ekibi
Destek Ekibi
Katılım
6 Ocak 2010
Mesajlar
2,224
Excel Vers. ve Dili
İŞ: 2021 Win Eng
SendKeys yöntemi ile sayfaya yapıştırmak ta mümkün.
Kod: 
Sub PrintScreen()
    Application.SendKeys "(%{1068})"
    DoEvents
    ActiveSheet.Paste
End Sub
 
I

ilhanfire

Katılım
2 Haziran 2006
Mesajlar
111
halit3' Alıntı:
Alternatif olarak kod ekran görüntüsünü sayfaya alarak yazdırıyor.

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

Private Sub CommandButton1_Click()

Application.VBE.MainWindow.Visible = False
Application.Visible = False

Dim basla
Dim bekle

basla = Timer
bekle = 2
While Timer < basla + bekle
DoEvents
Wend

Dosya_Adı = ActiveWorkbook.Name
Application.WindowState = xlMinimized

On Error Resume Next
Call keybd_event(vbKeySnapshot, 0, 0, 0)
DoEvents

Application.Visible = True
Application.WindowState = xlNormal
Windows(Dosya_Adı).Activate
Range("a1").Select
ActiveSheet.Paste
Selection.ShapeRange.LockAspectRatio = msoTrue

Selection.ShapeRange.Width = 680
Selection.ShapeRange.Height = 440

Application.WindowState = xlMaximized
Application.Visible = True


Worksheets(ActiveSheet.Name).PageSetup.PrintArea = "$A$1:$O$35"
Worksheets(ActiveSheet.Name).PrintOut Copies:=1, Collate:=True

Selection.Cut
Range("a1").Select

End Sub
Not Sayfa ve resim büyüklüğünü kendiniz ayarlayın.
Genişletmek için tıkla ...
hocam bu kodu modül olarak yazdım çalışmadı,
userforma yazdım çalışmadı,
buton 1 e yazdım çalışmadı.

Belirttiğin alanlarıda değiştirdim ama olmadı.
kodları nasıl hazırlamam gerekiyor. yardımcı olurmusun :)
 
YUSUF44

YUSUF44

Destek Ekibi
Destek Ekibi
Katılım
4 Ocak 2006
Mesajlar
12,070
Excel Vers. ve Dili
İş : Ofis 365 - Türkçe
Ev: Ofis 365 - Türkçe
mancubus' Alıntı:
SendKeys yöntemi ile sayfaya yapıştırmak ta mümkün.
Kod: 
Sub PrintScreen()
    Application.SendKeys "(%{1068})"
    DoEvents
    ActiveSheet.Paste
End Sub
Genişletmek için tıkla ...

Bu çok iyiymiş. Dün çok aradım ama bulamadım bu tuş vuruşunu. Teşekkürler. Üzerinde (makro kaydet yoluyla) değişiklik yaparak aşağıdaki kodları elde ettim. Alınan görüntüyü yeni sayfaya yapıştırıp sayfa yapısını yatay ve kenar boşluklarını 1 cm olarak ayarlıyor, dikey ve yatay olarak ortalayıp yazdırıyor. Son olarak sayfayı silip delilleri temizliyor:)

Kod: 
Sub PrintScreen()
    Application.SendKeys "(%{1068})"
    DoEvents
    Sheets.Add
    ActiveSheet.Paste
    Application.DisplayAlerts = False
    Application.ScreenUpdating = False
    With ActiveSheet.PageSetup
        .PrintTitleRows = ""
        .PrintTitleColumns = ""
    End With
    ActiveSheet.PageSetup.PrintArea = ""
    With ActiveSheet.PageSetup
        .LeftHeader = ""
        .CenterHeader = ""
        .RightHeader = ""
        .LeftFooter = ""
        .CenterFooter = ""
        .RightFooter = ""
        .LeftMargin = Application.InchesToPoints(0.393700787401575)
        .RightMargin = Application.InchesToPoints(0.393700787401575)
        .TopMargin = Application.InchesToPoints(0.393700787401575)
        .BottomMargin = Application.InchesToPoints(0.393700787401575)
        .HeaderMargin = Application.InchesToPoints(0.31496062992126)
        .FooterMargin = Application.InchesToPoints(0.31496062992126)
        .PrintHeadings = False
        .PrintGridlines = False
        .PrintComments = xlPrintNoComments
        .CenterHorizontally = True
        .CenterVertically = True
        .Orientation = xlLandscape
        .Draft = False
        .PaperSize = xlPaperA4
        .FirstPageNumber = xlAutomatic
        .Order = xlDownThenOver
        .BlackAndWhite = False
        .Zoom = False
        .FitToPagesWide = 1
        .FitToPagesTall = 1
        .PrintErrors = xlPrintErrorsDisplayed
        .OddAndEvenPagesHeaderFooter = False
        .DifferentFirstPageHeaderFooter = False
        .ScaleWithDocHeaderFooter = True
        .AlignMarginsHeaderFooter = True
        .EvenPage.LeftHeader.Text = ""
        .EvenPage.CenterHeader.Text = ""
        .EvenPage.RightHeader.Text = ""
        .EvenPage.LeftFooter.Text = ""
        .EvenPage.CenterFooter.Text = ""
        .EvenPage.RightFooter.Text = ""
        .FirstPage.LeftHeader.Text = ""
        .FirstPage.CenterHeader.Text = ""
        .FirstPage.RightHeader.Text = ""
        .FirstPage.LeftFooter.Text = ""
        .FirstPage.CenterFooter.Text = ""
        .FirstPage.RightFooter.Text = ""
    End With
    ActiveWindow.SelectedSheets.PrintOut Copies:=1
    ActiveSheet.Delete
End Sub
 
halit3

halit3

Uzman
Uzman
Katılım
18 Ocak 2008
Mesajlar
12,852
Excel Vers. ve Dili
2003 excell türkçe
ve
2007 excell türkçe
ilhanfire' Alıntı:
hocam bu kodu modül olarak yazdım çalışmadı,
userforma yazdım çalışmadı,
buton 1 e yazdım çalışmadı.

Belirttiğin alanlarıda değiştirdim ama olmadı.
kodları nasıl hazırlamam gerekiyor. yardımcı olurmusun :)
Genişletmek için tıkla ...
Kodu Sayfanın kod bölümüne ekliyeceksiniz ve bir komut düğmesiyle aktif yapacaksınız.
 

Ekli dosyalar

halit3

halit3

Uzman
Uzman
Katılım
18 Ocak 2008
Mesajlar
12,852
Excel Vers. ve Dili
2003 excell türkçe
ve
2007 excell türkçe
Bu kodu bir modüle ekleyin windows7 de resmi direk yazdırıyor.

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

Private Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hWnd As Long, ByVal lpOperation As String, _
ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long


Sub ekran_görüntüsünü_yazdır()
gen = Application.Width
yuk = Application.Height

Klasor = CreateObject("wscript.Shell").SpecialFolders("Desktop")
dosyaadı = "resim55.jpg"
yer = Klasor & "\" & dosyaadı

Application.VBE.MainWindow.Visible = False
Application.WindowState = xlMinimized
Application.Wait (Now + TimeValue("0:00:1"))

Call keybd_event(vbKeySnapshot, 0, 0, 0)
DoEvents

Set grafik = ActiveSheet.ChartObjects.Add([COLOR="Red"]0[/COLOR], [COLOR="red"]0[/COLOR], gen, yuk)
grafik.Chart.Paste
grafik.Chart.Export yer
grafik.Delete
Application.WindowState = xlNormal

ShellExecute 0, "print", yer, vbNullString, 0, SW_SHOWNORMAL
Application.Wait (Now + TimeValue("0:00:2"))
SendKeys ("{ENTER}"), True
Application.Wait (Now + TimeValue("0:00:2"))

Dim fl
Set fl = CreateObject("Scripting.FileSystemObject")
fl.DeleteFile yer

End Sub
 
Cevap yazmak için giriş yap yada kayıt ol.
Üst