frmoption.frm

机房管理

  
  If TabStrip1.SelectedItem.Key = "message" Then
     pic3.Visible = True
     txtAddLine.SetFocus
    Else
     pic3.Visible = False
  End If
  
  If TabStrip1.SelectedItem.Key = "mc" Then
     pic4X.Visible = True
     txtCompany.SetFocus
    Else
     pic4X.Visible = False
  End If
  
End Sub

Private Sub txtAddLine_Change()

 If txtAddLine <> "" Then
    cmdAddLine.Enabled = True
  Else
    cmdAddLine.Enabled = False
 End If
 
End Sub

Private Sub txtAddLine_KeyPress(KeyAscii As Integer)

 If KeyAscii = 13 Then
    If cmdAddLine.Enabled = True Then cmdAddLine.Value = True
 End If
 
End Sub

Private Sub txtCode_Change()

 If txtPM <> "" And txtDJ <> "" And txtCode <> "" Then
     cmdAdd.Enabled = True
    Else
     cmdAdd.Enabled = False
  End If
  
End Sub

Private Sub txtCode_GotFocus()
  
  txtCode.SelStart = 0
  txtCode.SelLength = Len(txtDJ)
  
End Sub

Private Sub txtCode_KeyPress(KeyAscii As Integer)

 If KeyAscii = 13 Then
    If cmdAdd.Enabled = True Then
       cmdAdd.Value = True   '添加记录
    End If
 End If
 
End Sub

Private Sub txtCompany_GotFocus()

  txtCompany.SelStart = 0
  txtCompany.SelLength = Len(txtCompany)
  
End Sub

Private Sub txtCompany_KeyPress(KeyAscii As Integer)

 If KeyAscii = 13 Then
    txtCompanyLen.SetFocus
 End If
 
End Sub

Private Sub txtCompanyLen_GotFocus()

  txtCompanyLen.SelStart = 0
  txtCompanyLen.SelLength = Len(txtCompany)
  
End Sub

Private Sub txtCompanyLen_KeyPress(KeyAscii As Integer)

If (KeyAscii > 46 And KeyAscii < 58 And KeyAscii <> 47) Or KeyAscii = 8 Then
    Exit Sub
 ElseIf KeyAscii = 13 Then
        Command3.Value = True
    Exit Sub
   Else
   KeyAscii = 0
End If

End Sub

Private Sub txtDJ_Change()

If txtPM <> "" And txtDJ <> "" And txtCode <> "" Then
     cmdAdd.Enabled = True
    Else
     cmdAdd.Enabled = False
  End If
  
End Sub

Private Sub txtDJ_GotFocus()

  txtDJ.SelStart = 0
  txtDJ.SelLength = Len(txtDJ)
  
End Sub

Private Sub txtDJ_KeyPress(KeyAscii As Integer)

If (KeyAscii > 45 And KeyAscii < 58 And KeyAscii <> 47) Or KeyAscii = 8 Then
   If KeyAscii = 46 And InStr(1, txtDJ, ".", vbBinaryCompare) > 0 Then '为小数点时
      KeyAscii = 0
   End If
      Exit Sub
 ElseIf KeyAscii = 13 Then
        txtDW.SetFocus
    Exit Sub
   Else
   KeyAscii = 0
End If

End Sub

Private Sub txtDW_GotFocus()
  
  txtDW.SelStart = 0
  txtDW.SelLength = Len(txtDJ)
  
End Sub

Private Sub txtDW_KeyPress(KeyAscii As Integer)

 If KeyAscii = 13 Then
    txtCode.SetFocus
 End If
 
End Sub

Private Sub txtJE_Change()

 If txtJE = "" Then
   txtJE = "0"
   txtJE.SelStart = 0
   txtJE.SelLength = Len(txtJE)
 End If
 
End Sub

Private Sub txtJE_GotFocus()

 txtJE.SelStart = 0
 txtJE.SelLength = Len(txtJE)
 
End Sub

Private Sub txtJE_KeyPress(KeyAscii As Integer)

If (KeyAscii > 45 And KeyAscii < 58 And KeyAscii <> 47) Or KeyAscii = 8 Then
   If KeyAscii = 46 And InStr(1, txtJE, ".", vbBinaryCompare) > 0 Then '为小数点时
      KeyAscii = 0
   End If
      Exit Sub
 Else
   KeyAscii = 0
End If

End Sub

Private Sub txtJE_LostFocus()

 If txtJE = "0" Then
    txtJE = "4.0"
 End If
 
End Sub

Private Sub txtJS_Change()

 If txtJS = "" Then
   txtJS = "0"
   txtJS.SelStart = 0
   txtJS.SelLength = Len(txtJS)
 End If
 
End Sub

Private Sub txtJS_GotFocus()

 txtJS.SelStart = 0
 txtJS.SelLength = Len(txtJS)
 
End Sub

Private Sub txtJS_KeyPress(KeyAscii As Integer)

If (KeyAscii > 47 And KeyAscii < 58) Or KeyAscii = 8 Then
   Exit Sub
 Else
   KeyAscii = 0
End If

End Sub

Private Sub txtJS_LostFocus()

 If txtJS = "0" Then
    txtJS = "15"
 End If
 
End Sub

Private Sub txtPM_Change()

  If txtPM <> "" And txtDJ <> "" And txtCode <> "" Then
     cmdAdd.Enabled = True
    Else
     cmdAdd.Enabled = False
  End If
  
End Sub

Private Sub txtPM_GotFocus()

  txtPM.SelStart = 0
  txtPM.SelLength = Len(txtPM)
  
End Sub

Private Sub txtPM_KeyPress(KeyAscii As Integer)

 If KeyAscii = 13 Then
    txtDJ.SetFocus
 End If
 
End Sub

Private Sub ConfigGrid()

On Error GoTo Err_init
Grid1.Visible = False
Grid1.Clear
Grid1.Cols = 5
Grid1.FormatString = "^ .. |^ 物品名称 |^ 单价（元） |^ 单位 |^ 代码 "
Grid1.ColWidth(0) = 300
Grid1.ColWidth(1) = 1500
Grid1.ColWidth(2) = 600
Grid1.ColWidth(3) = 800
Grid1.ColWidth(4) = 800

Dim DB As Database, Ef As Recordset, HH As Integer, DelNo As Long
Dim shiftStr As String, shiftStrL As String, shiftStrR As String, shiftNum As Integer, ili As Integer, TempStr As String, sureStr As String, Qy As Integer
    Set DB = OpenDatabase(ConData, False, False, ConStr)
    'Set DB = OpenConnection(ConData, dbDriverNoPrompt, False, ConStr)
    
    Set Ef = DB.OpenRecordset("EatList", dbOpenTable)
        DelNo = Ef.RecordCount
        Grid1.Rows = Ef.RecordCount + 1
    Set Ef = DB.OpenRecordset("EatList", dbOpenDynaset)
        HH = 1
        Do While Not Ef.EOF()
           Grid1.Row = HH
           Grid1.Col = 0
           Grid1.CellAlignment = 4
        If Not IsNull(Ef.Fields(0).Value) Then
           Grid1.Text = Ef.Fields(0).Value
        End If
           Grid1.Row = HH
           Grid1.Col = 1
           Grid1.CellAlignment = 1
        If Not IsNull(Ef.Fields(1).Value) Then
           Grid1.Text = Ef.Fields(1).Value
        End If
           Grid1.Row = HH
           Grid1.Col = 2
           Grid1.CellAlignment = 1
        If Not IsNull(Ef.Fields(3).Value) Then
           Grid1.Text = Ef.Fields(3).Value
        End If
           Grid1.Row = HH
           Grid1.Col = 3
           Grid1.CellAlignment = 1
        If Not IsNull(Ef.Fields(2).Value) Then
           Grid1.Text = Ef.Fields(2).Value
        End If
           Grid1.Row = HH
           Grid1.Col = 4
           Grid1.CellAlignment = 1
        If Not IsNull(Ef.Fields(4).Value) Then
           Grid1.Text = Ef.Fields(4).Value
        End If
        
          Ef.MoveNext
          HH = HH + 1
        Loop
        Ef.Close
        DB.Close
 Grid1.Col = 1
 Grid1.Row = 1
 Grid1.ColSel = 4
 Grid1.Visible = True
   Exit Sub
Err_init:
 MsgBox "网络配置错误!    " & vbCrLf & vbCrLf & Err.Description, vbCritical
 
End Sub

Private Sub DelRecord(sWP As String, sFields As String, sTable As String)

   On Error GoTo Err_init
   Dim DB As Database
   Dim sEXE As String
   
   Set DB = OpenDatabase(ConData, False, False, ConStr)
   'Set DB = OpenConnection(ConData, dbDriverNoPrompt, False, ConStr)
   
   ' SQL语言删除
     sEXE = "Delete * From " & sTable & " Where " & sFields & "='" & sWP & "'"
     DBEngine.BeginTrans     ' 进行事务操作
     DB.Execute sEXE
     DBEngine.CommitTrans
     DB.Close
          Exit Sub
Err_init:
 MsgBox "记录删除错误!    " & vbCrLf & vbCrLf & Err.Description, vbCritical
 
End Sub

Private Sub AddRecord(sWP1 As String, sFields1 As String, sWP2 As Currency, sFields2 As String, sWP3 As String, sFields3 As String, sWP4 As String, sFields4 As String, sTable As String)

  On Error GoTo Err_init
   Dim DB As Database
   Dim sEXE As String
   
   Set DB = OpenDatabase(ConData, False, False, ConStr)
   'Set DB = OpenConnection(ConData, dbDriverNoPrompt, False, ConStr)
   
   ' SQL语言删除
     sEXE = "Insert into " & sTable & " (" & sFields1 & "," & sFields2 & "," & sFields3 & "," & sFields4 & ") values('" & sWP1 & "'," & sWP2 & ",'" & sWP3 & "','" & sWP4 & "')"
     DBEngine.BeginTrans     ' 进行事务操作
     DB.Execute sEXE
     DBEngine.CommitTrans
     DB.Close
          Exit Sub
Err_init:
 MsgBox "添加记录错误!    " & vbCrLf & vbCrLf & Err.Description, vbCritical
 
End Sub

Private Sub ConfigMessage()

 On Error GoTo Err_init
     ' 设定系统路径
  Dim sFileBuffer As String * 250, retVal As Long, sSystemInI As String
     
     retVal = GetSystemDirectory(sFileBuffer, 251)
  If retVal = 0 Then
     sSystemInI = "C:\Windows\System\Message.InI"
   Else
     sSystemInI = left(sFileBuffer, InStr(1, sFileBuffer, Chr(0), vbBinaryCompare) - 1)
     sSystemInI = sSystemInI & "\Message.InI"
  End If
   
   On Error GoTo 1000            '第一次运行，文件不存在时
     Dim sTemp As String, lFile As Long
         lFile = FreeFile
     Open sSystemInI For Input As #lFile
     Do While Not EOF(lFile)
        Input #lFile, sTemp
        listLine.AddItem sTemp
     Loop
     Close lFile
   GoTo 1010
1000   '
  Close lFile
  Open sSystemInI For Output As 1
  Print #lFile, " 现 在 开 始 计 费 ! "
  Print #lFile, " 您 的 费 用 已 经 到 了 ! "
  Close lFile
  listLine.AddItem " 现 在 开 始 计 费 ! "
  listLine.AddItem " 您 的 费 用 已 经 到 了 ! "
1010 '
On Error GoTo 0
  If listLine.ListCount > 0 Then
     listLine.ListIndex = 0
  End If
  Exit Sub
Err_init:
 MsgBox "配置消息错误!    " & vbCrLf & vbCrLf & Err.Description, vbCritical
 
End Sub

Private Function GetCode(sWP As String, sFields As String, sTable As String) As Boolean

  On Error GoTo Err_init
   Dim DB As Database
   Dim Ef As Recordset
   Dim sEXE As String
   
   Set DB = OpenDatabase(ConData, False, False, ConStr)
   'Set DB = OpenConnection(ConData, dbDriverNoPrompt, False, ConStr)
   
   ' SQL语言删除
     sEXE = "Select * From " & sTable & " Where " & sFields & "='" & sWP & "'"
   Set Ef = DB.OpenRecordset(sEXE, dbOpenDynaset)
     If Ef.EOF And Ef.BOF Then
        GetCode = True
      Else
        GetCode = False
     End If
     Ef.Close
     DB.Close
     Exit Function
     
Err_init:
 MsgBox "添加记录错误!    " & vbCrLf & vbCrLf & Err.Description, vbCritical
 GetCode = False
 
End Function