• 締切済み

EXCEL VBAで、PnPでCOMポート番号取得

EXCELで、USB-RS232C変換アダプタをPCに繋げたとき、使用しているCOMポート番号を取得するマクロを作ろうとしています。 下記のコードのGetUseComNameプロシージャを実行してポート番号を取得できるようになりました。 わざわざGetUseComNameプロシージャを実行しなくても、USB-RS232C変換アダプタをPCに接続されたのをプラグアンドプレイで検知して、 COMポート番号を取得する仕様に改良したいのですが、どうすれば良いでしょうか。 私のパソコンの環境は(windows XP 2002 SP3 office excel2003 sp3)です。 '-------------------- Option Explicit '-------------------- Sub GetUseComName() Dim a, b, port_no As String      Range("a1").Select   Selection.Clear      '通信ポート名を取得   a = GetUseComNo()     '通信ポート名の文字列からCOMポート番号(書式「1,2,・・・」の形で)を取り出す。   Do While InStr(a, "(COM") <> 0     a = Mid(a, InStr(a, "(COM") + 4)     port_no = port_no + Left(a, 1)     If InStr(a, "(COM") <> 0 Then       port_no = port_no & ","     End If   Loop      'USB-232C変換アダプタが接続されていれば、セルa1に通信ポート番号を表示する。   If port_no = "" Then     MsgBox ("使用できるCOM Portがありません。")     Exit Sub   ElseIf InStr(port_no, ",") <> 0 Then     Selection = port_no   End If    End Sub '--------------------- Function GetUseComNo() As String   Dim Serial    As Object   Dim SerialSet   As Object   Dim objWMIService As Object   Dim strComputer  As String   Dim intCnt    As Integer  '要素数   Dim strComName  As String   '取得したデバイス名   strComputer = "."   'WMIを呼び出す   Set objWMIService = GetObject("winmgmts:\\" & strComputer & "\root\cimv2")   'PnPで登録されているもの(デバイスマネージャで見えるもの)から   'シリアルポートのクラスでかつ名前に「(COMxx)」と付いているものを抽出   Set SerialSet = objWMIService.ExecQuery("Select * from Win32_PNPEntity Where " & _           "(ClassGuid = '{4D36E978-E325-11CE-BFC1-08002BE10318}') and " & _           "(Name like '%(COM%)')")   '全ポートの数(取得できた項目数)   intCnt = SerialSet.Count   '情報の取得   strComName = ""   For Each Serial In SerialSet     'デバイス名を取得 「"通信ポート (COM1)"」     If strComName <> "" Then       strComName = strComName & vbCrLf     End If     strComName = strComName & Serial.Name   Next   '戻り値セット   GetUseComNo = strComName End Function

みんなの回答

回答No.1

使用出来るCOMポートが発生するまで、GetUseComNoをグルグル回すしか無いと思いますが・・。 それか、COMポートを監視するWindowsの常駐アプリを作って、それをトリガーにそのVBAを起動させるとかですかね・・。 どちらも似たようなものですが。 ※ちなみに「プラグアンドプレイ」って、デバイスが接続されたらそれ用のデバイスを自動で組み込んで使えるようにしますよ。って意味なのはご存知でしょうか。(アプリケーションをキックする為の仕組みではない)

参考URL:
http://ja.wikipedia.org/wiki/%E3%83%97%E3%83%A9%E3%82%B0%E3%82%A2%E3%83%B3%E3%83%89%E3%83%97%E3%83%AC%E3%82%A4
mokichi3216
質問者

お礼

ありがとうございます。 「デバイスが接続されたらアプリケーションをキックする」という仕組みはないということなのでしょうか。。。 まだ諦めがつかないので、もう少し調べてみます。

関連するQ&A

  • VBAでソースから全てのURLを取得したい

    VBAでソースに書いてある全てのURLを取得したいのですが、現状では一部しか取得できません。 文字数制限にでも引っかかっているのでしょうか? どうすれば全てのURLを取得できるのか・・添削して頂けると or ヒントを教えて頂けると助かります。 よろしくお願いします。 (Excel2003を使用) Sub test() Dim objIE As Object Dim objTAG As Object Dim source As String Dim url As String Dim url_start As String Dim url_end As String Dim y As Long url_end = 1 y = 1 Set objIE = CreateObject("InternetExplorer.application") objIE.Visible = False objIE.Navigate "http://dir.yahoo.co.jp/" Do While objIE.Busy = True DoEvents Loop Application.Wait Time:=Now + TimeValue("00:00:03") source = objIE.Document.All(1).Innerhtml Do While y < 10000 url_start = InStr(url_end, source, "<a href=", vbTextCompare) If url_start = 0 Then y = 10000 Else url_end = InStr(url_start, source, ">", vbTextCompare) url = Mid(source, url_start + 9, url_end - url_start - 10) Cells(y, 1).Value = url y = y + 1 End If Loop End Sub

  • VBAで文字の位置が正確に取得できない

    Excel2003のマクロで、URLを抜き出すマクロを作っているのですが、なぜかurl_endの値が正確に取得できません。何がいけないのでしょうか? 事象 url_endに格納される値がなぜか1376(くらいだったような・・)になってしまう。 url_startには1260が格納されており、<a href=の部分をきちんと取得している。 ソース Sub test() Dim objIE As Object Dim objTAG As Object Dim souce As String Dim url As String Dim url_start As String Dim url_end As String url_end = 1 Set objIE = CreateObject("InternetExplorer.application") objIE.Visible = False objIE.Navigate "http://dir.yahoo.co.jp/" Do While objIE.Busy = True DoEvents Loop Application.Wait Time:=Now + TimeValue("00:00:02") url_start = InStr(url_end, objIE.Document.All(1).Innerhtml,"<a href=", vbTextCompare) url_end = InStr(url_start,objIE.Document.All(1).Innerhtml, ">", vbTextCompare) url = Mid(objIE.Document.All(1).Innerhtml, url_start, url_end) Cells(1, 1).Value = url End Sub

  • WindowsのCOMポート番号を入れ替えたい

    PC(WindowsXP)に接続して使う機器があり、 この機器はCOMポートを二つ使用します。 デバイスドライバのインストール順を間違えてしまい COMポート番号が反対になってしまいました。 ・意図した割り当て COM7:機器のAポート COM8:機器のBポート ・現状 COM7:機器のBポート COM8:機器のAポート COMポートの番号を入れ替えたいのですが、デバイスドライバを削除して インストールし直せば良いのでしょうか? デバイスドライバはネットワーク経由で取得したため、どれだったか記憶にありません・・・。 どなたか解決方法をご存知でしたら、教えて頂きたいです。 お願い致します。

  • エクセルVBA 重複を表示したい

    エクセルVBA 重複を表示したい A列で重複すると警告するコードを以下のように作成しました。 これを修正してA列で重複して、なおかつB列でも重複した場合警告するコードにしたいのです。 添付した図では「同姓同名あり、確認してください、鈴木一郎、山口」と表示したいのです。 ご教授よろしくお願いします。 Sub test() Dim myRange As Range Dim 同一flag As Boolean Dim MsgStr As String For Each myRange In Range("A2:A10") If WorksheetFunction.CountIf(Range("A2:A10"), myRange) > 1 Then If 同一flag = False Then 同一flag = True If InStr(1, MsgStr, myRange) = 0 Then MsgStr = MsgStr & myRange & vbCrLf End If End If Next If 同一flag = True Then MsgBox "同姓同名あり" & Chr(13) & _ "確認してください" & Chr(13) & _ vbCrLf & MsgStr Else End If End Sub

  • BluetoothのCOMポートの変更方法(COM16以下に)

    Princetronのブルートースアダプターを購入しました。 セットするとCOM40になりました。 VBのCOMコンポーネントのポートNoは最大でCOM16までです。 どうしたらCOM40を16以下にできるでしょうか。教えてください 新規接続の設定では40から62までの範囲でしかできません。

  • Excelで用紙番号取得

    Excel2000 VBAで用紙番号を取得しようと考えています。 調べてみたのですが、APIのDeviceCapabilities()が使用できそうな感じというのは解ったのですが、 バッファというのがいまいち解らず使えません。 出力バッファやデバイスデータのバッファとは何を指してるのでしょうか? また、以下コードをExcel2000で実行するとエラーになります。 やはりバッファの使い方がおかしいのでしょうか? アドバイスよろしくお願いいたします。 Sub Numbertest() Dim strDeviceName As String Dim strDevicePort As String Dim lngPaperCount As Long Dim bytPaper() As Byte Dim strPaperName As String * 64 Dim lngCounter As Long Dim aintNubytPaper() As Integer Dim lngRet As Long GetPrinterNameAndPort sDeviceName, sDevicePort ' バッファに必要なサイズを取得 lngPaperCount = DeviceCapabilities(strDeviceName, strDevicePort, DC_PAPERNAMES, ByVal vbNullString, ByVal vbNullString) ' バッファ確保 ReDim bytPaper(64 - 1, lngPaperCount - 1) ReDim aintNubytPaper(1 To lngPaperCount) '用紙名を取得 DeviceCapabilities strDeviceName, strDevicePort, DC_PAPERNAMES, bytPaper(0, 0), ByVal vbNullString 'paper numbers を取得 lngRet = DeviceCapabilities(strDeviceName, strDevicePort, DC_PAPERS, aintNubytPaper(1), ByVal vbNullString) '用紙名を列挙 For lngCounter = 0 To lngPaperCount - 1 ' 用紙名コピー MoveMemory ByVal strPaperName, bytPaper(0, lngCounter), 64 ' 用紙名追加 MsgBox aintNubytPaper(lngCounter + 1) MsgBox Left(strPaperName, InStr(strPaperName, vbNullChar) - 1) Next lngCounter End Sub

  • Excel VBA ・・・教えてください

    何度も質問させて頂いてます。すみません、 下記のプログラムはこの場で教えて頂いたプログラムで、 実行すると●の後を▲や■が追いかける動きをします。 下記のプログラムをある程度使用して 1~20の数字が順々で追いかけっこする プログラムを作成するにはどのようにすればいいのでしょうか… できればプログラムは長めにならず 20の数字から簡単に増やすことのできるような そんなプログラムが作成したいです… どなたかアドバイスお持ちの方 教えて下さいお願いします... Dim time1 As Integer, time As Integer Dim X As Integer, Y As Integer Dim X1 As Integer, Y1 As Integer Dim X2 As Integer, Y2 As Integer Dim maru As String, yoko As String, tate As String Dim sankaku As String, shikaku As String Sub 描画() Cells(Y2, X2).Value = shikaku Cells(Y1, X1).Value = sankaku Cells(Y, X).Value = maru End Sub Sub 削除() Cells(Y2, X2).Value = "" End Sub Sub 待機() For time1 = 0 To 1000 For time2 = 0 To 1000 Next Next End Sub Sub 座標移動() X2 = X1 Y2 = Y1 X1 = X Y1 = Y If yoko = "右" Then X = X + 1 Else X = X - 1 End If If X = 30 Then yoko = "左" ElseIf X = 1 Then yoko = "右" End If If tate = "上" Then Y = Y + 1 Else Y = Y - 1 End If If Y = 20 Then tate = "下" ElseIf Y = 1 Then tate = "上" End If End Sub Sub main() maru = "●" sankaku = "▲" shikaku = "■" X = 1 Y = 1 X1 = 1 Y1 = 1 X2 = 1 Y2 = 1 yoko = "右" tate = "上" Do 描画 待機 削除 待機 座標移動 Loop End Sub

  • ▲ExcelのVBA▼困っています

    何度もVBAで質問させてもらい助けてもらっています。 懲りずにまた質問ですが… 下のプログラムは"●"が跳ね返るものなのですが… ●の後を■と▲が追うようなプログラムにするには なにを追加すればいいのでしょうか…?; どなたか教えて下さい;;お願いします;; Dim time1 As Integer, time As Integer Dim X As Integer, Y As Integer Dim maru As String, yoko As String, tate As String Sub 描画() Cells(X, Y).Value = maru End Sub Sub 削除() Cells(X, Y).Value = "" End Sub Sub 待機() For time1 = 0 To 1000 For time2 = 0 To 1000 Next Next End Sub Sub 座標移動() If yoko = "右" Then Y = Y + 1 Else Y = Y - 1 End If If Y = 30 Then yoko = "左" ElseIf Y = 1 Then yoko = "右" End If If tate = "上" Then X = X + 1 Else X = X - 1 End If If X = 20 Then tate = "下" ElseIf X = 1 Then tate = "上" End If End Sub Sub main() maru = "●" X = 1 Y = 1 yoko = "右" tate = "上" Do 描画 待機 削除 待機 座標移動 Loop End Sub

  • SAPデータ取得 エクセルVBA

    いつもここでお世話になっております。 次のサイトで掲載されていたVBAで、SAPのデータ(テーブルデータ)をエクセルで取得することができることがわかりましたが、例えばですがSQLを利用するようなVBAを追記して、任意のフィールド、任意のデータを指定して、それに合致するものだけをエクセルに表示させることはできないでしょうか(イメージとして、SELECT フィールド FROM QUERY_TABLE WHERE データのような感じ)。 何度も試行錯誤をしたのですが、うまくいきません。なにとぞよろしくお願い申し上げます。 ※SAPテーブル取得のエクセルVBA : http://d.hatena.ne.jp/sikakura/20100702/1278053742 -ーーー【以下、テーブルデータ取得のためにVBA】---- Sub ログインR3_LOGON() Set R3 = CreateObject("SAP.Functions") 'R3.Connection.System = "172.31.220.42" 'R3.Connection.client = "100" 'R3.Connection.User = "SAP*" 'R3.Connection.Password = "" 'R3.Connection.Language = "EN" '自動ログインする場合は、Connection.Logon(0,True)にして、 '上のパラメータを設定すればOK. If R3.Connection.Logon(0, False) <> True Then MsgBox "ログインを中止しました" Exit Sub End If 'IMPORTパラメータ Dim QUERY_TABLE As Object Dim DELIMITER As Object Dim NO_DATA As Object Dim ROWSKIPS As Object Dim ROWCOUNT As Object '条件式 Dim OPTIONS As Object Dim FIELDS As Object 'データ Dim DATA As Object '結果保持用 Dim ROW As Object Dim Result As Boolean Dim iRow, iColumn, iStart, iStartRow, iField, iLength As Variant '***************************************************** 'RFC_READ_TABLEを指定します '***************************************************** Set MyFunc = R3.Add("RFC_READ_TABLE") Set QUERY_TABLE = MyFunc.exports("QUERY_TABLE") Set DELIMITER = MyFunc.exports("DELIMITER") Set NO_DATA = MyFunc.exports("NO_DATA") Set ROWSKIPS = MyFunc.exports("ROWSKIPS") Set ROWCOUNT = MyFunc.exports("ROWCOUNT") Set DATA = MyFunc.Tables("DATA") Set OPTIONS = MyFunc.Tables("OPTIONS") Set FIELDS = MyFunc.Tables("FIELDS") QUERY_TABLE.Value = "CSKT" DELIMITER.Value = " " NO_DATA = " " ROWSKIPS = 0 ROWCOUNT = 0 Result = MyFunc.Call If Result = True Then Set DATA = MyFunc.Tables("DATA") Set FIELDS = MyFunc.Tables("FIELDS") Set OPTIONS = MyFunc.Tables("OPTIONS") Else MsgBox MyFunc.EXCEPTION Exit Sub End If '列名をExcelシートに出力 For iField = 1 To FIELDS.ROWCOUNT Worksheets("Sheet2").Cells(1, iField).Value = FIELDS(iField, "FIELDTEXT") Next 'データをExcelシートに出力 iField = 1 For iRow = 1 To DATA.ROWCOUNT For iField = 1 To FIELDS.ROWCOUNT iStart = FIELDS(iField, "OFFSET") + 1 iLength = FIELDS(iField, "LENGTH") If iStart > Len(DATA(iRow, "WA")) Then vField = Null Else vField = Mid(DATA(iRow, "WA"), iStart, iLength) End If Worksheets("Sheet2").Cells(iRow + 1, iField).Value = vField Next Next ' **************************************************** ' Release Object ' **************************************************** Set MyFunc = Nothing Set QUERY_TABLE = Nothing Set DELIMITER = Nothing Set NO_DATA = Nothing Set ROWSKIPS = Nothing Set ROWCOUNT = Nothing Set OPTIONS = Nothing Set FIELDS = Nothing End Sub Private Function Split(ByVal inp As String, Optional delim As String = ",") As Variant Dim outarray() As Variant Dim arrsize As Integer While InStr(inp, delim) > 0 ReDim Preserve outarray(0 To arrsize) As Variant outarray(arrsize) = Left(inp, InStr(inp, delim) - 1) inp = Mid(inp, InStr(inp, delim) + 1) arrsize = arrsize + 1 Wend ReDim Preserve outarray(0 To arrsize) As Variant outarray(arrsize) = inp Split = outarray End Function ーーーーーーーーーーーーーーーーーーーーーー

  • EXCEL VBA リストボックスの表示について

    EXCEL VBA リストボックスの表示について Dim rngCell As Range Dim strStr As String Dim strCom As String Dim strId As String UserForm1.ListBox1.Clear strStr = UserForm1.TextBox.text If strStr = "" Then Exit Sub ThisWorkbook.Worksheets("sheet1").Activate For Each rngCell In [a:a] If rngCell.Value Like "*" & strStr & "*" Then If InStr(strCom, rngCell.Value) = 0 Then strCom = rngCell.Offset(0, 5).Value UserForm1.ListBox1.AddItem strCom strCom = "" strId = rngCell.Offset(0, 6).Value UserForm1.ListBox1.AddItem strId strId = "" End If End If Next End Sub 上記のようなコードを作成しました。 キーワードを入力すると決まった行から結果を出力しリストボックスに表示します。 2つの行から結果が出力されるのですがリストボックスの結果表示が上下になってしまいます。 希望としては aaaaa bbbbb と言うように横表示になればと思っています。 &でつなげる方法もありますがリストボックスのColunmWidthsで指定したとおりの間隔で表示させたいと思っています。 どうか助言をお願いいたします。