End If
Next
rd.Open "select * from company_data where code=('" & SS & "')", ADO_Cnn, adOpenKeyset, adLockOptimistic
If rd.EOF Then
rd.AddNew
rd.Fields("code") = SS
rd.Fields("name") = sa
rd.Fields("address") = sb
rd.Fields("phone") = sC
rd.Fields("fax") = se
rd.Fields("email") = sm
rd.Fields("class") = "Z"
rd.UPdate
rd.Close
Else
rd.Fields("email") = sm
rd.Fields("name") = sa
rd.Fields("address") = sb
rd.Fields("phone") = sC
rd.Fields("fax") = se
rd.UPdate
rd.Close
End If
Dim iuy As New ADODB.Recordset
iuy.Open "delete from company_employee_data where email=('" & sg & "')", ADO_Cnn, adOpenKeyset, adLockOptimistic
rr.Open "select * from company_employee_data where name=('" & sf & "') and email=('" & sg & "') and company_code=('" & sa & "')", ADO_Cnn, adOpenKeyset, adLockOptimistic
If rr.EOF Then
rr.AddNew
rr.Fields("name") = sf
rr.Fields("email") = sg
rr.Fields("company_code") = SS
rr.UPdate
rr.Close
End If
MsgShow "数据传送成功"
With spdShowEmail
.Row = .ActiveRow
.Col = -1
.BackColor = &HFFFFFF
.ForeColor = &HFF&
.Col = 7
.Text = 1
.Col = 8
If .Text = "check" Then
Kill (App.Path + "\Inemail" + "\" + CName)
End If
End With
With ToolbarShowEmail
.Buttons("InData").Enabled = False
' .Buttons("delete").Enabled = False
End With
End If
很久前写的代码,希望对你有帮助
Dim rs As New ADODB.Recordset
Dim rd As New ADODB.Recordset
Dim rr As New ADODB.Recordset
Dim xmldoc As Variant
Dim rootnode As Variant
Dim priceroot As Variant '表示运价根节点
Dim pricenode As Variant '表示一条运价
Dim field As Variant '表示一个字段
Dim attr As Variant
Dim Node As Variant
Dim adate, acompany As Variant
Dim s, SS, sa, sb, sC, sm, se As String
Dim S1 As String
Dim S2 As String
Dim S3, S4, S5, S6, S7, S8, S9, S10, S11, S12, s13 As String
Dim s14, s15, s16, s17, s18, s19, s20, s21, s22, s23, s24, s25 As String
Dim s26, s27, s28, s29 As String
Dim Count As Integer
Dim i As Long
Dim CName, cfirst, tdate, edate As String
tdate = Format(G_sysdate, "yyyy-mm-dd")
With spdShowEmail
.Row = .ActiveRow
.Col = 1
CName = .Text
tname = .Text
End With
cfrist = Mid(CName, 1, 6)
If TYP = "check" Then
If cfrist = "templa" Then
Set xmldoc = CreateObject("Microsoft.XMLDOM")
On Error GoTo ErrHandler
xmldoc.async = False
If (xmldoc.parseError.errorCode) < 0 Then
MsgBox "读取数据文件发生如下错误:行号(" + CStr(xmldoc.parseError.Line) + "), 列号(" + CStr(xmldoc.parseError.linepos) + ")" + vbCrLf + _
"错误原因: " + xmldoc.parseError.reason + vbCrLf + _
"错误文本: " + xmldoc.parseError.srcText
Exit Sub
End If
Set rootnode = xmldoc.documentElement '取得根节点
If rootnode Is Nothing Then
MsgBox "数据文件为空!"
GoTo ClearAndExit
End If
'验证根节点的名称为freight-data
If rootnode.baseName <> "freight-data" Then
MsgBox "数据内容错误"
GoTo ClearAndExit
End If
'检查必要的属性
If rootnode.Attributes Is Nothing Then
MsgBox "根节点缺少必要的属性"
GoTo ClearAndExit
End If
Set attr = rootnode.Attributes.getNamedItem("version")
If attr Is Nothing Then
MsgBox "未找到版本数据"
GoTo ClearAndExit
End If
s = attr.Text
If s <> "1.0" Then
MsgBox "当前仅支持1.0版本的数据"
GoTo ClearAndExit
End If
Set attr = rootnode.Attributes.getNamedItem("gen-date")
' Set adate = attr
If attr Is Nothing Then
MsgBox "未找到生成时间"
GoTo ClearAndExit
End If
s = attr.Text
Set attr = rootnode.Attributes.getNamedItem("gen-email")
If attr Is Nothing Then
MsgBox "未找到email"
GoTo ClearAndExit
End If
sm = attr.Text
Set attr = rootnode.Attributes.getNamedItem("gen-Cname")
If attr Is Nothing Then
MsgBox "未找到单位中文名称"
GoTo ClearAndExit
End If
sa = attr.Text
Set attr = rootnode.Attributes.getNamedItem("gen-address")
If attr Is Nothing Then
MsgBox "未找到单位地址"
GoTo ClearAndExit
End If
sb = attr.Text
Set attr = rootnode.Attributes.getNamedItem("gen-phone")
If attr Is Nothing Then
MsgBox "未找到单位电话"
GoTo ClearAndExit
End If
sC = attr.Text
Set attr = rootnode.Attributes.getNamedItem("gen-fax")
If attr Is Nothing Then
MsgBox "未找到单位传真"
GoTo ClearAndExit
End If
se = attr.Text
Set attr = rootnode.Attributes.getNamedItem("gen-unit")
If attr Is Nothing Then
MsgBox "未找到生成单位简称"
GoTo ClearAndExit
End If
SS = attr.Text
Set attr = rootnode.Attributes.getNamedItem("gen-username")
If attr Is Nothing Then
MsgBox "未找到生成报价SALES"
GoTo ClearAndExit
End If
sf = attr.Text
Set attr = rootnode.Attributes.getNamedItem("gen-useremail")
If attr Is Nothing Then
MsgBox "未找到生成报价SALES信箱地址"
GoTo ClearAndExit
End If
sg = attr.Text
'取价格
If Not rootnode.hasChildNodes Then
MsgBox "没有数据"
GoTo ClearAndExit
Else
For Each Node In rootnode.childNodes
If Node.baseName = "price" Then
Set priceroot = Node
Exit For
End If
Next
End If
If priceroot Is Nothing Then
MsgBox "没有价格数据"
GoTo ClearAndExit
End If
Count = 0
For Each pricenode In priceroot.childNodes
If pricenode.baseName <> "record" Then
MsgBox "价格数据错误"
GoTo ClearAndExit
Else '一条价格记录
S1 = ""
S2 = ""
For Each Node In pricenode.childNodes
If Node.baseName = "ID" Then
S1 = Node.Text
ElseIf Node.baseName = "生效日期" Then
S2 = Node.Text
edate = Format(S2, "yyyy-mm-dd")
ElseIf Node.baseName = "失效日期" Then
S3 = Node.Text
ElseIf Node.baseName = "承运人" Then
S4 = Node.Text
ElseIf Node.baseName = "开船日期" Then
S5 = Node.Text
' TTin = s5
' Call EtdChangeIn
ElseIf Node.baseName = "目的港" Then
S6 = Node.Text
ElseIf Node.baseName = "起运港" Then
s14 = Node.Text
ElseIf Node.baseName = "GP20价格" Then
S7 = Node.Text
ElseIf Node.baseName = "GP40价格" Then
S8 = Node.Text
ElseIf Node.baseName = "GP45价格" Then
S9 = Node.Text
ElseIf Node.baseName = "中转港" Then
S10 = Node.Text
ElseIf Node.baseName = "航程" Then
S11 = Node.Text
ElseIf Node.baseName = "报价协议号" Then
S12 = Node.Text
ElseIf Node.baseName = "备注" Then
s13 = Node.Text
Else
MsgBox "价格记录字段错误"
GoTo ClearAndExit
End If
Next
Count = Count + 1
rs.Open "select * from freight_in_price where booking_co=('" & SS & "') and etd=('" & S5 & "') and sp_price='0 'and carrier=('" & S4 & "')and end_date> ('" & tdate & "') and ('" & edate & "')>('" & tdate & "') and port_loading=('" & s14 & "') and port_discharge=('" & S6 & "') and status=0 ", ADO_Cnn, adOpenKeyset, adLockOptimistic
If Not rs.EOF Then
rs.Fields("end_date") = Format(S2, "yyyy-mm-dd")
rs.Fields("status") = -1
rs.UPdate
End If
rs.Close
rs.Open "select * from freight_in_price where booking_co=('" & SS & "') and etd=('" & S5 & "') and sp_price='0 'and carrier=('" & S4 & "')and end_date> ('" & tdate & "') and ('" & edate & "')<=('" & tdate & "') and port_loading=('" & s14 & "') and port_discharge=('" & S6 & "') and status=0 ", ADO_Cnn, adOpenKeyset, adLockOptimistic
If Not rs.EOF Then
rs.Fields("status") = -1
rs.UPdate