金蝶KIS单据中如何增加插件实现一些操作（抛砖引玉）

core130

有批发行业的客户在做出库单时，希望能在录单的同时记录商品的序列号
举个例子，发一批商品A，100件，那么流水号也就是商品的一个特殊识别码比如是A001,A002,A003....A100，如果是要记录每一个流水码，那么在录入单据时就要录入100次商品的流水码，有什么办法可以实现方便快捷的录入吗，利用DLL插件就可以实现
先上效果图：

  



本插件需要增加两列自定义列FEntrySelfB0136和FEntrySelfB0137，FEntrySelfB0136是录入单元，而FEntrySelfB0137是我们需要的数据单元，在查询的时候就可以通过对FEntrySelfB0137的过滤就能查到相应流水号的商品发货信息了！
其中FEntrySelfB0137列的长度需要在企业管理器中调整成自己需要的长度！

下面是本插件的VB代码
Option Explicit
Private WithEvents m_BillTransfer As KISBillTransfer.Bill
Private objconn As Object
Private iColFEntrySelfB0136 As Long
Private FSupplyID   As Long
Private iColFSupplyID   As Long
Private Sub m_BillTransfer_BillInitialize()
    '单据初始化时间
    '例如给单据增加自定义菜单
   iColFEntrySelfB0136 = GetCtlOrderByFieldName("FEntrySelfB0136", 1)
    iColFSupplyID = GetCtlOrderByFieldName("FSupplyID", 0)
End Sub
Private Sub m_BillTransfer_EndSave(ByVal BillNo As String)
On Error GoTo myer
Dim i As Long
Dim sn As String
Dim rs As ADODB.Recordset
Dim sqltemp As String
Dim FinterID As Long
    FSupplyID = Val(m_BillTransfer.HeadCtl(iColFSupplyID).vale)
    sqltemp = "select finterid from ICStockBill where fbillno='" & BillNo & "' and FSupplyID=" & FSupplyID
    Set rs = objconn.Execute(sqltemp)
    If rs.RecordCount > 0 Then
        FinterID = rs.Fields(0)
    Else
        Exit Sub
    End If
   
    i = 1
    Do While m_BillTransfer.GetGridText(i, 2) <> ""
        Dim sns() As String
        sns = Split(Replace(m_BillTransfer.GetGridText(i, iColFEntrySelfB0136), "，", ","), ",")
        Dim j As Integer
        For j = 0 To UBound(sns)
            sn = sn & Allsn(sns(j)) & ","
        Next j
   
        'sn = Allsn(m_BillTransfer.GetGridText(i, iColFEntrySelfB0136))
        If sn <> "" Then
            sn = Left(sn, Len(sn) - 1)
            Set rs = New ADODB.Recordset
            sqltemp = "update ICStockBillEntry set FEntrySelfB0137='" & sn & "' where finterid=" & FinterID & " and fentryid=" & i
            Set rs = objconn.Execute(sqltemp)
        End If
        i = i + 1
        
    Loop
    Exit Sub
myer:
MsgBox Err.Description & " 单据保存出错，请把当前单据删除重新录入！"
Exit Sub
End Sub
Private Function Allsn(strOrg As String) As String
If strOrg <> "" Then
        Dim Strsn As String
        Dim Strsnorg As String
        Dim Strsnf As String
        Dim A As String
        Dim B As String
        Dim Be As String
        Dim Strtmp As String
        Dim Allnumber As Boolean
        Dim Strsne As String
        Strsnorg = strOrg
        If InStr(1, Strsnorg, "..") > 0 Then
            Strsnf = Left(Strsnorg, InStr(1, Strsnorg, "..") - 1)
            Strsne = Right(Strsnorg, Len(Strsnorg) - InStr(1, Strsnorg, ".."))
            Dim i As Integer
            For i = 1 To Len(Strsnf) - 1
                If Not IsNumeric(Mid(Strsnf, Len(Strsnf) - i, 1)) Then
                    A = Left(Strsnf, Len(Strsnf) - i)
                    B = Right(Strsnf, i)
                    Be = Right(Strsne, i)
                    Allnumber = True
                    Exit For
                End If
            Next i
            Dim ii As Long
            If Allnumber = True Then
                For ii = 0 To Val(Be) - Val(B)
                    Strtmp = A & Right(Format(Val(B) + ii, "0000000000"), Len(B))
                    Strsn = Strsn & "," & Strtmp
                Next ii
            Else
                For ii = 0 To Val(Strsne) - Val(Strsnf)
                    Strtmp = Right(Format(Val(Strsnf) + ii, "0000000000"), Len(Strsnf))
                    Strsn = Strsn & "," & Strtmp
                Next ii
            End If
            Strsn = Right(Strsn, Len(Strsn) - 1)
            Allsn = Strsn
                       
        End If
    End If

End Function

Private Function GetCtlOrderByFieldName(ByVal FieldName As String, Optional ByVal ObjType As Long = 1) As Long
   
    On Error GoTo HOver
   
    Dim i As Long
   
    If FieldName = "" Then GoTo HOver
   
    If ObjType = 1 Then
        For i = 1 To UBound(m_BillTransfer.EntryCtl)
            If VBA.UCase(VBA.Trim(m_BillTransfer.EntryCtl(i).FieldName)) = VBA.UCase(VBA.Trim(FieldName)) Then
                GetCtlOrderByFieldName = Val(m_BillTransfer.EntryCtl(i).FCtlOrder)
                Exit For
            End If
        Next i
    ElseIf ObjType = 0 Then
        For i = 0 To UBound(m_BillTransfer.HeadCtl)
            'Debug.Print m_BillTransfer.HeadCtl(i).vale & " " & m_BillTransfer.HeadCtl(i).FieldName
            If VBA.UCase(VBA.Trim(m_BillTransfer.HeadCtl(i).FieldName)) = VBA.UCase(VBA.Trim(FieldName)) Then
                GetCtlOrderByFieldName = Val(m_BillTransfer.HeadCtl(i).FCtlIndex)
                Exit For
            End If
        Next i
    End If
   
    Exit Function
HOver:
    GetCtlOrderByFieldName = 0
End Function


希望能对各位有点用处！

bright_123

要好好学习VB了     要不程序都看不懂

sicoop

这个太复杂了，我相信大多数的朋友不懂VB代码，好像金蝶BOS也不需要懂得多少代码的人才能操作