ネットワークドライブに対応したフォルダ作成

http://blog.livedoor.jp/yorinaga/archives/51557918.html
がネットワークドライブに対応してなかったのでカスタマイズ。

Public Function MakeFolder(strPath As String) As Boolean

  On Error GoTo ErrHandler
  On Error GoTo 0
  Dim pos1 As Integer
  Dim pos2 As Integer
  Dim sNWRoot As String 'ネットワークドライブの場合
  Dim temp As String
  Dim i As Integer
  Dim end_flg As Boolean

  'strPath の評価
  '最後の\以降のテキストに.が入っている場合はファイル名とみなす
  
  strPath = Replace(strPath, "/.", "")
  
  sNWRoot = ""
  temp = Right(strPath, Len(strPath) - InStrRev(strPath, "\"))
  If InStr(1, temp, ".") = 0 Then
    strPath = strPath & "\"
  Else
    strPath = Left(strPath, InStrRev(strPath, "\"))
  End If
  end_flg = False
  If Left(strPath, 2) = "\\" Then 'ネットワークドライブ
    sNWRoot = Left(strPath, InStr(InStr(3, strPath, "\") + 1, strPath, "\"))
  End If
  
  Dim nStartChr As Long
  nStartChr = 1
  If sNWRoot <> "" Then nStartChr = nStartChr + Len(sNWRoot)
    
  For i = nStartChr To Len(strPath)
    pos1 = InStr(i, strPath, "\")
    pos2 = InStr(pos1 + 1, strPath, "\")
    If pos2 = 0 Then
      pos2 = Len(strPath)
      end_flg = True
    Else
      pos2 = pos2 - 1
    End If
  
    temp = Left(strPath, pos2)
    If Dir(temp, vbDirectory) = "" Then
      MkDir temp
    End If
    
    If end_flg = True Then
      Exit For
    Else
      i = pos1
    End If
  Next i
    
  MakeFolder = True
  Exit Function
ErrHandler:
  MakeFolder = False
End Function