frmsbill.frm

一个设计销售订单的源码；可以通过修改成为通用的单据控件

         AllowUserResizing=   1
         SelectionMode   =   1
         GridLines       =   1
         GridLinesFixed  =   2
         GridLineWidth   =   1
         Rows            =   1
         Cols            =   1
         FixedRows       =   0
         FixedCols       =   0
         RowHeightMin    =   275
         RowHeightMax    =   0
         ColWidthMin     =   0
         ColWidthMax     =   0
         ExtendLastCol   =   -1  'True
         FormatString    =   $"frmSBill.frx":05BB
         ScrollTrack     =   0   'False
         ScrollBars      =   0
         ScrollTips      =   0   'False
         MergeCells      =   0
         MergeCompare    =   0
         AutoResize      =   0   'False
         AutoSizeMode    =   0
         AutoSearch      =   1
         AutoSearchDelay =   3
         MultiTotals     =   -1  'True
         SubtotalPosition=   1
         OutlineBar      =   0
         OutlineCol      =   0
         Ellipsis        =   2
         ExplorerBar     =   7
         PicturesOver    =   0   'False
         FillStyle       =   0
         RightToLeft     =   0   'False
         PictureType     =   0
         TabBehavior     =   0
         OwnerDraw       =   0
         Editable        =   2
         ShowComboButton =   1
         WordWrap        =   0   'False
         TextStyle       =   0
         TextStyleFixed  =   0
         OleDragMode     =   0
         OleDropMode     =   0
         DataMode        =   0
         VirtualData     =   -1  'True
         DataMember      =   ""
         ComboSearch     =   3
         AutoSizeMouse   =   -1  'True
         FrozenRows      =   0
         FrozenCols      =   0
         AllowUserFreezing=   0
         BackColorFrozen =   0
         ForeColorFrozen =   0
         WallPaperAlignment=   9
      End
      Begin VB.Label lblName 
         AutoSize        =   -1  'True
         BackStyle       =   0  'Transparent
         Caption         =   "来件名称"
         Height          =   180
         Left            =   7500
         TabIndex        =   17
         Top             =   750
         Width           =   720
      End
      Begin VB.Label Label1 
         AutoSize        =   -1  'True
         BackStyle       =   0  'Transparent
         Caption         =   "来件类型"
         Height          =   180
         Left            =   4800
         TabIndex        =   16
         Top             =   750
         Width           =   720
      End
      Begin VB.Label lblDept 
         AutoSize        =   -1  'True
         BackStyle       =   0  'Transparent
         Caption         =   "单位名称"
         Height          =   180
         Left            =   180
         TabIndex        =   15
         Top             =   750
         Width           =   720
      End
      Begin VB.Label lblEndDate 
         AutoSize        =   -1  'True
         BackStyle       =   0  'Transparent
         Caption         =   "至"
         Height          =   180
         Left            =   3090
         TabIndex        =   14
         Top             =   360
         Width           =   180
      End
      Begin VB.Label lblOrderDate 
         AutoSize        =   -1  'True
         BackStyle       =   0  'Transparent
         Caption         =   "接件时间"
         Height          =   180
         Left            =   180
         TabIndex        =   13
         Top             =   360
         Width           =   720
      End
      Begin VB.Label lblID 
         AutoSize        =   -1  'True
         Caption         =   "业务号："
         Height          =   180
         Left            =   5730
         TabIndex        =   12
         Top             =   360
         Width           =   720
      End
   End
End
Attribute VB_Name = "frmSBill"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Private mblnInit        As Boolean
Private mblnOK          As Boolean
'网格列常量
Private Const conID = 0


'======================================================
' 功  能：取得业务号
' 返回值：
' 参  数：rstItem   ---   记录集  (t_GP_Item)
'======================================================
Public Function GetID() As String
On Error Resume Next
        
    If Not mblnInit Then mblnInit = Init
    mblnOK = False
    With vfgList
        .Redraw = flexRDNone
        Call RefreshList
        .Redraw = flexRDBuffered
        If .Rows > 1 Then .Select 1, 2
    End With
    Me.Show vbModal
    If mblnOK Then
        With vfgList
            GetID = .TextMatrix(.Row, conID)
        End With
    End If
    Exit Function
Err:
    Call ErrTreat(Err.Number, Err.Source, Err.Description)
End Function

'初始化
Private Function Init() As Boolean
On Error GoTo Err
    Dim strSQL          As String
    Dim rstTmp          As ADODB.Recordset
    dtpEnd.Value = Now
    dtpBegin.Value = DateAdd("m", "-1", dtpEnd.Value)
    strSQL = "SELECT FName='全部',FNumber='' Union ALL " & _
             "SELECT FName,FNumber FROM t_GP_Item WHERE FClassNumber='4' ORDER BY FNumber"
    Set rstTmp = GetRecordset(strSQL)
    '来件类型
    With vfgCbo(0)
        .ColComboList(0) = .BuildComboList(rstTmp, "FName,FNumber", "FNumber")
    End With
    Set rstTmp = Nothing
    Init = True
    Exit Function
Err:
    Set rstTmp = Nothing
    Call ErrTreat(Err.Number, Err.Source, Err.Description)
End Function

'显示
Private Sub RefreshList()
On Error GoTo Err
    Dim strFilter   As String
    Dim strSQL      As String
    Dim rstTmp      As ADODB.Recordset
    
    strFilter = " AND FDate>='" & Format(dtpBegin.Value, "yyyy-MM-dd hh:mm") & "' AND FDate<='" & Format(dtpEnd.Value, "yyyy-MM-dd hh:mm") & "'"
    If Not Len(Trim(txtID.Text)) = 0 Then _
        strFilter = strFilter & " AND FID like '%" & Trim(txtID.Text) & "%'"
    If Not Len(Trim(txtDept.Text)) = 0 Then _
        strFilter = strFilter & " AND FDept like '%" & Trim(txtDept.Text) & "%'"
    With vfgCbo(0)
        If Not (.TextMatrix(0, 0) = "全部" Or .TextMatrix(0, 0) = "") Then _
            strFilter = strFilter & " AND FType='" & Trim(.TextMatrix(0, 0)) & "'"
    End With
    If Not Len(Trim(txtName.Text)) = 0 Then _
        strFilter = strFilter & " AND FName like '%" & Trim(txtName.Text) & "%'"
    strSQL = "SELECT FID,FDate,FEndDate,FDept,FType,FName,FNo,FDonne,FHurry,FSecret,FIsNo,FBillID " & _
             "FROM t_GP_JDBill WHERE 1=1 " & strFilter
    Set rstTmp = GetRecordset(strSQL)
    With vfgList
        .Redraw = flexRDNone
        Set .DataSource = rstTmp
        .Redraw = flexRDBuffered
        If .Rows > 1 Then .Select 1, 0
    End With
    Set rstTmp = Nothing
    Exit Sub
Err:
    Set rstTmp = Nothing
    Call ErrTreat(Err.Number, Err.Source, Err.Description)
End Sub

Private Sub cmdCancel_Click()
    Me.Hide
End Sub

Private Sub cmdOK_Click()
    With vfgList
        If .Row < 1 Then Exit Sub
    End With
    mblnOK = True
    Me.Hide
End Sub

Private Sub cmdRefresh_Click()
    Call RefreshList
End Sub

Private Sub vfgList_DblClick()
    With vfgList
        If .MouseRow > 0 Then Call cmdOK_Click
    End With
End Sub

'单位只允许F7选择
Private Sub txtDept_GotFocus()
    Clipboard.Clear
End Sub

'选择单位
Private Sub txtDept_KeyDown(KeyCode As Integer, Shift As Integer)
On Error GoTo Err
    Dim rstItem     As ADODB.Recordset
    If KeyCode = vbKeyF7 Then
        If GetItemRst("1", rstItem) Then
            If frmItem.GetItem(rstItem) Then
                txtDept.Text = Trim(rstItem!FName)
                txtDept.Tag = Trim(rstItem!FNumber)
                Set rstItem = Nothing
            End If
        End If
    End If
    Exit Sub
Err:
    Set rstItem = Nothing
    Call ErrTreat(Err.Number, Err.Source, Err.Description)
End Sub