WindowsのプロダクトIDを取得する方法

このQ&Aのポイント
  • WindowsのプロダクトIDを取得する方法について解説します。
  • Active Basic 4.24.00を使用してプログラムを書いており、WindowsのProduct IDを取得しようとしています。しかし、うまく取得できません。
  • 関数GetWinProductIdを使用してProduct IDを取得する方法について質問しています。
回答を見る
  • ベストアンサー

WindowsのプロダクトIDを取得する方法について

WindowsのプロダクトIDを取得する方法について Active Basic 4.24.00を使用してプログラムを書いています。 (AB5はバグがあるためまだ使用していません。) http://www.ruriplus.com/msaccess/tch/tch_036.html 上記のサイト様を参考に、WindowsのProduct IDを取得しようとしています。 (参考というより、コピペなのですが・・・) しかし、きちんと取得してくれません。 AB用に以下のように書き直しました。 Function GetWinProductId() As String Dim stSubKey As String Dim stProductid As String Dim hkeyRoot As HKEY Dim lErr As Long Dim OSVER As OSVERSIONINFO Dim dummy As Long stProductid=ZeroString(256) OSVER.dwOSVersionInfoSize = Len(OSVER) lErr = GetVersionEx(OSVER) If lErr = 0 Then Exit Function If OSVER.dwPlatformId = VER_PLATFORM_WIN32_NT Then stSubKey = "SOFTWARE\Microsoft\Windows NT\CurrentVersion" Else stSubKey = "SOFTWARE\Microsoft\Windows\CurrentVersion" End If lErr = RegOpenKeyEx(HKEY_LOCAL_MACHINE, stSubKey, &0, KEY_READ, hkeyRoot) If lErr <> 0 Then MessageBox(0,"ERROR","1",0) Exit Function End If lErr = RegQueryValueEx(hkeyRoot, "ProductId", &0, REG_SZ,stProductid, 256) If lErr <> 0 Then MessageBox(0,"ERROR","2",0) Exit Function End If lErr = RegCloseKey(hkeyRoot) If lErr <> 0 Then MessageBox(0,"ERROR","3",0) Exit Function End If GetWinProductId = Left$(stProductid, 255 /*InStr(1, stProductid, vbNullChar, vbBinaryCompare)*/) End Function MessageBox(0,GetWinProductId(),0,0) ※ Left$(stProductid, 255 /*InStr(1, stProductid, vbNullChar, vbBinaryCompare)*/) この部分は、よく分からなかったので、とりあえず放置しています。 その前に、変数『stProductid』に値が帰ってこないのです。 (RegQueryValueExでエラーが返る。FormatMessageでエラーを見ると、正常終了している。・・・が、0以外の値が返ってくる) すいませんが、ご存知の方、やり方をご教示ください。 お願いします。

質問者が選んだベストアンサー

  • ベストアンサー
回答No.4

ちょっと興味があって試してみました。 C++ で作成しました。 Win32 で作成し、Win7 (64bit) で実行すると "ProductId" はダメでした。 同じ実行ファイルを、XP (32bit) で実行すると正常に取得できました。 また、"ProductId" を "ProductName" に変えると、Win7 (64bit) でも正常に取得できました。 #include "stdafx.h" int _tmain(int argc, _TCHAR* argv[]) { OSVERSIONINFO osv; HKEY hk; LPTSTR pKeyName; TCHAR szProductId[ 1000 ]; DWORD dwSize = 1000; DWORD dwType = REG_SZ; LONG result; osv.dwOSVersionInfoSize = sizeof( OSVERSIONINFO ); GetVersionEx( &osv ); if( osv.dwPlatformId == VER_PLATFORM_WIN32_NT ) { pKeyName = _T("SOFTWARE\\Microsoft\\Windows NT\\CurrentVersion"); } else { pKeyName = _T("SOFTWARE\\Microsoft\\Windows\\CurrentVersion"); } if( 0 == RegOpenKeyEx( HKEY_LOCAL_MACHINE, pKeyName, 0, KEY_QUERY_VALUE, &hk ) ) { memset( szProductId, 0, dwSize ); result = RegQueryValueEx( hk, _T("ProductId"), 0, &dwType, ( LPBYTE )szProductId, &dwSize ); // result = RegQueryValueEx( hk, _T("ProductName"), 0, &dwType, ( LPBYTE )szProductId, &dwSize ); if( result == ERROR_SUCCESS ) { MessageBox( NULL, szProductId, _T("Get Product ID"), MB_ICONINFORMATION ); } else { MessageBox( NULL, _T("Error"), _T("Get Product ID"), MB_ICONEXCLAMATION ); } RegCloseKey( hk ); } return 0; } ところが、同じソースを X64 でビルドすると、Win7 (64bit) で正常に取得できました。 ん~、何なんでしょうね・・・。WOW64 が何か絡んでいそうですね。

mogeraccho
質問者

お礼

>Win32 で作成し、Win7 (64bit) で実行すると "ProductId" はダメでした。 >同じ実行ファイルを、XP (32bit) で実行すると正常に取得できました。 おお、まったく同じ環境だ。 当方も同じ環境です。 Win 7 64bit Win XP 32bit で実験。 32bitコンパイラー使用しました。 >ところが、同じソースを X64 でビルドすると、Win7 (64bit) で正常に取得できました。 なんと! それは気がつかなかった。 早速実験したところ、確かに64bitコンパイラーで実行すると、取得できました。 今、これをやっているのは、インストーラー的なものを作っていて、 再配布防止にプロダクトIDを中身にこっそり付け加えようという陰謀なのです。 しかし、64bitでコンパイルすると、32bitのパソコンで使えないのが困りますね・・・ 出来れば32bitでコンパイルしたいです。 64bitでも動かせるので・・・ 確かに、64bitに移りつつありますが、それでも32bitを使ってる方は多いです。 まだ32bitでコンパイルした方が無難ですね・・・ >WOW64 が何か絡んでいそうですね。 WOW64・・・何かで聞いたなぁ・・・なんでしたっけ・・・ といってググって理解。 確かに関係ありそう・・・? でも、レジストリ(レジストリー?)の値を読み取るだけですし・・・ 関係あるのでしょうか・・・? 悩まされます。 しかも取得できるのは、完全な個人情報(・・・というか、外部に漏れたらまずそうな情報)以外ですよね・・・ な~んか引っかかります・・・ 権限が足りないのか・・・と思っても、完全管理者権限ですし・・・ 何なのでしょう・・・?

その他の回答 (3)

  • koi1234
  • ベストアンサー率53% (1866/3459)
回答No.3

#2にも書いたように私はABの構文知りませんので (PC自体には以前入れたけど使ってないし) 試しに挑戦しましたが結局アドレスの渡し方がわからず断念しました また#2自体にもちょっと書き忘れてる部分がありました (REG_SZそのまま渡してるのも間違い) 以下此方でVCにて確認したソースコードとなります エラー処理など省いています 同じ内容が変換できてれば動くはずなので 動かないのであればどこかのパラメータが 正常に渡せていないんでしょうとしか言えません 自分が挫折した範囲では RegOpenKeyEx のhkeyRoot の アドレス渡しの方法がわからず   VarPtr(hkeyRoot) で書いても構文エラーになってお手上げ 適当にやってみて関数自体は正常終了するが まともな値が得られていないような感じでした   デバック方法すらどうやればいいのかよくわからないので   違うかもしてませんが 他には見た限り \\ でなくて \ で動いてそうでした (ABってそうなのねと ちなみに使ったのはVer4.23) char stSubKey[256]; char stProductid[256]; HKEY hkeyRoot; LONG lErr; OSVERSIONINFO OSVER; ULONG dummy; ULONG dummy1; memset(stProductid, 0, sizeof(stProductid)); OSVER.dwOSVersionInfoSize = sizeof(OSVER); lErr = GetVersionEx(&OSVER); if (OSVER.dwPlatformId == VER_PLATFORM_WIN32_NT)  strcpy(stSubKey ,"SOFTWARE\\Microsoft\\Windows NT\\CurrentVersion"); else  strcpy(stSubKey , "SOFTWARE\\Microsoft\\Windows\\CurrentVersion"); lErr = RegOpenKeyEx(HKEY_LOCAL_MACHINE, stSubKey, 0, KEY_READ, &hkeyRoot); dummy = REG_SZ; dummy1 = sizeof(stProductid); lErr = RegQueryValueEx(hkeyRoot, "ProductId", 0, &dummy,(unsigned char *)stProductid, &dummy1); lErr = RegCloseKey(hkeyRoot); 今回まだそこまで行ってないですが実際レジストリに値が存在してることも 確認しないとダメでしょう

mogeraccho
質問者

お礼

ご回答ありがとうございます。 >以下此方でVCにて確認したソースコードとなります >エラー処理など省いています 参考にさせていただきました。 自分が書き直したコードはエラーがなかったのですが、 どうしても値が読み取れず、とりあえず、ほかの値を指定して 取得してみると、見事取得。 (レジストリに値は存在しております。) ・・・ということは、ProductIdだけ取得できないのでしょうか? 書き忘れていましたが、当方、Windows 7 HPを使用しております。 7では防御されてしまうのでしょうか・・・?

  • koi1234
  • ベストアンサー率53% (1866/3459)
回答No.2

ABの構文は知らないので同様のことをVCで確認しました結果 気になった点を羅列します 1."SOFTWARE\Microsoft\Windows NT\CurrentVersion"   文字列内 \ の表記は \\ のようにしないと   エスケープ文字として誤認されませんか?   ※ VCではコンパイルでエラーになってます 2.サンプルコードに間違いがあると思われます(以下2か所)   RegOpenKeyEx(HKEY_LOCAL_MACHINE, stSubKey, 0&, KEY_READ, hkeyRoot)   hkeyRootの値ではなくアドレス渡さないとダメ   RegQueryValueEx(hkeyRoot, "ProductId", 0&, REG_SZ, ByVal stProductid, 255)   255の値を渡すのではなくその値が入ってるアドレス渡さないとダメ   ではないかと思います   また下が ByVal stProductid と書くのであれば上が stSubKey ってのは   おかしいのではないかと(どっちでも同じ意味になるならいいです) 3.RegQueryValueExでエラーになったときCloseしてないのが問題ではないか 上記3点 そのあたりを直して手元で確認した限りきちんと読めてます

mogeraccho
質問者

お礼

ご回答ありがとうございます。 とりあえず、一からチェックしていったところ、 RegQueryValueExの第四引数はNULL 第六引数は返ってくる値を受ける変数の指定みたいですね。 すいませんでした。 とりあえず、ABにエスケープはない(・・・見たことないだけか)ので、 エラーは出ませんし、これはないと思います。 しかし、アクセスエラーが出なくなったら、『指定されたファイルが見つかりません』と出ます。 Registory Editorで確認しても、値はあります。 これは何故なのでしょうか? またまたすいませんが、再度ご教授ください。 何度やっても同じエラーで困っています。 よろしくお願いします。

  • koi1234
  • ベストアンサー率53% (1866/3459)
回答No.1

内容はちゃんと見てません >(RegQueryValueExでエラーが返る。FormatMessageでエラーを見ると、 > 正常終了している。・・・が、0以外の値が返ってくる) 手元のMSDN見てみると -------------- 関数が失敗すると、WINERROR.H ヘッダファイルで定義された、0 以外のエラーコードが返ります。FORMAT_MESSAGE_FROM_SYSTEM フラグを指定して FormatMessage 関数を呼び出すと、エラーの一般的な説明が取得できます。 -------------- との記載があります  フラグ指定してますか?

mogeraccho
質問者

お礼

ご回答ありがとうございます。 >フラグ指定してますか? すいません、GetLastError()使っていました。 早速戻り値を指定したところ、 『パラメーターが間違っています。』 と返ってきました。 ・・・しかし、間違っている箇所が分かりません。 とりあえず、エラーが返ってきたのが、RegQueryValueEx関数です。 すいませんが、ご教授ください。

関連するQ&A

  • サイトタイトルを取得するマクロが「応答なし」になる

    下記のマクロは、選択したセルのURLからサイトタイトルを取得するものです。 このマクロを使って、1万を越えるURLの作業をやろうとしています。 作業に取り掛かったのですが、下記のマクロがすぐに「応答なし」になり、 エクセルの画面が真っ白になり、Escでマクロを止めることもできません。 ようやくマクロを止めても応答なしのときはマクロが動いておらず、作業が進みません。 取得するサイトタイトルの数が多いため、 寝てるときにマクロを動かしてやっていきたいです。 下記のマクロを「応答なし」にせずに、順調にサイトタイトルを取得していくには、 どのような記述にすれば、できるようになるでしょうか? EXCEL2016です。 よろしくお願いいたします。 ↓応答なしになるマクロ Sub サイトタイトル() Dim rng As Range Dim url As String Dim s As String For Each rng In Selection url = rng.Value If url <> "" Then If url Like "*://*" Then s = GetTitle(rng.Value) Else s = GetTitle("https://" & url) If s = "Error" Then s = GetTitle("http://" & url) If s = "Error" Then s = GetTitle("https://www." & url) If s = "Error" Then s = GetTitle("http://www." & url) End If rng.Offset(, 1) = s End If Next End Sub Function GetTitle(url As String) As String Dim http As Object Dim html As Object Set http = CreateObject("MSXML2.XMLHTTP") Set html = CreateObject("htmlfile") GetTitle = "Error" On Error Resume Next http.Open "GET", url, False http.send If http.Status <> 200 Then Exit Function On Error GoTo 0 html.Write http.responseText GetTitle = html.Title End Function

  • 現在ファイルを開いている全てのユーザー名を取得

    パソコン1に入っているアクセスファイル(accdb)に パソコン1とパソコン2で同時に開いています。 共有している状態です。 その際、現在ファイルを開いている全てのユーザー名を取得したいのですが http://okwave.jp/qa/q3589812.html を参考に ' // 標準モジュール Private Declare Function GetUserName Lib "ADVAPI32.dll" Alias "GetUserNameA" ( _     ByVal lpBuffer As String, _     ByRef nSize As Long _ ) As Long Private Const MAX_PATH As Long = 256 ' // Windows のログインユーザー名を取得する Public Function GetLoginUserName() As String   Dim sBuffer As String   sBuffer = String$(MAX_PATH, vbNullChar)   If CBool(GetUserName(sBuffer, MAX_PATH) > 0) Then     GetLoginUserName = Left$(sBuffer, InStr(sBuffer, vbNullChar) - 1)   End If End Function Sub 使い方サンプル()   Dim sUserName As String      sUserName = GetLoginUserName()   MsgBox "USER: " & sUserName, vbInformation    End Sub を実行してみたのですが、それぞれ自分のユーザー名しか取得されません。 http://billyboy.blog81.fc2.com/blog-entry-157.html の Public Declare Function GetUserName Lib "advapi32.dll" Alias "GetUserNameA" _ (ByVal lpBuffer As String, _ nSize As Long) As Long Function GetLoginName() Dim strBuffer As String * 255, retValue As Long retValue = GetUserName(strBuffer, 255) GetLoginName = Left(strBuffer, InStr(strBuffer, vbNullChar) - 1) End Function Sub sample() MsgBox GetLoginName() End Sub を実行しても同じです。 http://www.tsware.jp/tips/tips_013.htm も自分のユーザー名しか取得できません。 どれも標準モジュールに貼り付けました。 現在ファイルを開いているユーザー名を取得するにはどうすればいいでしょうか?

  • コマンドプロンプトで実行したら・・・

    Function SpaceDelete(dt As String) As String Dim tmp As String Dim Aftr As String Dim i As Integer For i = 1 To Len(dt) tmp = Mid(dt, i, 1) If tmp <> " " And tmp <> " " Then Aftr = Aftr & tmp End If Next i SpaceDelete = Aftr End Function test.vbs(1,25) Microsoft VBScript コンパイル エラー: ')'がありません。とエラーがでます。 どこが問題かわかりません。 どなたか教えて頂けないでしょうか。 宜しくお願いします。

  • 数値かどうかを取得したい IsNumberではダメ

    Sub Macro2() Dim mystr As String mystr = "1" If IsDate(mystr) = False Then MsgBox "NO" End If End Sub これなら日付型かどうかを取得できるのに、 Sub Macro1() Dim mystr As String mystr = "1" If IsNumber(mystr) = False Then MsgBox "NO" End If End Sub だと、IsNumberがコンパイルエラーになります。 変数に入っている値が数値として評価できるかを取得する方法を教えてください。

  • URLからタイトルを取得したい!

    エクセルのA列にはURLがずらっとあり、B列にタイトル取得を考えています。 そこで、他の質問者さんのコードを試しました。 その結果、普通のサイトでは問題なく取得できたのですが、 アメーバーブログなどの無料ブログでは、途中で止まってエラーとなってしまうようです。 どこかいけないのでしょうか? Public Sub ReadTitle() Dim url As Range Dim Http, buf As String Set Http = CreateObject("MSXML2.XMLHTTP") Set url = Range("A1") Do While (url.Value <> "") Http.Open "GET", url.Value, False Http.Send buf = StrConv(Http.ResponseBody, vbUnicode) 'msgbox buf url.Offset(0, 1).Value = getTitle(buf) Set url = url.Offset(1, 0) Loop Set Http = Nothing End Sub Private Function getTitle(buf As String) As String Dim pos1 As Long, pos2 As Long pos1 = InStr(1, buf, "<title>") If pos1 = 0 Then pos1 = InStr(1, buf, "<TITLE>") If pos1 = 0 Then getTitle = "" Exit Function Else pos2 = InStr(pos1 + 7, buf, "</TITLE>") End If Else pos2 = InStr(pos1 + 7, buf, "</title>") End If getTitle = Mid(buf, pos1 + 7, pos2 - pos1 - 7) End Function

  • 起動時シフトキーを無効にして、作成したmdbのセキュリテーを高める方法について

    以下のコードは、次回起動時シフトキーを無効にする方法らしいのですが、★印のところで、型が一致しませんとエラーが出てしまいます。 どうしてでしょか?対応方法を教えてください。 Function NoShiftKey()   ChangeProperty "AllowBypassKey", dbBoolean, False End Function Function ChangeProperty(strPropName As String, varPropType, varPropValue) As Integer On Error GoTo エラー   Dim dbs As Database, prp As Property   Const conPropNotFoundError = 3270   Set dbs = CurrentDb   dbs.Properties(strPropName) = varPropValue   ChangeProperty = True   Exit Function エラー:   If Err = conPropNotFoundError Then     Set prp = dbs.CreateProperty(strPropName, varPropType, varPropValue) '★この行でエラーがでます。     dbs.Properties.Append prp     Resume Next   Else     ChangeProperty = False     Exit Function   End If End Function

  • メール

    VBから変数Aを本文に自動的に貼り付ける方法を教えてください。 なお下は以前開発したものです。応用して使えるでしょうか? Public Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" _ (ByVal hwnd As Long, ByVal ipopperation As String, ByVal lpfile As String, _ ByVal lpparameters As String, ByVal lpdirectory As String, ByVal nshowcmd As Long) As Long --------- Private Sub ??_Click() Dim LngReturn As Long Dim StrCommand As String StrCommand = Trim$(Text_mail_pc) If LCase(Left(StrCommand, 7)) <> "mailto:" Then StrCommand = "mailto:" & StrCommand End If LngReturn = ShellExecute(Me.hwnd, "open", StrCommand, vbNullChar, vbNullChar, Sw_Shownormal) End Sub ---------- ※↓のVBの質問とは全く関係ありません。

  • 保存の仕方

    こんにちは、次のようなアドレスを入力するとそのソースを表示するプログラムを作ったのですがこれで表示されるソースに名前を付けて保存することってできますか?お願いします。 Private Sub Command1_Click() Dim strUrl As String Dim strBuf As String Command1.Enabled = False strUrl = InputBox("URLを入力して下さい.") If (Len(strUrl) = 0) Then Exit Sub End If Command1.Enabled = True strBuf = Inet1.OpenURL(strUrl) Form2.Show Form2.Text1.Text = strBuf End Sub Function Getsource() As String Dim strBuf As String Dim strUrl As String strBuf = Inet1.OpenURL(strUrl) 'ファイル内容を取得 Getsource = strBuf End Function

  • GetOpenFileName 開かない

    win7 32bitで使用していたVBAが、win10 64bitで動作せず、困っております。 ダイアログが開かないまま先に進んでしまうのですが、どのように修正すれば良いでしょうか? #If Win64 Then Public Declare PtrSafe Function GetOpenFileName Lib "comdlg32.dll" Alias "GetOpenFileNameA" ( pOpenFileName As OPENFILENAME) As Long #Else Public Declare Function GetOpenFileName Lib "comdlg32.dll" Alias "GetOpenFileNameA" ( pOpenFileName As OPENFILENAME) As Long #End If Type OPENFILENAME lStructSize As Long hwndOwner As LongPtr hInstance As LongPtr lpstrFilter As String lpstrCustomFilter As Long nMaxCustrFilter As Long nFilterIndex As Long lpstrFile As String nMaxFile As Long lpstrFileTitle As String nMaxFileTitle As Long lpstrInitialDir As String lpstrTitle As String Flags As Long nFileOffset As Integer nFileExtension As Integer lpstrDefExt As String lCustrData As LongPtr lpfnHook As LongPtr lpTemplateName As Long End Type Public Const OFN_ALLOWMULTISELECT = &H200 Public Const OFN_CREATEPROMPT = &H2000 Public Const OFN_EXPLORER = &H80000 Public Const OFN_FILEMUSTEXIST = &H1000 Public Const OFN_HIDEREADONLY = &H4 Public Const OFN_NOCHANGEDIR = &H8 Public Const OFN_NODEREFERENCELINKS = &H100000 Public Const OFN_NONETWORKBUTTON = &H20000 Public Const OFN_NOREADONLYRETURN = &H8000 Public Const OFN_NOVALIDATE = &H100 Public Const OFN_OVERWRITEPROMPT = &H2 Public Const OFN_PATHMUSTEXIST = &H800 Public Const OFN_READONLY = &H1 Public Const OFN_SHOWHELP = &H10 Public Const OFN_EXTENSIONDIFFERENT = &H400 Public Function GetFileName(pstrDir As String, pstrFile) As String Dim pOpenFileName As OPENFILENAME Dim lngRet As Long pOpenFileName.hwndOwner = Application.hWndAccessApp pOpenFileName.hInstance = 0 ' pOpenFileName.lpstrFilter = "CSVファイル (*.xlsx)" & String(1, vbNullChar) & "*.xlsx" & String(2, vbNullChar) ' pOpenFileName.lpstrFilter = "全てのファイル (*.*)" & String( 1, vbNullChar) & "*.*" & String(2, vbNullChar) pOpenFileName.lpstrCustomFilter = 0 pOpenFileName.nMaxCustrFilter = 0 pOpenFileName.nFilterIndex = 1 pOpenFileName.lpstrFile = String(511, vbNullChar) pOpenFileName.nMaxFile = 511 pOpenFileName.lpstrFileTitle = String(512, vbNullChar) pOpenFileName.nMaxFileTitle = 511 pOpenFileName.lpstrInitialDir = pstrDir pOpenFileName.lpstrTitle = String(1, vbNullChar) pOpenFileName.nFileOffset = 0 pOpenFileName.nFileExtension = 0 pOpenFileName.lpstrDefExt = String(1, vbNullChar) pOpenFileName.lCustrData = 0 pOpenFileName.lpfnHook = 0 pOpenFileName.lpTemplateName = 0 pOpenFileName.lStructSize = Len(pOpenFileName) pOpenFileName.Flags = OFN_HIDEREADONLY _ Or OFN_EXPLORER lngRet = GetOpenFileName(pOpenFileName) GetFileName = Left(pOpenFileName.lpstrFile, _ InStr(pOpenFileName.lpstrFile, vbNullChar) - 1) If Len(GetFileName) Then pstrFile = Left(pOpenFileName.lpstrFileTitle, _ InStr(pOpenFileName.lpstrFileTitle, vbNullChar) - 1) pstrDir = Left(GetFileName, Len(GetFileName) - Len(pstrFile) - 1) End If End Function '実行プロシージャ Private Sub CmdlgTest() Dim strPath As String, strfile As String Debug.Print GetFileName(strPath, strfile) End Sub

  • 縦に取得するのを横にする&最後に取得したところから

    下記のマクロで、A1の語句をGoogle検索して、 上位5位のタイトル・URLをA2~A11へ記入できます。 そのA1に語句、A2~A11に上位5位というのを、 A1に語句、B1~K1に上位5位という風に変更したいです。 A1(語句)|A2(タイトル)|A3(URL)| ↓ A1(語句)|B1(タイトル)|C1(URL)| という感じです。 もう一つ、 途中でロボットでない証明のクリックがあります。 そのため、マクロを止めざるおえないです。 改めて、マクロを再開する時に、 最後に取得した語句から始めるようにしたいです。 これらは、どのようなマクロの記述になるでしょうか? EXCEL2016です。 よろしくお願いいたします。 '//標準モジュール Private Declare Sub Sleep Lib "kernel32.dll" (ByVal dwMilliseconds As Long) Dim objIE As SHDocVw.InternetExplorer '参照設定 Microsoft Internet Contorls Dim oHTML As HTMLDocument '参照設定 Microsoft HTML Object Library Sub Main()  Dim c As Range  Dim enSrTxt As String  Dim counter As Long  On Error GoTo ErrHandler  Const BASEURL As String = "https://www.google.co.jp/search?q="  With ActiveSheet   Set objIE = Nothing   For Each c In .Range("A1", .Cells(1, Columns.Count).End(xlToLeft))    If c.Value <> "" Then     If c.Value Like "*[ぁ-龠]*" Then      enSrTxt = EnUtf8(c.Value)     Else      enSrTxt = c.Value     End If     Call getIE(BASEURL & enSrTxt)     'Application.Wait TimeSerial(0, 0, 10) '遅くしていた元凶     Sleep 500     counter = counter + 1    End If   Next c  End With ErrHandler:  If Err <> 0 Then   MsgBox Err.Description  End If End Sub Sub getIE(ByVal strURL As String)  Dim cnt As Long  Dim cl As Object  Dim c As Range  Dim nm As Long  Set oHTML = New HTMLDocument  If objIE Is Nothing Then   Set objIE = New SHDocVw.InternetExplorer  End If  Set c = Cells(2, Columns.Count).End(xlToLeft) '二行目で計る  If c.Value <> "" Then nm = c.Column + 1 Else nm = c.Column  With objIE   .Visible = True   .navigate strURL   Do While .Busy Or .readyState <> 4: DoEvents: Loop   Set oHTML = .document  End With   Call outputLog(oHTML, nm)   Set cl = objIE.document.getElementsByClassName("csb ch")   cl(1).Click   DoEvents   Sleep 500   Do While objIE.Busy Or objIE.readyState <> 4: DoEvents: Loop   Set oHTML = objIE.document  Cells(1, nm).EntireColumn.AutoFit  Application.ScreenUpdating = True End Sub Sub outputLog(oHTML As HTMLDocument, nm As Long)  Dim buf As Variant  Dim j As Long, i As Long, k As Long  Dim gLinks As Object  Dim mTitle As Variant  Dim cnt As Long  j = Cells(Rows.Count, nm).End(xlUp).Row + 1  With oHTML   Set mTitle = oHTML.getElementsByClassName("LC20lb")   Set gLinks = oHTML.getElementsByClassName("TbwUpd")   If gLinks.Length > 0 Then    If (gLinks.Length - 1) > 4 Then cnt = 4 Else cnt = gLinks.Length - 1    For i = 0 To cnt '' 5コまで、     Cells(j, nm).Value = mTitle(i).innerText     buf = gLinks(i).ParentNode.href     If InStr(1, buf, "%") > k Then buf = DecodeUTF8(buf)     Cells(j + 1, nm).Value = buf     Cells(j + 1, nm).Font.ColorIndex = 4 'フォントの色     j = j + 2     buf = ""    Next   End If  End With End Sub Private Function EnUtf8(ByRef strSource As String) As String  'Encode  Dim objSC As Object  Set objSC = CreateObject("ScriptControl")  objSC.Language = "Jscript"  EnUtf8 = objSC.CodeObject.encodeURIComponent(strSource)  Set objSC = Nothing End Function Private Function DecodeUTF8(ByVal strSearch As String)  'Decord  If strSearch = "" Then Exit Function  With CreateObject("ScriptControl")   .Language = "JScript"   With .CodeObject    DecodeUTF8 = .decodeURI(strSearch)   End With  End With End Function