📄 arrangerecord.frm
字号:
VERSION 5.00
Object = "{86CF1D34-0C5F-11D2-A9FC-0000F8754DA1}#2.0#0"; "MSCOMCT2.OCX"
Begin VB.Form frmArrangeRecord
BorderStyle = 3 'Fixed Dialog
Caption = "接洽与洽谈记录"
ClientHeight = 4890
ClientLeft = 45
ClientTop = 330
ClientWidth = 5730
Icon = "ArrangeRecord.frx":0000
KeyPreview = -1 'True
LinkTopic = "Form1"
MaxButton = 0 'False
MinButton = 0 'False
ScaleHeight = 4890
ScaleWidth = 5730
ShowInTaskbar = 0 'False
StartUpPosition = 3 '窗口缺省
Begin VB.CommandButton cmdSaveNew
Caption = "保存并新建"
Height = 375
Left = 780
TabIndex = 6
Top = 4380
Width = 1395
End
Begin VB.CommandButton cmdSaveClose
Caption = "保存并关闭"
Height = 375
Left = 2310
TabIndex = 7
Top = 4380
Width = 1395
End
Begin VB.CommandButton cmdClose
Caption = "关闭"
Height = 375
Left = 3900
TabIndex = 8
Top = 4380
Width = 1395
End
Begin VB.Frame Frame1
Height = 4245
Left = 60
TabIndex = 9
Top = -30
Width = 5625
Begin VB.CommandButton cmdChose
Caption = "..."
BeginProperty Font
Name = "Arial"
Size = 9
Charset = 0
Weight = 700
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 345
Left = 5010
TabIndex = 1
Top = 240
Width = 345
End
Begin MSComCtl2.DTPicker dtpDate
Height = 315
Left = 1140
TabIndex = 2
Top = 660
Width = 1695
_ExtentX = 2990
_ExtentY = 556
_Version = 393216
Format = 30212096
CurrentDate = 37642
End
Begin VB.TextBox txtType
Height = 315
Left = 1140
TabIndex = 3
Text = "Text4"
Top = 1080
Width = 2145
End
Begin VB.TextBox txtMemo
Height = 2625
Left = 1140
MultiLine = -1 'True
TabIndex = 5
Text = "ArrangeRecord.frx":000C
Top = 1470
Width = 4365
End
Begin VB.TextBox txtRelaMan
Height = 315
Left = 4230
TabIndex = 4
Text = "Text2"
Top = 1080
Width = 1275
End
Begin VB.TextBox txtName
Enabled = 0 'False
Height = 315
Left = 1140
TabIndex = 0
Text = "Text1"
Top = 270
Width = 3675
End
Begin VB.Label Label5
Caption = "洽谈内容及结果："
Height = 975
Left = 180
TabIndex = 14
Top = 1500
Width = 795
End
Begin VB.Label Label4
Caption = "联系人："
Height = 255
Left = 3480
TabIndex = 13
Top = 1140
Width = 1155
End
Begin VB.Label Label3
Caption = "何类业务："
Height = 405
Left = 180
TabIndex = 12
Top = 1080
Width = 945
End
Begin VB.Label Label2
Caption = "日期："
Height = 435
Left = 180
TabIndex = 11
Top = 720
Width = 675
End
Begin VB.Label Label1
Caption = "客户名称："
Height = 315
Left = 180
TabIndex = 10
Top = 330
Width = 975
End
End
End
Attribute VB_Name = "frmArrangeRecord"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Public mbAdd As Boolean
Public mARID As Long
Private Sub mClear()
'清空控件的值
txtName.Text = ""
txtName.Tag = ""
dtpDate.Value = Now
txtMemo.Text = ""
txtRelaman.Text = ""
txtType.Text = ""
End Sub
Private Function mbSaveArrangeRecord() As Boolean
'**********************************************
'
'保存当前的单据
'
'**********************************************
Dim sSql As String
Dim Rs As New ADODB.Recordset
Dim lID As Long
On Error GoTo ErrSave
'检验数据正确性
If mbCheckOk() = False Then mbSaveArrangeRecord = False: Exit Function
Screen.MousePointer = vbHourglass
Rs.Open "Select max(AR_ID) from ArrangeRecord", CN
If IsNull(Rs.Fields(0)) Then
lID = 1
Else
lID = CLng(Rs.Fields(0)) + 1
End If
Rs.Close
If mbAdd = False Then
sSql = "Delete from ArrangeRecord where AR_ID=" & mARID
sSql = sSql & vbCrLf & "Insert ArrangeRecord (AR_ID,AR_AID,AR_Date,AR_Type,AR_RelaMan,AR_Memo) values("
sSql = sSql & mARID & ","
sSql = sSql & txtName.Tag & ",'"
sSql = sSql & Format(dtpDate.Value, "yyyy-mm-dd") & "','"
sSql = sSql & DoubleQuote(txtType.Text) & "','"
sSql = sSql & DoubleQuote(txtRelaman.Text) & "','"
sSql = sSql & DoubleQuote(txtMemo.Text) & "')"
Else
sSql = "Insert ArrangeRecord (AR_ID,AR_AID,AR_Date,AR_Type,AR_RelaMan,AR_Memo) values("
sSql = sSql & lID & ","
sSql = sSql & txtName.Tag & ",'"
sSql = sSql & Format(dtpDate.Value, "yyyy-mm-dd") & "','"
sSql = sSql & DoubleQuote(txtType.Text) & "','"
sSql = sSql & DoubleQuote(txtRelaman.Text) & "','"
sSql = sSql & DoubleQuote(txtMemo.Text) & "')"
End If
If sSql <> "" Then
CN.Execute sSql
mbSaveArrangeRecord = True
Else
mbSaveArrangeRecord = False
End If
Screen.MousePointer = vbDefault
Exit Function
ErrSave:
Screen.MousePointer = vbDefault
mbSaveArrangeRecord = False
gShowMsg "保存洽谈记录时出错 frmArrangeRecord.mbSaveArrangeRecord"
End Function
Private Function mbCheckOk() As Boolean
'**********************************************
'
'校验输入内容的合法性
'
'**********************************************
Dim sSql As String
Dim Rs As New ADODB.Recordset
On Error GoTo ErrCheckOk
If txtName.Tag = "" Then
MsgBox "请选择客户名称！！！", vbInformation, ""
mbCheckOk = False
Exit Function
Else
mbCheckOk = True
End If
Exit Function
ErrCheckOk:
Screen.MousePointer = vbDefault
mbCheckOk = False
gShowMsg "校验洽谈记录出错 frmArrangeRecord.mbCheckOK"
End Function
Private Function mbShowOldArrangeRecord() As Boolean
'***********************************************
'
'显示要修改洽谈记录
'
'***********************************************
Dim sSql As String
Dim Rs As New ADODB.Recordset
Dim iRow As Integer
On Error GoTo ErrShowOldArrangeRecord
sSql = "Select AR_ID,CT_Name,AR_AID,AR_Date,AR_Type,AR_RelaMan,AR_Memo"
sSql = sSql & vbCrLf & " from ArrangeRecord AR inner join Customers CT on CT.CT_AID=AR.AR_AID"
sSql = sSql & vbCrLf & " where AR_ID = " & mARID
Screen.MousePointer = vbHourglass
Rs.Open sSql, CN
Screen.MousePointer = vbDefault
'客户名称
txtName.Text = IIf(IsNull(Rs.Fields!CT_Name), "", Rs.Fields!CT_Name)
txtName.Tag = IIf(IsNull(Rs.Fields!AR_AID), 0, Rs.Fields!AR_AID)
'日期
dtpDate.Value = Format(IIf(IsNull(Rs.Fields!AR_Date), Now, Rs.Fields!AR_Date), "yyyy-mm-dd")
'何类业务
txtType.Text = IIf(IsNull(Rs.Fields!AR_Type), "", Rs.Fields!AR_Type)
'联系人
txtRelaman.Text = IIf(IsNull(Rs.Fields!AR_RelaMan), "", Rs.Fields!AR_RelaMan)
'洽谈记录
txtMemo.Text = IIf(IsNull(Rs.Fields!AR_Memo), "", Rs.Fields!AR_Memo)
mbShowOldArrangeRecord = True
Exit Function
ErrShowOldArrangeRecord:
Screen.MousePointer = vbDefault
mbShowOldArrangeRecord = False
gShowMsg "显示要修改的洽谈记录时出错 frmArrangeRecord.mbShowOldArrangeRecord"
End Function
Private Sub cmdChose_Click()
frmSearchArch.Show vbModal
If frmSearchArch.mArchiveID <> 0 Then
txtName.Text = frmSearchArch.mCustomerName
txtName.Tag = frmSearchArch.mArchiveID
End If
Unload frmSearchArch
End Sub
Private Sub cmdClose_Click()
Unload Me
End Sub
Private Sub cmdSaveClose_Click()
If mbSaveArrangeRecord Then
Call SendMessageToCtl(frmMain.vsf, WM_KEYDOWN, VK_F5, 0)
Call mClear
Unload Me
End If
End Sub
Private Sub cmdSaveNew_Click()
If mbSaveArrangeRecord Then
Call SendMessageToCtl(frmMain.vsf, WM_KEYDOWN, VK_F5, 0)
Call mClear
End If
End Sub
Private Sub Form_KeyPress(KeyAscii As Integer)
If KeyAscii = vbKeyReturn Then
KeyAscii = 0
SendKeys "{tab}"
ElseIf KeyAscii = vbKeyEscape Then
KeyAscii = 0
Unload Me
End If
End Sub
Private Sub Form_Load()
Center Me
Call mClear
If mbAdd = False Then
cmdSaveNew.Enabled = False
Call mbShowOldArrangeRecord
End If
End Sub
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -