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

ひさびさに仕事のお話

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

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

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

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

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


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

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


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

'
'
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

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

'
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