VB6で深くフォルダーを作成する

ひさびさに仕事のお話

過去に作ったプログラムが、最近になってファイルエクスポート処理でエラーが出るとの報告がありました

調べてみると、事前に保存フォルダを作成する処理でエラーが出ている様子。
この部分はネットから探してきた”深くフォルダーを作ってくれるユーティリティ関数”をありがたく利用させていただいていました。

障害のポイントは大体わかるけど、解析するの面倒だなぁ～

と思いましたが、ここは単機能なのでいろいろ悩むよりも、作りなおしたほうが早く良い物ができる法則に従い、同様の機能を作成しなおしました。

作成のポイントは ・・・・


VB6の標準関数ではなくFileSystemObjectを使ったところ、コアの深いフォルダ作成する部分には再帰処理で実現。あと、クラスとして提供している部分かな？

自分用なので、いろいろと抜けはあると思います。
エラー処理もしていないので微妙ですね。
注意点はFileSystemObjectを利用している関係で参照設定にMicrosoft Scripting Runtimeを入れなければならないです。この件については、MSのサポートを見ると経緯が分かったりします＞＞ここ


以下がソースリストです。モジュールではなく、クラスなので注意しましょう。

view plainprint?

1. '  
2. '  
3. Private fso As FileSystemObject  
4.   
5. Private Function accepts(ByVal pth As String) As Boolean  
6.     accepts = True  
7.     If Left(pth, 2) = "\\" Then  
8.         accepts = False  
9.     End If  
10. End Function  
11.   
12. Private Function mCreateFolder(ByVal pth As String) As Folder  
13.     Dim fld As Folder  
14.     On Error Resume Next  
15.     Set fld = fso.GetFolder(pth)  
16.     If Err.Number = 76 Then  
17.         Set mCreateFolder = mCreateFolder(fso.GetParentFolderName(pth))  
18.     End If  
19.     On Error GoTo 0  
20.     If fld Is Nothing Then  
21.         Set mCreateFolder = fso.CreateFolder(pth)  
22.     End If  
23. End Function  
24.   
25.   
26. Public Function CreateFolder(ByVal pth As String) As Folder  
27.     Set CreateFolder = Nothing  
28.     If accepts(pth) Then  
29.         Set CreateFolder = mCreateFolder(pth)  
30.     End If  
31. End Function  
32.   
33. Private Sub Class_Initialize()  
34.     Set fso = New FileSystemObject  
35. End Sub  
36.   
37. Private Sub Class_Terminate()  
38.     Set fso = Nothing  
39. End Sub  

'
'
Private fso As FileSystemObject

Private Function accepts(ByVal pth As String) As Boolean
    accepts = True
    If Left(pth, 2) = "\\" Then
        accepts = False
    End If
End Function

Private Function mCreateFolder(ByVal pth As String) As Folder
    Dim fld As Folder
    On Error Resume Next
    Set fld = fso.GetFolder(pth)
    If Err.Number = 76 Then
        Set mCreateFolder = mCreateFolder(fso.GetParentFolderName(pth))
    End If
    On Error GoTo 0
    If fld Is Nothing Then
        Set mCreateFolder = fso.CreateFolder(pth)
    End If
End Function


Public Function CreateFolder(ByVal pth As String) As Folder
    Set CreateFolder = Nothing
    If accepts(pth) Then
        Set CreateFolder = mCreateFolder(pth)
    End If
End Function

Private Sub Class_Initialize()
    Set fso = New FileSystemObject
End Sub

Private Sub Class_Terminate()
    Set fso = Nothing
End Sub

ちなみにこれが過去に使わせていただいていたソース（一部処理を付け加えたかも？）

view plainprint?

1. '  
2. Public Function T_DeepMkdir(strPath As String) As Long  
3.   Dim i          As Integer  
4.   Dim strPaths() As String  
5.   Dim strTemp    As String  
6.   On Error GoTo err_T_DeepMKdir  
7.   T_DeepMkdir = 0  
8.   strPaths = Split(strPath, "\")  
9.   strTemp = strPaths(LBound(strPaths))  
10.   For i = LBound(strPaths) + 1 To UBound(strPaths)  
11.     strTemp = strTemp + "\" + strPaths(i)  
12.     If Dir(strTemp, vbDirectory) = "" Then  
13.       Call MkDir(strTemp)  
14.     End If  
15.   Next  
16.   Exit Function  
17.   
18. err_T_DeepMKdir:  
19.   T_DeepMkdir = Err.Number  
20.   MsgBox "フォルダ作成でエラー発生" & vbCrLf & vbCrLf & Err.Number & ":" & Err.Description   & vbCrLf & vbCrLf & strPath, vbOKOnly, ""  
21.   
22. End Function  

'
Public Function T_DeepMkdir(strPath As String) As Long
  Dim i          As Integer
  Dim strPaths() As String
  Dim strTemp    As String
  On Error GoTo err_T_DeepMKdir
  T_DeepMkdir = 0
  strPaths = Split(strPath, "\")
  strTemp = strPaths(LBound(strPaths))
  For i = LBound(strPaths) + 1 To UBound(strPaths)
    strTemp = strTemp + "\" + strPaths(i)
    If Dir(strTemp, vbDirectory) = "" Then
      Call MkDir(strTemp)
    End If
  Next
  Exit Function

err_T_DeepMKdir:
  T_DeepMkdir = Err.Number
  MsgBox "フォルダ作成でエラー発生" & vbCrLf & vbCrLf & Err.Number & ":" & Err.Description   & vbCrLf & vbCrLf & strPath, vbOKOnly, ""

End Function