📄 frmaddtonote.frm
字号:
VERSION 5.00
Object = "{580AE2E1-B57A-4D4F-8AFF-F366CF0AC8FE}#1.0#0"; "StatusBar.ocx"
Object = "{4604723D-F4AC-4924-B10D-E5678DF6B7EC}#1.0#0"; "DataListGrid.ocx"
Begin VB.Form FrmAddToNote
BorderStyle = 3 'Fixed Dialog
Caption = "将发件人添加到通讯薄"
ClientHeight = 4545
ClientLeft = 2565
ClientTop = 1500
ClientWidth = 7680
Icon = "FrmAddToNote.frx":0000
KeyPreview = -1 'True
LinkTopic = "Form1"
MaxButton = 0 'False
MinButton = 0 'False
ScaleHeight = 4545
ScaleWidth = 7680
ShowInTaskbar = 0 'False
StartUpPosition = 2 '屏幕中心
Begin DataListGrid.OutlookMailGrid OutlookMailGrid1
Height = 3495
Left = 120
TabIndex = 9
Top = 120
Width = 7455
_ExtentX = 13150
_ExtentY = 6165
End
Begin StatusBar.XpStatusBar ctlBottonStatus
Align = 2 'Align Bottom
Height = 375
Left = 0
TabIndex = 8
Top = 4170
Width = 7680
_ExtentX = 13547
_ExtentY = 661
BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851}
Name = "宋体"
Size = 9
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
BackColor = -2147483633
SimpleStyle = 0
End
Begin VB.PictureBox picOptions
BorderStyle = 0 'None
Height = 3780
Index = 3
Left = -20000
ScaleHeight = 3780
ScaleWidth = 5685
TabIndex = 4
TabStop = 0 'False
Top = 480
Width = 5685
Begin VB.Frame fraSample4
Caption = "示例 4"
Height = 1785
Left = 2100
TabIndex = 7
Top = 840
Width = 2055
End
End
Begin VB.PictureBox picOptions
BorderStyle = 0 'None
Height = 3780
Index = 2
Left = -20000
ScaleHeight = 3780
ScaleWidth = 5685
TabIndex = 3
TabStop = 0 'False
Top = 480
Width = 5685
Begin VB.Frame fraSample3
Caption = "示例 3"
Height = 1785
Left = 1545
TabIndex = 6
Top = 675
Width = 2055
End
End
Begin VB.PictureBox picOptions
BorderStyle = 0 'None
Height = 3780
Index = 1
Left = -20000
ScaleHeight = 3780
ScaleWidth = 5685
TabIndex = 2
TabStop = 0 'False
Top = 480
Width = 5685
Begin VB.Frame fraSample2
Caption = "示例 2"
Height = 1785
Left = 645
TabIndex = 5
Top = 300
Width = 2055
End
End
Begin VB.CommandButton cmdCancel
Cancel = -1 'True
Caption = "取消"
Height = 375
Left = 6480
TabIndex = 1
Top = 3735
Width = 1095
End
Begin VB.CommandButton cmdOK
Caption = "确定"
Height = 375
Left = 5280
TabIndex = 0
Top = 3735
Width = 1095
End
End
Attribute VB_Name = "FrmAddToNote"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
'********************************************************************************
'CopyRight:重庆康诺数码科技有限公司Smart项目组
'Date:2004-5-2
'********************************************************************************
Public Enum AddToNoteBookMode
AddContact = 1
AddCustomer = 2
AddEmployee = 3
End Enum
Private mAddToNoteBookMode As AddToNoteBookMode
Private Declare Function OleTranslateColor Lib "oleaut32.dll" (ByVal lOleColor As Long, ByVal lHPalette As Long, lColorRef As Long) As Long
Private Declare Function InflateRect Lib "user32" (lpRect As RECT, ByVal x As Long, ByVal y As Long) As Long
Private Declare Function OffsetRect Lib "user32" (lpRect As RECT, ByVal x As Long, ByVal y As Long) As Long
Private Declare Function CreateSolidBrush Lib "gdi32" (ByVal crColor As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function FillRect Lib "user32" (ByVal hdc As Long, lpRect As RECT, ByVal hBrush As Long) As Long
Private Declare Function UnionRect Lib "user32" (lpDestRect As RECT, lpSrc1Rect As RECT, lpSrc2Rect As RECT) As Long
Private Declare Function SetBkMode Lib "gdi32" (ByVal hdc As Long, ByVal nBkMode As Long) As Long
Private Declare Function DrawText Lib "user32" Alias "DrawTextA" (ByVal hdc As Long, ByVal lpStr As String, ByVal nCount As Long, lpRect As RECT, ByVal wFormat As Long) As Long
Private Const OPAQUE = 2
Private Const TRANSPARENT = 1
Private Const DT_SINGLELINE = &H20&
Private Const DT_VCENTER = &H4&
Private m_lMax As Long
Private m_lValue As Long
Private Sub cmdCancel_Click()
Unload Me
End Sub
Private Sub cmdOK_Click()
Dim i As Long
Dim lngRowSelCount As Long
ProgressMax = OutlookMailGrid1.Rows
Dim m_Contact As PContact.Contact
Dim m_CPContact As New PContact.clsContact
m_CPContact.Init gdbCurrentDB
Dim clsCustomer As New PCustomer.clsCustomer
clsCustomer.Init gdbCurrentDB, gLngEmployeeID1
Dim clsEmployee As New PEmployee.clsEmployee
Dim Customer As PCustomer.Customer
Dim Employee As PEmployee.Employee
clsEmployee.Init gdbCurrentDB
Dim LngCurID As Long
For i = 1 To OutlookMailGrid1.Rows
ProgressValue = i
If OutlookMailGrid1.RowSelected(i) Then
LngCurID = OutlookMailGrid1.CellID(i)
If LngCurID > 0 Then
If mAddToNoteBookMode = AddContact Then
m_CPContact.GetContact LngCurID, m_Contact
m_Contact.blnIsNew = False
If Not m_CPContact.SaveContact(m_Contact, False, True) Then
ShowMessageBoxEx "联系人：" & m_Contact.strContactName & "无法加入通讯簿,请查看是否重复?", vbOKOnly + vbInformation, "提示"
Else
lngRowSelCount = lngRowSelCount + 1
End If
ElseIf mAddToNoteBookMode = AddCustomer Then
clsCustomer.GetCustomer LngCurID, Customer
m_Contact.lngContactID = 0
m_Contact.strContactName = Customer.strCustomerName
m_Contact.strEmail = Customer.strEmail
m_Contact.strEmail2 = Customer.strEmail
m_Contact.LngEmployeeID = gLngEmployeeID1
m_Contact.lngFromEmployeeID = 0
m_Contact.lngFromCustomerID = Customer.LngCustomerID
m_Contact.blnIsNew = False
If Not m_CPContact.SaveContact(m_Contact, False, True) Then
ShowMessageBoxEx "客户：" & Customer.strCustomerName & "无法加入通讯簿,请查看是否重复?", vbOKOnly + vbInformation, "提示"
Else
lngRowSelCount = lngRowSelCount + 1
End If
ElseIf mAddToNoteBookMode = AddEmployee Then
clsEmployee.GetEmployee LngCurID, Employee
m_Contact.blnIsNew = False
m_Contact.lngContactID = 0
m_Contact.strContactName = Employee.strEmployeeName
m_Contact.lngPositionID = Employee.lngPositionID
m_Contact.strWorkCompany = Employee.strWorkCompany
m_Contact.strWorkPostalCode = Employee.strWorkPostalCode
m_Contact.strWorkProvince = Employee.strWorkProvince
m_Contact.strWorkCity = Employee.strWorkCity
m_Contact.strWorkAddress = Employee.strWorkAddress
m_Contact.strWorkTel = Employee.strWorkTel
m_Contact.strWorkTel2 = Employee.strWorkTel2
m_Contact.strWorkFax = Employee.strWorkFax
m_Contact.strWorkWeb = Employee.strWorkWeb
m_Contact.strHomePostalCode = Employee.strHomePostalCode
m_Contact.strHomeProvince = Employee.strHomeProvince
m_Contact.strHomeCity = Employee.strHomeCity
m_Contact.strHomeAddress = Employee.strHomeAddress
m_Contact.strHomeTel = Employee.strHomeTel
m_Contact.strHomeTel2 = Employee.strHomeTel2
m_Contact.strHomeFax = Employee.strHomeFax
m_Contact.strEmail = Employee.strEmail
m_Contact.strEmail2 = Employee.strEmail2
m_Contact.strMobiePhone = Employee.strMobiePhone
m_Contact.strICQ = Employee.strICQ
m_Contact.strMessager = Employee.strMessager
m_Contact.strQQ = Employee.strQQ
m_Contact.strPersonalWeb = Employee.strPersonalWeb
m_Contact.strBeeper = Employee.strBeeper
m_Contact.StrMemo = Employee.StrMemo
m_Contact.strOffice = Employee.strOffice
m_Contact.strCustomWork = Employee.strCustomWork
m_Contact.strNickName = Employee.strNickName
m_Contact.strGender = Employee.strGender
m_Contact.dteBirthday = Employee.dteBirthday
m_Contact.strPreference = Employee.strPreference
m_Contact.strStrongSuit = Employee.strStrongSuit
m_Contact.strPersonalCustom = Employee.strPersonalCustom
m_Contact.strHomeCustom = Employee.strHomeCustom
m_Contact.strSpouse = Employee.strSpouse
m_Contact.strHomeMember = Employee.strHomeMember
m_Contact.lngCommunicationAddress = Employee.lngCommunicationAddress
m_Contact.strPhotoFilePath = Employee.strPhotoFilePath
m_Contact.dteUpdateDate = Employee.dteUpdateDate
m_Contact.blnIsNew = False
m_Contact.LngEmployeeID = gLngEmployeeID1
m_Contact.lngFromEmployeeID = Employee.LngEmployeeID
m_Contact.lngFromCustomerID = 0
If Not m_CPContact.SaveContact(m_Contact, False, True) Then
ShowMessageBoxEx "职员：" & Employee.strEmployeeName & "无法加入通讯簿,请查看是否重复?", vbOKOnly + vbInformation, "提示"
Else
lngRowSelCount = lngRowSelCount + 1
End If
End If
End If
Debug.Print
End If
Next i
ShowMessageBoxEx "成功将" & lngRowSelCount & "个人加入通讯簿！", vbOKOnly + vbInformation, "提示"
End Sub
Private Sub Form_Load()
OutlookMailGrid1.gdbCurrentDB = gdbCurrentDB
If mAddToNoteBookMode = AddContact Then
OutlookMailGrid1.mlngViewID = 43
If m_E_ViewMode = m_ServerMode Then
OutlookMailGrid1.RefreshData "Contact.blnisnew=1"
ElseIf m_E_ViewMode = m_CliendMode Then
'只要是不属于自己的联系人，任何操作员均可以添加给自己
OutlookMailGrid1.RefreshData "lngType=2 and Contact.lngEmployeeID<>" & gLngEmployeeID1
End If
Me.Caption = "将联系人添加到通讯薄"
ElseIf mAddToNoteBookMode = AddCustomer Then
OutlookMailGrid1.mlngViewID = 64
'只显示出自己的客户 供添加
If m_E_ViewMode = m_ServerMode Then
OutlookMailGrid1.RefreshData " lngCustomerID not in (select lngFromCustomerID from Contact)"
Else
OutlookMailGrid1.RefreshData " Customer.lngEmployeeID=" & gLngEmployeeID1 & " and lngCustomerID not in (select lngFromCustomerID from Contact)"
End If
Me.Caption = "将客户添加到通讯薄"
ElseIf mAddToNoteBookMode = AddEmployee Then
OutlookMailGrid1.mlngViewID = 63
OutlookMailGrid1.RefreshData " lngEmployeeID not in (select lngFromEmployeeid from Contact)"
Me.Caption = "将职员添加到通讯薄"
End If
pCreateStatus
End Sub
Public Sub ShowMe(m_AddToNoteBookMode As AddToNoteBookMode)
mAddToNoteBookMode = m_AddToNoteBookMode
Me.Show vbModal
End Sub
Private Sub pCreateStatus()
'初始化状态栏
ctlBottonStatus.AddPanel StatusBar.estbrStandard, SoftName, , , , True, False
ctlBottonStatus.AddPanel StatusBar.estbrOwnerDraw, , , , 96
End Sub
Private Sub ctlBottonStatus_DrawItem(ByVal lHDC As Long, ByVal iPanel As Long, ByVal lLeftPixels As Long, ByVal lTopPixels As Long, ByVal lRightPixels As Long, ByVal lBottomPixels As Long)
Dim hBrush As Long
Dim lColor As Long
Dim tR As RECT
Dim lRight As Long
' Clear progress bar:
tR.left = lLeftPixels
tR.Right = lRightPixels
tR.tOp = lTopPixels
tR.Bottom = lBottomPixels
OleTranslateColor vbButtonFace, 0, lColor
hBrush = CreateSolidBrush(lColor)
FillRect lHDC, tR, hBrush
DeleteObject hBrush
If (m_lValue > 0) Then
Dim tBarR As RECT
LSet tBarR = tR
tBarR.Right = tR.left + ((tR.Right - tR.left) * m_lValue) \ m_lMax
OleTranslateColor vbHighlight, 0, lColor
hBrush = CreateSolidBrush(lColor)
FillRect lHDC, tBarR, hBrush
DeleteObject hBrush
SetBkMode lHDC, TRANSPARENT
DrawText lHDC, m_lValue & " of " & m_lMax, -1, tR, DT_SINGLELINE Or DT_VCENTER
End If
End Sub
Private Sub Status(ByVal sStatus As String)
ctlBottonStatus.PanelText(2) = " " & sStatus
Me.Refresh
End Sub
Private Property Let ProgressMax(ByVal lMax As Long)
m_lMax = lMax
End Property
Private Property Let ProgressValue(ByVal lValue As Long)
m_lValue = lValue
ctlBottonStatus.RedrawPanel 2
End Property
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -