none
VBAでプログラムと一覧のEXCEL出力について RRS feed

  • 質問

  • VBAでプログラムと一覧を作成し、インストールされたプログラムのライセンス管理を検討中です。

    色々調べて、以下のプログラムの一覧の作成まではできたのですが、コントロールパネルのプログラムと一覧の件数と一致しません。

    また、以下のVBAではインストール日付とバージョンが一覧に出力されません。どなたか、ご教示ください。

    Sub ap_list()
      Dim reg As Object
      Dim keys As Variant
      Dim key As Variant
      Dim ret, i As Long
      Dim display_name, d_version As String
      Const HKEY_LOCAL_MACHINE = &H80000002
      Const SubKeyName = "Software\Microsoft\Windows\CurrentVersion\Uninstall\"
      
      Set reg = CreateObject("WbemScripting.SWbemLocator") _
                .ConnectServer(, "root\default").Get("StdRegProv")
               
      reg.EnumKey HKEY_LOCAL_MACHINE, SubKeyName, keys
     
      On Error Resume Next
     
      i = 1
     
     ThisWorkbook.Sheets(1).Active
     Range("A1").Activate
     
      For Each key In keys
        display_name = ""
        ret = reg.GetStringValue(HKEY_LOCAL_MACHINE, SubKeyName & key, "DisplayName", display_name)
        If ret <> 0 Then ret = reg.GetStringValue(HKEY_LOCAL_MACHINE, SubKeyName & key, "QuietDisplayName", display_name)
        If (ret = 0) And (Len(Trim(display_name)) > 0) Then
        Cells(i, 1) = display_name
        i = i + 1
        End If
      Next
      On Error GoTo 0
    End Sub

    2018年6月17日 14:27

回答

  • 次のロジックでプログラム一覧と同じ内容が出力できることが分かった。

    Sub ap_list()

      Dim reg As Object
      Dim keys As Variant
      Dim key As Variant
      Dim ret, i As Long
      Dim ap_name, ap_ver, m_name, int_date As String

      Const HKEY_CURRENT_USER = &H80000001
      Const HKEY_LOCAL_MACHINE = &H80000002
      Const SubKeyName = "Software\Microsoft\Windows\CurrentVersion\Uninstall\"
      Const SubKeyNameX86 = "Software\Wow6432Node\Microsoft\Windows\CurrentVersion\Uninstall\"

     
      Dim tBook, rBook_L_M_64, rBook_L_M_32, rBook_C_U_64 As Workbook
      Set tBook = ThisWorkbook
      
      Set reg = CreateObject("WbemScripting.SWbemLocator") _
                .ConnectServer(, "root\default").Get("StdRegProv")
               
     
    '*****rBook_L_M_64
      reg.EnumKey HKEY_LOCAL_MACHINE, SubKeyName, keys
      On Error Resume Next
      Set rBook_L_M_64 = Workbooks.Add
      rBook_L_M_64.Sheets(1).Activate
      Range("A1").Activate
      i = 1
       
      For Each key In keys
        ap_name = ""
        ret = reg.GetStringValue(HKEY_LOCAL_MACHINE, SubKeyName & key, "DisplayName", ap_name)
        reg.GetStringValue HKEY_LOCAL_MACHINE, SubKeyName & key, "DisplayVersion", ap_ver
        reg.GetStringValue HKEY_LOCAL_MACHINE, SubKeyName & key, "InstallDate", int_date
        reg.GetStringValue HKEY_LOCAL_MACHINE, SubKeyName & key, "Publisher", m_name
        'MsgBox ret & "   " & ap_name
        If ret <> 0 Then ret = reg.GetStringValue(HKEY_LOCAL_MACHINE, SubKeyName & key, "QuietDisplayName", ap_name)
        If (ret = 0) And (Len(Trim(ap_name)) > 0) Then
        Cells(i, 1) = ap_name
        Cells(i, 2) = ap_ver
        Cells(i, 3) = CDate(Format(int_date, "####/##/##"))
        Cells(i, 4) = m_name
        i = i + 1
        End If
      Next
      On Error GoTo 0
    '*****rBook_L_M_32  このロジックは上記のレジストリと同じ内容だったので不要と思われる。
      reg.EnumKey HKEY_LOCAL_MACHINE, SubKeyNameX86, keys
      On Error Resume Next
      Set rBook_L_M_32 = Workbooks.Add
      rBook_L_M_32.Sheets(1).Activate
      Range("A1").Activate
      i = 1
      For Each key In keys
        ap_name = ""
        ret = reg.GetStringValue(HKEY_LOCAL_MACHINE, SubKeyNameX86 & key, "DisplayName", ap_name)
        reg.GetStringValue HKEY_LOCAL_MACHINE, SubKeyNameX86 & key, "DisplayVersion", ap_ver
        reg.GetStringValue HKEY_LOCAL_MACHINE, SubKeyNameX86 & key, "InstallDate", int_date
        reg.GetStringValue HKEY_LOCAL_MACHINE, SubKeyNameX86 & key, "Publisher", m_name
       
        If ret <> 0 Then ret = reg.GetStringValue(HKEY_LOCAL_MACHINE, SubKeyNameX86 & key, "QuietDisplayName", ap_name)
        If (ret = 0) And (Len(Trim(ap_name)) > 0) Then
        Cells(i, 1) = ap_name
        Cells(i, 2) = ap_ver
        Cells(i, 3) = CDate(Format(int_date, "####/##/##"))
        Cells(i, 4) = m_name
       
        i = i + 1
       
        End If
      Next
      On Error GoTo 0
    '*****rBook_C_U_64? 次のロジックは、上記2つのレジストリには含まれていないので必要と思われる。
      reg.EnumKey HKEY_CURRENT_USER, SubKeyName, keys
      On Error Resume Next
      Set rBook_C_U_64 = Workbooks.Add
      rBook_C_U_64.Sheets(1).Activate
      Range("A1").Activate
      i = 1
       
      For Each key In keys
        ap_name = ""
        ret = reg.GetStringValue(HKEY_CURRENT_USER, SubKeyName & key, "DisplayName", ap_name)
        reg.GetStringValue HKEY_CURRENT_USER, SubKeyName & key, "DisplayVersion", ap_ver
        reg.GetStringValue HKEY_CURRENT_USER, SubKeyName & key, "InstallDate", int_date
        reg.GetStringValue HKEY_CURRENT_USER, SubKeyName & key, "Publisher", m_name
        If ret <> 0 Then ret = reg.GetStringValue(HKEY_CURRENT_USER, SubKeyName & key, "QuietDisplayName", ap_name)
        If (ret = 0) And (Len(Trim(ap_name)) > 0) Then
        Cells(i, 1) = ap_name
        Cells(i, 2) = ap_ver
        Cells(i, 3) = CDate(Format(int_date, "####/##/##"))
        Cells(i, 4) = m_name
       
        i = i + 1
       
        End If
      Next
      On Error GoTo 0
    End Sub



    • 編集済み bearbook41 2018年8月1日 8:46
    • 回答としてマーク bearbook41 2018年8月1日 8:47
    2018年8月1日 8:43