文字検索フォーム
Option Compare Database
Option Explicit
Public Function ExtractNumber(ByRef Text As String, ByVal index As Long) As Double
'数字だけを抜き出す関数
Dim re As Object
Dim matches As Object
If re Is Nothing Then
Set re = CreateObject("VBScript.RegExp")
re.Global = True
re.Pattern = "(\d+(?:,\d+)*(?:\.\d+)?)"
End If
Set matches = re.Execute(StrConv(Text, vbNarrow))
ExtractNumber = CDbl(matches(index).Value)
End Function
Private Sub btn_メーカー_Click()
chk_含む1 = True cmb_検索対象フィールド1 = "ﾒｰｶｰ" cmb_含む1.SetFocus
End Sub
Private Sub btn_JAN_Click()
chk_含む1 = True cmb_検索対象フィールド1 = "JAN" cmb_含む1.SetFocus
End Sub
Private Sub btn_型番_Click()
chk_含む1 = True cmb_検索対象フィールド1 = "型番" cmb_含む1.SetFocus
End Sub
Private Sub btn_検索_Click()
chk_含む1 = True cmb_検索対象フィールド1 = "検索" cmb_含む1.SetFocus
End Sub
Private Sub btn_特徴_Click()
chk_含む1 = True cmb_検索対象フィールド1 = "特徴" cmb_含む1.SetFocus
End Sub
Private Sub btn_写真_Click()
chk_含む1 = True cmb_検索対象フィールド1 = "写真" cmb_含む1.SetFocus
End Sub
Private Sub btn_商品_Click()
chk_含む1 = True cmb_検索対象フィールド1 = "商品" cmb_含む1.SetFocus
End Sub
Private Sub cmb_含む1_AfterUpdate()
Dim split_a As Variant
'Accessでの改行コードがあった場合は削除(=空文字に置換)
If InStr(Me![cmb_含む1], vbCrLf) Then
'MsgBox "使用禁止のため、改行は削除されます。", vbExclamation, "確認"
'Me![cmb_含む1] = Replace(Me![cmb_含む1], vbCrLf, "")
split_a = Split(Me![cmb_含む1], vbCrLf)
Me![cmb_含む1] = split_a(0)
End If
End Sub
Private Sub Form_Activate()
DoCmd.Restore cmb_含む1.SetFocus
End Sub
Private Sub chk_含む1_Click()
cmb_含む1.SetFocus
End Sub
Private Sub cmb_含む1_GotFocus()
chk_含む1.Value = True
End Sub
Private Sub cmb_検索対象フィールド1_AfterUpdate()
cmb_含む1.SetFocus
End Sub
Private Sub cmb_検索対象フィールド2_AfterUpdate()
cmb_含む2.SetFocus
End Sub
Sub Form_KeyDown(KeyCode As Integer, Shift As Integer)
If KeyCode = vbKeyEscape Then
'KeyCode = 0
Me.Visible = False
cmb_含む1.SetFocus
End If
End Sub
Private Sub Form_Open(Cancel As Integer)
cmb_含む1.SetFocus
End Sub
Private Sub btn_ロゴ_Click()
chk_含む1 = True cmb_検索対象フィールド1 = "ロゴ" cmb_含む1.SetFocus
End Sub
Private Sub フィルタ実行ボタン_Click()
'On Error GoTo err1:
Dim strKataban As String Dim varKataban As Variant Dim intKataban As Integer Dim strShohin As String Dim varShohin As Variant Dim intShohin As Integer Dim i As Integer Dim strKensaku As String Dim varKensaku As Variant Dim strField As String
If chk_含む1 = True And IsNull(Me![cmb_含む1].RowSource) Then
Me![cmb_含む1].RowSource = Me![cmb_含む1].Value
ElseIf chk_含む1 = True And Not IsNull(Me![cmb_含む1].RowSource) Then
Me![cmb_含む1].RowSource = Me![cmb_含む1].Value & ";" & Me![cmb_含む1].RowSource
End If
strField = Me![cmb_検索対象フィールド1]
'｢cmb_検索対象フィールド1｣が｢検索｣だったら-をトル
If Me![cmb_検索対象フィールド1] = "検索" Then
strKataban = Replace(Me![cmb_含む1], "-", "")
strKataban = Replace(strKataban, "/", "")
strKataban = Replace(strKataban, "･", "")
strKataban = Replace(strKataban, "~", "")
strKataban = Replace(strKataban, "!", "")
strKataban = Replace(strKataban, "+", "")
strKataban = Replace(strKataban, "*", "")
strKataban = Replace(strKataban, "×", "")
strKataban = Replace(strKataban, "～", "")
strKataban = Replace(strKataban, "＃", "")
strKataban = Replace(strKataban, "＆", "")
strKataban = Replace(strKataban, "！", "")
strKataban = Replace(strKataban, "（", "")
strKataban = Replace(strKataban, "）", "")
strKataban = Replace(strKataban, "’", "")
strKataban = Replace(strKataban, "：", "")
Else
strKataban = Me![cmb_含む1]
End If
'数字11～13桁だったらstrFieldをJANにする
If Left(strKataban, 1) = "9" Or Left(strKataban, 1) = "8" Or Left(strKataban, 1) = "7" Or Left(strKataban, 1) = "6" _
Or Left(strKataban, 1) = "5" Or Left(strKataban, 1) = "4" Or Left(strKataban, 1) = "3" Or Left(strKataban, 1) = "2" _
Or Left(strKataban, 1) = "1" Or Left(strKataban, 1) = "0" Then
Dim JANCODE As Variant
JANCODE = ExtractNumber(strKataban, 0)
If Len(JANCODE) = 13 Or Len(JANCODE) = 12 Or Len(JANCODE) = 11 Then
strField = "JAN"
End If
End If
'データ入力フォームの検索1にフィルタした文字列を入れる
If InStr(strField, "検索") Then
Forms![データ入力フォーム].[型番a] = strKataban
Else
Forms![データ入力フォーム].[型番a] = Null
End If
varKataban = Split(strKataban, " ", , vbTextCompare)
intKataban = UBound(varKataban)
'絞り込みフィルタ
If intKataban > 0 Then
For i = 0 To intKataban
If i = 0 Then
strKensaku = strField & " LIKE ""*" & varKataban(i) & "*"""
Else
strKensaku = strKensaku & "AND " & strField & " Like ""*" & varKataban(i) & "*"""
End If
Next
'検索文字に改行があたらトル
strKensaku = Replace(strKensaku, vbCrLf, "")
Forms![データ入力フォーム].Filter = strKensaku
'単純フィルタ
Else
'検索文字に改行があたらトル
strKataban = Replace(strKataban, vbCrLf, "")
Forms![データ入力フォーム].Filter = strField & " LIKE ""*" & strKataban & "*"""
End If
'フィルタの実行 Forms![データ入力フォーム].FilterOn = True Forms![データ入力フォーム].OrderBy = "入稿 DESC" Me.Visible = False cmb_含む1.SetFocus Exit Sub
err1:
MsgBox (Err.Number & " : " & Err.Description)
End Sub
Private Sub 閉じる_Click()
Me.Visible = False cmb_含む1.SetFocus
End Sub