'_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/
'                                                                                                              
'                                                                                                              
'                                         レコード条件検索ツール                                               
'                                                                                                              
'                                                                                                              
'_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/

<!--
Option Explicit

Const MDB_PATH = "C:\db1.mdb"

Dim dtmDate
    Dim objADO
    Dim objRS
    Dim strSQL

'_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/
'
'/*初期表示*/
'
'_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/

Sub Init()
'何も無し
End Sub

Sub IptToday()
    dtmDate = Year(Now()) & "-" & Right("0" & Month(Now()),2) & "-" & Right("0" & Day(Now()),2)
    Document.Date.DteInput1.Value = dtmDate
    Document.Date.DteInput2.Value = dtmDate
End Sub

Sub IptYstday()
    dtmDate = Year(Now()-1) & "-" & Right("0" & Month(Now()-1),2) & "-" & Right("0" & Day(Now()-1),2)
    Document.Date.DteInput1.Value = dtmDate
    Document.Date.DteInput2.Value = dtmDate
End Sub

Sub DltDay()
    Document.Date.DteInput1.Value = ""
    Document.Date.DteInput2.Value = ""
End Sub

'_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/
'
'/*検索*/
'
'_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/

Sub SrhStart()

Dim strMES
    Dim resultFlug

resultFlug = False

Set objADO = CreateObject("ADODB.Connection")
            objADO.Open "Driver={Microsoft Access Driver (*.mdb)}; DBQ=" & MDB_PATH & ";"

If Document.JobNo.Job.value = "" Then
        
        'B01条件時の検索
        If CndInput.value="B01" Then
            strSQL = "select * from sheet1 where 陳列コード = 'B01'"

If Document.Date.DteInput1.Value = "" Then
                If Document.Date.DteInput2.Value <> "" Then
                    Msgbox "日付を入力しないと検索できません。"
                    resultFlug = False
                Else
                    Set objRS = objADO.Execute(strSQL)
                    resultFlug = True
                End If
            Else
                If Document.Date.DteInput2.Value <> "" Then
                    Set objRS = objADO.Execute(strSQL&" and レコード更新日 between #" & _
                                Document.Date.DteInput1.value & "# and #" & Document.Date.DteInput2.value &"#")
                    resultFlug = True
                Else
                    Set objRS = objADO.Execute(strSQL&" and レコード更新日 >= #" & Document.Date.DteInput1.value & "#")
                    resultFlug = True
                End If
            End If

'B02条件時の検索
        ElseIf CndInput.value="B02" Then
            strSQL = "select * from sheet1 where 陳列コード = 'B02'"

If Document.Date.DteInput1.Value = "" Then
                If Document.Date.DteInput2.Value <> "" Then
                    Msgbox "日付を入力しないと検索できません。"
                    resultFlug = False
                Else
                    Set objRS = objADO.Execute(strSQL)
                    resultFlug = True
                End If
            Else
                If Document.Date.DteInput2.Value <> "" Then
                    Set objRS = objADO.Execute(strSQL&" and レコード更新日 between #" & _
                                Document.Date.DteInput1.value & "# and #" & Document.Date.DteInput2.value &"#")
                    resultFlug = True
                Else
                    Set objRS = objADO.Execute(strSQL&" and レコード更新日 >= #"&Document.Date.DteInput1.value&"#")
                    resultFlug = True
                End If
            End If

'B03条件時の検索
        ElseIf CndInput.value="B03" Then
            strSQL = "select * from sheet1 where 陳列コード = 'B03'"
            
            If Document.Date.DteInput1.Value = "" Then
                If Document.Date.DteInput2.Value <> "" Then
                    Msgbox "日付を入力しないと検索できません。"
                    resultFlug = False
                Else
                    Msgbox "表示件数が過大になるため検索できません。"
                    resultFlug = False
                End If
            Else
                If Document.Date.DteInput2.Value <> "" Then
                    Set objRS = objADO.Execute(strSQL&" and レコード更新日 between #" & _
                                Document.Date.DteInput1.value & "# and #" & Document.Date.DteInput2.value &"#")
                    resultFlug = True
                Else
                    Set objRS = objADO.Execute(strSQL&" and レコード更新日 >= #"&Document.Date.DteInput1.value &"#")
                    resultFlug = True
                End If
            End If

'来ることは無いはず
        Else
            Msgbox "条件を指定して無いため検索不可能です。"
            resultFlug = False
        End If

'番号のフォームに値が入っている時の検索
    Else
        MsgBox "番号の値のみを条件として検索します。"
        strSQL = "select * from sheet1 where 項目番号 = " & Document.JobNo.Job.value
            msgbox strSQL
            Set objRS = objADO.Execute(strSQL)
            resultFlug = True
    End If

'_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/
'
'レコードの表示を行う
'
'_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/

If resultFlug = True Then
    If Document.JobNo.Job.value = "" Then
        If CndInput.value <> "B03" Then
            strMES = strMES & "<table id='strData' border='1' cellspacing='0'><tr>" & _
                              "<td class='c1' style='background:lightblue' align=center><b>A</b></td>" & _
                              "<td class='c2' style='background:lightblue' align=center><b>B</b></td>" & _
                              "<td class='c2' style='background:lightblue' align=center><b>C</b></td>" & _
                              "<td class='c2' style='background:lightblue' align=center><b>D</b></td>" & _
                              "<td class='c2' style='background:lightblue' align=center><b>E</b></td>" & _
                              "<td class='c2' style='background:lightblue' align=center><b>F</b></td>" & _
                              "<td class='c2' style='background:lightblue' align=center><b>G</b></td>" & _
                              "<td class='c2' style='background:lightblue' align=center><b>H</b></td>" & _
                              "<td class='c2' style='background:lightblue' align=center><b>I</b></td>" & _
                              "<td class='c2' style='background:lightblue' align=center><b>J</b></td>" & _
                              "<td class='c2' style='background:lightblue' align=center><b>K</b></td></tr>"
                Do
                    If objRS.Eof Then Exit Do
                        strMES = strMES &"<tr>"& _
                                 "<td class='c1' align=center><input type='checkbox'>" & _
                                 "</td>" & _
                                 "<td class='c2' align=center>" & objRS(2) & "</td>" & _
                                 "<td class='c2' align=center>" & objRS(3) & "</td>" & _
                                 "<td class='c2' align=center>" & objRS(4) & "</td>" & _
                                 "<td class='c2' align=center>" & objRS(6) & "</td>" & _
                                 "<td class='c2' align=center>" & objRS(7) & "</td>" & _
                                 "<td class='c2' align=center>" & objRS(10) & "</td>" & _
                                 "<td class='c2' align=center>" & objRS(28) & "</td>" & _
                                 "<td class='c2' align=center>" & objRS(29) & "</td>" & _
                                 "<td class='c2' align=center>" & objRS(30) & "</td>" & _
                                 "<td class='c2' align=center>" & objRS(31) & "</td></tr>"
                        objRS.MoveNext
                Loop
            strMES = strMES & "</table>"
            objRS.Close
        Else
            strMES = strMES & "<table border=""1"" cellspacing=""0"">" & _
                              "<td style=""background:lightblue""><b><div style=""text-align:center"">A</b></div></td>" & _
                              "<td style=""background:lightblue""><b><div style=""text-align:center"">B</b></div></td>" & _
                              "<td style=""background:lightblue""><b><div style=""text-align:center"">C</b></div></td>" & _
                              "<td style=""background:lightblue""><b><div style=""text-align:center"">D</b></div></td>" & _
                              "<td style=""background:lightblue""><b><div style=""text-align:center"">E</b></div></td>" & _
                              "<td style=""background:lightblue""><b><div style=""text-align:center"">F</b></div></td>" & _
                              "<td style=""background:lightblue""><b><div style=""text-align:center"">G</b></div></td>" & _
                              "<td style=""background:lightblue""><b><div style=""text-align:center"">H</b></div></td>" & _
                              "<td style=""background:lightblue""><b><div style=""text-align:center"">I</b></div></td>" & _
                              "<td style=""background:lightblue""><b><div style=""text-align:center"">J</b></div></td>"

Do
                    If objRS.Eof Then Exit Do
                        strMES = strMES &"<tr>"& _
                                 "<td><div style=""text-align:center"">" & objRS(2) & "</div></td>" & _
                                 "<td><div style=""text-align:center"">" & objRS(3) & "</div></td>" & _
                                 "<td>" & objRS(4) & "</td>" & _
                                 "<td>" & objRS(6) & "</td>" & _
                                 "<td>" & objRS(7) & "</td>" & _
                                 "<td>" & objRS(10) & "</td>" & _
                                 "<td>" & objRS(28) & "</td>" & _
                                 "<td>" & objRS(29) & "</td>" & _
                                 "<td>" & objRS(30) & "</td>" & _
                                 "<td>" & objRS(31) & "</td></tr>"
                        objRS.MoveNext
                Loop
            strMES = strMES & "</table>"
            objRS.Close
        End If
    Else
            strMES = strMES & "<table border=""1"" cellspacing=""0"">" & _
                              "<td style=""background:lightblue""><b><div style=""text-align:center"">A</b></div></td>" & _
                              "<td style=""background:lightblue""><b><div style=""text-align:center"">B</b></div></td>" & _
                              "<td style=""background:lightblue""><b><div style=""text-align:center"">C</b></div></td>" & _
                              "<td style=""background:lightblue""><b><div style=""text-align:center"">D</b></div></td>" & _
                              "<td style=""background:lightblue""><b><div style=""text-align:center"">E</b></div></td>" & _
                              "<td style=""background:lightblue""><b><div style=""text-align:center"">F</b></div></td>" & _
                              "<td style=""background:lightblue""><b><div style=""text-align:center"">G</b></div></td>" & _
                              "<td style=""background:lightblue""><b><div style=""text-align:center"">H</b></div></td>" & _
                              "<td style=""background:lightblue""><b><div style=""text-align:center"">I</b></div></td>"

End If
Else
    strMES = strMES & "<table border=""1"" cellspacing=""0"">" & _
             "<tr><td style=""background:red""><b>【条件】・【日付】を正しく指定して検索してください。</b></td></table>"
End If
        document.all.Result.innerHTML = strMES
        objADO.Close
        Set objRS = Nothing
        Set objADO = Nothing

End Sub

'_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/
'
'/*転記*/'データを書き込みためにExcelを起動
'
'_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/

Sub PstStart()

On Error Resume Next

Const xlUP = -4162

Dim objExcelPath
    Dim i
    Dim objExcelBook
    Dim g_objExcelApp
    Dim objExcelApp

Dim strTR
    Dim strTDs
    Dim strCheckBox
    Dim strWHERE

Dim objExcelSheet
    Dim RowNo

Dim idxRow
    Dim idxCol

objExcelPath = "D:\レコード書き込みテスト.xls"
            'Excelを開く（2重起動回避）
            Set g_objExcelApp = GetObject(,"Excel.Application")
                If Err Then
                    Set objExcelApp = CreateObject("Excel.Application")
                        objExcelApp.Visible = True
                        objExcelApp.WorkBooks.Open (objExcelPath)
                ElseIf g_objExcelApp.Workbooks.Count Then
                    For Each i In g_objExcelApp.Workbooks
                        If i.FullName = objExcelPath Then
                            MsgBox objExcelPath & "が開いているので書き込めません。" & vbCrLf & vbCrLf & _
                                                "保存して終了してください。", vbCritical, "警告"
                            Exit Sub
                        End If
                    Next
                Else
                    MsgBox "Excelは起動していますが" & objExcelPath & "を開いてないので開きます。"
                    Set objExcelApp = CreateObject("Excel.Application")
                        objExcelApp.Visible = True
                        objExcelApp.WorkBooks.Open (objExcelPath)
                End If

'Excel転記用にデータを索引

Set objADO = CreateObject("ADODB.Connection")
            objADO.Open "Driver={Microsoft Access Driver (*.mdb)}; DBQ=" & MDB_PATH & ";"

strSQL = "select ID, " & _
                            "商品コード, " & _
                            "陳列コード, " & _
                            "商品名, " & _
                            "入荷日, " & _
                            "分類, " & _
                            "棚番, " & _
                            "値段,  " & _
                            "レコード更新日4,  " & _
                            "レコード更新時間4,  " & _
                            "レコード更新日5,  " & _
                            "レコード更新時間5  " & _
                            "from sheet1 where "

For Each strTR In document.getElementByID("strData").getElementsByTagName("TR")
                Set strTDs = strTR.getElementsByTagName("TD")
                For Each strCheckBox In strTDs(0).getElementsByTagName("INPUT")
                    If strCheckBox.Checked = True Then
                        If strTDs(2).innerText = "B01" Then
                            strWHERE = strWHERE & "(商品コード = '" & strTDs(1).innerText & "' and 陳列コード = 'B01') or "
                        ElseIf strTDs(2).innerText = "B02" Then
                            strWHERE = strWHERE & "(商品コード = '" & strTDs(1).innerText & "' and 陳列コード = 'B02') or "
                        End If
                    End If
                    Exit For
                Next
            Next

strWHERE = Left(strWHERE, Len(strWHERE) - 4)
            strSQL = strSQL & strWHERE
            Set objRS = objADO.Execute(strSQL)
            'msgbox strSQL
'_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/
'
'Excel転記を行う
'
'_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/

Set objExcelBook  = objExcelApp.Application.Workbooks(1)
            Set objExcelSheet = objExcelBook.WorkSheets("1nosheet")

RowNo = objExcelSheet.Range("J65536").End(xlUP).Row

idxRow = 0 + RowNo
            idxCol = 0

Do
                    If objRS.Eof Then Exit Do
                        idxRow = idxRow + 1

For idxCol = 0 To objRS.Fields.Count - 1
                        objExcelSheet.Cells(idxRow, idxCol + 10) = objRS(idxCol)
                    Next
                    objRS.MoveNext
                Loop

objRS.Close
            objADO.Close

Set g_objExcelApp = Nothing
            Set objExcelApp = Nothing
            Set strTDs = Nothing
            Set objExcelBook  = Nothing
            Set objExcelSheet = Nothing

objRS.Close
            objADO.Close

Set objRS = Nothing
            Set objADO = Nothing

'_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/
'
'もし案件作成が必要な場合
'
'_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/

If Document.ifl.idfile.Checked = True Then
                Dim objFSO
                Dim strNewName
                Dim objWShell
                Dim str4
                Dim dtPath
                Dim fdPath

objExcelPath = "D:\TEST\案件.xls"
                    'Excelを開く（2重起動回避）
                    Set g_objExcelApp = GetObject(,"Excel.Application")
                        If Err Then
                            Set objExcelApp = CreateObject("Excel.Application")
                                objExcelApp.Visible = True
                                objExcelApp.WorkBooks.Open (objExcelPath)
                        ElseIf g_objExcelApp.Workbooks.Count Then
                            For Each i In g_objExcelApp.Workbooks
                                If i.FullName = objExcelPath Then
                                    MsgBox objExcelPath & "が開いているので書き込めません。" & vbCrLf & vbCrLf & _
                                                        "保存して終了してください。", vbCritical, "警告"
                                    Exit Sub
                                End If
                            Next
                        Else
                            MsgBox "Excelは起動していますが" & objExcelPath & "を開いてないので開きます。"
                            Set objExcelApp = CreateObject("Excel.Application")
                                objExcelApp.Visible = True
                                objExcelApp.WorkBooks.Open (objExcelPath)
                        End If

Set objExcelBook  = objExcelApp.Application.Workbooks(1)
                    Set objExcelSheet = objExcelBook.WorkSheets("Sheet1")

RowNo = objExcelSheet.Range("C65536").End(xlUP).Row

Set objFSO = CreateObject("Scripting.FileSystemObject")
                    
                    For Each strTR In document.getElementByID("strData").getElementsByTagName("TR")
                        Set strTDs = strTR.getElementsByTagName("TD")
                        For Each strCheckBox In strTDs(0).getElementsByTagName("INPUT")
                            If strCheckBox.Checked = True Then
                                str4 = Replace(strTDs(4).innerText, "/", "")
                                Msgbox strTDs(3)
                                strNewName = "#" & _
                                             objExcelSheet.Cells(RowNo + 1, 2).Value & _
                                             "_●○●○ー(" & strTDs(3) & ")"
                            End If
                            Exit For
                        Next
                    Next

'もし、フォルダが存在しない場合は作成する

Set objWShell = CreateObject("WScript.Shell")
                    fdPath = objWShell.SpecialFolders("Desktop") & "\" & strNewName
                    
                    If Not objFSO.FolderExists(fdPath) Then
                        On Error Resume Next
                        objFSO.CreateFolder fdPath
                        If Err.Number = 0 Then
                            MsgBox _
                            objFSO.GetAbsolutePathName(fdPath) & vbCrLf & _
                            "を作成しました。"
                        Else
                            MsgBox _
                            objFSO.GetAbsolutePathName(fdPath) & vbCrLf & _
                            "の作成に失敗しました。" & _
                            vbCrLf & Err.Number & ": " & Err.Description
                        End If
                        On Error Goto 0

'もしフォルダが存在する場合は何もしない
                    Else
                        MsgBox "すでに" & vbCrLf & _
                        objFSO.GetAbsolutePathName(fdPath) & vbCrLf & _
                        "が存在します。"
                    End If

Set objFSO = Nothing
                Set objWShell = CreateObject("WScript.Shell")
                    objWShell.Run "D:\TEST"
                Set objWShell = Nothing

End If

End Sub

'_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/
'
'/*画面検索結果消去*/
'
'_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/

Sub DltStart()

document.all.Result.innerHTML = ""
    CndInput.selectedIndex = 0

End Sub
-->

'_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/
'
'HTAの構成要素
'
'_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/

</script>
<html>
<head>
<title>レコード条件検索ツール</title>
<script Language="VBScript">

</script>
<style type="text/css">

</style>
<link rel="canonical" href="http://www10.atpages.jp/chiechie/RS.html" />
<link rel="alternate" media="handheld" href="http://www10.atpages.jp/_/mgw/gw?_ucb_u=http%3A%2F%2Fwww10.atpages.jp%2Fchiechie%2FRS.html" type="text/html" />
</head>
<body><script type="text/javascript">
                   
                   </script><div align="center" style="text-align:center; display:block !important;
visibility:visible !important;">
<script type='text/javascript'></script><noscript><a href='http://d.href.asia/nw/d/ck.php?n=ac276855&cb=01079685146' target='_blank'><img src='http://d.href.asia/nw/d/avw.php?zoneid=1145&cb=01079685146&n=ac276855' border='0' alt='' /></a></noscript>
</div>

<table class="input">
<tr>
<td class="toolbar"><font size="-1">
【条件】
<select name="CndInput" size="1" style="width:115px">
<option value="B01">B01</option>
<option value="B02">B02</option>
<option value="B03">B03</option>
</select>
<form name="JobNo" style="margin: 0px;">
【番号】 <input type="text" name="Job" value="">
</form>
<form name="date" style="margin: 0px;">
【日付】
<input type="text" name="DteInput1" value="">    ～  
<input type="text" name="DteInput2" value="">  
<input type="button" name="go" value="今日" onclick="IptToday()">
<input type="button" name="go" value="昨日" onclick="Iptystday()">
<input type="button" name="go" value="日付を消去" onclick="DltDay()">
</form>
<br>
<form name="ifl" style="margin: 0px;">
          
<input type="button" name="go" value="検索" onclick="SrhStart()">   
<input type="button" name="go" value="転記" onclick="PstStart()">   
<input type="button" name="go" value="消去" onclick="DltStart()"></font>
<font size="-2">    
<input type="checkbox" name="idfile">転記と同時に案件作成</font></form>
</td>
</tr>
</table>
<br>
結果表示<br>
<pre id="Result"></pre>

</body>
</html>