Kod:
Private Declare Function Calistir Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hwnd As Long, ByVal lpszOp As String, ByVal lpszFile As String, _
ByVal lpszParams As String, ByVal lpszDir As String, ByVal FsShowCmd As Long) As Long
Private Const SW_HIDE = 0
Private Const SW_SHOWNORMAL = 1
Private Const SW_PRINTNORMAL = 2
Dim YazdirmaSeceneci As Long
Public Function Kostur(DosyaAdi As String, Optional DosyaIslem As String = "print") As Boolean
Dim CalIslem As Long
CalIslem = Calistir(0&, DosyaIslem, DosyaAdi, vbNullString, vbNullString, IIf(DosyaIslem = "print", SW_HIDE, SW_SHOWNORMAL))
If CalIslem <= 32 Then
Kostur = False
MsgBox "Hatali " & DosyaIslem & " " & DosyaAdi & vbCrLf & vbCrLf & "Islem yapilamadi.", vbExclamation
Else
Kostur = True
End If
End Function
Private Sub Form_Load()
Me.KlasorAdi.Text = App.Path
End Sub
Private Sub KlasorAdi_DblClick()
WinPen.ShowOpen
Me.KlasorAdi.Text = Mid(WinPen.FileName, 1, Len(WinPen.FileName) - InStr(1, StrReverse(WinPen.FileName), "\"))
End Sub
Private Sub KlasorAdi_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
Me.Mesaj.Caption = "Cift tiklayip, klasor degistirebilirsiniz."
End Sub
Private Sub KlasorSec_Change()
Me.KlasorAdi.Text = Me.KlasorSec.Path
End Sub
Private Sub KlasorSec_Click()
Me.KlasorAdi.Text = Me.KlasorSec.Path
End Sub
Private Sub KlasorSec_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
Me.Mesaj.Caption = "Klasoru secmek icin cift tiklayiniz."
End Sub
Private Sub Secmece_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
Me.Mesaj.Caption = "Yazdirilacak dosya tipini secin."
End Sub
Private Sub Yaz_Click()
Dim evn As Object, klasor As Object, dosya As Object, yol, Tip As Variant, Msg, Yer
Dim SW, Yz As Long
Msg = MsgBox("Yazdýrmak Ýstediðinizden Emin misiniz?", vbYesNo + vbQuestion, "Çýkýþ")
Tip = Array("", "pdf", "xls", "doc", "ppt", "txt") '********* DOSYA UZANTILARINI BURAYA YAZDIR ************
If Msg = vbYes Then
Yer = Me.KlasorAdi.Text
Set evn = CreateObject("shell.application")
yol = CreateObject("scripting.filesystemobject").getfolder(Yer)
Set klasor = evn.Namespace(yol)
Set dosya = klasor.Items()
SW = 1
For Each dosya In dosya
For SW = IIf(YazdirmaSeceneci = 0, 1, YazdirmaSeceneci) To IIf(YazdirmaSeceneci = 0, 5, YazdirmaSeceneci) '********* DOSYA UZANTILARINa gore 5 + veya - ************
If Tip(SW) = Mid(dosya.Name, (InStr(1, dosya.Name, ".") + 1), 3) Then Yz = 1: Exit For Else Yz = 0
Next SW
If Yz = 1 Then
Call Kostur(Yer & "\" & dosya.Name, "Print")
Me.Mesaj.Caption = dosya
Me.Mesaj.Refresh
End If
Yz = 0
Next dosya
Set dosya = Nothing: Set klasor = Nothing: Set yol = Nothing: Set evn = Nothing:
Me.Mesaj.Caption = "YAZDIRMA ISLEMI TAMAMLANDI."
ElseIf Msg = vbNo Then
Exit Sub
End If
If YazdirmaSeceneci > 0 Then Me.Controls("Option" & YazdirmaSeceneci).Value = False
YazdirmaSeceneci = 0
End Sub
Private Sub Yaz_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
Me.Mesaj.Caption = "Klasoru yazdirmak icin tiklayin."
End Sub
Private Sub Option1_Click()
YazdirmaSeceneci = Me.Option1.Tag
Me.Mesaj.Caption = "Pdf turunde ki dosyalar yazdirilacak"
End Sub
Private Sub Option2_Click()
YazdirmaSeceneci = Me.Option2.Tag
Me.Mesaj.Caption = "Excel turunde ki dosyalar yazdirilacak"
End Sub
Private Sub Option3_Click()
YazdirmaSeceneci = Me.Option3.Tag
Me.Caption = Me.Option3.Tag
Me.Mesaj.Caption = "Word turunde ki dosyalar yazdirilacak"
End Sub
Private Sub Option4_Click()
YazdirmaSeceneci = Me.Option4.Tag
Me.Mesaj.Caption = "Power Point turunde ki dosyalar yazdirilacak"
End Sub
Private Sub Option5_Click()
YazdirmaSeceneci = Me.Option5.Tag
Me.Mesaj.Caption = "Metin turunde ki dosyalar yazdirilacak"
End Sub
KlasorDosyaYazma.rar
(Dosya Boyutu: 8,28 KB | İndirme Sayısı: 3)
(
