文書番号: 402154
最終更新日: 1997/10/21
Declare Function lstrlen Lib "KERNEL" (ByVal lpStr As Any) As Integer
Declare Function GetDOSEnvironment Lib "KERNEL" () As Long
Declare Function lstrcpy Lib "KERNEL" (ByVal lpStr1 As Any, _
ByVal lpStr2 As Any) As Long
Function GetDOSEnv(strEnv As String) As String
Dim lpDOSEnv As Long, lpDummy As Long
Dim strDOSEnv As String
Dim intDOSEnvLen As Integer
Dim lngPtrLowPart As Long, lngPtrHighPart As Long
Dim intInx As Integer
' 引数 strEnv に与えられた文字列が存在しなければ "" を返します
GetDOSEnv = ""
' 現在のタスクの環境変数へのポインタを取得します
lpDOSEnv = GetDOSEnvironment()
Do
' 環境変数の長さを取得します
intDOSEnvLen = lstrlen(lpDOSEnv)
' 長さが 0 バイトであればループを終了します
If intDOSEnvLen = 0 Then Exit Do
' VBA で取り扱える文字列 strDOSEnv に代入します
strDOSEnv = String$(intDOSEnvLen, 0)
lpDummy = lstrcpy(strDOSEnv, lpDOSEnv)
' 文字列中に「= 」があれば、右辺を引き数と比較し、それに合致
' したときに左辺を取り出します
intInx = InStr(strDOSEnv, "=")
If intInx <> 0 Then
If strEnv = Left$(strDOSEnv, intInx - 1) Then
GetDOSEnv = Right$(strDOSEnv, intDOSEnvLen - intInx)
Exit Do
End If
End If
' ポインタを次の環境変数の先頭まで進めます
lpDOSEnv = lpDOSEnv + intDOSEnvLen + 1
Loop While True
End Function
Function GetDOSEnvArray() As Variant
Dim lpDOSEnv As Long, lpDummy As Long
Dim strDOSEnv As String
Dim intDOSEnvLen As Integer
Dim lngPtrLowPart As Long, lngPtrHighPart As Long
Dim intInx As Integer
Dim ReturnArray() As String
Dim arraycount As Integer
' 現在のタスクの環境変数へのポインタを取得します
lpDOSEnv = GetDOSEnvironment()
arraycount = 0
Do
' 環境変数の長さを取得します
intDOSEnvLen = lstrlen(lpDOSEnv)
' 長さが 0 バイトであればループを終了します
If intDOSEnvLen = 0 Then Exit Do
' VBA で取り扱える文字列 strDOSEnv に代入します
strDOSEnv = String(intDOSEnvLen, 0)
lpDummy = lstrcpy(strDOSEnv, lpDOSEnv)
' StrDOSEnv に受け取った文字列を配列に代入します
arraycount = arraycount + 1
ReDim Preserve ReturnArray(arraycount)
ReturnArray(arraycount) = strDOSEnv
lpDOSEnv = lpDOSEnv + intDOSEnvLen + 1
Loop While True
GetDOSEnvArray = ReturnArray
End Function
Sub DisplayPATH()
MsgBox GetDOSEnv("PATH")
End Sub
Sub DisplayEnvironments()
Dim ret As Variant
Dim i As Integer
ret = GetDOSEnvArray()
For i = 1 To UBound(ret)
MsgBox ret(i)
Next i
End Sub
Keywords: KBHOWTO KB402154
Technology: kbExcel500 kbExcelSearch kbExcelWinSearch