您所在位置：主题：亲人求助，急切。运行时错误‘--2147467259（80004005）
Dim a As Integer '定义整型变量
Dim str As String
Dim str1 As String
Dim adocn As New ADODB.Connection
Dim strSQL As String
Dim strcnn As String
Dim cnn_bd As String
Private Sub Command1_Click()
If Label1.Caption = "" Then
MsgBox ("请选择导入文件！")
Exit Sub
End If
Dim strSource, strDestination As String
strDestination = Label1.Caption
Set exlapp = New Excel.Application
exlapp.Workbooks.Open (strDestination)
Dim rng As Range
Dim i As Integer
Dim j As Integer
Set rng = exlapp.ActiveSheet.UsedRange
strSQL = "delete * from ls_zwxt_zcjk"
adocn.Open (str)
adocn.Execute strSQL
adocn.Close
strSQL = "delete * from ls_zwxt_zcls"
adocn.Open (str)
adocn.Execute strSQL
adocn.Close
For m = 8 To rng.Rows.Count
If exlapp.Cells(m, 4) <> "" Then
kmbm1.Caption = exlapp.Cells(m, 4)
Adodc1.RecordSource = "select * from xt_ysdw where 大平台二级单位编码='" + Left(exlapp.Cells(m, 3), 6) + "' "
Adodc1.Refresh
If Adodc1.Recordset.RecordCount > 0 Then
dwbm.Caption = Adodc1.Recordset.Fields("用友单位编码")
Else
MsgBox ("单位对应有错！")
Exit Sub
End If
Adodc1.Recordset.Close
If Len(exlapp.Cells(m, 4)) = 5 Then
Adodc1.RecordSource = "select * from xt_gnkm_erji where 二级功能科目编码='" + kmbm1.Caption + "'"
Adodc1.Refresh
If Adodc1.Recordset.RecordCount > 0 Then
Select Case Adodc1.Recordset.Fields("顶级功能科目编码")
Case "101"
kmbm.Caption = "501" & exlapp.Cells(m, 4)
Case "102"
kmbm.Caption = "505" & exlapp.Cells(m, 4)
Case "103"
kmbm.Caption = "506" & exlapp.Cells(m, 4)
End Select
Else
MsgBox ("功能科目对应有错！")
Exit Sub
End If
Adodc1.Recordset.Close
ElseIf Len(exlapp.Cells(m, 4)) = 7 Then
Adodc1.RecordSource = "select * from xt_gnkm_sanji where 三级功能科目编码='" + kmbm1.Caption + "'"
Adodc1.Refresh
If Adodc1.Recordset.RecordCount > 0 Then
Select Case Adodc1.Recordset.Fields("顶级功能科目编码")
Case "101"
kmbm.Caption = "501" & exlapp.Cells(m, 4)
Case "102"
kmbm.Caption = "505" & exlapp.Cells(m, 4)
Case "103"
kmbm.Caption = "506" & exlapp.Cells(m, 4)
End Select
Else
MsgBox ("功能科目对应有错！")
Exit Sub
End If
Adodc1.Recordset.Close
End If
For n = 7 To rng.Columns.Count
If exlapp.Cells(m, n) <> "" Then
Select Case exlapp.Cells(6, n)
Case "转账"
zy.Caption = "授权支付列支"
Case "现金"
zy.Caption = "授权支付列支"
Case "工资支出"
zy.Caption = "财政直发工资"
Case "转拨支出"
zy.Caption = "直接支付列支"
Case "其他支出"
zy.Caption = "直接支付列支"
End Select
lj.RecordSource = "select * from ls_zwxt_zcjk"
lj.Refresh
lj.Recordset.AddNew
lj.Recordset.Fields("功能科目编码") = kmbm.Caption
lj.Recordset.Fields("功能科目名称") = exlapp.Cells(m, 5)
lj.Recordset.Fields("单位编码") = dwbm.Caption
lj.Recordset.Fields("资金性质") = "预算内"
lj.Recordset.Fields("摘要") = zy.Caption
lj.Recordset.Fields("金额") = exlapp.Cells(m, n)
lj.Recordset.Update
lj.Recordset.Close
End If
Next n
End If
Next m
lj.RecordSource = "select distinct (单位编码),(功能科目编码),摘要 from ls_zwxt_zcjk order by 单位编码,功能科目编码,摘要"
lj.Refresh
If lj.Recordset.RecordCount > 0 Then
While Not lj.Recordset.EOF
Adodc2.RecordSource = "select sum(金额)as 合计金额 from ls_zwxt_zcjk where 功能科目编码='" + lj.Recordset.Fields("功能科目编码") + "' and 单位编码='" + lj.Recordset.Fields("单位编码") + "' and 摘要='" + lj.Recordset.Fields("摘要") + "'"
Adodc2.Refresh
If Adodc2.Recordset.RecordCount > 0 Then
Adodc1.RecordSource = "select * from ls_zwxt_zcls"
Adodc1.Refresh
Adodc1.Recordset.AddNew
Adodc1.Recordset.Fields("功能科目编码") = lj.Recordset.Fields("功能科目编码")
'Adodc1.Recordset.Fields("功能科目名称") = lj.Recordset.Fields("功能科目名称")
Adodc1.Recordset.Fields("单位编码") = lj.Recordset.Fields("单位编码")
Adodc1.Recordset.Fields("摘要") = lj.Recordset.Fields("摘要")
Adodc1.Recordset.Fields("合计金额") = Adodc2.Recordset.Fields("合计金额")
Adodc2.Recordset.Close
End If
Adodc1.Recordset.Update
Adodc1.Recordset.Close
lj.Recordset.MoveNext
Wend
End If
lj.Recordset.Close
exlapp.Visible = False 'True
exlapp.ActiveWorkbook.Close savechanges:=False
strSource = App.Path & "\baobiao\ywxt_gx_2014\凭证.xls"
'RegisterFee.xls就是一个模版文件
strDestination = App.Path & "\Temp.xls"
FileCopy strSource, strDestination
Set exlapp = New Excel.Application
exlapp.Workbooks.Open (strDestination)
m = 2
i = 3
j = 800
k = 1
Adodc1.RecordSource = "select * from ls_zwxt_zcls order by 单位编码,功能科目编码"
Adodc1.Refresh
If Adodc1.Recordset.RecordCount > 0 Then
While Not Adodc1.Recordset.EOF
Set xlSheet = exlapp.Application.Worksheets(2) '工作簿2
xlSheet.Cells(i, 1).NumberFormatLocal = "@"
xlSheet.Cells(i, 1) = j '凭证号
xlSheet.Cells(i, 2) = m '分录号
xlSheet.Cells(i, 3).NumberFormatLocal = "@"
xlSheet.Cells(i, 3) = Adodc1.Recordset.Fields("功能科目编码") '科目编码
xlSheet.Cells(i, 4) = Adodc1.Recordset.Fields("摘要") '摘要
xlSheet.Cells(i, 15) = Adodc1.Recordset.Fields("合计金额") '借方金额
xlSheet.Cells(i, 19) = "0" '贷方金额
xlSheet.Cells(i, 23).NumberFormatLocal = "@"
xlSheet.Cells(i, 23) = Adodc1.Recordset.Fields("单位编码") '部门编码
Adodc1.Recordset.MoveNext
m = m + 1
i = i + 1
Wend
End If
Set xlSheet = exlapp.Application.Worksheets(1) '工作簿1
xlSheet.Cells(2, 1).NumberFormatLocal = "@"
xlSheet.Cells(2, 1) = j '凭证号
xlSheet.Cells(2, 3).NumberFormatLocal = "@"
xlSheet.Cells(2, 3) = "记" '凭证类别
xlSheet.Cells(2, 4) = Year(rq.Value) '会计年度
xlSheet.Cells(2, 5).NumberFormatLocal = "@" '会计期间
xlSheet.Cells(2, 5) = Month(rq.Value)
xlSheet.Cells(2, 7).NumberFormatLocal = "yyyy-m-d;@"
xlSheet.Cells(2, 7) = rq.Value '制单日期
xlSheet.Cells(2, 8).NumberFormatLocal = "@"
xlSheet.Cells(2, 8) = "张小勇" '制单人
xlSheet.Cells(2, 20).NumberFormatLocal = "yyyy-m-d;@" '录入日期
xlSheet.Cells(2, 20) = rq.Value
xlSheet.Cells(2, 21).NumberFormatLocal = "@"
xlSheet.Cells(2, 21) = "张小勇" '录入员
Set xlSheet = exlapp.Application.Worksheets(2) '工作簿2
xlSheet.Cells(2, 1).NumberFormatLocal = "@"
xlSheet.Cells(2, 1) = j '凭证号
xlSheet.Cells(2, 2) = "1" '分录号
xlSheet.Cells(2, 3).NumberFormatLocal = "@"
xlSheet.Cells(2, 3) = "101001" '科目编码
xlSheet.Cells(2, 4) = "国库集中支付" '摘要
xlSheet.Cells(2, 15) = "0" '借方金额
Adodc2.RecordSource = "select sum(合计金额)as 金额 from ls_zwxt_zcls"
Adodc2.Refresh
xlSheet.Cells(2, 19) = Adodc2.Recordset.Fields("金额") '贷方金额
Adodc2.Recordset.Close
Set xlSheet = exlapp.Application.Worksheets(3) '工作簿3
xlSheet.Cells(2, 1).NumberFormatLocal = "@"
xlSheet.Cells(2, 1) = j '凭证号
xlSheet.Cells(2, 2) = "1"
exlapp.Visible = True 'TrueFalse
exlapp.ActiveWorkbook.SaveAs "E:\转换凭证\temp.xls"
MsgBox ("转换完成！已另存")
End Sub