• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

İstenilen adreste klasör ve dosya açmak

O

ockucukay

Katılım
29 Aralık 2005
Mesajlar
862
Excel Vers. ve Dili
Office 365 Türkçe
Merhaba arkadaşlar

Ekli dosyada sorularımı detaylı olarak anlattım.Kısaca textboxlarda ve comboboxlarda belirtilen alanları kullanarak oluşturduğum adreste yeni bir klasör açılmasını, spreadsheette ilgili satıra çift tıkladığımda o parçaya ait klasöre gitmesini istiyorum. Yardımlarınız için şimdiden teşekkür ederim.
 
forumda ve diğer yabancı forumlarda araştırma yaptım ama birşey bulamadım. arkadaşlar lütfen yardımlarınızı esirgemeyin.
 
Klasör yaratmak için kod örneği aşağıda verilmektedir. Kırmızı ile işaretli olan bölgeyi, combobox ve textbox'lardaki değerlere göre revize edin. Zira bu kısım, yaratacağınızın klasörün path'idir.

Kod: 
Sub KlasorYarat()
KlasorIsmi = InputBox("Yeni Klasor Adı giriniz")
If KlasorIsmi = "" Then: Exit Sub
   Set FSO = CreateObject("Scripting.FileSystemObject")
   On Error GoTo f1
   FSO.CreateFolder ([COLOR=red][B]ThisWorkbook.Path & "\Deneme\" & KlasorIsmi[/B][/COLOR])
   MsgBox "Yeni bir klasor yaratıldı", vbInformation
   Set FSO = Nothing
   Exit Sub
f1:
   MsgBox Err.Description, vbCritical, "UYARI"
   Set FSO = Nothing
End If
End Sub
 
sayın fpc ilginize öncelikle çok teşekkür ederim. kodunuzu uyguladığımda "KlasorIsmi = InputBox("Yeni Klasor Adı giriniz")" bu satırda type mismatch hatası verdi, sebebini bulamadım. ayrıca ben klasör ismini otomatik alsın istiyorum, kodu aşağıdaki gibi değiştirdim ama yine çalışmadı, sebebi nedir acaba?

Sub B16_Click()
KlasorIsmi = (ALAN01.Value & "-" & ALAN05.Value)("Yeni Parça No giriniz")
If ALAN05 = "" Then: Exit Sub
Set FSO = CreateObject("Scripting.FileSystemObject")
On Error GoTo f1
FSO.CreateFolder (ThisWorkbook.Path & ALAN02.Value & "\" & ALAN03.Value & "\" & KlasorIsmi)
MsgBox "Yeni klasör yaratıldı", vbInformation
Set FSO = Nothing
Exit Sub
f1:
MsgBox Err.Description, vbCritical, "Klasör adını vermediniz"
Set FSO = Nothing
End Sub
 
Kodunuzu aşağıdaki gibi değiştirip deneyin. Hatırlayabildiğim tüm hata kontrollerini koydum

Kod: 
Private Sub CommandButton1_Click()
YasakKarakterler = Array("*", ";", "+", "=", "/", "?", "<", ">", "[", "]")
VeriAlanlari = Array("ALAN01", "ALAN02", "ALAN03", "ALAN05")
For Each ctrl In UserForm1.Controls
    If TypeName(ctrl) = "TextBox" Then
       For z = 0 To 3
           If ctrl.Name = VeriAlanlari(z) Then: GoTo f1
       Next z
       GoTo f2
f1:
       If Len(ctrl.Text) <> 0 Then
          For i = 1 To Len(ctrl.Text)
              aranan = Mid(ctrl.Text, i, 1)
              For j = 0 To 9
                  If YasakKarakterler(j) = aranan Then
                     MsgBox ctrl.Text & " değeri; klasör ismi için uygun değil", vbCritical, "UYARI"
                     Exit Sub
                  End If
              Next j
          Next i
       Else
          MsgBox "Klasorü oluşturulacak elemanlardan birisi boş geçilemez", vbCritical, "UYARI"
          Exit Sub
       End If
f2:
    End If
Next
Klasor = ALAN01.Text & "-" & ALAN05.Text
UstKlasor = ALAN02.Text
Altklasor = ALAN03.Text
Set FSO = CreateObject("Scripting.FileSystemObject")
    yol = ThisWorkbook.Path & "\" & UstKlasor
          If FSO.FolderExists(yol) = False Then: FSO.createfolder (yol)
             yol = yol & "\" & Altklasor
                 If FSO.FolderExists(yol) = False Then: FSO.createfolder (yol)
                    yol = yol & "\" & Klasor
                        If FSO.FolderExists(yol) = False Then
                           FSO.createfolder (yol)
                           MsgBox "Klasor yaratma BAŞARILI", vbInformation, "BİLGİ"
                        Else
                             MsgBox ThisWorkbook.Path & " yolundaki" _
                           & vbCrLf _
                           & UstKlasor & " ve " & Altklasor & " dizinlerinin altında" _
                           & vbCrLf _
                           & Klasor & " adında bir klasör zaten var", vbCritical, "KLASOR ZATEN MEVCUT"
                             Exit Sub
                       End If
Set FSO = Nothing
End Sub
 
sayın fpc öncelikle ilginize çok çok teşekkür ederim, kodlarınızı yeni uygulayabildim ve hepsi çalışıyor. sizin kodlarınızı kullanarak açtığım klasörün içine "Maliyet-Sıra No-Parçano.xls" adı olan bir şablon dosya açmak istedim ancak dosyayı tarif ettiğim adreste açtıramadım. makroyla şablon.xls dosyasını açarak farklı kaydet yapıyorum ve dosyaya "Maliyet-Sıra No-Parçano.xls" ismi vererek kaydediyorum. ancak sizin yazdığınız kodlarla açtığım klasöre değilde masaüstüne kaydediyor.kodu ekte gönderiyorum, umarım yardımlarınız sayesinde bu işi tamamlarım.

Kodlar:

Sub B17_Click()
'
'
Workbooks.Open Filename:= _
"\\Server\d\M.I.S\Teklifler\teklifler\şablon.xls"
Sheets("Hesap Tablosu").Select
YasakKarakterler = Array("*", ";", "+", "=", "/", "?", "<", ">", "[", "]")
VeriAlanlari = Array("ALAN01", "ALAN02", "ALAN03", "ALAN05")
For Each ctrl In UserForm1.Controls
If TypeName(ctrl) = "TextBox" Then
For z = 0 To 3
If ctrl.Name = VeriAlanlari(z) Then: GoTo f1
Next z
GoTo f2
f1:
If Len(ctrl.Text) <> 0 Then
For i = 1 To Len(ctrl.Text)
aranan = Mid(ctrl.Text, i, 1)
For j = 0 To 9
If YasakKarakterler(j) = aranan Then
MsgBox ctrl.Text & " değeri; dosya ismi için uygun değil", vbCritical, "UYARI"
Exit Sub
End If
Next j
Next i
Else
MsgBox "Dosyayı oluşturulacak elemanlardan birisi boş geçilemez", vbCritical, "UYARI"
Exit Sub
End If
f2:
End If
Next
Klasor = "\\Server\d\M.I.S\Teklifler\teklifler\" & "\" & ALAN02.Text & "\" & ALAN03.Text & "\" & ALAN01.Text & "-" & ALAN04.Text
Dosya = "Maliyet-" & ALAN01.Text & "-" & ALAN04.Text & ".xls"
ActiveWorkbook.SaveAs Filename:= _
Dosya, FileFormat _
:=xlNormal, Password:="", WriteResPassword:="", ReadOnlyRecommended:= _
False, CreateBackup:=False 'creating second file with filename = value in cell w1
ActiveSheet.Shapes("Düğme 2").Delete
Range("a1:u5").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("z2:Ae2").ClearContents
Application.CutCopyMode = False
Range("j2").Select
End Sub
 
Aşağıdaki şekilde düzenledim ama deneme imkanım olmadı. Siz deneyip sonucu bildiriniz, düzenleme gerekli olursa da yaparız

Kod: 
Sub B17_Click()
YasakKarakterler = Array("*", ";", "+", "=", "/", "?", "<", ">", "[", "]")
VeriAlanlari = Array("ALAN01", "ALAN02", "ALAN03", "ALAN05")
For Each ctrl In UserForm1.Controls
    If TypeName(ctrl) = "TextBox" Then
       For z = 0 To 3
           If ctrl.Name = VeriAlanlari(z) Then: GoTo f1
       Next z
       GoTo f2
f1:
       If Len(ctrl.Text) <> 0 Then
          For i = 1 To Len(ctrl.Text)
              aranan = Mid(ctrl.Text, i, 1)
              For j = 0 To 9
                  If YasakKarakterler(j) = aranan Then
                     MsgBox ctrl.Text & " değeri; klasör ismi için uygun değil", vbCritical, "UYARI"
                     Exit Sub
                  End If
              Next j
          Next i
       Else
          MsgBox "Klasorü oluşturulacak elemanlardan birisi boş geçilemez", vbCritical, "UYARI"
          Exit Sub
       End If
f2:
    End If
Next
Klasor = ALAN01.Text & "-" & ALAN05.Text
UstKlasor = ALAN02.Text
Altklasor = ALAN03.Text
Set FSO = CreateObject("Scripting.FileSystemObject")
    yol = ThisWorkbook.Path & "\" & UstKlasor
          If FSO.FolderExists(yol) = False Then: FSO.createfolder (yol)
             yol = yol & "\" & Altklasor
                 If FSO.FolderExists(yol) = False Then: FSO.createfolder (yol)
                    yol = yol & "\" & Klasor
                        If FSO.FolderExists(yol) = False Then
                           FSO.createfolder (yol)
                           MsgBox "Klasor yaratma BAŞARILI", vbInformation, "BİLGİ"
                        Else
                             MsgBox ThisWorkbook.Path & " yolundaki" _
                           & vbCrLf _
                           & UstKlasor & " ve " & Altklasor & " dizinlerinin altında" _
                           & vbCrLf _
                           & Klasor & " adında bir klasör zaten var", vbCritical, "KLASOR ZATEN MEVCUT"
                             Exit Sub
                       End If
                       Workbooks.Open Filename:="[URL="file://server/d/M.I.S/Teklifler/teklifler/şablon.xls"]\\Server\d\M.I.S\Teklifler\teklifler\şablon.xls[/URL]"
                       Sheets("Hesap Tablosu").Select
                       Dosya = "Maliyet-" & ALAN01.Text & "-" & ALAN04.Text & ".xls"
                       ActiveWorkbook.SaveAs Filename:=yol & "\" & Dosya, _
                                             FileFormat:=xlNormal, _
                                             Password:="", _
                                             WriteResPassword:="", _
                                             ReadOnlyRecommended:=False, _
                                             CreateBackup:=False
                       ActiveSheet.Shapes("Düğme 2").Delete
                       Range("a1:u5").Select
                       Selection.Copy
                       Selection.PasteSpecial Paste:=xlPasteValues, _
                                              Operation:=xlNone, _
                                              SkipBlanks:=False, _
                                              Transpose:=False
                       Range("z2:Ae2").ClearContents
                       Application.CutCopyMode = False
                       Range("j2").Select
Set FSO = Nothing
End Sub
 
sayın fpc

ilginize çok teşekkür ederim, yazdığınız kodu inceledim. daha önceki klasör koduna ek yapmışsınız, ama ben ayrı bir command butona kod yazıp ayrıca yeni açtığım klasörün içine "Maliyet-Sıra No-Parçano.xls" dosyasını açmak istiyorum. çünkü her zaman açtığım klasörün içine maliyet dosyası açmıyorum. daha öncede yazdığım aşağıdaki kodla dosyayı açıyorum ama masaüstüne kayıt yapıyor adresi görmüyor. bunu nasıl yaparım ? bu konuda yardımcı olursanız sevinirim.

Sub B17_Click()
'
'
Workbooks.Open Filename:= _
"\\Server\d\M.I.S\Teklifler\teklifler\şablon.x ls"
Sheets("Hesap Tablosu").Select
YasakKarakterler = Array("*", ";", "+", "=", "/", "?", "<", ">", "[", "]")
VeriAlanlari = Array("ALAN01", "ALAN02", "ALAN03", "ALAN05")
For Each ctrl In UserForm1.Controls
If TypeName(ctrl) = "TextBox" Then
For z = 0 To 3
If ctrl.Name = VeriAlanlari(z) Then: GoTo f1
Next z
GoTo f2
f1:
If Len(ctrl.Text) <> 0 Then
For i = 1 To Len(ctrl.Text)
aranan = Mid(ctrl.Text, i, 1)
For j = 0 To 9
If YasakKarakterler(j) = aranan Then
MsgBox ctrl.Text & " değeri; dosya ismi için uygun değil", vbCritical, "UYARI"
Exit Sub
End If
Next j
Next i
Else
MsgBox "Dosyayı oluşturulacak elemanlardan birisi boş geçilemez", vbCritical, "UYARI"
Exit Sub
End If
f2:
End If
Next
Klasor = "\\Server\d\M.I.S\Teklifler\teklifler\" & "\" & ALAN02.Text & "\" & ALAN03.Text & "\" & ALAN01.Text & "-" & ALAN04.Text
Dosya = "Maliyet-" & ALAN01.Text & "-" & ALAN04.Text & ".xls"
ActiveWorkbook.SaveAs Filename:= _
Dosya, FileFormat _
:=xlNormal, Password:="", WriteResPassword:="", ReadOnlyRecommended:= _
False, CreateBackup:=False 'creating second file with filename = value in cell w1
ActiveSheet.Shapes("Düğme 2").Delete
Range("a1:u5").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("z2:Ae2").ClearContents
Application.CutCopyMode = False
Range("j2").Select
End Sub
 
Verdi&#287;iniz kod'da; a&#351;a&#287;&#305;daki blo&#287;un ne i&#351;e yarad&#305;&#287;&#305;n&#305; anlayamad&#305;m. Bunun prosed&#252;rde hi&#231;bir i&#351;levi yok.

Kod: 
'.....
YasakKarakterler = Array("*", ";", "+", "=", "/", "?", "<", ">", "[", "]")
VeriAlanlari = Array("ALAN01", "ALAN02", "ALAN03", "ALAN05")
For Each ctrl In UserForm1.Controls
If TypeName(ctrl) = "TextBox" Then
For z = 0 To 3
If ctrl.Name = VeriAlanlari(z) Then: GoTo f1
Next z
GoTo f2
f1:
If Len(ctrl.Text) <> 0 Then
For i = 1 To Len(ctrl.Text)
aranan = Mid(ctrl.Text, i, 1)
For j = 0 To 9
If YasakKarakterler(j) = aranan Then
MsgBox ctrl.Text & " de&#287;eri; dosya ismi i&#231;in uygun de&#287;il", vbCritical, "UYARI"
Exit Sub
End If
Next j
Next i
Else
MsgBox "Dosyay&#305; olu&#351;turulacak elemanlardan birisi bo&#351; ge&#231;ilemez", vbCritical, "UYARI"
Exit Sub
End If
f2:
End If
Next
Klasor = "\\Server\d\M.I.S\Teklifler\teklifler\" & "\" & ALAN02.Text & "\" & ALAN03.Text & "\" & ALAN01.Text & "-" & ALAN04.Text
'.........

Size enson verdi&#287;im kodlar, zaten bunu ayr&#305; bir d&#252;&#287;meye ataman&#305;z i&#231;in g&#246;nderilmi&#351;ti. Bu kod, ilgili parametrelere uyan bir klas&#246;r olup olmad&#305;&#287;&#305;na bakar, varsa bu klas&#246;r&#252;n alt&#305;na dosyay&#305; yarat&#305;r. Yoksa, ilk &#246;nce klas&#246;r&#252; yarat&#305;p sonra dosyay&#305; bu klas&#246;r&#252;n alt&#305;na ekler.

NOT : Denedi&#287;iniz kodlar&#305;n masa&#252;st&#252;ne kaydetmesinin nedeni ,aktif &#231;al&#305;&#351;ma dizinizin, Desktop olmas&#305;ndan kaynaklanmaktad&#305;r. Yani hi&#231;bir yol belirtmezseniz, kaydedilecek dosya aktif &#231;al&#305;&#351;ma dizinine kaydedilir. &#214;rne&#287;in : E&#287;er en son a&#231;t&#305;&#287;&#305;n&#305;z dosya, Belgelerim dizini olsayd&#305;, aktif &#231;al&#305;&#351;ma dizininiz Belgelerim klas&#246;r&#252; olacakt&#305; ve dosyan&#305;z buraya kaydedilecekti.
 
Veya iste&#287;iniz s&#246;yle bir&#351;ey midir?

"Klas&#246;r&#252;n varolup olmad&#305;&#287;&#305;n&#305; bilmiyorum. Onun i&#231;in bana bu dizin alt&#305;ndaki t&#252;m klas&#246;rleri listelesin.. Ben, buradan klas&#246;r&#252; se&#231;erek &#231;al&#305;&#351;ma kitab&#305;n&#305; bunun alt&#305;na kopyalayay&#305;m. E&#287;er yoksa, yeni bir prosed&#252;r devreye girsin ve bir tane klas&#246;r olu&#351;turup &#231;al&#305;&#351;ma kitab&#305;n&#305; bunun alt&#305;na ats&#305;n."
 
1. sorunuza cevap: anlamadığınız bloğu sizin kodlarınızdan almıştım, amacım sizin klasör oluştururken yaptığınız kontrolleri dosyayı oluştururken yapmaktı. anlaşılan becerememişim :)
2. sorunuza cevap: evet, klasör varmı yokmu baksın, klasör varsa altına bu dosyayı kaydetsin. klasör yoksa klasörü yaratıp dosyayıda bu yarattığı klasörün altına kaydetsin istiyorum.

aktif dizine gelince, makroya yazdığım kurala göre kaydetmesini istiyorum, neden ona uymuyorda aktif klasöre bakıyor? yanlış bir yazımmı yapıyorum acaba? öyle olmasa direk olarak aktif dizini seçmezdi herhalde...

sayın fpc, başınızı ağrıtmadım umarım. bu bilgiye aç arkadaşınızı hoşgörürsünüz inşallah, sağlıcakla kalın.
 
Klasör ve alt klasörlerin tümünü oluşturmanın kısa bir yolu;

Kod: 
Declare Function SHCreateDirectoryEx Lib "shell32" Alias "SHCreateDirectoryExA" (ByVal hwnd As Long, ByVal pszPath As String, ByVal psa As Any) As Long
'
Sub Test()
    Klasor = "\\Server\d\M.I.S\Teklifler\teklifler\" & "\" & ALAN02.Text & "\" & ALAN03.Text & "\" & ALAN01.Text & "-" & ALAN04.Text
    SHCreateDirectoryEx 0, Klasor, ByVal 0&
End Sub
 
Say&#305;n fpc;


Rica ederim, ben bir &#351;ey yapmad&#305;m.

Sadece, konuyla ilgili mevcut bir API fonksiyonu oldu&#287;unu hat&#305;rlam&#305;&#351;t&#305;m.

&#304;lginiz i&#231;in te&#351;ekk&#252;r ederim.
 
cahilliğimi mazur görün ama haluk beyin yazdığı kod makroda hangi satırları kısaltıyor anlayamadım, kısaca açıklayabilirmisiniz? birde aşağıdaki sorularla ilgili bir gelişme var mı acaba? ilgilenen arkadaşlarıma çok teşekkür ederim şimdiden...

"2. sorunuza cevap: evet, klasör varmı yokmu baksın, klasör varsa altına bu dosyayı kaydetsin. klasör yoksa klasörü yaratıp dosyayıda bu yarattığı klasörün altına kaydetsin istiyorum.

aktif dizine gelince, makroya yazdığım kurala göre kaydetmesini istiyorum, neden ona uymuyorda aktif klasöre bakıyor? yanlış bir yazımmı yapıyorum acaba? öyle olmasa direk olarak aktif dizini seçmezdi herhalde..."
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst