Excel listboxa klasör içindeki word belgelerini sırala

[işsiz123]

Arkadaşlar Hayırlı Cumalar
1 Ekte gönderdiğim dosyada userform içindeki listbox a word dosyalarını sıralamak istiyorum
2 Userform üzerindeki butona tıkladığımızda imputbox açılıp girdiğimiz veriyi yeni açılacak word dosyasının ismi kabul edecek.

http://s9.dosya.tc/server2/tr1s9b/dosyam_2.rar.html

 

[PLİNT]

Merhaba
"Userform" da bulunan kodları aşağıdakilerle değiştirip deneyiniz.

[SIZE="2"]Private Sub UserForm_Initialize()
Dim ds, dc, f, s
Set ds = CreateObject("Scripting.FileSystemObject")
Set f = ds.GetFolder("G:\çalışmalar\yeni\WORD HAZIRLA\")
Set dc = f.Files
For Each dosya In dc
If InStr(1, ds.GetExtensionName(dosya), "doc", vbTextCompare) > 0 Then _
[COLOR="Blue"]If InStr(1, ds.GetBaseName(dosya), "$", vbTextCompare) = 0 Then[/COLOR] ListBox1.AddItem ds.GetBaseName(dosya)
Next
End Sub [/SIZE]

[SIZE="2"]Private Sub CommandButton1_Click()
 Dim yeniword As String
     yeniword = InputBox("yeni word ismini giriniz")
    If yeniword = vbNullString Then
        MsgBox ("Hazırlanmadı")
        Else
Set s = CreateObject("Word.Application")
Set y = s.Documents.Add
 s.Visible = True
ad = Date
  y.SaveAs Filename:="G:\çalışmalar\yeni\WORD HAZIRLA\" & yeniword & ".docx"
g = MsgBox("işlem bitti,dosya kaydedildi kapatılsınmı?", vbYesNo)
If g = vbYes Then 
y.Close False
s.Quit
end if
    End If
[COLOR="Blue"]    ListBox1.Clear
    UserForm_Initialize[/COLOR]
End Sub [/SIZE]

 

[işsiz123]

Merhaba
"Userform" da bulunan kodları aşağıdakilerle değiştirip deneyiniz.

[SIZE="2"]Private Sub UserForm_Initialize()
Dim ds, dc, f, s
Set ds = CreateObject("Scripting.FileSystemObject")
Set f = ds.GetFolder("G:\çalışmalar\yeni\WORD HAZIRLA\")
Set dc = f.Files
For Each dosya In dc
If InStr(1, ds.GetExtensionName(dosya), "doc", vbTextCompare) > 0 Then _
[COLOR="Blue"]If InStr(1, ds.GetBaseName(dosya), "$", vbTextCompare) = 0 Then[/COLOR] ListBox1.AddItem ds.GetBaseName(dosya)
Next
End Sub [/SIZE]

[SIZE="2"]Private Sub CommandButton1_Click()
 Dim yeniword As String
     yeniword = InputBox("yeni word ismini giriniz")
    If yeniword = vbNullString Then
        MsgBox ("Hazırlanmadı")
        Else
Set s = CreateObject("Word.Application")
Set y = s.Documents.Add
 s.Visible = True
ad = Date
  y.SaveAs Filename:="G:\çalışmalar\yeni\WORD HAZIRLA\" & yeniword & ".docx"
g = MsgBox("işlem bitti,dosya kaydedildi kapatılsınmı?", vbYesNo)
If g = vbYes Then 
y.Close False
s.Quit
end if
    End If
[COLOR="Blue"]    ListBox1.Clear
    UserForm_Initialize[/COLOR]
End Sub [/SIZE]

Teşekkürler tek bir sorun kaldı.
yeni açtığımız word belgesi excel userform üzerinden veri akatara bilir miyiz. şu MsgBox("işlem bitti,dosya kaydedildi kapatılsınmı?" mesajdan önce
userformdan işaretlediğimiz checboxları word sayfasına eklesin
Word belgesinde userform için hazırladığım kod

Private Sub CheckBox1_Click()
If CheckBox1.Value = True Then
Selection.TypeText Text:=CheckBox1.Caption
    Selection.TypeParagraph    ' ALT ALTA YAZ
    CheckBox1.Locked = True
    Else

    End If
End Sub

lakin sizin verdiğini kodlardaki yeni açtığınız word dosyası uyarlayamadım

Uzun lafın kısası:yazici: yeni oluşturduğum word dosyasına userform üzerindeki CheckBox veya başka yöntemle veri eklemek istiyorum.

 

[PLİNT]

Merhaba
"Commandbutton1" kodlarının ilgili bölümüne aşağıdaki kırmızı kodları ekleyip/değiştirip; döngüyü "Checkbox" adedine göre ayarlayın.

 [SIZE="2"] '....
'....kodlarınız
  y.SaveAs Filename:="G:\çalışmalar\yeni\WORD HAZIRLA\" & yeniword & ".docx"
[COLOR="Red"]For n = 1 To 3
If Controls("CheckBox" & n).Value = True Then
i = i + 1
 y.Paragraphs(i).Range.Text = Controls("CheckBox" & n).Caption
y.Paragraphs(i).Range.InsertParagraphAfter
End If
Next[/COLOR]
g = MsgBox("işlem bitti,dosya kaydedildi kapatılsınmı?", vbYesNo)
If g = vbYes Then
y.Close [COLOR="Red"]True[/COLOR]
s.Quit
End If
    End If
    ListBox1.Clear
    UserForm_Initialize
End Sub
[/SIZE]

 

[işsiz123]

Sayın PLİNT gerçekten harikasınız teşekkürler
Son bir sorum listboxta seçtiğimiz word dosyayı silme işlemi için nasıl bir kod önerirsiniz

 

[işsiz123]

Konu güncel

 

[PLİNT]

Son bir sorum listboxta seçtiğimiz word dosyayı silme işlemi için nasıl bir kod önerirsiniz

Merhaba
"Listbox1" de dosya adına çift tık ile aşağıdaki gibi olabilir;

[SIZE="2"]Private Sub ListBox1_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
sor = MsgBox("seçilen dosya silinsinmi?", vbYesNo)
If sor = vbYes And ListBox1.Value <> "" Then
yol = "G:\çalışmalar\yeni\WORD HAZIRLA\"
Kill yol & ListBox1.Value & ".doc*"
End If
[COLOR="Blue"]   ListBox1.Clear
    UserForm_Initialize[/COLOR]
End Sub [/SIZE]

 

[işsiz123]

Teşekkürler

 

[işsiz123]

sayın PLİNT bir sorun var :kafa: CheckBox1 işaretlemesek hata veriyor hatta CheckBox1 harici diğer CheckBox işaretli ise word dosyasına yazmıyor. yani ila CheckBox1 işaretlemek gerekiyor.

Merhaba
"Commandbutton1" kodlarının ilgili bölümüne aşağıdaki kırmızı kodları ekleyip/değiştirip; döngüyü "Checkbox" adedine göre ayarlayın.

 [SIZE="2"] '....
'....kodlarınız
  y.SaveAs Filename:="G:\çalışmalar\yeni\WORD HAZIRLA\" & yeniword & ".docx"
[COLOR="Red"]For n = 1 [COLOR="Blue"]To 3[/COLOR]
If Controls("CheckBox" & n).Value = True Then
 y.Paragraphs(n).Range.Text = Controls("CheckBox" & n).Caption
y.Paragraphs(n).Range.InsertParagraphAfter
End If
Next[/COLOR]
g = MsgBox("işlem bitti,dosya kaydedildi kapatılsınmı?", vbYesNo)
If g = vbYes Then
y.Close [COLOR="Red"]True[/COLOR]
s.Quit
End If
    End If
    ListBox1.Clear
    UserForm_Initialize
End Sub
[/SIZE]

 

[PLİNT]

sayın PLİNT bir sorun var :kafa: CheckBox1 işaretlemesek hata veriyor hatta CheckBox1 harici diğer CheckBox işaretli ise word dosyasına yazmıyor. yani ila CheckBox1 işaretlemek gerekiyor.

Buton kodlarının içine sonradan eklediğimiz döngüyü şöyle deneyelim

'....
'...
For n = 1 [COLOR="Red"]To 3[/COLOR]
If Controls("CheckBox" & n).Value = True Then
[COLOR="Blue"]i = i + 1[/COLOR]
 y.Paragraphs([COLOR="Blue"]i[/COLOR]).Range.Text = Controls("CheckBox" & n).Caption
y.Paragraphs([COLOR="Blue"]i[/COLOR]).Range.InsertParagraphAfter
End If
Next
'....
'...

 

[işsiz123]

Tamam Oldu Teşekkürler.