frmcustomeraddresscard.frm

金算盘软件代码

      Left            =   135
      TabIndex        =   0
      Top             =   540
      Width           =   1350
   End
   Begin VB.Label lblAddress 
      AutoSize        =   -1  'True
      Caption         =   "收发地址名称(&N)"
      Height          =   180
      Index           =   4
      Left            =   135
      TabIndex        =   2
      Top             =   861
      Width           =   1350
   End
   Begin VB.Label lblAddress 
      Caption         =   "联系人(&M)"
      Height          =   195
      Index           =   3
      Left            =   3900
      TabIndex        =   8
      Top             =   540
      Width           =   1065
   End
   Begin VB.Label lblAddress 
      Caption         =   "办公电话(&O)"
      Height          =   195
      Index           =   6
      Left            =   135
      TabIndex        =   4
      Top             =   1182
      Width           =   1065
   End
   Begin VB.Label lblAddress 
      Caption         =   "住宅电话(&H)"
      Height          =   195
      Index           =   8
      Left            =   135
      TabIndex        =   6
      Top             =   1518
      Width           =   1065
   End
   Begin VB.Label lblAddress 
      Caption         =   "电子信箱(&E)"
      Height          =   195
      Index           =   11
      Left            =   135
      TabIndex        =   18
      Top             =   2190
      Width           =   1065
   End
   Begin VB.Label lblAddress 
      Caption         =   "收发地址(&S)"
      Height          =   195
      Index           =   10
      Left            =   135
      TabIndex        =   16
      Top             =   1854
      Width           =   1065
   End
   Begin VB.Label lblAddress 
      Caption         =   "传真(&F)"
      Height          =   195
      Index           =   7
      Left            =   3900
      TabIndex        =   12
      Top             =   1200
      Width           =   720
   End
   Begin VB.Label lblAddress 
      Caption         =   "邮编(&V)"
      Height          =   195
      Index           =   9
      Left            =   3900
      TabIndex        =   14
      Top             =   1530
      Width           =   720
   End
   Begin VB.Label lblAddress 
      Caption         =   "职务(&T)"
      Height          =   195
      Index           =   5
      Left            =   3900
      TabIndex        =   10
      Top             =   870
      Width           =   720
   End
End
Attribute VB_Name = "frmCustomerAddress"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
''''''''''''''''''''''''''''''''''''''''''
'单位收发地址卡片
'
'作者：苏涛
'
'接口：DelCard(lngID); AddCard(Optional strName,Optional intModal); EditCard(lngID,Optional intModal)
'
'时间:1998-07-29
'
'''''''''''''''''''''''''''''''''''''''''
Option Explicit
Option Compare Text

Private mclsGrid As Grid
Private mblnIsList As Boolean
Private mblnIsExist As Boolean
Private mblnIsChanged As Boolean
Private mblnAddressIsAdd As Boolean        '收发地址新增
Private mblnAddressCodeValid As Boolean
Private mblnIsInit As Boolean
Private mblnIsRefer As Boolean
Private mintRow As Integer
Private mlngTitleID As Long
Private mlngCustomerID As Long
Private mlngCustomerAddressID As Long

Public Function AddCard(lngCustomerID As Long, Optional strName As String = "", Optional intModal As Integer, _
    Optional ByVal IsList As Boolean = False) As Long
    Dim recCustomer As rdoResultset, strSql As String
    
    strSql = "SELECT * FROM Customer WHERE lngCustomerID=" & lngCustomerID
    Set recCustomer = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
    If recCustomer.EOF Then
        ShowMsg hwnd, "该单位不存在,不能对其收发地址进行编辑!", vbExclamation + MB_TASKMODAL, Caption
        Unload Me
    Else
        lblAddress(1).Caption = Trim(recCustomer!strCustomerCode) & "  " _
            & Trim(recCustomer!strCustomerName)
        mlngCustomerID = lngCustomerID
        mlngCustomerAddressID = 0
        Caption = "新增单位收发地址"
        InitCard strName
        mblnIsList = IsList
        Show intModal
        AddCard = mlngCustomerAddressID
    End If
    recCustomer.Close
End Function

Public Function DelCard(ByVal lngID As Long, Optional lnghWnd As Long = 0) As Boolean
    Dim strSql As String
'    Dim recSelect As rdoresultset
    Dim intMsgReturn As Integer
    Dim blnSQLExec As Boolean
    
    DelCard = False
'    strSQL = "SELECT * FROM Customer WHERE lngCustomerID=" & lngID
'    Set recSelect = gclsBase.BaseDB.openresultset(strSQL, rdopenstatic)
'    If recSelect.EOF Then
    If Not CheckIDUsed("CustomerAddress", "lngCustomerAddressID", lngID) Then
        intMsgReturn = ShowMsg(lnghWnd, "该单位收发地址不存在，不能删除！", _
            vbExclamation + vbOKOnly + MB_TASKMODAL, Caption)
'        recSelect.Close
'        frmCustomerList.IsShowCard(0) = False
        Exit Function
    End If
    If CodeUsed(lngID) Then
        intMsgReturn = ShowMsg(lnghWnd, "其它地方正在使用此单位收发地址，不能删除！", _
            vbExclamation + vbOKOnly + MB_TASKMODAL, Caption)
    Else
        intMsgReturn = ShowMsg(lnghWnd, "你确实要删除该单位收发地址吗！", _
            vbQuestion + vbOKCancel + MB_TASKMODAL, Caption)
        If intMsgReturn = vbOK Then
            strSql = "DELETE FROM CustomerAddress WHERE lngCustomerAddressID = " & lngID
            blnSQLExec = gclsBase.ExecSQL(strSql)
            If Not blnSQLExec Then
                intMsgReturn = ShowMsg(lnghWnd, "删除单位收发地址不成功！", _
                    vbExclamation + vbOKOnly + MB_TASKMODAL, Caption)
            Else
                gclsSys.SendMessage Me.hwnd, Message.msgCustomerAddress
                DelCard = True
            End If
        End If
    End If
'    recSelect.Close
'    frmCustomerList.IsShowCard(0) = False
End Function

'检查收发地址是否合法
Private Sub CheckAddressCode()
    Dim i As Integer

    For i = 1 To msgAddress.Rows - 1
        If msgAddress.RowHeight(i) <> 0 Then
            If mblnAddressIsAdd Then
                If msgAddress.TextMatrix(i, 1) = Trim$(txtAddress(0).Text) And _
                    msgAddress.TextMatrix(i, 2) = Trim$(txtAddress(2).Text) Then Exit For
            Else
                If msgAddress.TextMatrix(i, 1) = Trim$(txtAddress(0).Text) And _
                    msgAddress.TextMatrix(i, 2) = Trim$(txtAddress(2).Text) And _
                    i <> mintRow Then Exit For
            End If
        End If
    Next i
    mblnAddressCodeValid = (i >= msgAddress.Rows)
End Sub

'判断记录是否被使用（可能有多张表会使用此编码）
Private Function CodeUsed(lngID As Long) As Boolean
    CodeUsed = True
    If CheckIDUsed("ItemActivity", "lngCustomerAddressID", lngID) Then Exit Function
    If CheckIDUsed("PurchaseOrder", "lngCustomerAddressID", lngID) Then Exit Function
    If CheckIDUsed("SaleOrder", "lngCustomerAddressID", lngID) Then Exit Function
    CodeUsed = False
End Function

'进入修改单位
Public Sub EditCard(lngCustomerID As Long, ByVal lngID As Long, _
    Optional intModal As Integer = 0)
    Dim recCustomer As rdoResultset, strSql As String
    
    strSql = "SELECT * FROM Customer WHERE lngCustomerID=" & lngCustomerID
    Set recCustomer = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
    If recCustomer.EOF Then
        ShowMsg 0, "该单位不存在,不能对其收发地址进行编辑!", vbExclamation + MB_TASKMODAL, Caption
        Unload Me
    Else
        lblAddress(1).Caption = Trim(recCustomer!strCustomerCode) & "  " _
            & Trim(recCustomer!strCustomerName)
        mlngCustomerID = lngCustomerID
        mlngCustomerAddressID = lngID
        Caption = "修改单位收发地址"
        If Not InitCard() Then
            ShowMsg 0, "该单位收发地址不存在,不能进行编辑!", vbExclamation + MB_TASKMODAL, Caption
            Unload Me
        End If
        Show intModal
    End If
    recCustomer.Close
End Sub

Private Function InitCard(Optional strName As String = "") As Boolean
    Dim i As Integer
    
    mblnIsInit = True
    InitGrid
    setlistbox lstTitle, 4
    InitCard = True
    If mlngCustomerAddressID = 0 Then
        txtAddress(0).Text = GetNextCode(txtAddress(0).Text)
        For i = 1 To 8
            txtAddress(i).Text = ""
        Next i
        txtAddress(2).Text = Trim(strName)
    Else
        With msgAddress
        For i = 1 To .Rows - 1
            If .TextMatrix(i, 0) = mlngCustomerAddressID Then Exit For
        Next i
        If i < .Rows Then
            .Row = i
            msgAddress_Click
        Else
            InitCard = False
            Exit Function
        End If
        End With
    End If
    mblnIsInit = False
End Function

'刷新收发地址GRID
Private Sub InitGrid()
    Dim i As Integer
    Dim strSql As String
    
    strSql = "SELECT lngCustomerAddressID,strCustomerAddressCode AS 编码," _
        & "strCustomerAddressName AS 名称,strAddress AS 地址,strContactName " _
        & "AS 联系人,Title.strTitleName AS 职务,strFaxNumber AS 传真," _
        & "strPostalCode AS 邮编,strOfficePhoneNumber AS 办公电话," _
        & "strHomePhoneNumber AS 住宅电话,strEMail AS 电子邮件," _
        & "CustomerAddress.lngTitleID FROM CustomerAddress,Title " _
        & "WHERE CustomerAddress.lngTitleID=Title.lngTitleID(+) " _
        & "AND lngCustomerID=" & mlngCustomerID
    Set Data1.Resultset = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
    If Data1.Resultset.EOF Then
        msgAddress.Rows = 2
        msgAddress.RowHeight(1) = 0
        msgAddress.TextMatrix(1, 0) = 0
        msgAddress.RowData(1) = -1
    End If
    For i = 0 To msgAddress.Cols - 1
        msgAddress.FixedAlignment(i) = flexAlignCenterCenter
    Next i
    msgAddress.ColWidth(0) = 0
    msgAddress.ColWidth(11) = 0
    mintRow = 1
    mclsGrid.SetupStyle
End Sub

Private Sub cmdOk_Click(Index As Integer)
    Dim i As Integer, strMess As String
    
    If mblnIsExist Then Exit Sub
    With msgAddress
    Select Case Index
    Case 0
        If cmdOk(2).Enabled Then
'            If mblnAddressIsAdd Then
'                strMess = "要保存新增的企业收发地址“" & Trim$(txtAddress(0).Text) _
'                    & "”及帐号“" & Trim$(txtAddress(2).Text) & "”吗?"
'            Else
'                strMess = "要保存对企业收发地址“" & Trim$(txtAddress(0).Text) _
'                    & "”及帐号" & Trim$(txtAddress(2).Text) & "“的修改吗?"
'            End If
'            If ShowMsg(hwnd, strMess, vbQuestion + vbYesNo, Caption) = vbYes Then
                cmdOk(2).Value = True
                If Not mblnAddressCodeValid Then Exit Sub
'            End If
        Else
            If txtAddress(0).Text = "" And txtAddress(2).Text <> "" Then
                ShowMsg hwnd, "收发地址编码不能为空.", vbExclamation, Caption
                txtAddress(0).SetFocus
                Exit Sub
            ElseIf txtAddress(0).Text <> "" And txtAddress(2).Text = "" Then
                ShowMsg hwnd, "收发地址名称不能为空.", vbExclamation, Caption
                txtAddress(2).SetFocus
                Exit Sub
            End If
        End If
        If SaveCard Then Unload Me
    Case 1
        Unload Me
    Case 2
        CheckAddressCode
        If Not mblnAddressCodeValid Then
            ShowMsg hwnd, "编码" & Trim$(txtAddress(0).Text) & "及名称" & _
                Trim$(txtAddress(1).Text) & "已被使用,请重新录入!", vbExclamation + MB_TASKMODAL, Caption
            txtAddress(0).SelStart = 0
            txtAddress(0).SelLength = Len(txtAddress(0).Text)
            txtAddress(0).SetFocus
            Exit Sub
        End If
        If mblnAddressIsAdd Then
            mintRow = .Rows
            .Rows = .Rows + 1
            .TextMatrix(mintRow, 0) = 0  '新增
        Else
            .RowData(mintRow) = -5 '被修改
            cmdOk(3).Enabled = False
            mblnAddressIsAdd = True
        End If
        .TextMatrix(mintRow, 1) = txtAddress(0).Text
        .TextMatrix(mintRow, 2) = txtAddress(2).Text
        .TextMatrix(mintRow, 3) = txtAddress(7).Text
        .TextMatrix(mintRow, 4) = txtAddress(1).Text
        .TextMatrix(mintRow, 5) = lstTitle.TextMatrix(lstTitle.ReferRow, 2)
        .TextMatrix(mintRow, 6) = txtAddress(4).Text
        .TextMatrix(mintRow, 7) = txtAddress(6).Text
        .TextMatrix(mintRow, 8) = txtAddress(3).Text
        .TextMatrix(mintRow, 9) = txtAddress(5).Text
        .TextMatrix(mintRow, 10) = txtAddress(8).Text
        If lstTitle.TextMatrix(lstTitle.ReferRow, 1) = "" Then
            .TextMatrix(mintRow, 11) = 0
        Else
            .TextMatrix(mintRow, 11) = lstTitle.TextMatrix(lstTitle.ReferRow, 1)
        End If
        For i = 0 To 8
            txtAddress(i).Text = ""
        Next i
        lstTitle.Text = ""
        mblnIsChanged = True
        cmdOk(2).Enabled = False
        cmdOk(2).Caption = "新增(&A)"
        txtAddress(0).SetFocus
    Case 3
        If msgAddress.Row = 0 Or msgAddress.RowHeight(msgAddress.Row) = 0 Then Exit Sub
        If CodeIsUsed(msgAddress.TextMatrix(msgAddress.Row, 0)) Then
            ShowMsg Me.hwnd, "单位收发地址已有业务发生,不能删除！", _
                vbExclamation + MB_TASKMODAL, "删除单位收发地址"
        ElseIf ShowMsg(hwnd, "您确实要删除单位收发地址“" & txtAddress(0).Text _
            & "” “" & txtAddress(2).Text & "”吗？", _
            vbQuestion + vbYesNo + vbDefaultButton2, "删除单位收发地址") = vbYes Then
            msgAddress.RowData(mintRow) = -1   '被删除
            msgAddress.RowHeight(mintRow) = 0
            For i = 0 To 8
                txtAddress(i).Text = ""
            Next i
            lstTitle.Text = ""
            mlngTitleID = 0
            mblnAddressIsAdd = True
            mblnIsChanged = True