frmregister.frm

通用样品管理系统是一个商业程序,功能界面都还不错!

   Begin VB.Line Line1 
      X1              =   195
      X2              =   6510
      Y1              =   870
      Y2              =   870
   End
   Begin VB.Image SamplePhoto 
      BorderStyle     =   1  'Fixed Single
      Height          =   2475
      Left            =   3885
      Stretch         =   -1  'True
      Top             =   2250
      Width           =   2640
   End
   Begin VB.Label Label1 
      Alignment       =   1  'Right Justify
      AutoSize        =   -1  'True
      Caption         =   "样品描述"
      Height          =   180
      Index           =   1
      Left            =   150
      TabIndex        =   13
      Top             =   1155
      Width           =   945
   End
   Begin VB.Label Label1 
      Alignment       =   1  'Right Justify
      AutoSize        =   -1  'True
      Caption         =   "样品名称"
      Height          =   180
      Index           =   0
      Left            =   135
      TabIndex        =   12
      Top             =   390
      Width           =   945
   End
End
Attribute VB_Name = "frmRegister"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Dim AddBool As Boolean, ErrorEx As Boolean, N_S As Boolean
Private Sub E_Button_Click()
If AddBool = True Then
   x = MsgBox("需要保存输入的信息吗(Y/N)?", vbYesNo + 48, "警告!")
   If x = 6 Then
      Call S_Button_Click
      If ErrorEx = True Then
         Exit Sub
      End If
   End If
End If
If NS = False Then
   Unload Me
   Exit Sub
 Else
   frmExplorer!Command1.Value = True
   Unload Me
   frmExplorer.Show
   Exit Sub
End If
End Sub

Private Sub Form_Activate()
 ConfTrue = 2
End Sub

Private Sub Form_Load()
frmRegister.HelpContextID = 1
frmRegister.Left = (MDIForm1.Width - frmRegister.Width) / 2 + 500
frmRegister.Top = (MDIForm1.Height - frmRegister.Height) / 2 - 1500
AddBool = False
ErrorEx = False
N_S = False
SamplePhoto.ToolTipText = "双击选择图片,图片宽与高为300:350点" & Chr(10) & Chr(13) & "如果取消图片,请按Shift+鼠标左键!"
Dim x As Integer
    For x = 0 To 9
        Label1(x) = Pro(x)
    Next
End Sub
'-----------------------------------------------Info-----------------
Private Sub fieldstxt_Change(Index As Integer)
  AddBool = True
End Sub

Private Sub fieldstxt_GotFocus(Index As Integer)
  FieldsTxt(Index).BackColor = &HC0FFFF
  FieldsTxt(Index).SelStart = 0
  FieldsTxt(Index).SelLength = Len(Trim(FieldsTxt(Index).Text))
End Sub

Private Sub fieldstxt_KeyDown(Index As Integer, KeyCode As Integer, Shift As Integer)
If KeyCode = 38 And Index <> 1 Then
   If Index > 0 Then
      FieldsTxt(Index - 1).SetFocus
   End If
End If
If KeyCode = 40 And Index <> 1 Then
   If Index < 9 Then
      FieldsTxt(Index + 1).SetFocus
   End If
End If
End Sub

Private Sub fieldstxt_KeyPress(Index As Integer, KeyAscii As Integer)
If KeyAscii = 13 And Index <> 1 Then
   SendKeys "{tab}"
   Exit Sub
   End If
If Index = 6 Then
   If NumberTrue(KeyAscii, FieldsTxt(6)) = False Then
      KeyAscii = 0
      Exit Sub
   End If
End If
If Index = 7 Then
   If NumberTrue(KeyAscii, FieldsTxt(7)) = False Then
      KeyAscii = 0
      Exit Sub
   End If
End If
If Index = 8 Then
   If NumberTrue(KeyAscii, FieldsTxt(8)) = False Then
      KeyAscii = 0
      Exit Sub
   End If
End If
End Sub

Private Sub fieldstxt_LostFocus(Index As Integer)
FieldsTxt(Index).BackColor = &HFFFFFF
If InStr(1, FieldsTxt(Index).Text, "'", vbTextCompare) Then
   MsgBox "该项目之中有特殊字符" + "<'>,请删除。", vbOKOnly + 48, "提示："
   FieldsTxt(Index).SetFocus
   Exit Sub
End If
'较对有无重复的编号
If Index = 0 Then
   Dim DB As Database, EF As Recordset, Tempstr As String
   Set DB = OpenDatabase(SampleData)
   Set EF = DB.OpenRecordset("S_Main", dbOpenDynaset)
       Tempstr = "样品名称='" & FieldsTxt(0).Text & "'"
       EF.FindFirst Tempstr
   If Not EF.NoMatch Then
      MsgBox "重复的样品名,系统将在样品后自动加1,可以自己修改!", vbOKOnly + 48, "警告!"
        DB.Close
        FieldsTxt(0).Text = Trim(FieldsTxt(0).Text) + "1"
        FieldsTxt(0).SetFocus
        N_S = True
        Exit Sub
       Else
        DB.Close
   End If
End If
N_S = False
End Sub


Function NumberTrue(keyNumber As Integer, NumberStr As TextBox) As Boolean
   '转入退格键时
   If keyNumber = 8 Then
        NumberTrue = True
        Exit Function
      End If
   If keyNumber >= 46 And keyNumber <= 57 And keyNumber <> 47 Then
       NumberTrue = True
        Else
       NumberTrue = False
   End If
End Function

Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
  If AddBool = True And (UnloadMode = 0 Or UnloadMode = 4) Then
     Call fieldstxt_LostFocus(0)
     If N_S = True Then
        Cancel = -1
        FieldsTxt(0).SelStart = 0
        FieldsTxt(0).SelLength = Len(FieldsTxt(0).Text)
        FieldsTxt(0).SetFocus
        Exit Sub
     End If
     Call E_Button_Click
     Exit Sub
  End If
End Sub

Private Sub S_Button_Click()
   If FieldsTxt(0).Text = "" Then
      MsgBox "样品名称必须填写!", vbOKOnly + 32, "警告!"
      ErrorEx = True
      FieldsTxt(0).SetFocus
      Exit Sub
   End If
   If Val(FieldsTxt(6).Text) = 0 Then
      FieldsTxt(6).Text = 0
   End If
   If Val(FieldsTxt(7).Text) = 0 Then
      FieldsTxt(7).Text = 0
   End If
   If Val(FieldsTxt(8).Text) = 0 Then
      FieldsTxt(8).Text = 0
   End If
  'Save Data
  '**************** 开始 *****************
   Dim DB As Database, EF As Recordset, x As Integer, Tempstr As String
       x = 0
   For x = 0 To 9
      If x = 6 Or x = 7 Or x = 8 Then
         Tempstr = Tempstr + FieldsTxt(x).Text + ","
        ElseIf x < 9 Then
          Tempstr = Tempstr + "'" + FieldsTxt(x).Text + "',"
         Else
          Tempstr = Tempstr + "'" + FieldsTxt(x).Text + "'"
      End If
   Next
    Tempstr = " Values (" + Tempstr + ")"
    Tempstr = "Insert into S_Main (样品名称,样品描述,颜色,尺码,风格,其它,批发价,零售价,其它价,样品图片)" + Tempstr
  Set DB = OpenDatabase(SampleData)
   
   '---演示版样品数不能超过10个----------------------------------
  Set EF = DB.OpenRecordset("S_Main", dbOpenTable)
   If EF.RecordCount > 10 Then
      EF.Close
      DB.Close
      MsgBox " 对不起，演示版的样品只能添加10个，" & vbCrLf & vbCrLf & "如果需要使用10个以上的样品，请购买完全版。    ", vbOKOnly + vbInformation, "Demo By YuSilong"
      Exit Sub
   End If 'Exit-----------------------------
   
      DB.Execute Tempstr
      DB.Close
  'Recommand set null value
    For x = 0 To 9
      FieldsTxt(x).Text = ""
    Next
  '指针调回编号
   FieldsTxt(0).SetFocus
   SamplePhoto.Picture = LoadPicture()
  '**************** 结束 *****************
   AddBool = False
   ErrorEx = False
   N_S = False
End Sub

Private Sub SamplePhoto_DblClick()
  frmRegister.MousePointer = 11
    SelectFile.Show 1
  frmRegister.MousePointer = 0
End Sub

Private Sub SamplePhoto_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
If Shift = 1 And Button = 1 Then
   SamplePhoto.Picture = LoadPicture()
   FieldsTxt(9).Text = ""
End If
End Sub