httz.frm

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

Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False

'本模块中完成合同调整后，有两种保存方式:(1)
Dim tzxx As Integer
Dim tx As Boolean
Dim thtl As Long
Dim tdj As Long
Dim tje As Double
Dim tjcje As Double
Dim twfl As Long
Dim thth As String
Dim tyfl As Long

Private Sub Command1_Click()
Dim tzl As Long '要调整的合同量
Dim tzjc As Long '调整价差
Dim tbpk As Long '退（补）票款


Dim dd As Integer
thth = Me.txtFields(0)
thtl = Val(Me.txtFields(1))
tdj = Adodc1.Recordset.Fields("dj")
tje = Adodc1.Recordset.Fields("je")
twfl = Adodc1.Recordset.Fields("wfl")
tjcje = Adodc1.Recordset.Fields("jcje")
tyfl = Adodc1.Recordset.Fields("yfl")

Set rest = New ADODB.Recordset
Dim tht As Integer
rest.Open "select hth from htk where hth>'' order by hth", cn, adOpenStatic
If rest.RecordCount > 1 Then
rest.MoveLast
tht = rest.Fields("hth")
End If
 
If tx = False Then
  Me.txtFields(0) = tht
  End If
  If tx = True Then
  Exit Sub
  End If
Select Case tzxx
Case 1 '调整合同单价：（1）结余金额=原结余金额+欠存量*价格调整量
'（2）合同金额=原合同金额+欠存量*价格调整量
  '（3）本合同单价=调整后合同金额/合同量
Me.txtFields(7) = Val(Me.txtFields(7)) + (Val(Me.txtFields(3)) * Val(Text1)) / 1000
  Me.txtFields(9) = Val(Me.txtFields(9)) + (Val(Me.txtFields(3)) * Val(Text1)) / 1000
 Me.txtFields(8) = Fix((Val(Me.txtFields(9)) * 1000) / Val(Me.txtFields(1)))

Case 2
'调整合同量有两种情况：1、剩余的合同量不在执行，要求退款；
'2、由于质量等其他原因，双双协商达成的以煤抵款赔赏.

'调整合同量，单价不变，变更合同合金额和结存金额
If Val(Me.txtFields(3)) + Val(Text2) < 0 Then
  MsgBox "结余量不足以退减" & Val(Text2) & "公斤"
  Exit Sub
End If
'Me.txtFields(3) = ""
 Me.txtFields(1) = Val(Me.txtFields(1)) + Val(Text2.Text)
 Me.txtFields(3) = Val(Me.txtFields(3)) + Val(Text2.Text)

 '合同金额=原合同金额+合同调整量*本合同单价
 Me.txtFields(9) = Val(Me.txtFields(9)) + Val(Me.txtFields(8)) * (Val(Text2.Text) / 1000)
 结余金额 = 原结余金额 + 合同调整量 * 本合同单价
' MsgBox (Val(Me.txtFields(3).Text) * Val(Text2.Text)) / 1000
  Me.txtFields(7) = Val(Me.txtFields(7)) + (Val(Me.txtFields(8)) * (Val(Text2.Text) / 1000))

End Select
jl_hth = Me.txtFields(0)
jl_htl = Val(Me.txtFields(1))
jl_dj = Val(Me.txtFields(8))
jl_je = Val(Me.txtFields(9))
jl_wfl = Val(Me.txtFields(3))
jl_jcje = Val(Me.txtFields(7))
jl_yfl = Val(Me.txtFields(2))
jl_hwm = Val(Me.txtFields(4))
jl_fhr = Val(Me.txtFields(5))
jl_fhdw = Val(Me.txtFields(6))



dd = MsgBox("售煤合同已调整，是否保存调整结果？", 36, "保存调整结果")

If dd = 6 Then

'保存调整结果

cn.Execute "update htk set  hth='" _
& jl_hth & "', htl=" _
& jl_htl & " & ", yfl = "" _
& tyfl & " & ", wfl = "" _
& jl_wfl & ", hwm='" _
 & jl_hwm & "', fhr='" _
 & jl_fhr & "', fhdw='" _
 & txtFields(6) & " ,dj=" _
 & tdj & ",je=" _
 & tje & ", htldx='" _
 & ChMoney2(Str(thtl)) & ", jedx='" _
 & Up(Str(tje)) & "' ,sj='" _
 & Me.Text4.Text & " ,jcje=" _
 & tjcje & ",htldx='" _
 & ChMoney2(jl_htl) & "',jedx='" _
 & ChMoney(tje) & "' where hth='" & jl_hth & "'"
 Else
 Command7_Click
 Exit Sub
End If
tx = True
End Sub

Private Sub Command2_Click()
Dim tbkd As String '表头
Dim tkje As Long '退补款金额
Dim tkdj As Long '单位价差
Dim tkhtl As Long
If Me.Option1 = True Then
 tkdj = Val(Me.Text1.Text)
 If tkdj > 0 Then
  tbkd = "补款"
  Else
  tbkd = "退款"
  End If
  httzyl.Label10(2).Caption = tbkd & "金额"
  httzyl.Label1(2).Caption = jl_qym & tbkd & "单"
  httzyl.Label13(0).Caption = txtFields(6)
  httzyl.Label38(0).Caption = txtFields(5)
  httzyl.Label39(0).Caption = txtFields(14)
  httzyl.Label40(0).Caption = txtFields(0).Text
  httzyl.Label41(0).Caption = txtFields(4)
  httzyl.Label42(0).Caption = Val(txtFields(3)) / 1000
  httzyl.Label43(0).Caption = txtFields(15)
  httzyl.Label44(0).Caption = Abs(tkdj)
  httzyl.Label55(0).Caption = ChMoney(Abs(twfl * tkdj) / 1000)
  httzyl.Label57(0).Caption = jl_sby
  httzyl.Label32(0).Caption = txtFields(10)
   Commandd (Abs(twfl * tkdj) / 1000)
     httzyl.Show
 End If
  If Me.Option2 = True Then
     tkhtl = Val(Me.Text2.Text)
    If tkdj > 0 Then
      tbkd = "补款"
    Else
      tbkd = "退款"
    End If
httzyl.Label9(2).Caption = "单价"
 httzyl.Label10(2).Caption = tbkd & "金额"
 httzyl.Label1(2).Caption = jl_qym & tbkd & "单"
  httzyl.Label13(0).Caption = txtFields(6)
  httzyl.Label38(0).Caption = txtFields(5)
  httzyl.Label39(0).Caption = txtFields(14)
  httzyl.Label40(0).Caption = txtFields(0).Text
  httzyl.Label41(0).Caption = txtFields(4)
  httzyl.Label42(0).Caption = tkhtl / 1000
  httzyl.Label43(0).Caption = txtFields(15)
  httzyl.Label44(0).Caption = txtFields(8)
  httzyl.Label55(0).Caption = ChMoney(Abs(Val(txtFields(8)) * tkhtl) / 1000)
  httzyl.Label57(0).Caption = jl_sby
  httzyl.Label32(0).Caption = txtFields(10)
   Commandd (Abs(Val(txtFields(8)) * tkhtl) / 1000)
     httzyl.Show
 End If
 End Sub
Private Sub Command4_Click()
Unload Me
End Sub
Private Sub Command5_Click()
MonthView1.Visible = True
End Sub

Private Sub Command6_Click()
Dim tbkd As String '表头
Dim tkje As Long '退补款金额
Dim tkdj As Long '单位价差
Dim tkhtl As Long
Dim msg As Integer
'‘ httzyl.Label1(2).Caption = jl_qym & "结算单"

If Val(Me.txtFields(3).Text) > 0 Then
  msg = MsgBox("该合同尚未完全执行，如要结算，必须先做退款处理，" + Chr(10) + Chr(13) + "调整合同内容后，方能进行结算。进行调整吗？", 36, "提示")
  If msg = 6 Then
   Me.Text2.Text = -Val(Me.txtFields(3))
   Me.Option2.Value = True
   Command1_Click
  
    If Me.Option2 = True Then
         tkhtl = Val(Me.Text2.Text)
            If tkdj > 0 Then
                tbkd = "补款"
             Else
               tbkd = "退款"
             End If
       httzyl.Label9(2).Caption = "单价"
       httzyl.Label10(2).Caption = tbkd & "金额"
       httzyl.Label1(2).Caption = jl_qym & tbkd & "单"
        httzyl.Label13(0).Caption = txtFields(6)
        httzyl.Label38(0).Caption = txtFields(5)
        httzyl.Label39(0).Caption = txtFields(14)
        httzyl.Label40(0).Caption = txtFields(0).Text
        httzyl.Label41(0).Caption = txtFields(4)
        httzyl.Label42(0).Caption = tkhtl / 1000
        httzyl.Label43(0).Caption = txtFields(15)
        httzyl.Label44(0).Caption = txtFields(8)
        httzyl.Label55(0).Caption = ChMoney(Abs(Val(txtFields(8)) * tkhtl) / 1000)
        httzyl.Label57(0).Caption = jl_sby
        httzyl.Label32(0).Caption = txtFields(10)
         Commandd (Abs(Val(txtFields(8)) * tkhtl) / 1000)
           httzyl.Show
  End If
End If
Else
msg = MsgBox("   如果确定进行结算，合同结算后将不能恢复" + Chr(10) + Chr(13) + "或进行调整。进行结算吗？", 36, "提示")
 If msg = 6 Then
    httzyl.Label1(2).Caption = jl_qym & "结算单"
    httzyl.Label9(2).Caption = "单价"
       httzyl.Label10(2).Caption = tbkd & "结算金额"
   httzyl.Label8(2).Caption = "结算合同量"

        httzyl.Label13(0).Caption = txtFields(6)
        httzyl.Label38(0).Caption = txtFields(5)
        httzyl.Label39(0).Caption = txtFields(14)
        httzyl.Label40(0).Caption = txtFields(0).Text
        httzyl.Label41(0).Caption = txtFields(4)
        httzyl.Label42(0).Caption = tkhtl / 1000
        httzyl.Label43(0).Caption = txtFields(15)
        httzyl.Label44(0).Caption = txtFields(8)
        httzyl.Label55(0).Caption = ChMoney(Val(txtFields(9)))
        httzyl.Label57(0).Caption = jl_sby
        httzyl.Label32(0).Caption = txtFields(10)
         Commandd (Val(txtFields(9)))
          
           httzyl.Show
cn.Execute "update htk set yjs=1"
End If
End If
   



End Sub

Private Sub Command7_Click()
Me.txtFields(0) = thth
 Me.txtFields(1) = Str(thtl)
 Me.txtFields(8) = Str(tdj)
 Me.txtFields(9) = tje
  Me.txtFields(3) = Str(twfl)
  Me.txtFields(7) = tjcje
  tx = False
End Sub

Private Sub Form_Load()
On Error Resume Next
httz.Adodc1.ConnectionString = connetstr
Adodc1.RecordSource = "SELECT  hth, htl, yfl, wfl, hwm, fhr, fhdw, qydw, dj,je, sj, bz, htldx, jedx, ysfs,jsfs, fphm, tbr, fzr, id, sj1,jcje,djj FROM htk where hth='" & jl_hth & "'"
httz.Adodc1.refresh
tx = False
Me.MonthView1.Value = Now
Call dATA1
thth = Me.txtFields(0)
thtl = Val(Me.txtFields(1))
tdj = Adodc1.Recordset.Fields("dj")
tje = Adodc1.Recordset.Fields("je")
twfl = Adodc1.Recordset.Fields("wfl")
tjcje = Adodc1.Recordset.Fields("jcje")
tyfl = Adodc1.Recordset.Fields("yfl")
Me.Text4.Text = Format(Now, "yyyy-mm-dd")
End Sub

Private Sub MonthView1_DateClick(ByVal DateClicked As Date)
Text4.Text = Format(MonthView1.Value, "yyyy-mm-dd")
MonthView1.Visible = False
End Sub

Private Sub Option1_Click()
tzxx = 1
Text1.Enabled = True
Text2.Enabled = False
Text3.Enabled = False
End Sub

Private Sub Option2_Click()
Text1.Enabled = False
Text2.Enabled = True
Text3.Enabled = False

tzxx = 2
End Sub

Private Sub Option3_Click()
tzxx = 3
Text1.Enabled = False
Text2.Enabled = False
Text3.Enabled = True

End Sub
Sub dATA1()
On Error Resume Next
   txtFields(0).Text = Me.Adodc1.Recordset.Fields("hth")
   txtFields(1) = Adodc1.Recordset.Fields("htl")
   txtFields(2) = Adodc1.Recordset.Fields("yfl")
   txtFields(3) = Adodc1.Recordset.Fields("wfl")
   txtFields(4) = Adodc1.Recordset.Fields("hwm")
   txtFields(5) = Adodc1.Recordset.Fields("fhr")
   txtFields(6) = Adodc1.Recordset.Fields("fhdw")
   txtFields(7) = Adodc1.Recordset.Fields("jcje")
   txtFields(8) = Adodc1.Recordset.Fields("dj")
   txtFields(9) = Adodc1.Recordset.Fields("je")
   txtFields(10) = Adodc1.Recordset.Fields("sj")
    txtFields(14) = Adodc1.Recordset.Fields("ysfs")
    txtFields(15) = Adodc1.Recordset.Fields("jsfs")
 'Me.chkFields(20).Value = Adodc1.Recordset.Fields("djj")
   
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) = httzyl.Label54
    Set tob(1) = httzyl.Label53
    Set tob(2) = httzyl.Label52
    Set tob(3) = httzyl.Label51
    Set tob(4) = httzyl.Label50
    Set tob(5) = httzyl.Label49
    Set tob(6) = httzyl.Label48
    Set tob(7) = httzyl.Label47
    Set tob(8) = httzyl.Label46
    Set tob(9) = httzyl.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
    
    httzyl.Label34.Caption = Mid(strr, inamb + 1, 1)
      httzyl.Label35.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