Dim fff1 As String
Dim fff2 As String
Dim kai As Integer
Dim f(1, 50)

Sub ki017()
  kai = 0
  ki017a
  kai = 1
  ki017a
End Sub
Sub ki017a()
'ダイアログ表示
If kai = 0 Then
   fsitei = "基準ファルダ−指定"
Else
   fsitei = "相対アドレスをチェックするファルダ−指定"
End If
     fff = Application.GetOpenFilename(Title:=fsitei)
     If fff = "False" Then
        MsgBox "ファイルを１個指定して下さい"
        End
     End If
     dai = fff
If kai = 0 Then
   fff1 = fff
   k = 0
Else
   fff2 = fff
   k = 1
End If
For i = 1 To 20: f(k, i) = "": Next
   
   i = 1: ssa1 = 0: fname = ""
  Do
    ssa = InStr(1, dai, "\", 1)
     ssa1 = ssa1 + ssa
    If ssa > 0 Then
        dai = Mid(dai, ssa + 1)
        ssb = InStr(1, dai, "\", 1)
        If ssb > 0 Then
           f(k, i) = Left(dai, ssb - 1)
        End If
        i = i + 1
    End If
  Loop Until ssa = 0
If kai = 0 Then
   Exit Sub
End If
'相対パス設定
  sad = ""
  For i = 1 To 50
     If f(0, i) <> f(1, i) Then
        If f(0, i) = "" Then
           sad = sad & f(1, i) & "/"
        Else
           If f(1, i) = "" Then
              sad = sad & "../"
           Else
              sad = sad & "../"
              For j = 49 To i Step -1
                 f(1, j + 1) = f(1, j)
              Next
           End If
        End If
     Else
        If f(0, i) = "" Then
            Exit For
        End If
     End If
  Next
'メッセ−ジ
 fname = Mid(fff2, ssa1 + 1)
 msg = "基点となるファルダ−" & fff1 & Chr$(10) & _
        "確認したいファルダ−" & fff2 & Chr$(10) & _
        "相対アドレスは      " & sad & fname & Chr$(10) & Chr$(10) & _
        "(他のフォルダ−も確認しますか）"
     kesu = MsgBox(msg, 4, "相対アドレス")
        If kesu = 6 Then
             ki017a
        Else
             End
        End If
End Sub