skdj.frm

煤炭销售管理系统.完成煤炭销售的日常管理工作,和重车计量系统空车计量系统配合使用.

'：Form_Unload
'：Cancel 为Integer型

Private Sub Form_Unload(Cancel As Integer)
    '  Screen.MousePointer = vbDefault
    On Error Resume Next
    Dim dd As Integer
    dd = MsgBox("发货单可能发生了变更，" + Chr(10) + Chr(13) + "确认这些变更吗", 36, "确认")
    If dd <> 6 Then
        datPrimaryRS.Recordset.CancelUpdate
    End If
    
    
   cmdAdd.Enabled = True
   cmdDelete.Enabled = True
   cmdFirst.Enabled = True
   cmdLast.Enabled = True
   cmdPrevious.Enabled = True
     ''MDIForm1.Toolbar1.Visible = True
    jl_hth = ""
    Unload Me
    headle = 0
End Sub
    

'：datPrimaryRS_Error
'：ByVal 为orNumber As Long型
'：Description 为String型
'：ByVal 为de As Long型
'：ByVal 为rce As String型
'：ByVal 为pFile As String型
'：ByVal 为pContext As Long型
'：fCancelDisplay 为Boolean型

    

'：cmdAdd_Click
'： 无

Private Sub cmdAdd_Click()
    On Error GoTo AddErr
    datPrimaryRS.Recordset.AddNew
    Text2.Text = ""
    txtFields(0) = ""
    txtFields(1) = ""
    txtFields(3) = ""
    txtFields(4) = ""
       txtFields(5) = ""
    txtFields(7) = ""
    Label2.Text = ""
    Label4.Text = ""
    Combo1.Text = ""
    txtFields(9) = ""
    txtFields(10) = ""
    txtFields(11) = ""
    Combo1.Text = ""
    Text1.Text = ""
    Me.txtFields(4) = jl_fhdw
      rest.Open "select hth from htk where hth>'' order by hth"
rest.MoveLast
Me.txtFields(0) = rest.Fields(0) + 1

    Exit Sub
AddErr:
    MsgBox err.Description
End Sub
    

'：cmdDelete_Click
'： 无

Private Sub cmdDelete_Click()
    On Error GoTo DeleteErr
    With datPrimaryRS.Recordset
    .delete
    .MoveNext
    Call cmdNext_Click
    If .EOF Then .MoveLast
    End With
    Exit Sub
DeleteErr:
    MsgBox err.Description
End Sub
    

'：cmdRefresh_Click
'： 无

Private Sub cmdRefresh_Click()
    '只有多用户应用程序需要
    On Error GoTo RefreshErr
    'datPrimaryRS.Refresh
    Me.cmdAdd.Enabled = True
    'mbDataChanged = False
   Call yd
    
    Exit Sub
RefreshErr:
    MsgBox err.Description
End Sub
    

'：cmdUpdate_Click
'： 无

Private Sub cmdUpdate_Click()
    On Error GoTo UpdateErr
    'datPrimaryRS.Recordset.AddNew
    If Me.txtFields(3).Text = "" Or Me.txtFields(4).Text = "" Then
     MsgBox "没有添加任何数据，点击刷新或重新添加新数据"
     Me.txtFields(0).SetFocus
     Else
    
    datPrimaryRS.Recordset.Fields("sj") = Trim(Text2.Text)
    datPrimaryRS.Recordset.Fields("hth") = txtFields(0)
    datPrimaryRS.Recordset.Fields("htl") = Val(txtFields(1))
    datPrimaryRS.Recordset.Fields("fhr") = txtFields(3)
    datPrimaryRS.Recordset.Fields("fhdw") = txtFields(4)
    datPrimaryRS.Recordset.Fields("yfl") = 0
    datPrimaryRS.Recordset.Fields("wfl") = Val(txtFields(1))
    datPrimaryRS.Recordset.Fields("dj") = Val(txtFields(5))
    datPrimaryRS.Recordset.Fields("je") = Val(txtFields(7))
    datPrimaryRS.Recordset.Fields("htldx") = Label2.Text
    datPrimaryRS.Recordset.Fields("jedx") = Label4.Text
    datPrimaryRS.Recordset.Fields("jsfs") = Combo2.Text
    datPrimaryRS.Recordset.Fields("ysfs") = Combo1.Text
    'datPrimaryRS.Recordset.Fields("bz") = txtFields(9)
    datPrimaryRS.Recordset.Fields("tbr") = txtFields(10)
    datPrimaryRS.Recordset.Fields("hwm") = Combo1.Text
    datPrimaryRS.Recordset.Fields("fphm") = Text1.Text
    datPrimaryRS.Recordset.Fields("djj") = 0
   
    Text2.Text = Format(DTPicker1.Value, "yyyy-mm-dd")
    datPrimaryRS.Recordset.UpdateBatch adAffectAllChapters
   
    Me.cmdAdd.Enabled = True
     End If
UpdateErr:
    MsgBox err.Description
End Sub
    

'：cmdClose_Click
'： 无

Private Sub cmdClose_Click()
    Unload Me
End Sub
    

'：Label2_KeyPress
'：KeyAscii 为Integer型

Private Sub Label2_KeyPress(KeyAscii As Integer)
    If KeyAscii = 13 Then
        txtFields(5).SetFocus
    End If
End Sub
    

'：Text1_KeyPress
'：KeyAscii 为Integer型

Private Sub text1_KeyPress(KeyAscii As Integer)
    If KeyAscii = 13 Then
        Me.Combo3.SetFocus
    End If
    
End Sub
    

'：Text2_Change
'： 无

Private Sub Text2_Change()
    
    'DTPicker1.Value = Text2.text
End Sub
    

'：Text2_DblClick
'： 无

Private Sub Text2_DblClick()
    DTPicker1.Visible = True
    Text2.Visible = False
    
End Sub
    
Private Sub Text2_KeyPress(KeyAscii As Integer)
If KeyAscii = 13 Then
Me.txtFields(3).SetFocus
End If
End Sub

Private Sub Text2_LostFocus()
Me.txtFields(3).SetFocus
End Sub


'：txtFields_Change
'：Index 为Integer型

Private Sub txtFields_Change(Index As Integer)
    'Call txtFields_LostFocus(Index)
End Sub
    

'：txtFields_KeyPress
'：Index 为Integer型
'：KeyAscii 为Integer型

Private Sub txtFields_KeyPress(Index As Integer, KeyAscii As Integer)
    If KeyAscii = 13 Then
        
        Select Case Index
            Case 0
                Text1.SetFocus
                
            Case 1
                 
        txtFields(5).SetFocus
  
             Case 2
            Case 3
            Me.txtFields(3).SetFocus
               Combo3.SetFocus
            Case 4
                Me.Text2.SetFocus
            Case 5
                 txtFields(9).SetFocus
            Case 9
             txtFields(10).SetFocus
            Case 10
             txtFields(11).SetFocus
              Case 10
             cmdUpdate.SetFocus
        End Select
    End If
    
End Sub

'：dwdy
'： 无



'## 函数名称：return1
'：s 为String型
'As String'## 返回类型：As String

Function return1(S As String) As String
    return1 = zw(CInt(S))
End Function

'## 函数名称：return2
'：d 为Integer型
'As String'## 返回类型：As String

Function return2(d As Integer) As String
    If i <= 2 Then
        return2 = dw(d - 1)
    Else
        return2 = dw(d - 2)
    End If
End Function
    

'：txtFields_LostFocus
'：Index 为Integer型

Private Sub txtFields_LostFocus(Index As Integer)
    'On Error GoTo err
    Dim line_all As Double
    Dim sl As Double
    Dim jgtemp As String
    Dim hth
    Dim jg As String
    Dim line_zensu As Integer
    Dim dot As Integer
    Dim zensu As Integer
    Dim mon As String
    Select Case Index
            
        Case 0
            'MsgBox "sjkhf"
            'datPrimaryRS.refresh
            'If datPrimaryRS.Recordset.EOF Then Exit Sub
             datPrimaryRS.RecordSource = "select * from htk where hth='" & txtFields(0) & "' order by hth"
            datPrimaryRS.refresh
            If datPrimaryRS.Recordset.RecordCount > 1 Then
                         datPrimaryRS.Recordset.MoveLast
              hth = datPrimaryRS.Recordset.Fields("hth")
             MsgBox "该发货票号已存在，最后一个号码为:   " + Chr(10) + "   " & hth
            Exit Sub
            End If
            Case 4
            Me.Text2.SetFocus
                   
        Case 1
            
            
            sl = Val(Format(Val(txtFields(1).Text), "00000000000.00"))
          
            'End If
            Label2.Text = ChMoney2(sl)
           
            
        Case 5
            Dim tje As Currency
             tje = Val(txtFields(5)) * Val(txtFields(1)) / 1000
             tje = FormatNumber(tje, 2, vbFalse, vbFalse, vbFalse)
            txtFields(7).Text = FormatNumber(tje, 2, vbFalse, vbFalse, vbFalse)
            Label4.Text = ChMoney(tje)
           
            
    End Select
    
    'MsgBox jg
    
err:
    'MsgBox err.Number
    If err.Number = 13 Then MsgBox "非法字符", vbExclamation
    Exit Sub
End Sub
    
Private Sub yd()
On Error Resume Next
  Text2.Text = datPrimaryRS.Recordset.Fields("sj")
    txtFields(0) = datPrimaryRS.Recordset.Fields("hth")
    txtFields(1) = datPrimaryRS.Recordset.Fields("htl")
    txtFields(3) = datPrimaryRS.Recordset.Fields("fhr")
    txtFields(4) = datPrimaryRS.Recordset.Fields("fhdw")
    txtFields(5) = datPrimaryRS.Recordset.Fields("dj")
    txtFields(7) = datPrimaryRS.Recordset.Fields("je")
    Label2.Text = datPrimaryRS.Recordset.Fields("htldx")
    Label4.Text = datPrimaryRS.Recordset.Fields("jedx")
    Combo1.Text = datPrimaryRS.Recordset.Fields("ysfs")
    txtFields(9) = datPrimaryRS.Recordset.Fields("bz")
    txtFields(10) = datPrimaryRS.Recordset.Fields("tbr")
    txtFields(11) = datPrimaryRS.Recordset.Fields("fzr")
    Combo3.Text = datPrimaryRS.Recordset.Fields("hwm")
    Text1.Text = datPrimaryRS.Recordset.Fields("fphm")
    Combo2.Text = datPrimaryRS.Recordset.Fields("jsfs")
    
 End Sub

Private Sub Commandd(n1 As Double)
On Error Resume Next
   ' Dim strQueryA As String
    'strQueryA = "SELECT hth, htl, yfl, wfl, hwm, fhr, fhdw, qydw, dj, je, sj, bz, htldx, jedx, ysfs, jsfs, fphm, tbr, fzr FROM htk where hth='" & Trim(txtFields(0).Text) & "'"
    'With DataEnvironment1.rsCommand2
    'If .State = adStateOpen Then .Close
   ' .Source = strQueryA
    '.Open '打开想输出的数据库数据项以便输出
    'End With
    'DataReport2.ExportFormats
    'DataReport2.Show 1
     Dim myobb
    Dim tob(10)
    Set tob(0) = dyyll.Label54
    Set tob(1) = dyyll.Label53
    Set tob(2) = dyyll.Label52
    Set tob(3) = dyyll.Label51
    Set tob(4) = dyyll.Label50
    Set tob(5) = dyyll.Label49
    Set tob(6) = dyyll.Label48
    Set tob(7) = dyyll.Label47
    Set tob(8) = dyyll.Label46
    Set tob(9) = dyyll.Label45
    Dim ii As Integer
    Dim jj As Integer
    Dim strlen As Integer
    Dim strr As String
    Dim inamb As Integer
    strr = Trim(Str(n1))
    Debug.Print strr
    strlen = Len(strr)
    inamb = InStr(strr, ".")
    If inamb > 0 Then
    strlen = inamb - 1
    
     dyyll.Label60(0).Caption = Mid(strr, inamb + 1, 1)
       dyyll.Label61.Caption = Val(Mid(strr, inamb + 2, 1))
     End If
     For jj = 1 To 10
          Set myobb = tob(jj - 1)(ii)
          myobb.Caption = ""
     Next jj
         
  
     For jj = 0 To strlen
           
           Set myobb = tob(jj)(ii)
          myobb.Caption = ""
            
         Next jj
            
         For jj = 0 To strlen - 1
         
           Set myobb = tob(jj)(ii)
          myobb.Caption = Mid(strr, strlen - jj, 1)
            
         Next jj
                
          Set myobb = tob(jj)(ii)
          myobb.Caption = "￥"
             
End Sub