販売管理ソフトを作る - 「見積一覧」 入力チェック

「見積一覧」 入力チェック

■ frmList

00408 '入力値が妥当か？

00409 Private Function InputCheck(aControl As MSForms.Control) As Boolean

00410     InputCheck = False

00411 

00412     If aControl Is txtDateMin Then

00413         InputCheck = InputCheckDate(txtDateMin, True)

00414         Exit Function

00415 

00416     ElseIf aControl Is txtDateMax Then

00417         InputCheck = InputCheckDate(txtDateMax, True)

00418         Exit Function

00419 

00420     ElseIf aControl Is txtBusyo Then

00421         InputCheck = InputCheckBusyo(txtBusyo, True)

00422         InputCheckTanto txtTanto, False

00423         Exit Function

00424 

00425     ElseIf aControl Is txtTanto Then

00426         InputCheckBusyo txtBusyo, False

00427         InputCheck = InputCheckTanto(txtTanto, True)

00428         Exit Function

00429 

00430     ElseIf aControl Is txtTokui Then

00431         InputCheck = InputCheckTokui(txtTokui, True)

00432         Exit Function

00433 

00434     ElseIf aControl Is cmdSearch Then

00435         If Not InputCheckDate(txtDateMin, True) Then Exit Function

00436         If Not InputCheckDate(txtDateMax, True) Then Exit Function

00437         If Not InputCheckBusyo(txtBusyo, True) Then Exit Function

00438         If Not InputCheckTanto(txtTanto, True) Then Exit Function

00439         If Not InputCheckTokui(txtTokui, True) Then Exit Function

00440         If Not InputCheckSearch Then Exit Function

00441     End If

00442 

00443     InputCheck = True

00444 End Function

00445 '日付が妥当か？

00446 Private Function InputCheckDate(txtDate As MSForms.TextBox, aDispError As Boolean) As Boolean

00447     If Trim$(txtDate.Text) = "" Then

00448         InputCheckDate = True

00449         Exit Function

00450     End If

00451 

00452     InputCheckDate = False

00453 

00454     '数字だけ取り出す

00455     Dim s As String

00456     Dim c As String

00457     Dim i As Integer

00458     For i = 1 To txtDate.TextLength

00459         c = Mid$(txtDate.Text, i, 1)

00460         If IsNumeric(c) Then

00461             s = s + c

00462         End If

00463     Next

00464 

00465     'システム日付を取得

00466     Dim sysdate As String: sysdate = Format$(Now, "yyyyMMdd")

00467 

00468     If Len(s) < 1 Then

00469         '未入力

00470         s = sysdate

00471     ElseIf Len(s) <= 2 Then

00472         '日だけ入力

00473         s = Left$(sysdate, 6) + Right$("0" + s, 2)

00474     ElseIf Len(s) <= 4 Then

00475         '月日だけ入力

00476         s = Left$(sysdate, 4) + Right$("000" + s, 4)

00477     ElseIf Len(s) < 8 Then

00478         '年をフル入力していない

00479         s = Left$(sysdate, 8 - Len(s)) + s

00480     ElseIf Len(s) > 8 Then

00481         '８桁以上なら、余分な桁を 捨てる

00482         s = Left$(s, 8)

00483     End If

00484 

00485     '妥当な日付でなければ、システム日付

00486     txtDate.Text = Format$(s, "0000/00/00")

00487     If Not IsDate(txtDate.Text) Then

00488         txtDate.Text = Format$(Now, "yyyy\/MM\/dd")

00489     End If

00490 

00491     '大小チェック

00492     If txtDate Is txtDateMax Then

00493         If InputCheckDate(txtDateMin, False) Then

00494             If txtDateMin.Text <> "" Then

00495                 If CDate(txtDateMin) > CDate(txtDateMax) Then

00496                     s = txtDateMin.Text

00497                     txtDateMin.Text = txtDateMax.Text

00498                     txtDateMax.Text = s

00499                 End If

00500             End If

00501         End If

00502     End If

00503 

00504     InputCheckDate = True

00505 End Function

00506 '部署ＣＤが妥当か？

00507 Private Function InputCheckBusyo(txtBusyo As MSForms.TextBox, aDispError As Boolean) As Boolean

00508     lblBusyoNM.Caption = ""

00509     If Trim$(txtBusyo.Text) = "" Then

00510         InputCheckBusyo = True

00511         Exit Function

00512     End If

00513 

00514     InputCheckBusyo = False

00515 

00516     txtBusyo.Text = Right$(String(txtBusyo.MaxLength, "0") + txtBusyo.Text, txtBusyo.MaxLength)

00517 

00518     'クエリー文字列を編集

00519     Dim Sql As String

00520     Sql = "SELECT "

00521     Sql = Sql & "部署NM "

00522     Sql = Sql & "FROM "

00523     Sql = Sql & "TM_部署 "

00524     Sql = Sql & "WHERE 部署CD = '" & txtBusyo.Text & "'"

00525 

00526     'マスタから 名称を取得

00527     Dim sName As String

00528     If LoadName(Sql, "部署NM", sName, aDispError) Then

00529         lblBusyoNM.Caption = sName

00530         InputCheckBusyo = True

00531     Else

00532         TextGotFocus txtBusyo

00533     End If

00534 End Function

00535 '担当者ＣＤが妥当か？

00536 Private Function InputCheckTanto(txtTanto As MSForms.TextBox, aDispError As Boolean) As Boolean

00537     lblTantoNM.Caption = ""

00538     If Trim$(txtTanto.Text) = "" Then

00539         InputCheckTanto = True

00540         Exit Function

00541     End If

00542 

00543     InputCheckTanto = False

00544 

00545     txtTanto.Text = Right$(String(txtTanto.MaxLength, "0") + txtTanto.Text, txtTanto.MaxLength)

00546 

00547     'クエリー文字列を編集

00548     Dim Sql As String

00549     Sql = "SELECT "

00550     Sql = Sql & "担当者NM "

00551     Sql = Sql & "FROM "

00552     Sql = Sql & "TM_担当者 "

00553     Sql = Sql & "WHERE 部署CD = '" & txtBusyo.Text & "'"

00554     Sql = Sql & "  AND 担当者CD = '" & txtTanto.Text & "'"

00555 

00556     'マスタから 名称を取得

00557     Dim sName As String

00558     If LoadName(Sql, "担当者NM", sName, aDispError) Then

00559         lblTantoNM.Caption = sName

00560         InputCheckTanto = True

00561     Else

00562         TextGotFocus txtTanto

00563     End If

00564 End Function

00565 '得意先ＣＤが妥当か？

00566 Private Function InputCheckTokui(txtTokui As MSForms.TextBox, aDispError As Boolean) As Boolean

00567     lblTokuiNM.Caption = ""

00568     If Trim$(txtTokui.Text) = "" Then

00569         InputCheckTokui = True

00570         Exit Function

00571     End If

00572 

00573     InputCheckTokui = False

00574 

00575     txtTokui.Text = Right$(String(txtTokui.MaxLength, "0") + txtTokui.Text, txtTokui.MaxLength)

00576 

00577     'クエリー文字列を編集

00578     Dim Sql As String

00579     Sql = "SELECT "

00580     Sql = Sql & "得意先NM "

00581     Sql = Sql & "FROM "

00582     Sql = Sql & "TM_得意先 "

00583     Sql = Sql & "WHERE 得意先CD = '" & txtTokui.Text & "'"

00584 

00585     'マスタから 名称を取得

00586     Dim sName As String

00587     If LoadName(Sql, "得意先NM", sName, aDispError) Then

00588         lblTokuiNM.Caption = sName

00589         InputCheckTokui = True

00590     Else

00591         TextGotFocus txtTokui

00592     End If

00593 End Function

00594 

00595 'マスタから 名称を取得

00596 Private Function LoadName(ByVal aSql As String, ByVal aFieldName As String, ByRef aName As String, ByVal aDispError As Boolean) As Boolean

00597     LoadName = False

00598 

00599     'データベースを開く (排他モード = False, 読み込み専用 = True)

00600     Dim db As Database

00601     Set db = DBEngine.OpenDatabase(DB_PATH, False, True)

00602     'テーブルを開く

00603     Dim rs As Recordset

00604     Set rs = db.OpenRecordset(aSql, dbOpenForwardOnly)

00605     If Not rs.EOF Then

00606         aName = rs(aFieldName) & ""

00607         LoadName = True

00608     Else

00609         If aDispError Then

00610             MsgBox "登録されていません。", vbExclamation, "警告"

00611         End If

00612     End If

00613     'テーブルを閉じる

00614     rs.Close

00615     'データベースを閉じる

00616     db.Close

00617 End Function

00618 '抽出条件が１つ以上入力されているか？

00619 Private Function InputCheckSearch() As Boolean

00620     InputCheckSearch = True

00621 

00622     If Trim$(txtDateMin.Text) <> "" Then Exit Function

00623     If Trim$(txtDateMax.Text) <> "" Then Exit Function

00624     If Trim$(txtBusyo.Text) <> "" Then Exit Function

00625     If Trim$(txtTanto.Text) <> "" Then Exit Function

00626     If Trim$(txtTokui.Text) <> "" Then Exit Function

00627 

00628     MsgBox "抽出条件を入力してください。", vbExclamation, "警告"

00629     txtDateMin.SetFocus

00630     TextGotFocus txtDateMin

00631 

00632     InputCheckSearch = False

00633 End Function