
-
- Destek
-
Özel Arama
![]() |
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
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
ozan.ilgun@boun.edu.tr |
Ozan İLGÜN yazdı: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
ozan.ilgun@boun.edu.tr |
[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.ilgun@boun.edu.tr |
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'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.ilgun@boun.edu.tr |
Ozan İLGÜN yazdı: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.
ozan.ilgun@boun.edu.tr |
Bu forumu görüntüleyenler: AhrefsBot ve 1 misafir