DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
Altın Üyelik Hakkında Bilgi
Sub sayfakaydet()
Sayfa_Adı = ActiveSheet.Name
Klasor = ActiveWorkbook.Path & Application.PathSeparator
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
Dim ds, a
Set ds = CreateObject("Scripting.FileSystemObject")
Dim sayfa As Worksheet
For Each sayfa In Worksheets
If sayfa.Name = Sayfa_Adı Then
For i = Len(ThisWorkbook.Name) To 1 Step -1
If Mid(ThisWorkbook.Name, i, 1) = "." Then
Dosya_adi = Mid(ThisWorkbook.Name, 1, i - 1)
Exit For
End If
Next
For Each Dosya In CreateObject("Scripting.FileSystemObject").GetFolder(Klasor).Files
If Mid(Dosya.Name, 1, Len(Dosya_adi)) = Dosya_adi Then
sat = sat + 1
a = ds.FileExists(Klasor & Dosya_adi & sat) ' & Uzanti)
If a = True Then
Else
son = 1
Exit For
End If
End If
Next
If son = 0 Then
sat = sat + 1
End If
sayfa.Copy
deger = Dosya_adi & sat & Uzanti
ActiveSheet.DrawingObjects.Delete
For Each component In ActiveWorkbook.VBProject.VBComponents
If component.Type <> 100 Then
ActiveWorkbook.VBProject.VBComponents.Remove component
Else
Set modul = component.CodeModule
modul.DeleteLines 1, modul.CountOfLines
End If
Next
Dim wb As Workbook
Set wb = ActiveWorkbook
Application.DisplayAlerts = False
With wb
.SaveAs Klasor & deger
.Close SaveChanges:=False
End With
Application.DisplayAlerts = True
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End If
Next
End Sub
Dim oWSHShell As Object
Set oWSHShell = CreateObject("WScript.Shell")
Klasor = oWSHShell.SpecialFolders("Desktop") & Application.PathSeparator
Set oWSHShell = Nothing
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
Dim ds, a
Set ds = CreateObject("Scripting.FileSystemObject")
Dim sayfa As Worksheet
For Each sayfa In Worksheets
If sayfa.Name = "GELENEVRAK" Then
For i = Len(ThisWorkbook.Name) To 1 Step -1
If Mid(ThisWorkbook.Name, i, 1) = "." Then
Dosya_adi = Mid(ThisWorkbook.Name, 1, i - 1)
Exit For
End If
Next
For Each Dosya In CreateObject("Scripting.FileSystemObject").GetFolder(Klasor).Files
If Mid(Dosya.Name, 1, Len(Dosya_adi)) = Dosya_adi Then
sat = sat + 1
a = ds.FileExists(Klasor & Dosya_adi & sat) ' & Uzanti)
If a = True Then
Else
son = 1
Exit For
End If
End If
Next
If son = 0 Then
sat = sat + 1
End If
sayfa.Copy
deger = Dosya_adi & sat & Uzanti
ActiveSheet.DrawingObjects.Delete
For Each component In ActiveWorkbook.VBProject.VBComponents
If component.Type <> 100 Then
ActiveWorkbook.VBProject.VBComponents.Remove component
Else
Set modul = component.CodeModule
modul.DeleteLines 1, modul.CountOfLines
End If
Next
Dim wb As Workbook
Set wb = ActiveWorkbook
Application.DisplayAlerts = False
With wb
.SaveAs Klasor & deger
.Close SaveChanges:=False
End With
Application.DisplayAlerts = True
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End If
Next
Private Sub cmdexcelrapor_Click()
Dim oWSHShell As Object
Set oWSHShell = CreateObject("WScript.Shell")
Klasor = oWSHShell.SpecialFolders("Desktop")
Set oWSHShell = Nothing
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
Dim ds, a
Set ds = CreateObject("Scripting.FileSystemObject")
Dim sayfa As Worksheet
For Each sayfa In Worksheets
If sayfa.Name = "GELENEVRAK" Then
For i = Len(ThisWorkbook.Name) To 1 Step -1
If Mid(ThisWorkbook.Name, i, 1) = "." Then
Dosya_adi = Mid(ThisWorkbook.Name, 1, i - 1)
Exit For
End If
Next
sayfa.Copy
deger = Dosya_adi & " " & Format(Now, "yyyymmdddd hhmmss") & Uzanti
ActiveSheet.DrawingObjects.Delete
For Each component In ActiveWorkbook.VBProject.VBComponents
If component.Type <> 100 Then
ActiveWorkbook.VBProject.VBComponents.Remove component
Else
Set modul = component.CodeModule
modul.DeleteLines 1, modul.CountOfLines
End If
Next
Dim wb As Workbook
Set wb = ActiveWorkbook
Application.DisplayAlerts = False
With wb
.SaveAs Klasor & Application.PathSeparator & deger
.Close SaveChanges:=False
End With
Application.DisplayAlerts = True
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End If
Next
End Sub
"Tekrar" derken daha önce "pdf" miydi?bir şey soracağım peki bu sayfayı tekrar pdf formatına dönüştürebilirmiyim
Dim oWSHShell As Object
Set oWSHShell = CreateObject("WScript.Shell")
Klasor = oWSHShell.SpecialFolders("Desktop")
Set oWSHShell = Nothing
Sheets("GELENEVRAK").ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
Klasor & "\GELEN EVRAK KAYIT " & Format(Now, "yyyymmdddd hhmmss") & ".pdf", Quality:=xlQualityStandard, _
IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:= _
False