WindowsのプロダクトIDを取得する方法
- 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以外の値が返ってくる) すいませんが、ご存知の方、やり方をご教示ください。 お願いします。
- mogeraccho
- お礼率57% (90/157)
- その他(プログラミング・開発)
- 回答数4
- ありがとう数7
- みんなの回答 (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 が何か絡んでいそうですね。
その他の回答 (3)
- koi1234
- ベストアンサー率53% (1866/3459)
#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); 今回まだそこまで行ってないですが実際レジストリに値が存在してることも 確認しないとダメでしょう
お礼
ご回答ありがとうございます。 >以下此方でVCにて確認したソースコードとなります >エラー処理など省いています 参考にさせていただきました。 自分が書き直したコードはエラーがなかったのですが、 どうしても値が読み取れず、とりあえず、ほかの値を指定して 取得してみると、見事取得。 (レジストリに値は存在しております。) ・・・ということは、ProductIdだけ取得できないのでしょうか? 書き忘れていましたが、当方、Windows 7 HPを使用しております。 7では防御されてしまうのでしょうか・・・?
- koi1234
- ベストアンサー率53% (1866/3459)
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点 そのあたりを直して手元で確認した限りきちんと読めてます
お礼
ご回答ありがとうございます。 とりあえず、一からチェックしていったところ、 RegQueryValueExの第四引数はNULL 第六引数は返ってくる値を受ける変数の指定みたいですね。 すいませんでした。 とりあえず、ABにエスケープはない(・・・見たことないだけか)ので、 エラーは出ませんし、これはないと思います。 しかし、アクセスエラーが出なくなったら、『指定されたファイルが見つかりません』と出ます。 Registory Editorで確認しても、値はあります。 これは何故なのでしょうか? またまたすいませんが、再度ご教授ください。 何度やっても同じエラーで困っています。 よろしくお願いします。
- koi1234
- ベストアンサー率53% (1866/3459)
内容はちゃんと見てません >(RegQueryValueExでエラーが返る。FormatMessageでエラーを見ると、 > 正常終了している。・・・が、0以外の値が返ってくる) 手元のMSDN見てみると -------------- 関数が失敗すると、WINERROR.H ヘッダファイルで定義された、0 以外のエラーコードが返ります。FORMAT_MESSAGE_FROM_SYSTEM フラグを指定して FormatMessage 関数を呼び出すと、エラーの一般的な説明が取得できます。 -------------- との記載があります フラグ指定してますか?
お礼
ご回答ありがとうございます。 >フラグ指定してますか? すいません、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
- ベストアンサー
- Visual Basic
- 現在ファイルを開いている全てのユーザー名を取得
パソコン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
- 締切済み
- Visual Basic
- 起動時シフトキーを無効にして、作成した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
- ベストアンサー
- Visual Basic
- メール
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の質問とは全く関係ありません。
- ベストアンサー
- Visual Basic
- 保存の仕方
こんにちは、次のようなアドレスを入力するとそのソースを表示するプログラムを作ったのですがこれで表示されるソースに名前を付けて保存することってできますか?お願いします。 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
- ベストアンサー
- Visual Basic
- 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
- 締切済み
- Access(アクセス)
- 縦に取得するのを横にする&最後に取得したところから
下記のマクロで、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
- 締切済み
- Excel(エクセル)
お礼
>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・・・何かで聞いたなぁ・・・なんでしたっけ・・・ といってググって理解。 確かに関係ありそう・・・? でも、レジストリ(レジストリー?)の値を読み取るだけですし・・・ 関係あるのでしょうか・・・? 悩まされます。 しかも取得できるのは、完全な個人情報(・・・というか、外部に漏れたらまずそうな情報)以外ですよね・・・ な~んか引っかかります・・・ 権限が足りないのか・・・と思っても、完全管理者権限ですし・・・ 何なのでしょう・・・?