リストボックス 複数選択の場合の値取得

質問

ACCESS2003を使用しています。
今、下記のプログラムにて
リストボックスからファイル名を選び
CSVをインポートさせ、更に選択したファイル名を新しいフィールドに書き込みをする。というシステムを作っています。
現在のプログラムですと、一つを選択した場合はうまく書き込めます。
ですが、複数同時選択する事はできますでしょうか？
長くて見づらいプログラムですが、参考までに掲載します。
よろしくお願いします。

Private Sub Form_Load()
Dim oFSO As Object
Dim oFile As Object
Dim sTmp As String
Const FolderPath = "\\St1\第２業務部\$運用\TESTkanno"

sTmp = ""
Set oFSO = CreateObject("Scripting.FileSystemObject")
For Each oFile In oFSO.GetFolder(FolderPath).files
If (Right(oFile.Name, 3) = "csv") Then
sTmp = sTmp & ";" & Left(oFile.Name, InStr(oFile.Name, ".") - 1)
End If
Next
If (Len(sTmp) > 0) Then
sTmp = Mid(sTmp, 2)
End If
Me.lst_01.RowSource = sTmp
'Me.lst_01 = Null
Set oFSO = Nothing
End Sub

Private Sub Cmd_01_Click()

Dim ercd As Integer
Dim LsName As String
Dim TName As String
Dim ITName As String
Dim Name1 As String
Dim Name2 As String
Dim teigi As String
Dim SQL As String
Dim aa As Long
Dim mySQL As String
Dim db As Database
Dim i As Integer
Dim varData As Variant
Dim strSelected As String

strSelected = vbNullString

With lst_01
For Each varData In .ItemsSelected

strSelected = strSelected & .ItemData(varData - 1) & " "

Next

End With

'ファイル名の取得
strError = 0
LsName = "\\St1\第２業務部\$運用\TESTkanno\"
TName = Left(strSelected, Len(strSelected) - 1)
LsName = LsName & TName & ".csv"
ITName = "T_Mas"

'レコードの追加
teigi = "ＲＧＢ定義"
DoCmd.TransferText acImportDelim, teigi, ITName, LsName, True

SQL = "INSERT INTO T_Mas (ID1,ID,処理状況,請求日,学校識別コード,学校名,学校分類名,メールアドレス,名前,ふりがな,性別,生年月日,職業,高校所在地,高校名,学年,郵便番号,都道府県,区市町村＆町域,番地以下,電話番号,FileName,区分,不備,不備理由,yu,gid,保留,処理済,件数報告日,納品日 )" & _
" SELECT [" & TName & "].[ID1], [" & TName & "].[ID],[" & TName & "].[処理状況], [" & TName & "].[請求日]," & _
" [" & TName & "].[学校識別コード], [" & TName & "].[学校名], [" & TName & "].[学校分類名], [" & TName & "].[メールアドレス]," & _
" [" & TName & "].[名前], [" & TName & "].[ふりがな], [" & TName & "].[性別], [" & TName & "].[生年月日]," & _
" [" & TName & "].[職業], [" & TName & "].[高校所在地], [" & TName & "].[高校名], [" & TName & "].[学年]," & _
" [" & TName & "].[郵便番号], [" & TName & "].[都道府県], [" & TName & "].[区市町村＆町域], [" & TName & "].[番地以下]," & _
" [" & TName & "].[電話番号], [" & TName & "].[FileName], [" & TName & "].[区分], [" & TName & "].[不備], [" & TName & "].[不備理由], [" & TName & "].[yu], [" & TName & "].[gid]," & _
" [" & TName & "].[保留], [" & TName & "].[処理済], [" & TName & "].[件数報告日],[" & TName & "].[納品日], From" & "LsName"
Name1 = TName & ".csv"
Name2 = Left(TName, Len(TName) - 5)

ret = MsgBox(Name1 & "を　FileName、" & Name2 & "を　区分に追加しますか？", vbYesNo + vbQuestion, "インポート確認")

Dim sql1 As String
sql1 = "Update T_Mas SET FileName = '" & Name1 & "',区分 = '" & Name2 & "'" & " WHERE FileName Is Null AND 区分 Is Null"
DoCmd.RunSQL sql1

End Sub

回答No.2

30246kiku

時間があったので、雰囲気作ってみました。
なるべく元の変数名を使うようにしていますが、細かい判別部分は分かってません。
（SQLの文字列がどこで使われているのかもわからなかったので）

雰囲気で見てください。雰囲気で。（検証とかしてません）

一時テーブルへ取り込みUpdate操作後、本テーブルへ追加する方法として
一時テーブルは本テーブルと同じ構造で既に存在していると想定
（DoCmd.TransferText の時にテーブルが新規に作られる？）
ファイル名にドット（ピリオド）が複数あった場合用に InStrRev に変更

Const FolderPath = "\\St1\第２業務部\$運用\TESTkanno"
Const ITName = "T_Mas"
Const TmpITName = "Tmp_Mas"　　' ★ T_Mas 構造と同じ取り込み用一時テーブル名
Const teigi = "ＲＧＢ定義"

Private Sub Form_Load()
　　Dim oFSO As Object
　　Dim oFile As Object
　　Dim sName As String
　　Dim sTmp As String

　　sTmp = ""
　　Set oFSO = CreateObject("Scripting.FileSystemObject")
　　For Each oFile In oFSO.GetFolder(FolderPath).files
　　　　sName = oFile.Name
　　　　If (Right(sName, Len(sName) - InStrRev(sName, ".")) = "csv") Then
　　　　　　sTmp = sTmp & ";" & Left(sName, InStrRev(sName, ".") - 1)
　　　　End If
　　Next
　　If (Len(sTmp) > 0) Then
　　　　sTmp = Mid(sTmp, 2)
　　End If
　　Me.lst_01.RowSource = sTmp
　　Set oFSO = Nothing
End Sub

Private Sub Cmd_01_Click()
　　Dim LsName As String
　　Dim TName As String
　　Dim Name1 As String
　　Dim Name2 As String
　　Dim ret As Variant
　　Dim sSql As String
　　Dim iTmp As Long

　　For Each iTmp In Me.lst_01.ItemsSelected
　　　　TName = Me.lst_01.ItemData(iTmp)
　　　　LsName = FolderPath & "\" & TName & ".csv"

'　　　　一時テーブルへまずは取り込み
　　　　CurrentProject.Connection.Execute "DELETE * FROM " & TmpITName
　　　　DoCmd.TransferText acImportDelim, teigi, TmpITName, LsName, True

　　　　Name1 = TName & ".csv"
　　　　Name2 = Left(TName, Len(TName) - 5)

　　　　ret = MsgBox(Name1 & "を　FileName、" & Name2 & "を　区分に追加しますか？", _
　　　　　　　　　　vbYesNo + vbQuestion, "インポート確認")
　　　　If (ret = vbYes) Then
　　　　　　sSql = "UPDATE " & TmpITName & " SET FileName = '" & Name1 & "',区分 = '" & Name2 & "'"
　　　　　　CurrentProject.Connection.Execute sSql

'　　　　 一時テーブルから正式なテーブルへ (必要なら除外フィールド指定)
　　　　　　sSql = InsertSqlMakeFromTable(ITName, TmpITName)
　　　　　　Debug.Print sSql
　　　　　　If (Len(sSql) > 0) Then
　　　　　　　　CurrentProject.Connection.Execute sSql
　　　　　　End If
　　　　End If
　　Next
End Sub

－－－以下を標準モジュールへ作成－－－

' 追加クエリ作成用ファンクション （条件設定なし）
' sTo : 追加先テーブル名
' sFrom : 追加元テーブル名
' sBase : フィールド名参照テーブル名（省略時 sTo 使用）
' sExclusion : 追加除外フィールド名（オートナンバーなど除外するためのもの）
'　　　　　　 複数指定時は、,カンマ区切り
'
' 戻り値： INSERT INTO で始まるSQL文
'
' ※ ADOX使用のため、参照設定に ADO Ext が必要
'

Public Function InsertSqlMakeFromTable(sTo As String, sFrom As String, _
　　　　　　　　　　　　　　　　Optional sBase As String = "", _
　　　　　　　　　　　　　　　　Optional sExclusion As String = "") As String

　　Dim catdb As New ADOX.Catalog
　　Dim clm As Column
　　Dim sTable As String
　　Dim sToTmp As String
　　Dim sFromTmp As String
　　Dim vTmp As Variant
　　Dim i As Integer
　　Dim bFound As Boolean

　　On Error GoTo ERR_HAND

　　sTable = IIf(Len(sBase) = 0, sTo, sBase)
　　If (Len(sExclusion) > 0) Then
　　　　vTmp = Split(sExclusion, ",")
　　End If

　　sToTmp = ""
　　sFromTmp = ""

　　catdb.ActiveConnection = CurrentProject.Connection

　　For Each clm In catdb.Tables(sTable).Columns
　　　　bFound = False
　　　　If (Not IsEmpty(vTmp)) Then
　　　　　　For i = 0 To UBound(vTmp)
　　　　　　　　If (clm.Name = vTmp(i)) Then
　　　　　　　　　　bFound = True
　　　　　　　　　　Exit For
　　　　　　　　End If
　　　　　　Next
　　　　End If
　　　　If (bFound = False) Then
　　　　　　sToTmp = sToTmp & ", [" & clm.Name & "]"
　　　　　　sFromTmp = sFromTmp & ", [" & sFrom & "].[" & clm.Name & "]"
　　　　End If
　　Next

　　If (Len(sToTmp) > 0) Then
　　　　InsertSqlMakeFromTable = "INSERT INTO " & sTo & " (" & Mid(sToTmp, 3) & ") " & _
　　　　　　　　　　　　　　　　"SELECT " & Mid(sFromTmp, 3) & " FROM " & sFrom & ";"
　　Else
　　　　InsertSqlMakeFromTable = ""
　　End If
　　Exit Function

ERR_HAND:
　　InsertSqlMakeFromTable = ""
End Function

回答No.1

30246kiku

ちょっと見しかできてませんが、

複数選択のものを , カンマ区切りで作っておいて、処理前で配列に。
その配列を使って、テーブル名、ファイルバスを作ればよいのでは。

> Dim strSelected As String

> strSelected = vbNullString

> With lst_01
> For Each varData In .ItemsSelected
> strSelected = strSelected & .ItemData(varData - 1) & " "
> Next
> End With

↓

Dim strSelected As String
Dim vTmp As Variant
Dim SubLsName As String

strSelected = ""

With lst_01
　　For Each varData In .ItemsSelected
　　　　strSelected = strSelected & "," & .ItemData(varData - 1) ' ★
　　Next
End With

vTmp = Split(Mid(strSelected,2),",")

LsName = "\\St1\第２業務部\$運用\TESTkanno\"
ITName = "T_Mas"

For i = 0 To UBound(vTmp)
　　TName = vTmp(i)
　　SubLsName = LsName & TName & ".csv"
　　DoCmd.TransferText acImportDelim, teigi, ITName, SubLsName, True

・・・・・・・

Next

※　★前の処理が正しいとして流用

※　従来の LsName 扱いは、使い回しができないように上書きされています。
LsName = LsName & TName & ".csv"

※　後は細かく見れてません。がんばってください。