DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
Altın Üyelik Hakkında Bilgi
Sub PrintViaMicrosoftToPDF()
'Save the current active printer for later reset:
Dim OldPrinter
OldPrinter = Trim(Split(Application.ActivePrinter, "in")(0))
'Define the new active printer
CreateObject("WScript.Network").SetDefaultPrinter "Microsoft Print to PDF"
Dim objShell
Set objShell = CreateObject("WScript.Shell")
Dim IE As InternetExplorer
Set IE = New InternetExplorerMedium ' New InternetExplorer
IE.Visible = True
Dim FSO As Scripting.FileSystemObject
Dim objfolder As Scripting.Folder
Dim objfiles As Scripting.Files
Dim F As Scripting.File
FilePath = ThisWorkbook.Path & "\htm\"
Set FSO = New Scripting.FileSystemObject
Set objfolder = FSO.GetFolder(FilePath)
Set objfiles = objfolder.Files
For Each F In objfiles
IE.Navigate2 F.Path
Do While IE.readyState <> 4
DoEvents
Loop
'Prints but prompts :(
'IE.ExecWB 6, 2, "", ""
IE.ExecWB 6, 2, 0, 0
Next
'Reset Printer
CreateObject("WScript.Network").SetDefaultPrinter OldPrinter
End Sub[code]
'===========================================================================
' Bu program ile belirli folderdaki tüm dosyalar sıra ile açılır. Açılan doyalarınız tarafınızdan kapatıldıkça
' program klasördeki dosyaları açmaya devam eder.
'===========================================================================
Call ExecuteDirectory("C:\Users\kullanıcı\Desktop\Stack_Html - Kopya") 'Klasör yolu
Function ExecuteDirectory(strPath2Folder)
Dim fso, f, fc, f1, strFiles, intFiles
Dim WshShell
Set WshShell = CreateObject("WScript.Shell")
strFiles = ""
Set fso = CreateObject("Scripting.FileSystemObject")
If (fso.FolderExists(strPath2Folder)) Then
Set f = fso.GetFolder(strPath2Folder)
Set fc = f.Files
'-- Execute each file in Folder
For Each f1 in fc
Dim fileToRun
fileToRun = strPath2Folder & "\" & f1.Name
WshShell.Run Chr(34) & fileToRun & Chr(34), 1, true
Next
Set f1 = Nothing
Set fc = Nothing
Set f = Nothing
End If
Set fso = Nothing
End Function
Sub test()
progName = "D:\htmlToPdf\htmlToPdf_.exe"
htmlPath = "D:\Test"
'CreateObject("WScript.Shell").Run progName & " " & htmlPath, 1, True
Shell progName & " " & htmlPath
End Sub
Çok teşekkür ederim, gayet pratik ve sorunsuz çalışıyor, toplu olarak pdf' e çeviriyor. İyi çalışmalar.Lınktekı rar dosyasını bır klasore çıkartın. Adresını progName de düzeltın. Programda kullanılan Dll'ın kullanımı ıçın sınır var mı bılmıyorum.Kod:Sub test() progName = "D:\htmlToPdf\htmlToPdf_.exe" htmlPath = "D:\Test" 'CreateObject("WScript.Shell").Run progName & " " & htmlPath, 1, True Shell progName & " " & htmlPath End Sub
Insallah calısır.
Veysel Bey merhaba,Lınktekı rar dosyasını bır klasore çıkartın. Adresını progName de düzeltın. Programda kullanılan Dll'ın kullanımı ıçın sınır var mı bılmıyorum.Kod:Sub test() progName = "D:\htmlToPdf\htmlToPdf_.exe" htmlPath = "D:\Test" 'CreateObject("WScript.Shell").Run progName & " " & htmlPath, 1, True Shell progName & " " & htmlPath End Sub
Insallah calısır.
test klasörünün içinde oluyor ancak klasörde değil de buraya çıkart şeklinde, yani html uzantılı dosyalar şeklide oluyorVeysel Bey merhaba,
Kodu çalıştırdım ama dosyaları bulamıyorum. Dosyaları nereye çıkartıyor ?
Teşekkür ederim.
Sub PrintViaMicrosoftToPDF()
'Save the current active printer for later reset:
Dim OldPrinter
OldPrinter = Trim(Split(Application.ActivePrinter, "in")(0))
'Define the new active printer
CreateObject("WScript.Network").SetDefaultPrinter "Microsoft Print to PDF"
Dim IE As InternetExplorer
Dim fso As Scripting.FileSystemObject
Dim objfolder As Scripting.Folder
Dim objfiles As Scripting.Files
Dim f As Scripting.File
filePath = ThisWorkbook.Path & "\htm\"
Set fso = New Scripting.FileSystemObject
Set objfolder = fso.GetFolder(filePath)
Set objfiles = objfolder.Files
For Each f In objfiles
Call Close_IEopenedWindows
'Set IE = New InternetExplorerMedium ' New InternetExplorer
Set IE = GetObject("new:{D5E8041D-920F-45e9-B8FB-B1DEB82C6E5E}")
IE.navigate "file:///" & (f.Path)
IE.Visible = True
pdfFilePath = objfolder & "\" & fso.GetBaseName(f) & ".pdf"
'IE.Navigate2 f.Path
Do While IE.readyState <> 4
DoEvents
Loop
'Prints but prompts :(
'IE.ExecWB 6, 2, "", ""
IE.ExecWB 6, 2, 0, 0
Application.Wait Now + TimeValue("00:00:02")
Application.SendKeys pdfFilePath, True
Application.Wait Now + TimeValue("00:00:02")
Application.SendKeys "{ENTER}"
Application.Wait Now + TimeValue("00:00:01")
Next
Call Close_IEopenedWindows
Set fso = Nothing: Set objfolder = Nothing: Set objfiles = Nothing: Set IE = Nothing
'Reset Printer
CreateObject("WScript.Network").SetDefaultPrinter OldPrinter
End Sub
Sub Close_IEopenedWindows()
Dim objWMI As Object, objProcess As Object, objProcesses As Object
Set objWMI = GetObject("winmgmts://.")
Set objProcesses = objWMI.ExecQuery( _
"SELECT * FROM Win32_Process WHERE Name = 'iexplore.exe'")
On Error Resume Next
For Each objProcess In objProcesses
Call objProcess.Terminate
Next
Set objShell = Nothing: Set objProcesses = Nothing: Set objShell = Nothing
End Sub
Sayın dost, teşekkür ederim öncelikle cevabınız için. Konuyu nasıl hallettim hatırlamıyorum inanın. Ama verdiğiniz kodu saklayacağım. Mutlaka işime yarayacaktır.@hamitcan,
Konu biraz eski ama...
Eğer sorununu çözmediysen aşağıdaki kodu denersiniz.
C++:Sub PrintViaMicrosoftToPDF() 'Save the current active printer for later reset: Dim OldPrinter OldPrinter = Trim(Split(Application.ActivePrinter, "in")(0)) 'Define the new active printer CreateObject("WScript.Network").SetDefaultPrinter "Microsoft Print to PDF" Dim IE As InternetExplorer Dim fso As Scripting.FileSystemObject Dim objfolder As Scripting.Folder Dim objfiles As Scripting.Files Dim f As Scripting.File filePath = ThisWorkbook.Path & "\htm\" Set fso = New Scripting.FileSystemObject Set objfolder = fso.GetFolder(filePath) Set objfiles = objfolder.Files For Each f In objfiles Call Close_IEopenedWindows 'Set IE = New InternetExplorerMedium ' New InternetExplorer Set IE = GetObject("new:{D5E8041D-920F-45e9-B8FB-B1DEB82C6E5E}") IE.navigate "file:///" & (f.Path) IE.Visible = True pdfFilePath = objfolder & "\" & fso.GetBaseName(f) & ".pdf" 'IE.Navigate2 f.Path Do While IE.readyState <> 4 DoEvents Loop 'Prints but prompts :( 'IE.ExecWB 6, 2, "", "" IE.ExecWB 6, 2, 0, 0 Application.Wait Now + TimeValue("00:00:02") Application.SendKeys pdfFilePath, True Application.Wait Now + TimeValue("00:00:02") Application.SendKeys "{ENTER}" Application.Wait Now + TimeValue("00:00:01") Next Call Close_IEopenedWindows Set fso = Nothing: Set objfolder = Nothing: Set objfiles = Nothing: Set IE = Nothing 'Reset Printer CreateObject("WScript.Network").SetDefaultPrinter OldPrinter End Sub Sub Close_IEopenedWindows() Dim objWMI As Object, objProcess As Object, objProcesses As Object Set objWMI = GetObject("winmgmts://.") Set objProcesses = objWMI.ExecQuery( _ "SELECT * FROM Win32_Process WHERE Name = 'iexplore.exe'") On Error Resume Next For Each objProcess In objProcesses Call objProcess.Terminate Next Set objShell = Nothing: Set objProcesses = Nothing: Set objShell = Nothing End Sub