Başka bir sayfadaki bir liste tarafından doldurulan şirketlerden oluşan bir açılır menüm var. Üç sütun, Şirket, İş # ve Parça Numarası.
Bir iş oluşturulduğunda, söz konusu şirket için bir klasöre ve söz konusu Parça Numarası için bir alt klasöre ihtiyacım var.
Eğer bu yoldan giderseniz şöyle görünecektir:
C:\Images\Company Name\Part Number\
Şirket adı veya Parça numarası mevcutsa oluşturmayın veya eskisinin üzerine yazmayın. Sadece bir sonraki adıma geçin. Yani her iki klasör de mevcutsa hiçbir şey olmaz, biri veya her ikisi de mevcut değilse gerektiği gibi oluşturun.
Başka bir soru, Mac'lerde ve PC'lerde aynı şekilde çalışmasını sağlamanın bir yolu var mı?
Bir alt ve iki fonksiyon. Sub, yolunuzu oluşturur ve yolun var olup olmadığını kontrol etmek ve yoksa oluşturmak için fonksiyonları kullanır. Eğer tam yol zaten mevcutsa, sadece geçip gidecektir. Bu PC'de çalışacaktır, ancak Mac'te de çalışması için nelerin değiştirilmesi gerektiğini kontrol etmeniz gerekecektir.
'requires reference to Microsoft Scripting Runtime
Sub MakeFolder()
Dim strComp As String, strPart As String, strPath As String
strComp = Range("A1") ' assumes company name in A1
strPart = CleanName(Range("C1")) ' assumes part in C1
strPath = "C:\Images\"
If Not FolderExists(strPath & strComp) Then
'company doesn't exist, so create full path
FolderCreate strPath & strComp & "\" & strPart
Else
'company does exist, but does part folder
If Not FolderExists(strPath & strComp & "\" & strPart) Then
FolderCreate strPath & strComp & "\" & strPart
End If
End If
End Sub
Function FolderCreate(ByVal path As String) As Boolean
FolderCreate = True
Dim fso As New FileSystemObject
If Functions.FolderExists(path) Then
Exit Function
Else
On Error GoTo DeadInTheWater
fso.CreateFolder path ' could there be any error with this, like if the path is really screwed up?
Exit Function
End If
DeadInTheWater:
MsgBox "A folder could not be created for the following path: " & path & ". Check the path name and try again."
FolderCreate = False
Exit Function
End Function
Function FolderExists(ByVal path As String) As Boolean
FolderExists = False
Dim fso As New FileSystemObject
If fso.FolderExists(path) Then FolderExists = True
End Function
Function CleanName(strName as String) as String
'will clean part # name so it can be made into valid folder name
'may need to add more lines to get rid of other characters
CleanName = Replace(strName, "/","")
CleanName = Replace(CleanName, "*","")
etc...
End Function
Private Sub CommandButton1_Click()
Dim fso As Object
Dim tdate As Date
Dim fldrname As String
Dim fldrpath As String
tdate = Now()
Set fso = CreateObject("scripting.filesystemobject")
fldrname = Format(tdate, "dd-mm-yyyy")
fldrpath = "C:\Users\username\Desktop\FSO\" & fldrname
If Not fso.folderexists(fldrpath) Then
fso.createfolder (fldrpath)
End If
End Sub
Burada hata işleme olmadan alt dizinler oluşturan kısa bir alt dizin var:
Public Function CreateSubDirs(ByVal vstrPath As String)
Dim marrPath() As String
Dim mint As Integer
marrPath = Split(vstrPath, "\")
vstrPath = marrPath(0) & "\"
For mint = 1 To UBound(marrPath) 'walk down directory tree until not exists
If (Dir(vstrPath, vbDirectory) = "") Then Exit For
vstrPath = vstrPath & marrPath(mint) & "\"
Next mint
MkDir vstrPath
For mint = mint To UBound(marrPath) 'create directories
vstrPath = vstrPath & marrPath(mint) & "\"
MkDir vstrPath
Next mint
End Function