Option Explicit

'////////////////////////////////////////////////////////////
' 関数名：IsFileExists
' 概　要：ファイルの存在チェック
' 引　数：①strFilePath：ファイルのパス
' 戻り値：存在:True、存在しない:False
'////////////////////////////////////////////////////////////
Function IsFileExists(ByVal strFilePath)
    Dim objFso
    Set objFso = WScript.CreateObject("Scripting.FileSystemObject")
    IsFileExists = objFso.FileExists(strFilePath)
    Set objFso = Nothing
End Function

'////////////////////////////////////////////////////////////
' 関数名：IsFolderExists
' 概　要：フォルダの存在チェック
' 引　数：①strFolderPath：フォルダのパス
' 戻り値：存在:True、存在しない:False
'////////////////////////////////////////////////////////////
Function IsFolderExists(ByVal strFolderPath)
    Dim objFso
    Set objFso = WScript.CreateObject("Scripting.FileSystemObject")
    IsFolderExists = objFso.FolderExists(strFolderPath)
    Set objFso = Nothing
End Function


'++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' ファイルのクラス
'++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Class FileCommon
    Private mstrMessage
    'Constructor
    Private Sub Class_Initialize()
        mstrMessage = ""
    End Sub

    '////////////////////////////////////////////////////////////
    ' プロパティ名：Message
    ' 概　　　　要：メッセージ
    '////////////////////////////////////////////////////////////
    Public Property Get Message()
        Message = mstrMessage
    End Property
    Private Property Let Message(ByVal strMsg)
        mstrMessage = strMsg
    End Property

    '////////////////////////////////////////////////////////////
    ' メソッド名：CreateFolder
    ' 概　　　要：フォルダを作成する
    ' 引　　　数：①strFolderPath：フォルダパス
    ' 戻　り　値：成功:True、失敗:False
    '////////////////////////////////////////////////////////////
    Public Function CreateFolder(ByVal strFolderPath)
        CreateFolder = False
        On Error Resume Next

        Dim blnExists
        blnExists = IsFolderExists(strFolderPath)
        If (blnExists = True) Then
            CreateFolder = True
            Exit Function
        End If

        Dim objFso
        Set objFso = WScript.CreateObject("Scripting.FileSystemObject")
        objFso.CreateFolder strFolderPath
        Set objFso = Nothing
        If Not (Err.Number = 0) Then
            Message = CStr(Err.Number) & ":" & Err.Description
            Err.Clear
            Exit Function
        End If
        
        On Error GoTo 0
        CreateFolder = True
    End Function

    '////////////////////////////////////////////////////////////
    ' メソッド名：FileDelete
    ' 概　　　要：ファイルを削除する
    ' 引　　　数：①strFolderPath：フォルダパス
    ' 戻　り　値：成功:True、失敗:False
    '////////////////////////////////////////////////////////////
    Public Function FileDelete(ByVal strFilePath)
        FileDelete = False
        On Error Resume Next

        Dim blnExists
        blnExists = IsFileExists(strFilePath)
        If (blnExists = False) Then
            FileDelete = True
            Exit Function
        End If

        Dim objFso
        Set objFso = WScript.CreateObject("Scripting.FileSystemObject")
        objFso.DeleteFile strFilePath
        Set objFso = Nothing

        If Not (Err.Number = 0) Then
            Message = CStr(Err.Number) & ":" & Err.Description
            Err.Clear
            Exit Function
        End If

        On Error GoTo 0
        FileDelete = True
    End Function

    '////////////////////////////////////////////////////////////
    ' メソッド名：FolderDelete
    ' 概　　　要：フォルダを削除する
    ' 引　　　数：①strFolderPath：フォルダパス
    ' 戻　り　値：成功:True、失敗:False
    '////////////////////////////////////////////////////////////
    Public Function FolderDelete(ByVal strFolderPath)
        FolderDelete = False
        On Error Resume Next
        Dim blnExists
        blnExists = IsFolderExists(strFolderPath)
        If (blnExists = False) Then
            FolderDelete = True
            Exit Function
        End If

        Dim objFso
        Set objFso = WScript.CreateObject("Scripting.FileSystemObject")
        objFso.DeleteFolder strFolderPath
        Set objFso = Nothing
        If Not (Err.Number = 0) Then
            Message = CStr(Err.Number) & ":" & Err.Description
            Err.Clear
            Exit Function
        End If

        On Error GoTo 0
        FolderDelete = True
    End Function

    '////////////////////////////////////////////////////////////
    ' メソッド名：FileCopy
    ' 概　　　要：ファイルをコピーする
    ' 引　　　数：①strFrom：コピー元ファイル
    ' 　　　　　　②strTo：コピー先ファイル
    ' 戻　り　値：成功:True、失敗:False
    '////////////////////////////////////////////////////////////
    Public Function FileCopy(ByVal strFrom, ByVal strTo)
        FileCopy = False
        On Error Resume Next

        Dim objFso
        Set objFso = WScript.CreateObject("Scripting.FileSystemObject")
        objFso.CopyFile strFrom, strTo
        Set objFso = Nothing
        If Not (Err.Number = 0) Then
            Message = CStr(Err.Number) & ":" & Err.Description
            Err.Clear
            Exit Function
        End If

        On Error GoTo 0
        FileCopy = True
    End Function

    '////////////////////////////////////////////////////////////
    ' メソッド名：FolderCopy
    ' 概　　　要：フォルダをコピーする
    ' 引　　　数：①strFrom：コピー元フォルダ
    ' 　　　　　　②strTo：コピー先フォルダ
    ' 戻　り　値：成功:True、失敗:False
    '////////////////////////////////////////////////////////////
    Public Function FolderCopy(ByVal strFrom, ByVal strTo)
        FolderCopy = False
        On Error Resume Next

        Dim objFso
        Set objFso = WScript.CreateObject("Scripting.FileSystemObject")
        objFso.CopyFolder strFrom, strTo
        Set objFso = Nothing
        If Not (Err.Number = 0) Then
            Message = CStr(Err.Number) & ":" & Err.Description
            Err.Clear
            Exit Function
        End If

        On Error GoTo 0
        FolderCopy = True
    End Function

    '////////////////////////////////////////////////////////////
    ' メソッド名：FileMove
    ' 概　　　要：ファイルを移動する
    ' 引　　　数：①strFrom：コピー元フォルダ
    ' 　　　　　　②strTo：コピー先フォルダ
    ' 戻　り　値：成功:True、失敗:False
    '////////////////////////////////////////////////////////////
    Public Function FileMove(ByVal strFrom, ByVal strTo)
        FileMove = False
        On Error Resume Next

        Dim objFso
        Set objFso = WScript.CreateObject("Scripting.FileSystemObject")
        objFso.MoveFile strFrom, strTo
        Set objFso = Nothing
        If Not (Err.Number = 0) Then
            Message = CStr(Err.Number) & ":" & Err.Description
            Err.Clear
            Exit Function
        End If

        On Error GoTo 0
        FileMove = True
    End Function

    '////////////////////////////////////////////////////////////
    ' メソッド名：FolderMove
    ' 概要　　　：フォルダをコピーする
    ' 引　　　数：①strFrom：コピー元フォルダ
    ' 　　　　　　②strTo：コピー先フォルダ
    ' 戻　り　値：成功:True、失敗:False
    '////////////////////////////////////////////////////////////
    Public Function FolderMove(ByVal strFrom, ByVal strTo)
        FolderMove = False
        On Error Resume Next

        Dim objFso
        Set objFso = WScript.CreateObject("Scripting.FileSystemObject")
        objFso.MoveFolder strFrom, strTo
        Set objFso = Nothing
        If Not (Err.Number = 0) Then
            Message = CStr(Err.Number) & ":" & Err.Description
            Err.Clear
            Exit Function
        End If

        On Error GoTo 0
        FolderMove = True
    End Function

End Class


'////////////////////////////////////////////////////////////
' テキストファイルのクラス
'////////////////////////////////////////////////////////////
Class TextFile
    Private mstrMessage
    'Constructor
    Private Sub Class_Initialize()
        mstrMessage = ""
    End Sub

    '////////////////////////////////////////////////////////////
    ' プロパティ名：Message
    ' 概　　　　要：メッセージ
    '////////////////////////////////////////////////////////////
    Public Property Get Message()
        Message = mstrMessage
    End Property
    Private Property Let Message(ByVal strMsg)
        mstrMessage = strMsg
    End Property

    '////////////////////////////////////////////////////////////
    ' メソッド名：ReadText
    ' 概　　　要：指定されたファイルをすべて読み込む
    ' 引　　　数：①strFilePath：ファイルのパス
    ' 戻　り　値：テキストファイルの内容
    '////////////////////////////////////////////////////////////
    Public Function ReadText(ByVal strFilePath)
        ReadText = False
        On Error Resume Next

        Dim blnRet
        blnRet = IsFileExists(strFilePath)
        If (blnRet = False) Then
            Message = "ファイルが見つかりませんでした。"
            Exit Function
        End If

        Dim objFso
        Set objFso = WScript.CreateObject("Scripting.FileSystemObject")
        Dim objFile
        Set objFile = objFso.OpenTextFile(strFilePath, 1, False)
        If Not (Err.Number = 0) Then
            Message = CStr(Err.Number) & ":" & Err.Description
            Err.Clear
            Exit Function
        End If
        Dim strBuf
        strBuf = objFile.ReadAll
        Set objFile = Nothing
        Set objFso = Nothing

        On Error GoTo 0
        ReadText = strBuf
    End Function

    '////////////////////////////////////////////////////////////
    ' メソッド名：WriteText
    ' 概　　　要：指定されたファイルに書き込みする
    ' 引　　　数：①strFilePath：ファイルのパス
    ' 　　　　　　②strValue：書き込む内容
    ' 戻　り　値：成功:True、失敗:False
    '////////////////////////////////////////////////////////////
    Public Function WriteText(ByVal strFilePath, ByVal strValue)
        WriteText = False
        On Error Resume Next

        Dim blnRet
        blnRet = IsFileExists(strFilePath)
        If (blnRet = False) Then
            Message = "ファイルが見つかりませんでした。"
            Exit Function
        End If

        If (CStr(strValue) = "") Then
            WriteText = True
            Exit Function
        End If

        Dim objFso
        Set objFso = WScript.CreateObject("Scripting.FileSystemObject")
        Dim objFile
        Set objFile = objFso.OpenTextFile(strFilePath, 8, False)
        objFile.WriteLine strValue
        If Not (Err.Number = 0) Then
            Message = CStr(Err.Number) & ":" & Err.Description
            Err.Clear
            Exit Function
        End If
        Set objFile = False
        Set objFso = Nothing

        On Error GoTo 0
        WriteText = True
    End Function

'↓201111
    '////////////////////////////////////////////////////////////
    ' メソッド名：OverwriteText
    ' 概　　　要：指定されたファイルに書き込みする（上書き）
    ' 引　　　数：①strFilePath：ファイルのパス
    ' 　　　　　　②strValue：書き込む内容
    ' 戻　り　値：成功:True、失敗:False
    '////////////////////////////////////////////////////////////
    Public Function OverwriteText(ByVal strFilePath, ByVal strValue)
        OverwriteText = False
        On Error Resume Next

        Dim blnRet
        blnRet = IsFileExists(strFilePath)
        If (blnRet = False) Then
            Message = "ファイルが見つかりませんでした。"
            Exit Function
        End If

        If (CStr(strValue) = "") Then
            OverwriteText = True
            Exit Function
        End If

        Dim objFso
        Set objFso = WScript.CreateObject("Scripting.FileSystemObject")
        Dim objFile
        Set objFile = objFso.OpenTextFile(strFilePath, 2, False)
        objFile.WriteLine strValue
        If Not (Err.Number = 0) Then
            Message = CStr(Err.Number) & ":" & Err.Description
            Err.Clear
            Exit Function
        End If
        Set objFile = False
        Set objFso = Nothing

        On Error GoTo 0
        OverwriteText = True
    End Function
'↑201111

    '////////////////////////////////////////////////////////////
    ' メソッド名：CreateText
    ' 概　　　要：テキストファイルを作成する
    ' 引　　　数：①strFilePath：ファイルのパス
    ' 戻　り　値：成功:True、失敗:False
    '////////////////////////////////////////////////////////////
    Public Function CreateText(ByVal strFilePath)
        CreateText = False
        On Error Resume Next

        Dim blnRet
        blnRet = IsFileExists(strFilePath)
        If Not (blnRet = False) Then
            CreateText = True
            Exit Function
        End If

        Dim objFso
        Set objFso = WScript.CreateObject("Scripting.FileSystemObject")
        Dim objFile
        Set objFile = objFso.CreateTextFile(strFilePath, True)
        If Not (Err.Number = 0) Then
            Message = CStr(Err.Number) & ":" & Err.Description
            Err.Clear
            Exit Function
        End If
        objFile.Close
        Set objFile = Nothing
        Set objFso = Nothing

        On Error GoTo 0
        CreateText = True
    End Function

End Class

'////////////////////////////////////////////////////////////
' 関数名：IsRegStrExists
' 概　要：レジストリのエントリの有無
' 引　数：①lRoot：レジストリのルート
' 　　　　②strKeyPath：レジストリのパス
' 戻り値：
'////////////////////////////////////////////////////////////
Function IsRegExists(ByVal lRoot, ByVal strKeyPath, ByVal strValueName)
    Set objRegistry = GetObject("winmgmts:\\" & strComputer & "\root\default:StdRegProv")
    objRegistry.GetStringValue lRoot, strKeyPath, strValueName, strValue
    IsRegExists = NOT(IsNull(strValue))
End Function

'////////////////////////////////////////////////////////////
' 関数名：GetRegNamesTypes
' 概　要：レジストリのエントリの一覧取得
' 引　数：①lRoot：レジストリのルート
' 　　　　②strKeyPath：レジストリのパス
' 　　　　③[ref]arrValueNames：エントリ名の配列
' 　　　　④[ref]arrValueTypes：エントリの型の配列
'////////////////////////////////////////////////////////////
Function GetRegNamesTypes(ByVal lRoot, ByVal strKeyPath, ByRef arrValueNames,  ByRef arrValueTypes)
    On Error Resume Next
    strComputer = "."
    Set oReg=GetObject("winmgmts:{impersonationLevel=impersonate}!\\" & strComputer & "\root\default:StdRegProv")
    oReg.EnumValues lRoot, strKeyPath, arrValueNames, arrValueTypes
End Function

'////////////////////////////////////////////////////////////
' 関数名：GetRegSubkeys
' 概　要：レジストリのサブキーの一覧取得
' 引　数：①lRoot：レジストリのルート
' 　　　　②strKeyPath：レジストリのパス
' 戻り値：
'////////////////////////////////////////////////////////////
Function GetRegSubkeys(ByVal lRoot, ByVal strKeyPath)
    On Error Resume Next
    strComputer = "."
    Set oReg=GetObject("winmgmts:{impersonationLevel=impersonate}!\\" & strComputer & "\root\default:StdRegProv")
    oReg.EnumKey lRoot, strKeyPath, arrSubKeys
    GetRegSubkeys = arrSubKeys
End Function

'////////////////////////////////////////////////////////////
' 関数名：GetFileCnt
' 概　要：フォルダ内のファイル数を再帰的に集計
' 引　数：①strDirName：検索するフォルダ
' 　　　　②iCnt：ファイル数
' 戻り値：
'////////////////////////////////////////////////////////////
Function GetFileCnt(ByVal strDirName, ByRef iCnt)
    On Error Resume Next
    Dim f_objFso, f_objFolder
    Set f_objFso = WScript.CreateObject("Scripting.FileSystemObject")
    Set f_objFolder = f_objFso.GetFolder(strDirName)
    iCnt = iCnt + f_objFolder.Files.Count

    '再帰的にサブフォルダ内のファイル数を検索
    For Each DirName In f_objFolder.SubFolders
        GetFileCnt DirName, iCnt
    Next
    Set f_objFolder = Nothing
    Set f_objFso = Nothing
End Function

'////////////////////////////////////////////////////////////
' 関数名：MakeZipFormDir
' 概　要：指定されたフォルダを指定先にZIPで圧縮
' 引　数：①SrcDirName：圧縮対象フォルダ
' 　　　　②DestDirName：ZIP作成先フォルダ
'////////////////////////////////////////////////////////////
Function MakeZipFromDir(ByVal SrcDirName, ByVal DestDirName)
    Dim objFso, objApp
    Set objFso = WScript.CreateObject("Scripting.FileSystemObject")
    Set objApp = WScript.CreateObject("Shell.Application")

    'ファイル名編集
    Dim strFileName, strFileFullPath
    strFileName = "TKCPCRepResult" & Year(Date) & _
      Right("0" & Month(Date),2) & Right("0" & Day(Date),2) & _
      Right("0" & Hour(Time),2) & Right("0" & Minute(Time),2) & _
      Right("0" & Second(Time),2) &  ".zip"
    strFileFullPath = DestDirName & "\" & strFileName

    'ZIPファイル作成
    Dim fZip
    Set fZip = objFso.CreateTextFile(strFileFullPath)
    fZip.Write "PK" & Chr(5) & Chr(6) & String(18,0)
    fZip.Close
    Set fZip = Nothing

    'ZIPファイルへファイルを追加し、Sleepで圧縮完了を待つ
    Dim objZip
    Set objZip = objApp.NameSpace(strFileFullPath)
    objZip.CopyHere SrcDirName
    Do Until objZip.Items.Count = 1
        WScript.sleep 100
    Loop

    Set objZip = Nothing
    Set objFso = Nothing
    Set objApp = Nothing
End Function

'////////////////////////////////////////////////////////////
' 関数名：MakeZipFormFiles
' 概　要：指定されたフォルダ内のファイルを指定先にZIPで圧縮
' 引　数：①SrcDirName：圧縮対象フォルダ
' 　　　　②DestDirName：ZIP作成先フォルダ
'////////////////////////////////////////////////////////////
Function MakeZipFromFiles(ByVal SrcDirName, ByVal DestDirName)
    Dim objFso, objApp
    Set objFso = WScript.CreateObject("Scripting.FileSystemObject")
    Set objApp = WScript.CreateObject("Shell.Application")

    'ファイル名編集
    Dim strFileName, strFileFullPath
    strFileName = "TKCPCInfResult" & Year(Date) & _
      Right("0" & Month(Date),2) & Right("0" & Day(Date),2) & _
      Right("0" & Hour(Time),2) & Right("0" & Minute(Time),2) & _
      Right("0" & Second(Time),2) &  ".zip"
    strFileFullPath = DestDirName & "\" & strFileName

    'ZIPファイル作成
    Dim fZip
    Set fZip = objFso.CreateTextFile(strFileFullPath)
    fZip.Write "PK" & Chr(5) & Chr(6) & String(18,0)
    fZip.Close
    Set fZip = Nothing

    Dim objFolder, objFiles
    Set objFolder = objFso.GetFolder(SrcDirName)
    Set objFiles = objFolder.Files

    'ZIPファイルへファイルを追加し、Sleepで圧縮完了を待つ
    Dim objZip
    Set objZip = objApp.NameSpace(strFileFullPath)
    Dim DoneCnt, file
    DoneCnt = 0
    For each file in objFiles
        objZip.CopyHere file.Path
        DoneCnt = DoneCnt + 1
        Do Until objZip.Items.Count = DoneCnt
            WScript.sleep 100
        Loop
    Next

    Set objZip = Nothing
    Set objFolder = Nothing
    Set objFiles = Nothing
    Set objFso = Nothing
    Set objApp = Nothing
End Function

'↓201111
'////////////////////////////////////////////////////////////
' 関数名：GetWaitMsg
' 概　要：ウェイトメッセージを表示する
' 引　数：処理中の項目番号(1～8)
' 　　　　　第二引数が1の場合のみ、ゼロも指定可
' 　　　　プロモーションステート(0～3)
' 戻り値：ウェイトメッセージ
'////////////////////////////////////////////////////////////
Function GetWaitMsg(ByVal iRow, ByVal PromoState)
    On Error Resume Next
    Dim conMsg, strMsg, conMsgPrmo
    conMsg       = Array("１．基本情報　　　　　　　　　　　　　　　", _
                         "２．ハードウェアの情報　　　　　　　　　　", _
                         "３．ＯＳの情報　　　　　　　　　　　　　　", _
                         "４．ＩＥの情報　　　　　　　　　　　　　　", _
                         "５．インストールされているプログラムの一覧", _
                         "６．ネットワークの情報　　　　　　　　　　", _
                         "７．セキュリティの情報　　　　　　　　　　", _
                         "８．ログ等　　　　　　　　　　　　　　　　")
    conMsgPrmo   = Array("１．権限昇格が必要な情報　　　　　　　　　", _
                         "２．基本情報　　　　　　　　　　　　　　　", _
                         "３．ハードウェアの情報　　　　　　　　　　", _
                         "４．ＯＳの情報　　　　　　　　　　　　　　", _
                         "５．ＩＥの情報　　　　　　　　　　　　　　", _
                         "６．インストールされているプログラムの一覧", _
                         "７．ネットワークの情報　　　　　　　　　　", _
                         "８．セキュリティの情報　　　　　　　　　　", _
                         "９．ログ等　　　　　　　　　　　　　　　　")
    Const ING = "　・・・　収集中　"
    Const FIN = "　・・・　収集完了"
    Const YET = "　　　　　　　　　"

    strMsg =             "情報の収集を実行中です。　　　　　　　　　" & YET & vbCrLf
    strMsg = strMsg &    "しばらくお待ちください。　　　　　　　　　" & YET & vbCrLf
    strMsg = strMsg &    "　　　　　　　　　　　　　　　　　　　　　" & YET & vbCrLf
    strMsg = strMsg &    "《進行状況》　　　　　　　　　　　　　　　" & YET & vbCrLf
    Dim i, tmpAry
    If (PromoState = "1") or _
       (PromoState = "2") Then
       iRow = iRow + 1
       tmpAry = conMsgPrmo
    Else
       tmpAry = conMsg
    End If
    For i = 0 To UBound(tmpAry) Step 1
        if i + 1 = iRow Then ' 処理中
            strMsg = strMsg & tmpAry(i) & ING & vbCrLf
        Elseif i + 1 < iRow Then '完了
            strMsg = strMsg & tmpAry(i) & FIN & vbCrLf
        Else '未処理
            strMsg = strMsg & tmpAry(i) & YET & vbCrLf
        End If
    Next
    GetWaitMsg = strMsg
End Function
'↑201111

'////////////////////////////////////////////////////////////
' 関数名：GetSelected
' 概　要：選択結果を返す。
' 引　数：選択結果
' 戻り値：■ or □
'////////////////////////////////////////////////////////////
Function GetSelected(ByVal bSelected)
    On Error Resume Next
    If (bSelected) Then
        GetSelected = "■"
    Else
        GetSelected = "□"
    End If
End Function

'////////////////////////////////////////////////////////////
' 関数名：GetEditedRow
' 概　要：編集結果を返す。
' 引　数：①sItemName：項目名
' 　　　　②sVal：収集結果
' 戻り値：編集した１行
'////////////////////////////////////////////////////////////
Function GetEditedRow(ByVal sItemName, ByVal sVal)
    On Error Resume Next
    Const LEN_ITEM = 32 '項目名の長さ
    Const LEN_ROW  = 80 '１行の長さ
    Const DELIM    = "："
    Dim sRet
    sRet = "　" & sItemName
    if (LEN_ITEM > LenEx(sRet)) Then
        sRet = sRet & Space(LEN_ITEM - LenEx(sRet))
    End If
    sRet = sRet & DELIM & sVal
    GetEditedRow = sRet '201212
End Function

'////////////////////////////////////////////////////////////
' 関数名：GetEditedRowArray
' 概　要：編集結果を返す。
' 引　数：①sItemName：項目名
' 　　　　②sVal：収集結果の配列
' 戻り値：編集した配列
'////////////////////////////////////////////////////////////
Function GetEditedRowArray(ByVal sItemName, ByVal ary)
    On Error Resume Next
    Const LEN_ITEM = 32 '項目名の長さ
    Const LEN_ROW  = 80 '１行の長さ
    Const DELIM    = "："
    Dim sRet, tmpItem, i
    sRet = "　" & sItemName
    if (LEN_ITEM > LenEx(sRet)) Then
        sRet = sRet & Space(LEN_ITEM - LenEx(sRet))
    End If
    sRet = sRet & DELIM
    i = 0
    For Each tmpItem In ary
        If i <> 0 Then
            sRet = sRet & Space(LEN_ITEM + LenEx(DELIM))
        End If
        sRet = sRet & tmpItem & vbCrLf
        i = i + 1
    Next
    GetEditedRowArray = DelLastLF(sRet) '201212
End Function

'////////////////////////////////////////////////////////////
' 関数名：UBoundEx
' 概　要：配列のインデックスの最大値を返す。
' 　　　　要素がない動的配列に対応。（-1を返す。）
' 引　数：array：配列
' 戻り値：配列のインデックスの最大値
'////////////////////////////////////////////////////////////
Function UBoundEx(ByRef array)
    On Error Resume Next
    UBoundEx = UBound(array)
    If Err.Number <> 0 Then
        Err.Clear
        UBoundEx = -1
    End If
End Function

'////////////////////////////////////////////////////////////
' 関数名：FindTkcStr
' 概　要：指定された文字列に文字列「ＴＫＣ」が含まれているか確認
' 　　　　「ＴＫＣ」は前半角、大文字小文字は問わない。
' 引　数：検索対象文字列
' 戻り値：True:「ＴＫＣ」がみつかった、False:見つからなかった
'////////////////////////////////////////////////////////////
Function FindTkcStr(ByVal str)
    Dim ret
    ret = InStr(1, str, "TKC", vbTextCompare) 'テキストモード（前半角、大文字小文字区別なし）
    If IsNull(ret) Then
        FindTkcStr = False
    Else
        FindTkcStr = (ret > 0)
    End If
End Function

'////////////////////////////////////////////////////////////
' 関数名：FindSqlExeStr
' 概　要：指定された文字列にSQLServerのexeのフルパスが含まれているか確認
' 引　数：
' 　　　　検索対象文字列
' 戻り値：True:見つかった、False:見つからなかった
'////////////////////////////////////////////////////////////
Function FindSqlExeStr(ByVal str, ByVal path)
    Dim ret
    ret = InStr(1, str, path & "\Binn\sqlservr.exe", vbTextCompare) 'テキストモード（前半角、大文字小文字区別なし）
    If IsNull(ret) Then
        FindSqlExeStr = False
    Else
        FindSqlExeStr = (ret > 0)
    End If
End Function

'////////////////////////////////////////////////////////////
' 関数名：GetInt2Bool
' 概　要：引数をBoolに変換する
' 引　数：1 or 0
' 戻り値：引数が1の時True、それ以外False
'////////////////////////////////////////////////////////////
Function GetInt2Bool(ByVal i)
    GetInt2Bool = (i = 1)
End Function

'////////////////////////////////////////////////////////////
' 関数名：LenEx
' 概　要：文字列のバイト数を返す
' 引　数：調査対象文字列
' 戻り値：バイト数
'////////////////////////////////////////////////////////////
Function LenEx(ByVal strVal)  
    Dim i, strChr
    LenEx = 0
    If Trim(strVal) <> "" Then
        For i = 1 To Len(strVal)  
            strChr = Mid(strVal, i, 1)
            '２バイト文字は＋２  
            If (Asc(strChr) And &HFF00) <> 0 Then
                LenEx = LenEx + 2
            Else 
                LenEx = LenEx + 1
            End If
        Next
    End If
End Function

'////////////////////////////////////////////////////////////
' 関数名：GetEditedIeRowArray
' 概　要：編集結果を返す。
' 引　数：①sItemName：項目名
' 　　　　②sVal：収集結果の配列
' 戻り値：編集した配列
'////////////////////////////////////////////////////////////
Function GetEditedIeRowArray(ByVal sItemName, ByVal ary)
    On Error Resume Next
    Const LEN_ITEM = 56 '項目名の長さ
    Const LEN_ROW  = 160 '１行の長さ
    Const DELIM    = "："
    Dim sRet, tmpItem, i
    sRet = "　" & sItemName
    if (LEN_ITEM > LenEx(sRet)) Then
        sRet = sRet & Space(LEN_ITEM - LenEx(sRet))
    End If
    sRet = sRet & DELIM
    If UboundEx(ary) = -1 Then
        sRet = sRet & vbCrLf
    Else
        i = 0
        For Each tmpItem In ary
            If i <> 0 Then
                sRet = sRet & Space(LEN_ITEM + LenEx(DELIM))
            End If
            sRet = sRet & tmpItem & vbCrLf
            i = i + 1
        Next
    End If
    GetEditedIeRowArray = DelLastLF(sRet) '201212
End Function

'////////////////////////////////////////////////////////////
' 関数名：Yes2Checked
' 概　要：yes もしくは no を受け取り、■もしくは□返す
' 引　数：文字列
' 戻り値：yes:■, no:□
'////////////////////////////////////////////////////////////
Function Yes2Checked(ByVal reg)
    On Error Resume Next
    Dim sRet
    If IsNull(reg) Then
        sRet = MSG_NOTEXIST
    Else
        If reg = MSG_NOTSELECTED Then
            sRet = reg
        Else
            If StrComp(reg, "yes", vbTextCompare) = 0 Then
                sRet = "■"
            Else
                sRet = "□"
            End If
        End If
    End If
    Yes2Checked = sRet
End Function

'////////////////////////////////////////////////////////////
' 関数名：No2Checked
' 概　要：yes もしくは no を受け取り、■もしくは□返す
' 引　数：文字列
' 戻り値：yes::□, no:■
'////////////////////////////////////////////////////////////
Function No2Checked(ByVal reg)
    On Error Resume Next
    Dim sRet
    If IsNull(reg) Then
        sRet = MSG_NOTEXIST
    Else
        If reg = MSG_NOTSELECTED Then
            sRet = reg
        Else
            If StrComp(reg, "no", vbTextCompare) = 0 Then
                sRet = "■"
            Else
                sRet = "□"
            End If
        End If
    End If
    No2Checked = sRet
End Function

'////////////////////////////////////////////////////////////
' 関数名：GetIeValue
' 概　要：編集結果を返す。
' 引　数：①sItemName：項目名
' 　　　　②sVal：収集結果
' 戻り値：編集した１行
'////////////////////////////////////////////////////////////
Function GetIeValue(ByVal reg, ByVal ary)
    On Error Resume Next
    Dim sRet
    If IsNull(reg) Then
        sRet = MSG_NOTEXIST
    Else
        If reg = MSG_NOTSELECTED Then
            sRet = reg
        Else
            sRet = ary(reg)
            If Err.Number <> 0 Then
                Err.Clear
                sRet = "項目値の取得に失敗しました。"
            End If
        End If
    End If
    GetIeValue = sRet
End Function

'////////////////////////////////////////////////////////////
' 関数名：GetEditedIeRow
' 概　要：編集結果を返す。
' 引　数：①sItemName：項目名
' 　　　　②sVal：収集結果
' 戻り値：編集した１行
'////////////////////////////////////////////////////////////
Function GetEditedIeRow(ByVal sItemName, ByVal sVal)
    On Error Resume Next
    Const LEN_ITEM = 56 '項目名の長さ
    Const LEN_ROW  = 160 '１行の長さ
    Const DELIM    = "："
    Dim sRet
    sRet = "　" & sItemName
    if (LEN_ITEM > LenEx(sRet)) Then
        sRet = sRet & Space(LEN_ITEM - LenEx(sRet))
    End If
    sRet = sRet & DELIM & sVal
    GetEditedIeRow = sRet '201212
End Function

'////////////////////////////////////////////////////////////
' 関数名：GetIeDefValue
' 概　要：レジストリが存在しない場合のデフォルト値を返す
' 引　数：①Ver：ＩＥのバージョン（指定以上の場合に処理）
' 　　　　②Def：デフォルト値
' 　　　　③value：レジストリの値（NULL値の可能性あり）
' 戻り値：valueがNULLの場合はDefを返す。
'////////////////////////////////////////////////////////////
Function GetIeDefValue(ByVal Ver, ByVal Def, ByVal value)
    On Error Resume Next
    Dim sRet
    If IsNull(value) Then
        If Left(IeVer, 1) >= Ver Then
            sRet = Def
        Else
            sRet = value
        End If
    Else
        sRet = value
    End If
    GetIeDefValue = sRet
End Function

'////////////////////////////////////////////////////////////
' 関数名：FindJavaStr
' 概　要：指定された文字列に文字列「ＪＡＶＡ」が含まれているか確認
' 　　　　「ＪＡＶＡ」は前半角、大文字小文字は問わない。
' 引　数：検索対象文字列
' 戻り値：True:「ＪＡＶＡ」がみつかった、False:見つからなかった
'////////////////////////////////////////////////////////////
Function FindJavaStr(ByVal str)
    Dim ret
    ret = InStr(1, str, "JAVA", vbTextCompare) 'テキストモード（前半角、大文字小文字区別なし）
    If IsNull(ret) Then
        FindJavaStr = False
    Else
        FindJavaStr = (ret > 0)
    End If
End Function

'////////////////////////////////////////////////////////////
' 関数名：DelLastLF
' 概　要：最後尾の改行コードを削除
' 引　数：文字列
' 戻り値：最後尾の改行コードを削除した文字列
'////////////////////////////////////////////////////////////
Function DelLastLF(ByVal str)
    Dim intLength, strEnd, ret
    ret = str
    intLength = Len(str)
    strEnd = Right(str, 2)
    If strEnd = vbCrLf Then
        ret = Left(str, intLength - 2)
    End If
    DelLastLF = ret
End Function
