Formに検索結果が表示されない

Question

Access2003で使用していたツールを365（内部的には恐らく2016）の環境に移して実行した時、

form画面にSQLでデータベースから抽出した情報が反映されませんでした。

デバッグして生成されたSQLをデータベースに流して

目的のレコードが抽出できるのは確認したのでFormに

セットするところで失敗しているように思いますが

2003と2010以降のAccessで何か違うのでしょうか？

ご存知の方がいらっしゃったらご教示いただけますと幸いです。

ちなみに試したAccessのバージョンは2010と365です。

2003は32bitで2010と365は64bitです。

Public Function fnDataSearch(lonRetErr As LongLong, _

                                  strErrMsg As String, _

                                  RetSearchCondition As SearchConditionRec_Type) As Boolean

    Dim rs               As ADODB.Recordset

    Dim intLoop          As Integer

    Dim strSQL           As String

    On Error GoTo fnDataSearch_Err

    Set rs = New ADODB.Recordset        'SMILEﾚｺｰﾄﾞｾｯﾄ

    fnDataSearch = False

    '/**************************************************/

    '/**　    トランザクション開始

    '/**************************************************/

    strSQL = "SELECT"

    strSQL = strSQL & Space(1) & "*"

    strSQL = strSQL & Space(1) & "FROM"

    strSQL = strSQL & Space(1) & "("

        strSQL = strSQL & Space(1) & "SELECT"

'        strSQL = strSQL & Space(1) & "'0'" & " AS ﾌﾗｸﾞ" & ","

        strSQL = strSQL & Space(1) & "HANR004002" & " AS 得意先ｺｰﾄﾞ" & ","

        strSQL = strSQL & Space(1) & "HAN07M001TOKUI.HANM001006" & " AS 得意先" & ","

        strSQL = strSQL & Space(1) & "HANR004003" & " AS 受注日付" & ","

        strSQL = strSQL & Space(1) & "HANR004004" & " AS 受注区分" & ","

        strSQL = strSQL & Space(1) & "HANR004005" & " AS 受注No" & ","

        strSQL = strSQL & Space(1) & "HANR004TI002" & " AS 施設ｺｰﾄﾞ" & ","

        strSQL = strSQL & Space(1) & "HANR004015" & " AS 出荷予定日" & ","

        strSQL = strSQL & Space(1) & "HANR004TI004" & " AS 返却予定日" & ","

        strSQL = strSQL & Space(1) & "HANR004TI005" & " AS 手術予定日" & ","

        strSQL = strSQL & Space(1) & "HANTIMA01SHISETSU.HANMA01TI003" & " AS 施設名" & ","

        strSQL = strSQL & Space(1) & "HAN07R030KAKUCHO.HANR030008" & " AS 送付先ｺｰﾄﾞ" & ","

        strSQL = strSQL & Space(1) & "HAN07R030KAKUCHO.HANR030009" & " AS 送付先名1" & ","

        strSQL = strSQL & Space(1) & "HAN07R030KAKUCHO.HANR030010" & " AS 送付先名2" & ","

        strSQL = strSQL & Space(1) & "HAN07R030KAKUCHO.HANR030011" & " AS 郵便番号" & ","

        strSQL = strSQL & Space(1) & "HAN07R030KAKUCHO.HANR030012" & " AS 住所1" & ","

        strSQL = strSQL & Space(1) & "HAN07R030KAKUCHO.HANR030013" & " AS 住所2" & ","

        strSQL = strSQL & Space(1) & "HAN07R030KAKUCHO.HANR030014" & " AS 住所3" & ","

        strSQL = strSQL & Space(1) & "HAN07R030KAKUCHO.HANR030015" & " AS TEL" & ","

        strSQL = strSQL & Space(1) & "HAN07R030KAKUCHO.HANR030016" & " AS ﾃﾞｨｰﾗｰ担当" & ","

        strSQL = strSQL & Space(1) & "HAN07R030KAKUCHO.HANR030023" & " AS 手術日" & ","

        '/************************************************

        strSQL = strSQL & Space(1) & "HAN07R030KAKUCHO.HANR030007" & " AS 送付先区分" & ","

        strSQL = strSQL & Space(1) & "HAN07R030KAKUCHO.HANR030024" & " AS ｼｽﾃﾑｺｰﾄﾞ" & ","

        strSQL = strSQL & Space(1) & "HAN07M003SHOHIN.HANM003002" & " AS ｼｽﾃﾑ名" & ","

        strSQL = strSQL & Space(1) & "HAN07M001TOKUI.HANM001004" & " AS 得意先名1" & ","

        strSQL = strSQL & Space(1) & "HAN07M001TOKUI.HANM001005" & " AS 得意先名2" & ","

        strSQL = strSQL & Space(1) & "HAN07M001TOKUI.HANM001012" & " AS 得意先_TEL" & ","

        strSQL = strSQL & Space(1) & "HAN07M001TOKUI.HANM001013" & " AS 得意先_FAX" & ","

        '/*** 【追加】　送付先ｺｰﾄﾞより得意先情報取得

        '/***　　　　　 FAX番号をﾏｽﾀｰより取得して頂きたい(CS野口依頼)

        strSQL = strSQL & Space(1) & "DESTINATIONInfo.HANM001004" & " AS 送付先_得意先名1" & ","

        strSQL = strSQL & Space(1) & "DESTINATIONInfo.HANM001005" & " AS 送付先_得意先名2" & ","

        strSQL = strSQL & Space(1) & "DESTINATIONInfo.HANM001013" & " AS 送付先_得意先_FAX"   

        strSQL = strSQL & Space(1) & "FROM"

        strSQL = strSQL & Space(1) & "HAN07R030KAKUCHO"

        strSQL = strSQL & Space(1) & "INNER JOIN"

        strSQL = strSQL & Space(1) & "HAN07R004JUHACHUH ON HAN07R030KAKUCHO.HANR030004 = HAN07R004JUHACHUH.HANR004005"

        strSQL = strSQL & Space(1) & "LEFT OUTER JOIN"

        strSQL = strSQL & Space(1) & "HAN07M003SHOHIN ON HAN07R030KAKUCHO.HANR030024 = HAN07M003SHOHIN.HANM003001"

        strSQL = strSQL & Space(1) & "LEFT OUTER JOIN"

        strSQL = strSQL & Space(1) & "HAN07M001TOKUI ON HAN07R004JUHACHUH.HANR004002 = HAN07M001TOKUI.HANM001003"

        strSQL = strSQL & Space(1) & "LEFT OUTER JOIN"

        strSQL = strSQL & Space(1) & "HANTIMA01SHISETSU ON HAN07R004JUHACHUH.HANR004TI002 = HANTIMA01SHISETSU.HANMA01TI001"

        strSQL = strSQL & Space(1) & "LEFT OUTER JOIN"

        strSQL = strSQL & Space(1) & "HAN07M001TOKUI DESTINATIONInfo ON HAN07R030KAKUCHO.HANR030008 = DESTINATIONInfo.HANM001003"

        strSQL = strSQL & Space(1) & "WHERE"

        strSQL = strSQL & Space(1) & "HAN07R004JUHACHUH.HANR004004 = 2 And HAN07R030KAKUCHO.HANR030001 = 2 And HAN07R030KAKUCHO.HANR030002 = 2 And HAN07R030KAKUCHO.HANR030003 = 0 And HAN07R030KAKUCHO.HANR030005 = 0"

        strSQL = strSQL & Space(1) & ") OKURIDATA_TBL"

    strSQL = strSQL & Space(1) & "WHERE"

    strSQL = strSQL & Space(1) & "受注日付>=" & "'" & RetSearchCondition.strSDate & "'"

    strSQL = strSQL & Space(1) & "AND"

    strSQL = strSQL & Space(1) & "受注日付<=" & "'" & RetSearchCondition.strEDate & "'"

    strSQL = strSQL & Space(1) & "AND"

    strSQL = strSQL & Space(1) & "("

    strSQL = strSQL & Space(1) & "出荷予定日>=" & "'" & RetSearchCondition.strSShipDate & "'"

    strSQL = strSQL & Space(1) & "AND"

    strSQL = strSQL & Space(1) & "出荷予定日<=" & "'" & RetSearchCondition.strEShipDate & "'"

    strSQL = strSQL & Space(1) & ")"   

    '送付先住所

    If Trim(RetSearchCondition.strShippingAdd) <> "" Then

        strSQL = strSQL & Space(1) & "AND"

        strSQL = strSQL & Space(1) & "("

        strSQL = strSQL & Space(1) & "住所1 LIKE " & "'%" & RetSearchCondition.strShippingAdd & "%'"

        strSQL = strSQL & Space(1) & "OR"

        strSQL = strSQL & Space(1) & "住所2 LIKE " & "'%" & RetSearchCondition.strShippingAdd & "%'"

        strSQL = strSQL & Space(1) & "OR"

        strSQL = strSQL & Space(1) & "住所3 LIKE " & "'%" & RetSearchCondition.strShippingAdd & "%'"

        strSQL = strSQL & Space(1) & ")"

    End If

    '送付先

    If Trim(RetSearchCondition.strShipping) <> "" Then

        strSQL = strSQL & Space(1) & "AND"

        strSQL = strSQL & Space(1) & "("

        strSQL = strSQL & Space(1) & "送付先名1 LIKE " & "'%" & RetSearchCondition.strShipping & "%'"

        strSQL = strSQL & Space(1) & "OR"

        strSQL = strSQL & Space(1) & "送付先名2 LIKE " & "'%" & RetSearchCondition.strShipping & "%'"

        strSQL = strSQL & Space(1) & ")"

    End If

    '得意先

    If Trim(RetSearchCondition.strtDealer) <> "" Then

        strSQL = strSQL & Space(1) & "AND"

        strSQL = strSQL & Space(1) & "("

        strSQL = strSQL & Space(1) & "得意先 LIKE " & "'%" & RetSearchCondition.strtDealer & "%'"

        strSQL = strSQL & Space(1) & ")"

    End If

    '施設名

    If Trim(RetSearchCondition.strHospital) <> "" Then

        strSQL = strSQL & Space(1) & "AND"

        strSQL = strSQL & Space(1) & "("

        strSQL = strSQL & Space(1) & "施設名 LIKE " & "'%" & RetSearchCondition.strHospital & "%'"

        strSQL = strSQL & Space(1) & ")"

    End If

    '伝票No

    If Trim(RetSearchCondition.strNo) <> "" Then

        strSQL = strSQL & Space(1) & "AND"

        strSQL = strSQL & Space(1) & "("

        strSQL = strSQL & Space(1) & "受注No=" & "'" & RetSearchCondition.strNo & "'"

        strSQL = strSQL & Space(1) & ")"

    End If

    strSQL = strSQL & Space(1) & "ORDER BY"

    strSQL = strSQL & Space(1) & "受注日付" & ","

    strSQL = strSQL & Space(1) & "受注No"

    'ﾃﾞｰﾀ読込

    rs.Open strSQL, AdoCn, adOpenStatic, adLockReadOnly

ここでセットに失敗していると思われる

    Set Forms("F_SMILE送り状出力").F_SMILE送付先一覧サブフォーム.Form.Recordset = rs.Clone

    On Error Resume Next

       rs.Close

       Set rs = Nothing

    On Error GoTo 0

    'AdoCn.RollbackTrans

    fnDataSearch = True

    strErrMsg = ""

fnDataSearch_resume:  

    Exit Function  

fnDataSearch_Err:  

    lonRetErr = Err.Number

    strErrMsg = Err.Description

    Err.Clear

    GoTo fnDataSearch_resume  

End Function

ちなみにフォームのコードは以下です。

メイン

Option Compare Database

Option Explicit

Private Const m_ReportView = AcView.acViewNormal

Private Sub cmdSearch_Click()

    Dim rs               As ADODB.Recordset

'    Dim lonRetErr As Long

    Dim lonRetErr As LongLong

    Dim strErrMsg As String

    Dim strSDate As String

    Dim strEDate As String

    Dim strSShipDate As String

    Dim strEShipDate As String

    '/*************************************/

    '/***          入力ﾁｪｯｸ             ***/

    '/*************************************/

    '受注日付開始日

    If IsNull(Me.txtS_Date.Value) = True Then

        strSDate = "00000000"

    Else

        strSDate = Replace$(txtS_Date.Value, "/", "")

    End If

    '受注日付終了日

    If IsNull(txtE_Date.Value) = True Then

        strEDate = "99999999"

    Else

        strEDate = Replace$(txtE_Date.Value, "/", "")

    End If

    If strSDate > strEDate Then

        MsgBox "指定日付に誤りがあります", vbCritical, "入力ﾁｪｯｸ"

        txtE_Date.SetFocus

        Exit Sub

    End If

    '貸出日付開始日

    If IsNull(Me.txtS_ShipDate.Value) = True Then

        strSShipDate = "00000000"

    Else

        If Trim(txtS_ShipDate.Value) = "" Then

            strSShipDate = "00000000"

        Else

            strSShipDate = Replace$(txtS_ShipDate.Value, "/", "")

        End If

    End If

    '貸出日付終了日

    If IsNull(txtE_ShipDate.Value) = True Then

        strEShipDate = "99999999"

    Else

        If Trim(txtE_ShipDate.Value) = "" Then

            strEShipDate = "99999999"

        Else

            strEShipDate = Replace$(txtE_ShipDate.Value, "/", "")

        End If

    End If

    If strSShipDate > strEShipDate Then

        MsgBox "指定日付に誤りがあります", vbCritical, "入力ﾁｪｯｸ"

        txtE_ShipDate.SetFocus

        Exit Sub

    End If 

    With SearchConditionRec

        .strSDate = strSDate

        .strEDate = strEDate

        .strSShipDate = strSShipDate

        .strEShipDate = strEShipDate

        '/** 受注No

        If IsNull(txtNo.Value) = True Then

            .strNo = ""

        Else

            .strNo = Trim(txtNo.Value)

        End If

        '/** 送付先

        If IsNull(txtShipping.Value) = True Then

            .strShipping = ""

        Else

            .strShipping = Trim(txtShipping.Value)

        End If

        '/** 送付先住所

        If IsNull(txtShippingAdd.Value) = True Then

            .strShippingAdd = ""

        Else

            .strShippingAdd = Trim(txtShippingAdd.Value)

        End If

        '/** ﾃﾞｨｰﾗｰ

        If IsNull(txtDealer.Value) = True Then

            .strtDealer = ""

        Else

            .strtDealer = Trim(txtDealer.Value)

        End If

        '/** 病院

        If IsNull(txtHospital.Value) = True Then

            .strHospital = ""

        Else

            .strHospital = Trim(txtHospital.Value)

        End If

    End With

    Forms("F_SMILE送り状出力").F_SMILE送付先一覧サブフォーム.Form.Visible = False

    DoEvents

    '***　情報検索ﾃﾞｰﾀ　***/

    If fnDataSearch(lonRetErr, _

                    strErrMsg, _

                    SearchConditionRec) = False Then

        MsgBox strErrMsg, vbCritical

    End If

    Forms("F_SMILE送り状出力").F_SMILE送付先一覧サブフォーム.Form.Visible = True

    With Forms("F_SMILE送り状出力").F_SMILE送付先一覧サブフォーム.Form

        .txtChkList.Value = ""

    End With

End Sub

サブ

Option Compare Database

Option Explicit

Private Sub cmdChk_Click()

    On Error Resume Next

        If Me.chk1 Then

            Me.txtChkList = Replace(Me.txtChkList & ",", "," & Me.受注No & ",", ",")

            Me.txtChkList = Left(Me.txtChkList, Len(Me.txtChkList) - 1)

        Else

            Me.txtChkList = Me.txtChkList & "," & Me.受注No

        End If

    On Error GoTo 0

End Sub

Answer 1

> Access2003で使用していたツール

ファイル形式は mdb ファイルのままなのでしょうか。

> rs.Open strSQL, AdoCn, adOpenStatic, adLockReadOnly

AdoCn への Connection オブジェクトの参照渡しは

どのようにされているのでしょうか。

また、VBA プロジェクトのライブラリ参照設定において、

どのバージョンの ADO ライブラリを追加されているのでしょうか。

Answer 2

>Open メソッドが実行された直後において、

>rs の EOF プロパティは False を返している、

>ということでしょうか。

確認しました。

EOF プロパティは False でした。

Answer 3

> ・実行時エラーは発生しないが、[F_SMILE送付先一覧サブフォーム]に

> 　1 件もレコードが表示されない。

>

> に該当します。

> rs.Open strSQL, AdoCn, adOpenStatic, adLockReadOnly

> rs.Cloneにデータがセットされるところまでは確認しています。

Open メソッドが実行された直後において、

rs の EOF プロパティは False を返している、

ということでしょうか。

Answer 4

返信ありがとうございます。

・実行時エラーは発生しないが、[F_SMILE送付先一覧サブフォーム]に

　1 件もレコードが表示されない。

に該当します。

rs.Cloneにデータがセットされるところまでは確認しています。

もしかしたらサブフォームに問題があるのかもしれません。

Answer 5

> Access2003で使用していたツールを365（内部的には恐らく2016）の環境に移して実行した時、

> form画面にSQLでデータベースから抽出した情報が反映されませんでした。

> Set Forms("F_SMILE送り状出力").F_SMILE送付先一覧サブフォーム.Form.Recordset = rs.Clone

・上記のステートメントを実行しようとした時点で

　何らかの実行時エラーが発生している。

・実行時エラーは発生しないが、[F_SMILE送付先一覧サブフォーム]に

　1 件もレコードが表示されない。

・実行時エラーは発生しないが、メインフォームで指定した抽出条件と

　[F_SMILE送付先一覧サブフォーム]に表示されるレコードの条件が

　合致していない。

・上記以外の状況。

以上のどれに該当しているのかを明記されることを

お奨めします。