frmpmodify.frm

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

      Left            =   4020
      Stretch         =   -1  'True
      Top             =   2430
      Width           =   2640
   End
   Begin VB.Line Line1 
      X1              =   330
      X2              =   6645
      Y1              =   855
      Y2              =   855
   End
   Begin VB.Line Line2 
      BorderColor     =   &H00FFFFFF&
      X1              =   345
      X2              =   6645
      Y1              =   870
      Y2              =   870
   End
   Begin VB.Label Label1 
      Alignment       =   1  'Right Justify
      AutoSize        =   -1  'True
      Caption         =   "图片："
      Height          =   180
      Index           =   9
      Left            =   3645
      TabIndex        =   22
      Top             =   1905
      Width           =   825
   End
End
Attribute VB_Name = "frmPModify"
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, OldName As String

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 MS = 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 = 3
End Sub

Private Sub Form_Load()
frmPModify.HelpContextID = 2
ErrorEx = False
N_S = False
Dim X As Integer
    For X = 0 To 9
        Label1(X) = Pro(X)
    Next
    X = 0
OldName = ""
Me.Left = (MDIForm1.Width - Me.Width) / 2 + 100
Me.Top = (MDIForm1.Height - Me.Height) / 2 - 1500
SamplePhoto.ToolTipText = "双击选择图片,图片宽与高300:350点," & Chr(10) & Chr(13) & "如果取消图片,请按Shift+鼠标左键!"
Dim DB As Database, EF As Recordset
    Set DB = OpenDatabase(SampleData)
    Set EF = DB.OpenRecordset("S_Main", dbOpenDynaset)
        ModifyText = "样品名称='" & ModifyText & "'"
        EF.FindFirst ModifyText
        For X = 0 To 9
            If Not IsNull(EF.Fields(X).Value) Then
               FieldsTxt(X).Text = EF.Fields(X).Value
            End If
        Next
        DB.Close
        OldName = FieldsTxt(0).Text
        AddBool = False
        On Error GoTo NP
        SamplePhoto.Picture = LoadPicture(FieldsTxt(9).Text)
        
        Exit Sub
NP:
        MsgBox "图片文件没找到或格式出错，不能浏览！", vbOKOnly + 16, "图片不能安装"
        On Error Resume Next
        SamplePhoto.Picture = LoadPicture(Browser + "photo\default.bmp")
        Exit Sub
        
End Sub
'-----------------------------------------------Info-----------------
Private Sub fieldstxt_Change(Index As Integer)
  AddBool = True
  S_Button.Enabled = 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 Trim(FieldsTxt(0).Text) = OldName Then Exit Sub
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)
      DB.Execute "Delete * From S_Main Where 样品名称='" & OldName & "'"
      DB.Execute Tempstr
      DB.Close
      OldName = Trim(FieldsTxt(0).Text)
   FieldsTxt(0).SetFocus
  '**************** 结束 *****************
   S_Button.Enabled = False
   AddBool = False
   ErrorEx = False
   N_S = False
End Sub

Private Sub SamplePhoto_DblClick()
  frmPModify.MousePointer = 11
    SelectFile.Show 1
  frmPModify.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