clsqtgb_gb.cls

这是一个基于金蝶K/3的磅秤插件源代码。安装本差价需要金蝶K/310.0以上的版本。本插件是客户端程序。在车辆过磅时自动产生金蝶K/3的出库单。

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "clsQTGB_GB"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = True
 Option Explicit
'定义 BillEvent 接口. 必须具有的声明, 以此来获得事件
Private WithEvents m_BillInterface  As BillEvent
Attribute m_BillInterface.VB_VarHelpID = -1
Private BZChange As Boolean
Private PZChange As Boolean
Dim gGrid  As Object
Dim IsFirstTime As Boolean

 
Public Sub Show(ByVal oBillInterface As Object)
 
    'BillEvent 接口实现
    '注意: 此方法必须存在, 请勿修改
    Set m_BillInterface = oBillInterface
    IsFirstTime = True
End Sub

Private Sub Class_Terminate()
 
    '释放接口对象
    '注意: 此方法必须存在, 请勿修改
    Set m_BillInterface = Nothing

End Sub
Private Sub doLockCol()
    If isOK Then
        m_BillInterface.BillEntrys(1).BOSFields("FChuChangZhongLiang").FieldLock = False  '出厂重量
        m_BillInterface.BillEntrys(1).BOSFields("FJingChangZhongLiang").FieldLock = False '进厂重量
        
        
    Else
        m_BillInterface.BillEntrys(1).BOSFields("FChuChangZhongLiang").FieldLock = True  '出厂重量
        m_BillInterface.BillEntrys(1).BOSFields("FJingChangZhongLiang").FieldLock = True '进厂重量
    
    End If
    m_BillInterface.BillEntrys(1).BOSFields("FJingChangShiJian").FieldLock = True  '出厂时间
    m_BillInterface.BillEntrys(1).BOSFields("FChuChangShiJian").FieldLock = True '进厂时间
    m_BillInterface.BillEntrys(1).BOSFields("FZhongLiangCha").FieldLock = True '重量差
End Sub


Private Function getTime() As Date
On Error GoTo HERROR
    Dim Rt As ADODB.Recordset
    Set Rt = m_BillInterface.K3Lib.GetData("select getdate()")
    getTime = Rt.Fields(0).Value
    Rt.Close
    Set Rt = Nothing
    Exit Function
HERROR:
    MsgBox Err.Description, vbCritical
    
End Function


Private Sub m_BillInterface_AfterFillRow(ByVal lRow As Long, ByVal dctPage As KFO.IDictionary, ByVal dctEntryData As KFO.IDictionary, ByVal dctLink As KFO.IDictionary)
    doLockCol
'If IsFirstTime Then
'    If TypeName(m_BillInterface.GetActiveCtl) = "fpSpread" Then
'        Set gGrid = m_BillInterface.GetActiveCtl
        'gGrid.OperationMode = OperationModeRow
'        IsFirstTime = False
'    End If
'End If
End Sub



Private Sub m_BillInterface_AfterNewBill()
    m_BillInterface.BillHeads(1).BOSFields("FDate").Value = getTime
    doLockCol
End Sub

Private Sub m_BillInterface_BeforeSave(bCancel As Boolean)
    Dim I As Integer
    
    For I = 1 To gGrid.DataRowCnt
        gGrid.Row = I
        gGrid.Col = 4
        If gGrid.Text = strCar Then
            gGrid.SetActiveCell 4, I
            m_BillInterface.SetFieldValue "fchepaihao", "", I
            
        End If
    Next I
End Sub

Private Sub m_BillInterface_BeginEdit(ByVal dct As KFO.IDictionary, ByVal Col As Long, ByVal Row As Long)
On Error GoTo HERROR
    If IsFirstTime Then
        Set gGrid = m_BillInterface.GetActiveCtl
        IsFirstTime = False
    End If

    If Trim(m_BillInterface.GetFieldValue("fchepaihao", Row)) = "" Then
      m_BillInterface.SetFieldValue "fchepaihao", strCar, Row
    End If
    
    
    Exit Sub
HERROR:
    MsgBox Err.Description, vbCritical

End Sub

Private Sub m_BillInterface_Change(ByVal dct As KFO.IDictionary, ByVal dctFld As KFO.IDictionary, ByVal Col As Long, ByVal Row As Long, Cancel As Boolean)
If dct("FFieldName") = "FJingChangZhongLiang" Or dct("FFieldName") = "FChuChangZhongLiang" Then
    GetJinZhong
End If

If dct("FFieldName") = "FKeHu" Then
    If m_BillInterface.BillHeads(1).BOSFields("FKeHu").Value <> "" Then
            m_BillInterface.BillHeads(1).BOSFields("FGongYingShang").FieldLock = True
            m_BillInterface.BillHeads(1).BOSFields("FDiaoBoDanWei").FieldLock = True
    Else
            m_BillInterface.BillHeads(1).BOSFields("FGongYingShang").FieldLock = False
            m_BillInterface.BillHeads(1).BOSFields("FDiaoBoDanWei").FieldLock = False
    End If
End If
If dct("FFieldName") = "FGongYingShang" Then
    If m_BillInterface.BillHeads(1).BOSFields("FGongYingShang").Value <> "" Then
            m_BillInterface.BillHeads(1).BOSFields("FKeHu").FieldLock = True
            m_BillInterface.BillHeads(1).BOSFields("FDiaoBoDanWei").FieldLock = True
    Else
            m_BillInterface.BillHeads(1).BOSFields("FKeHu").FieldLock = False
            m_BillInterface.BillHeads(1).BOSFields("FDiaoBoDanWei").FieldLock = False
    End If
End If
If dct("FFieldName") = "FDiaoBoDanWei" Then
    If m_BillInterface.BillHeads(1).BOSFields("FDiaoBoDanWei").Value <> "" Then
            m_BillInterface.BillHeads(1).BOSFields("FGongYingShang").FieldLock = True
            m_BillInterface.BillHeads(1).BOSFields("FKeHu").FieldLock = True
    Else
            m_BillInterface.BillHeads(1).BOSFields("FGongYingShang").FieldLock = False
            m_BillInterface.BillHeads(1).BOSFields("FKeHu").FieldLock = False
    End If
End If


End Sub

Private Sub m_BillInterface_MenuBarClick(ByVal BOSTool As K3ClassEvents.BOSTool, Cancel As Boolean)
    Dim strSql As String
    Dim I As Integer
    Dim J As Integer
    Dim rowdata As String
    Dim SumFp As Double
    
        'TODO: 请在此处添加代码响应事件 MenuBarClick
     
    
             
        Select Case BOSTool.ToolName
        Case "butJCGB"
            '此处添加处理 butPZGB 菜单对象的 Click 事件
            doGetJCZL
        Case "butCCGB"
            '此处添加处理 butPZGB 菜单对象的 Click 事件
            doGetCCZL
            
        Case "butJS"
            '此处添加处理 butPZGB 菜单对象的 Click 事件
            FrmPassword.Show 1
            doLockCol
        Case "butJIAS"
            '此处添加处理 butJIAS 菜单对象的 Click 事件
             isOK = False
             doLockCol
        Case Else
        End Select

End Sub

Private Sub m_BillInterface_MenuBarInitialize(ByVal oMenuBar As K3ClassEvents.MenuBar)
 
    Dim oTool   As K3ClassEvents.BOSTool
    Dim oBand   As K3ClassEvents.BOSBand
 
'*************** 开始新增 BOS 菜单 ***************
 
    '新增 butPZGB 菜单对象，并设置属性
    Set oTool = oMenuBar.BOSTools.Add("butJCGB")
    With oTool
        .Caption = "进厂过磅"
        .ToolTipText = "进厂过磅"
        .Description = "进厂过磅"
        .ShortcutKey = 35
        .Visible = True
        .Enabled = True
        .BeginGroup = False
        .ToolPicture = App.Path + "\guobang.ico"
        .SetPicture 0, vbButtonFace
    End With
 
    Set oBand = oMenuBar.BOSBands("BandToolBar")
    oBand.BOSTools.InsertBefore "mnuFileExit", oTool     '将菜单对象插入指定工具栏
    
    Set oBand = oMenuBar.BOSBands("mnuCust")
    oBand.BOSTools.InsertBefore "", oTool     '将菜单对象插入指定工具栏
    
    
    
    Set oTool = oMenuBar.BOSTools.Add("butCCGB")
    With oTool
        .Caption = "出厂过磅"
        .ToolTipText = "出厂过磅"
        .Description = "出厂过磅"
        .ShortcutKey = 36
        .Visible = True
        .Enabled = True
        .BeginGroup = False
        .ToolPicture = App.Path + "\guobang.ico"
        .SetPicture 0, vbButtonFace
    End With
 
    Set oBand = oMenuBar.BOSBands("BandToolBar")
    oBand.BOSTools.InsertBefore "mnuFileExit", oTool     '将菜单对象插入指定工具栏
    
    Set oBand = oMenuBar.BOSBands("mnuCust")
    oBand.BOSTools.InsertBefore "", oTool     '将菜单对象插入指定工具栏

 
    Set oTool = oMenuBar.BOSTools.Add("butJS")
    With oTool
        .Caption = "解锁"
        .ToolTipText = "解锁"
        .Description = "解锁"
        .ShortcutKey = 0
        .Visible = True
        .Enabled = True
        .BeginGroup = False
        .ToolPicture = App.Path + "\lopen.bmp"
        .SetPicture 0, vbButtonFace
    End With
 
    Set oBand = oMenuBar.BOSBands("BandToolBar")
    oBand.BOSTools.InsertBefore "mnuFileExit", oTool    '将菜单对象插入指定工具栏
    Set oBand = oMenuBar.BOSBands("mnuCust")
    oBand.BOSTools.InsertBefore "", oTool     '将菜单对象插入指定工具栏
    
    
    Set oTool = oMenuBar.BOSTools.Add("butJIAS")
    With oTool
        .Caption = "加锁"
        .ToolTipText = "加锁"
        .Description = "加锁"
        .ShortcutKey = 0
        .Visible = True
        .Enabled = True
        .BeginGroup = False
        .ToolPicture = App.Path + "\LSHUT.bmp"
        .SetPicture 0, vbButtonFace
    End With
 
    Set oBand = oMenuBar.BOSBands("BandToolBar")
    oBand.BOSTools.InsertBefore "mnuFileExit", oTool    '将菜单对象插入指定工具栏
    Set oBand = oMenuBar.BOSBands("mnuCust")
    oBand.BOSTools.InsertBefore "", oTool     '将菜单对象插入指定工具栏

 
 InitCS

End Sub
Private Sub InitCS()
On Error GoTo HERROR
    Dim Rt As ADODB.Recordset
    Set Rt = m_BillInterface.K3Lib.GetData("select * from t_NHG_SystemProfile")
    InitGuoBangCs Rt
    Rt.Close
    Set Rt = Nothing
    isOK = False
    Exit Sub
HERROR:
    MsgBox Err.Description, vbCritical

End Sub
Private Sub GetJinZhong()
On Error GoTo HERROR
    Dim dJingChang As Double
    Dim dChuChang As Double
    
    '计算净重
    If m_BillInterface.BillEntrys(1).BOSFields("FChuChangZhongLiang").Value = "" Then m_BillInterface.BillEntrys(1).BOSFields("FChuChangZhongLiang").Value = "0"
    If m_BillInterface.BillEntrys(1).BOSFields("FJingChangZhongLiang").Value = "" Then m_BillInterface.BillEntrys(1).BOSFields("FJingChangZhongLiang").Value = "0"
    
    dChuChang = m_BillInterface.BillEntrys(1).BOSFields("FChuChangZhongLiang").Value
    
    dJingChang = m_BillInterface.BillEntrys(1).BOSFields("FJingChangZhongLiang").Value
    
    m_BillInterface.BillEntrys(1).BOSFields("FZhongLiangCha").Value = dJingChang - dChuChang

    Exit Sub
HERROR:
    MsgBox Err.Description, vbCritical

End Sub

Private Sub doGetJCZL()
On Error GoTo HERROR
    Dim ret As Integer
    Dim I As Integer
    Dim SumJingZhong As Double
    Dim iindex As Long
    Dim spkey As String
    Dim dctTemp As KFO.Dictionary
    
    If Trim(m_BillInterface.BillEntrys(1).BOSFields("FChePaiHao").Value) = strCar Or Trim(m_BillInterface.BillEntrys(1).BOSFields("FChePaiHao").Value) = "" Then
        MsgBox "请先填写车牌号码！"
        Exit Sub
    End If
    
    
    If Val(m_BillInterface.BillEntrys(1).BOSFields("FJingChangZhongLiang").Value) <> 0 Then
        ret = MsgBox("车牌号(" + m_BillInterface.BillEntrys(1).BOSFields("FChePaiHao").Value + ")的进厂重量已经存在，是否重新过磅？", vbYesNo)
        If ret = vbNo Then Exit Sub
    End If
    
    Frmgb.Show vbModal
    If SjZl = "-1" Then Exit Sub
    
    
    '过磅调整
    SjZl = CStr(Val(SjZl) + Val(strGBTZ))
    
    '毛重
    
    m_BillInterface.BillEntrys(1).BOSFields("FJingChangZhongLiang").Value = SjZl
    
    
    '进厂时间
    If Trim(m_BillInterface.BillEntrys(1).BOSFields("FJingChangShiJian").Value) = "" Then
        m_BillInterface.BillEntrys(1).BOSFields("FJingChangShiJian").Value = getTime
    End If
    
    '计算净重
    GetJinZhong
    
    Set dctTemp = m_BillInterface.GetFieldInfoByKey("FJingChangZhongLiang", "", 0)
    m_BillInterface.BillCtl.SetSumData dctTemp
    Set dctTemp = m_BillInterface.GetFieldInfoByKey("FZhongLiangCha", "", 0)
    m_BillInterface.BillCtl.SetSumData dctTemp
    Exit Sub
HERROR:
    MsgBox Err.Description, vbCritical

End Sub


Private Sub doGetCCZL()
On Error GoTo HERROR
    Dim ret As Integer
    Dim I As Integer
    Dim SumJingZhong As Double
    Dim iindex As Long
    Dim spkey As String
    Dim dctTemp As KFO.Dictionary
    
    
    If Trim(m_BillInterface.BillEntrys(1).BOSFields("FChePaiHao").Value) = strCar Or Trim(m_BillInterface.BillEntrys(1).BOSFields("FChePaiHao").Value) = "" Then
        MsgBox "请先填写车牌号码！"
        Exit Sub
    End If
    
    
    If Val(m_BillInterface.BillEntrys(1).BOSFields("FChuChangZhongLiang").Value) <> 0 Then
        ret = MsgBox("车牌号(" + m_BillInterface.BillEntrys(1).BOSFields("FChePaiHao").Value + ")的出厂重量已经存在，是否重新过磅？", vbYesNo)
        If ret = vbNo Then Exit Sub
    End If
    
    
    Frmgb.Show vbModal
    If SjZl = "-1" Then Exit Sub
    
    
    '过磅调整
    SjZl = CStr(Val(SjZl) + Val(strGBTZ))
    
    '毛重
    
    m_BillInterface.BillEntrys(1).BOSFields("FChuChangZhongLiang").Value = SjZl
    
    
    '进厂时间
    If Trim(m_BillInterface.BillEntrys(1).BOSFields("FChuChangShiJian").Value) = "" Then
        m_BillInterface.BillEntrys(1).BOSFields("FChuChangShiJian").Value = getTime
    End If
    
    
    '计算净重
    GetJinZhong
    
    Set dctTemp = m_BillInterface.GetFieldInfoByKey("FChuChangZhongLiang", "", 0)
    m_BillInterface.BillCtl.SetSumData dctTemp
    Set dctTemp = m_BillInterface.GetFieldInfoByKey("FZhongLiangCha", "", 0)
    m_BillInterface.BillCtl.SetSumData dctTemp

    Exit Sub
HERROR:
    MsgBox Err.Description, vbCritical

End Sub