[massgrave]

UserForm1'de bulunan TextBoxlardaki verilerin ekte göndermiş olduğum formatta PDF olarak görüntüleyip yazdırmak istiyorum. Yardımcı olursanız memnun olurum.

[massgrave]

Bu kod tüm sayfayı pdf olarak kaydediyor. Düzenleyebilecek arkadaş var mı acaba?

Kod: Tümünü seç

Private Sub CommandButton810_Click()
'www.contextures.com
'for Excel 2010 and later
Dim wsA As Worksheet
Dim wbA As Workbook
Dim strTime As String
Dim strName As String
Dim strPath As String
Dim strFile As String
Dim strPathFile As String
Dim myFile As Variant
On Error GoTo errHandler

Set wbA = ActiveWorkbook
Set wsA = ActiveSheet
strTime = Format(Now(), "yyyymmdd\_hhmm")

'get active workbook folder, if saved
strPath = wbA.Path
If strPath = "" Then
  strPath = Application.DefaultFilePath
End If
strPath = strPath & "\"

'replace spaces and periods in sheet name
strName = Replace(wsA.Name, " ", "")
strName = Replace(strName, ".", "_")

'create default name for savng file
strFile = strName & "_" & strTime & ".pdf"
strPathFile = strPath & strFile

'use can enter name and
' select folder for file
myFile = Application.GetSaveAsFilename _
    (InitialFileName:=strPathFile, _
        FileFilter:="PDF Files (*.pdf), *.pdf", _
        Title:="Select Folder and FileName to save")

'export to PDF if a folder was selected
If myFile <> "False" Then
    wsA.ExportAsFixedFormat _
        Type:=xlTypePDF, _
        Filename:=myFile, _
        Quality:=xlQualityStandard, _
        IncludeDocProperties:=True, _
        IgnorePrintAreas:=False, _
        OpenAfterPublish:=False
    'confirmation message with file info
    MsgBox "PDF file has been created: " _
      & vbCrLf _
      & myFile
End If

exitHandler:
    Exit Sub
errHandler:
    MsgBox "Could not create PDF file"
    Resume exitHandler
End Sub

[Ozan İLGÜN]

Userform kodlarının en tepesine koyun.Yazdırma butonunuza call pdfyaz() kodunu ekleyin.

Kod: Tümünü seç

Option Explicit
#If VBA7 Then
Private Declare PtrSafe Sub keybd_event Lib "user32" (ByVal bVk As Byte, _
ByVal bScan As Byte, ByVal dwFlags As LongPtr, ByVal dwExtraInfo As LongPtr)
Private Declare PtrSafe Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" _
(ByVal hwnd As LongPtr, ByVal lpOperation As String, ByVal lpFile As String, _
ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
#Else
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
#End If

Const VK_SNAPSHOT = 44
Const VK_LMENU = 164
Const KEYEVENTF_KEYUP = 2
Const KEYEVENTF_EXTENDEDKEY = 1


Private Sub pdfyaz()
Application.DisplayAlerts = False
    Dim pdfdosya As String
    Dim gizlisayfa As Worksheet
     
    keybd_event VK_LMENU, 0, KEYEVENTF_EXTENDEDKEY, 0
    keybd_event VK_SNAPSHOT, 0, KEYEVENTF_EXTENDEDKEY, 0
    keybd_event VK_SNAPSHOT, 0, KEYEVENTF_EXTENDEDKEY + KEYEVENTF_KEYUP, 0
    keybd_event VK_LMENU, 0, KEYEVENTF_EXTENDEDKEY + KEYEVENTF_KEYUP, 0
     
    DoEvents
    Application.Wait (Now + TimeValue("0:00:02"))
   
     
    Set gizlisayfa = ThisWorkbook.Worksheets.Add(After:=Worksheets(Worksheets.Count))
    gizlisayfa.Select
    gizlisayfa.PasteSpecial
    pdfdosya = ActiveWorkbook.Path & "\" & Me.Name & ".pdf"
    gizlisayfa.ExportAsFixedFormat Type:=xlTypePDF, _
        Filename:=pdfdosya, Quality:=xlQualityStandard, _
        IncludeDocProperties:=False, IgnorePrintAreas:=False, _
        OpenAfterPublish:=False
    gizlisayfa.Delete
    Application.DisplayAlerts = True
     ShellExecute 0, "Open", pdfdosya, "", "", vbNormalNoFocus
     Me.Hide
End Sub


[massgrave]

Userform kodlarının en tepesine koyun.Yazdırma butonunuza call pdfyaz() kodunu ekleyin.

Kod: Tümünü seç

Option Explicit
#If VBA7 Then
Private Declare PtrSafe Sub keybd_event Lib "user32" (ByVal bVk As Byte, _
ByVal bScan As Byte, ByVal dwFlags As LongPtr, ByVal dwExtraInfo As LongPtr)
Private Declare PtrSafe Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" _
(ByVal hwnd As LongPtr, ByVal lpOperation As String, ByVal lpFile As String, _
ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
#Else
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
#End If

Const VK_SNAPSHOT = 44
Const VK_LMENU = 164
Const KEYEVENTF_KEYUP = 2
Const KEYEVENTF_EXTENDEDKEY = 1


Private Sub pdfyaz()
Application.DisplayAlerts = False
    Dim pdfdosya As String
    Dim gizlisayfa As Worksheet
     
    keybd_event VK_LMENU, 0, KEYEVENTF_EXTENDEDKEY, 0
    keybd_event VK_SNAPSHOT, 0, KEYEVENTF_EXTENDEDKEY, 0
    keybd_event VK_SNAPSHOT, 0, KEYEVENTF_EXTENDEDKEY + KEYEVENTF_KEYUP, 0
    keybd_event VK_LMENU, 0, KEYEVENTF_EXTENDEDKEY + KEYEVENTF_KEYUP, 0
     
    DoEvents
    Application.Wait (Now + TimeValue("0:00:02"))
   
     
    Set gizlisayfa = ThisWorkbook.Worksheets.Add(After:=Worksheets(Worksheets.Count))
    gizlisayfa.Select
    gizlisayfa.PasteSpecial
    pdfdosya = ActiveWorkbook.Path & "\" & Me.Name & ".pdf"
    gizlisayfa.ExportAsFixedFormat Type:=xlTypePDF, _
        Filename:=pdfdosya, Quality:=xlQualityStandard, _
        IncludeDocProperties:=False, IgnorePrintAreas:=False, _
        OpenAfterPublish:=False
    gizlisayfa.Delete
    Application.DisplayAlerts = True
     ShellExecute 0, "Open", pdfdosya, "", "", vbNormalNoFocus
     Me.Hide
End Sub


Merhaba.
Bu kodları kullandığımda normal form1'i pdf olarak kaydediyor ve gösteriyor.

Ben aşağıdaki formatta textbox'ların içindeki verileri yazdırmak istiyorum. KİŞİ KARTI ÇIKTISI VERİR GİBİ

Yani:
ADI: ALİ VELİ
DOĞUM TARİHİ: 01.01.1955
MEMLEKETİ : İSTANBUL

[Ozan İLGÜN]

Ozaman bir sayfaya textbox değerlerini kodla yazın sonra onu pdf olarak çevirelim. Bayrama girdiğim için pcye geçemiyorum.

[massgrave]

Değerleri alacağı TextBox'lar:

Kod: Tümünü seç

[b]KİŞİ KARTI[/b]
[b]Firma Adres Bilgisi[/b]
AD1: TextBox1.text
AD2: TextBox2.text
AD3: TextBox4.text
AD4: TextBox3.text
AD5: TextBox6.text
AD6: TextBox7.text
AD7: TextBox5.text
AD8: TextBox8.text
AD9: TextBox9.text
AD10: TextBox10.text
AD11: TextBox11.text
AD:12 TextBox12.text


[Ozan İLGÜN]

Dosyanızı ekleyebilir misiniz? Bayramdan sonra bakabilirim.

[massgrave]

Teşekkür ederim. Dosyayı ekledim.
İyi bayramlar.
Bayramdan sonra bu konu üzerinden hatırlatma metni yazarım.

[massgrave]

Merhaba kendi çapımda birşeyler çıkardım. Pdf olarak beceremedim ama excel olarak birşeyler denedim fakat bir sorun meydana geliyor.Oda şuki: Ayrı pencerede açıyor ayarladğım şekilde çıkıyor ok sorun yok fakat açılan excel sayfasını kapattığım zaman kaydet kaydetme diye soruyor kaydetme diyorum Run-Time error (Method Save of object _Workbook failed hatası veriyor ve kullanmıs oldugum programda kapanıyor. Ne yapmalıyım?

Ayrıca bu dosyayı pdf olarak ' Sheets(1).Range("C7") = TextBox4.Value ' değerine verilen isimle PDF olarak kaydetmek istiyorum.
Karşıma excel sayfası değilde convert edilen PDF sayfası gelsin hem yazdır hazır ekranı ile yazdırabilsin hemde PDF olarak kayıt yapabilsin. Yeni açılan excel sayfasıyla alakalı hiçbirşey görünmesin. En alttaki kod ile PDF çevirebildim ama istediğim şekilde olmadı.

Dosyayı ekte göndermiştim. Bayramdan sonra görüşmek üzre.

Kod: Tümünü seç

Private Sub VcardYaz_Click()
Workbooks.Add
On Error Resume Next
Sheets(1).Range("B3,B5,B7,B8,B9,B10,B11,B13,D5,D7,D8,B12,D9,D10").Font.ColorIndex = 56 'başlık yazı rengi
On Error Resume Next
Sheets(1).Range("B3,B5,B7,B8,B9,B10,B11,B13,D5,D7,D8,B12,D9,D10").Interior.ColorIndex = 35 ' başlık arkaplan
On Error Resume Next
Sheets(1).Range("B3,B5,B7,B8,B9,B10,B11,B13,D5,D7,D8,B12,D9,D10").Font.ColorIndex = 56 'başlık yazı rengi
On Error Resume Next
Sheets(1).Range("B3,B5,B7,B8,B9,B10,B11,B13,D5,D7,D8,B12,D9,D10").Font.Bold = True
On Error Resume Next
Sheets(1).Range("B5,B7,B8,B9,B10,B11,B13,D5,D7,D8,B12,D9,D10").Font.Size = 15
On Error Resume Next
Sheets(1).Range("B3:E3").Merge
Sheets(1).Range("B4:E4").Merge
Sheets(1).Range("B6:E6").Merge
Sheets(1).Range("D10:D13").Merge
Sheets(1).Range("E10:E13").Merge
Sheets(1).Range("D7:D8").Merge
Sheets(1).Range("E7:E8").Merge
Sheets(1).Range("B3:B4").Merge

Sheets(1).Range("B3") = "BAŞLIK YAZISI"
Sheets(1).Range("B3").Font.Size = 27

Sheets(1).Range("B5") = "D.SIRANO"
Sheets(1).Range("C5") = TextBox1.Value
Sheets(1).Range("C5").Font.Bold = True
Sheets(1).Range("C5").Font.Size = 25

Sheets(1).Range("D5") = "ARŞİV Mİ"
Sheets(1).Range("E5") = TextBox2.Value
Sheets(1).Range("E5").Font.Bold = True
Sheets(1).Range("E5").Font.Size = 25

Sheets(1).Range("B7") = "KİŞİ 1"
Sheets(1).Range("C7") = TextBox4.Value

Sheets(1).Range("B8") = "NO"
Sheets(1).Range("C8") = TextBox3.Value

Sheets(1).Range("B9") = "İL"
Sheets(1).Range("C9") = TextBox6.Value

Sheets(1).Range("B10") = "DENEME"
Sheets(1).Range("C10") = TextBox7.Value

Sheets(1).Range("B11") = "KARSI DENEME"
Sheets(1).Range("C11") = TextBox5.Value

Sheets(1).Range("B12") = "DURUM"
Sheets(1).Range("C12") = TextBox8.Value

Sheets(1).Range("B13") = "KİŞİ 2"
Sheets(1).Range("C13") = TextBox9.Value

Sheets(1).Range("D10") = "NOT"
Sheets(1).Range("E10") = TextBox10.Value

Sheets(1).Range("D7") = "ADRES"
Sheets(1).Range("E7") = TextBox11.Value

Sheets(1).Range("D9") = "TELEFON"
Sheets(1).Range("E9") = TextBox12.Value

Sheets(1).Columns("B").ColumnWidth = 20
Sheets(1).Columns("D").ColumnWidth = 20

Sheets(1).Columns("C").ColumnWidth = 45
Sheets(1).Columns("E").ColumnWidth = 45
   
Sheets(1).UsedRange.RowHeight = 20 'satır yükseliği
On Error Resume Next
'Sheets(1).UsedRange.ColumnWidth = 18 'sütun genişliğini elle vermek isterseniz
'On Error Resume Next
'Sheets(1).UsedRange.Columns.AutoFit 'otomatik sütun genişliği
'On Error Resume Next
Sheets(1).UsedRange.HorizontalAlignment = xlCenter 'dikey yerleşim ortala
On Error Resume Next
Sheets(1).UsedRange.VerticalAlignment = xlVAlignCenter ' yatay yerleşim ortala
On Error Resume Next
Sheets(1).UsedRange.WrapText = False 'metni kaydırma
On Error Resume Next
Sheets(1).UsedRange.ShrinkToFit = True 'uyacak şekilde daralt
On Error Resume Next
Sheets(1).UsedRange.Borders.LineStyle = xlContinuous 'tablo çizgisi ekle
On Error Resume Next
Sheets(1).UsedRange.Borders.ColorIndex = 56 'tablo çizgisi rengi
On Error Resume Next
Sheets(1).UsedRange.Borders.Weight = xlThin 'tablo çizgi kalınlığı
On Error Resume Next
Sheets(1).PageSetup.Orientation = xlLandscape 'yatay yerleşim
On Error Resume Next
Sheets(1).PageSetup.LeftMargin = 2 'soldan pay
On Error Resume Next
Sheets(1).PageSetup.RightMargin = 2 'sağdan pay
On Error Resume Next
Sheets(1).PageSetup.TopMargin = 5 'üstten pay pay
On Error Resume Next
Sheets(1).PageSetup.FooterMargin = 5 'alttan pay pay
On Error Resume Next
Sheets(1).Cells.HorizontalAlignment = xlLeft 'sola yaslar
On Error Resume Next
Sheets(1).Range("B3").HorizontalAlignment = xlCenter 'başlığı ortalar
On Error Resume Next
'Sheets(1).PageSetup.PrintArea = "$B$1:$E$10" 'yazdırma alanı
'Sheets(1).PrintOut Copies:=1 'yazdırır
ActiveWindow.SelectedSheets.PrintPreview
On Error Resume Next

End Sub

PDF

Kod: Tümünü seç

'PDF'e Çevir Başlangıç
'Dim Yol As String
'Application.ScreenUpdating = False
'Application.DisplayAlerts = False
'Yol = ThisWorkbook.Path
'say = CreateObject("Scripting.FileSystemObject").getfolder(Yol).Files.Count + 1
'Sheets("TABLO").PageSetup.PrintArea = "$A$1:$AV$75"
'Sheets(Array("TABLO")).Select
'ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=Yol & "\" & say & ".pdf", _
'Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, _
'OpenAfterPublish:=True
'Application.ScreenUpdating = True
'Application.DisplayAlerts = True
'ActiveWindow.SelectedSheets.PrintPreview 'excel sayfasında önizleme yapıyor
'PDF'e Çevir Bitiş

[Ozan İLGÜN]

Formun sağındaki yazdır butonuna basın.
Soldaki yazdır butonunu silecektim. Ancak başka yerde kullanıp kullanmadığınızı hatırlayamadığım için silmedim.

Dosyam.rar

[massgrave]

Formun sağındaki yazdır butonuna basın.
Soldaki yazdır butonunu silecektim. Ancak başka yerde kullanıp kullanmadığınızı hatırlayamadığım için silmedim.

Dosyam.rar

Teşekkür ediyorum. Yazdır denilip PDF olarak kaydedilince aktif formda kapanıyor.
Ne yapabiliriz.

[Ozan İLGÜN]

Unload Me kısmını kaldırın butondan kapanmasını engellemiş olursunuz.

[massgrave]

Teşekkürler.
İyi Çalışmalar.