Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちら をご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


74547 / 76738 ←次へ | 前へ→

【6653】Re:LAN環境で・・・
回答  ichinose  - 03/7/18(金) 3:03 -

引用なし
パスワード
   ▼やま さん:
こんばんは。
>エクセルのユーザーフォームにラジオボタンを数個配置し、アンケートを作りたいと思います。アンケートの集計にはLAN上の任意のコンピュータ内のマイドキュメントフォルダに「集計.xls」のブックを作成し、その中にセルA1に回答者Aの氏名B1に一問目の解答結果、C2に二問目の解答結果、という風に集計していきたいのです。2番目の回答者は下の行にずらして解答結果を入力させたいのですが、LAN上のコンピュータ全てのコンピュータ名を取得し、リストボックスに表示させ、リストボックス内のコンピュータを選び、さらにその中の「集計.xls」を開いて結果を保存するようなコードはどう記述すれば良いのでしょうか?お願いします。
もっと他に良い方法があるのかもしれませんが・・・。
取りあえず、「xx:\My Documents\集計.xls」を探すということで・・・、
ユーザーフォーム(Userfrom1)内にリストボックス(Listbox1)とコマンドボタン
(Commandbutton1)を配置してください。
参照設定で「MICROSOFT SHELL CONTROLS AND AUTOMATION」をチェックして下さい。
(これしないと、エラーになりました、疑問ですが・・)

標準モジュール(Module1)に、
'=========================================
Sub main()
  UserForm1.Show
End Sub


標準モジュール(Module2)に、
'============================================
Function get_compnm() 'コンピュータ名の取得
  Dim nm()
  Dim myshell As Shell
'           ↑ここがObjectやVariantだとエラーになる不思議
'            よって、上述の参照設定が必要
  Set myshell = CreateObject("Shell.Application")
  With myshell
   Set fol = .NameSpace(18) 'Folderオブジェクト
   Set fc = fol.Items 'FolderItemsコレクション
   jdx = 0
   For idx = 1 To fc.Count - 1
    wk = fc.Item(idx).Name
    ReDim Preserve nm(1 To jdx + 1)
    nm(jdx + 1) = wk
    jdx = jdx + 1
    Next
   End With
  If jdx > 0 Then
    get_compnm = nm()
  Else
    get_compnm = ""
    End If
  Set myshell = Nothing
End Function
'==================================================
Function get_subpath(Optional mydir As String = "") As String
'指定されたパスにあるフォルダパスの取得
  Static sdx
  Static myshell As Shell
'           ↑ここがObjectやVariantだとエラーになるのが不思議
  Static fol As Object
  Static fc As Object
  If mydir <> "" Then
    Set myshell = CreateObject("Shell.Application")
    Set fol = myshell.NameSpace(mydir)
    Set fc = fol.Items
    sdx = 0
    End If
  If sdx <= fc.Count - 1 Then
    get_subpath = fc.Item(sdx).Path
    sdx = sdx + 1
  Else
    get_subpath = ""
    Set fc = Nothing
    Set fol = Nothing
    Set myshell = Nothing
    End If
End Function


Userform1のモジュールに
'=====================================================
Private Sub CommandButton1_Click()
  Dim compnm As String
  Dim fld As String
  Dim bk As Workbook
  With ListBox1
    If .ListIndex >= 0 Then
     compnm = .Value
     fld = get_subpath("\\" & compnm)
     Do While fld <> ""
       Set bk = book_open(fld & "\my documents\集計.xls")
       If Not bk Is Nothing Then
        MsgBox bk.Name & "取得"
        '処理
        bk.Close False
        Exit Do
        End If
       fld = get_subpath
       Loop
     End If
    End With
End Sub
'========================================
Private Sub UserForm_Initialize()
  Dim compnm
  compnm = get_compnm
  If VarType(compnm) = 8204 Then
    ListBox1.List = compnm
    End If
End Sub
'=========================================
Function book_open(flnm) As Workbook
  On Error Resume Next
  Set book_open = Workbooks.Open(flnm)
  If Err.Number <> 0 Then
    Set book_open = Nothing
    End If
  On Error GoTo 0
End Function

で指定されたコンピュータの「My Documents\集計.xls」が取得できましたが、
確認してください。
0 hits

【6649】LAN環境で・・・ やま 03/7/17(木) 10:35 質問
【6653】Re:LAN環境で・・・ ichinose 03/7/18(金) 3:03 回答
【6654】Re:LAN環境で・・・ やま 03/7/18(金) 9:41 お礼

74547 / 76738 ←次へ | 前へ→
ページ:  ┃  記事番号:
2610219
(SS)C-BOARD v3.8 is Free