diskinport.frm

通过数据导入导出实现与金蝶财务软件接口的程序源码

Dim excelname2 As String
Dim sheetname2 As String
Dim counts1 As Integer


Private Sub cleartemp_Click()
 '**************************************************
 '删除临时表历史数据
 Set cnn1 = New ADODB.Connection
  'strConnect = "User ID=Admin;Password=;Data Source=" & App.Path & _
  "\users.mdb;Provider=Microsoft.Jet.OLEDB.3.51"
  'strConnect = "DSN=users;DBQ=" & App.Path & "\USERS.MDB;DriverId=281;FIL=MS Access;MaxBufferSize=2048;PageTimeout=5;UID=admin;"
  strConnect = "DBQ=" & App.Path & "\exceltemp.mdb;Driver={Microsoft Access Driver (*.mdb)};DriverId=281;FIL=MS Access;FILEDSN=" & App.Path & "\users.dsn;MaxBufferSize=2048;MaxScanRows=8;PageTimeout=5;SafeTransactions=0;Threads=3;UID=admin;UserCommitSync=Yes;"
  cnn1.Open strConnect
  strSQL1 = "DELETE FROM YHYJDXX"
  Set cmm1 = New ADODB.Command
  Set cmm1.ActiveConnection = cnn1
  With cmm1
      '.ActiveConnection = cnn1
      .CommandType = adCmdText
      .CommandText = strSQL1
      .Execute
  End With
  MsgBox "临时表数据已经清除", vbOKOnly, "提示"
 
 '**************************************************
 '删除用户表历史数据
  'Set cnn2 = New ADODB.Connection
   ' 'strcnn = "driver={Oracle ODBC Driver};Service Name=sqcdb;" & _
       "User Id=gas;Password=gas;"
   ' 'strCnn = "Provider=MSDASQL.1;Persist Security Info=False;User ID=gas;Password=gas;Data Source=oracle2"
  '  strcnn = "Provider=MSDAORA.1;User ID=gas;Password=gas;Data Source=sqcdb;Persist Security Info=False"
  '  cnn2.Open strcnn
 'strSQL1 = "DELETE FROM T_YHYJDXX where FYJDND='2001'"
 ' Set cmm1.ActiveConnection = cnn2
 ' With cmm1
     ' '.ActiveConnection = cnn1
     ' .CommandType = adCmdText
    '  .CommandText = strSQL1
    '  .Execute
  'End With
 'MsgBox "用户表数据已经清除", vbOKOnly, "提示"
End Sub

Private Sub dataimport_Click()
 excelname1 = Trim(Text1.text)
 excelname2 = Trim(Text2.text)
 '####################################################################################################################################################################################################################################################################
 If excelname1 = "" Then
  MsgBox "请先选择月报盘打开后再导入数据！", vbOKOnly, "警告"
 Else
  Open App.Path + "\data_import.log" For Output As #1  ' 打开输出文件。
  Print #1, CStr(Date) + "  " + CStr(Time) ' 将系统日期写入文件。
  Print #1,
  '****************************************************************
  '设置Excel对象，打开报盘1
  Label5.Caption = "正在打开EXCEL报盘．．．"
  Set ex = CreateObject("excel.application")
  Set exwbook1 = ex.Workbooks.Open(excelname1)
  sheetname1 = getsheetname(excelname1)
  'Set exsheet1 = exwbook1.Worksheets(sheetname1)
  Set exsheet1 = exwbook1.Worksheets(1)
  rowcount1 = getcount(exsheet1)
  
  '****************************************************************
  '打开Access数据库中的临时表
  Set cnn1 = New ADODB.Connection
  'strConnect = "User ID=Admin;Password=;Data Source=" & App.Path & _
  "\users.mdb;Provider=Microsoft.Jet.OLEDB.3.51"
  'strConnect = "DSN=users;DBQ=" & App.Path & "\USERS.MDB;DriverId=281;FIL=MS Access;MaxBufferSize=2048;PageTimeout=5;UID=admin;"
  strConnect = "DBQ=" & App.Path & "\exceltemp.mdb;Driver={Microsoft Access Driver (*.mdb)};DriverId=281;FIL=MS Access;FILEDSN=" & App.Path & "\users.dsn;MaxBufferSize=2048;MaxScanRows=8;PageTimeout=5;SafeTransactions=0;Threads=3;UID=admin;UserCommitSync=Yes;"
  cnn1.Open strConnect
  
  '**************************************************
  '删除临时表历史数据
  Label5.Caption = "正在删除临时表历史数据．．．"
  strSQL1 = "DELETE FROM YHYJDXX"
  Set cmm1 = New ADODB.Command
  Set cmm1.ActiveConnection = cnn1
  With cmm1
      '.ActiveConnection = cnn1
      .CommandType = adCmdText
      .CommandText = strSQL1
      .Execute
  End With
  
  Label5.Caption = "正在生成临时表．．．"
   
  '**************************************************
  '设置Excel对象，打开报盘2
  If excelname2 <> "" Then
   Set exwbook2 = ex.Workbooks.Open(excelname2)
   'sheetname2 = getsheetname(excelname2)
   'Set exsheet2 = exwbook2.Worksheets(sheetname2)
   Set exsheet2 = exwbook2.Worksheets(1)
   rowcount2 = getcount(exsheet2)
  End If
  Label5.Caption = "正将临时表数据导入到Oracle数据库中．．．"
  
  '**************************************************
  '分别为代码参照表和临时表设置Recordset对象
  Set rst1 = New ADODB.Recordset
  Set rst2 = New ADODB.Recordset
  
  '**************************************************
  '对报盘1的每一行，将代码与参考表比较后将数据插入到临时表中
  For rown = 1 To rowcount1
   dwcode = Trim(exsheet1.Cells(rown, 9))
   'For i = 1 To Len(strdw)
    'If Mid(strdw, i, 1) = " " Then
    '   len1 = i - 1
    '   Exit For
    'Else
    '   len1 = Len(strdw)
    'End If
   'Next i
   'dwcode = Trim(Mid(strdw, 1, len1))
   'dwname = Trim(Right(strdw, Len(strdw) - len1))
   
   '**************************************************
   '打开参照表的对象rst1,将报盘1代码与参考表中的代码比较，若存在，则插入到临时表中
   strSQL1 = "select YHDM  from refyhdm where DWDM='" + dwcode + "'"
   Call OpenSourceSet(strSQL1, cnn1, rst1)
   
   If (rst1.BOF = False) And (rst1.EOF = False) Then
    '代码存在，打开临时表的对象rst2，将数据插入到临时表中
    yhcode = rst1.Fields(0).Value
    strsql2 = "select * from YHYJDXX"
    Call OpenSourceSet(strsql2, cnn1, rst2)
    rst2.AddNew
    rst2!ND = Combo1.List(Combo1.ListIndex)
    rst2!YF = Combo2.List(Combo2.ListIndex)
    rst2!YHDM = yhcode
    rst2!QCYE = exsheet1.Cells(rown, 3)
    rst2!BYYSK = exsheet1.Cells(rown, 4)
    rst2!BYSSK = exsheet1.Cells(rown, 5)
    rst2!QMYE = exsheet1.Cells(rown, 6)
    '判断有报盘2，有则将其数据插入到临时表中
    If rowcount2 <> 0 Then
     If Trim(exsheet2.Cells(rown, 9)) = dwcode Then
       rst2!NCS = exsheet2.Cells(rown, 3)
       rst2!BNYSK = exsheet2.Cells(rown, 4)
       rst2!BNSSK = exsheet2.Cells(rown, 5)
     Else
      For j = 1 To rowcount2
       If Trim(exsheet2.Cells(j, 9)) = dwcode Then
        rst2!NCS = exsheet2.Cells(rown, 3)
        rst2!BNYSK = exsheet2.Cells(rown, 4)
        rst2!BNSSK = exsheet2.Cells(rown, 5)
       End If
      Next j
     End If
    End If
    
    rst2!ZCJSTS = 30
    
    On Error Resume Next
    rst2.update
    If Err.Number <> 0 Then
        Print #1, "在向临时表插入用户：'" + CStr(Trim(exsheet1.Cells(rown, 2))) + "'时出错!"
      Else
      'counts1 = counts1 + 1
    End If
   Else
    Print #1, "参照表中无此用户：'" + CStr(Trim(exsheet1.Cells(rown, 2))) + "'不能导入此用户的数据!"
   End If
  
  Next rown
  'ex.Quit
  Set ex = Nothing
  Set exsheet1 = Nothing
  Set exwbook1 = Nothing
  Set exsheet2 = Nothing
  Set exwbook2 = Nothing
  rst1.Close
  
  strsql2 = "select ND,YF,YHDM,QCYE,BYYSK,BYSSK,QMYE,NCS,BNYSK,BNSSK,ZCJSTS from YHYJDXX"
  Call OpenSourceSet(strsql2, cnn1, rst2)
  Set Adomoney.Recordset = rst2
  
  ProgressBar1.Min = 0
  ProgressBar1.Max = rst2.RecordCount
  counts1 = 0
  ProgressBar1.Visible = True
  '######################################################################
  '打开Oracle数据库,将临时表数据插入到Oracle数据库中
   Label5.Caption = "正在打开Oracle数据库．．．"
    Set cnn2 = New ADODB.Connection
    'strcnn = "driver={Oracle ODBC Driver};Service Name=sqcdb;" & _
       "User Id=gas;Password=gas;"
    'strCnn = "Provider=MSDASQL.1;Persist Security Info=False;User ID=gas;Password=gas;Data Source=oracle2"
    strcnn = "Provider=MSDAORA.1;User ID=gas;Password=gas;Data Source=sqcdb;Persist Security Info=False"
    cnn2.Open strcnn
    ProgressBar1.Value = ProgressBar1.Min
    Label5.Caption = "正将临时表数据导入到Oracle数据库中..."
    Do Until rst2.EOF
       If Len(rst2.Fields(1).Value) = 1 Then
        str = "0"
       Else
        str = ""
       End If
       strsql = "VALUES('" + CStr(rst2.Fields(0).Value) + "'" + "," + "'" + str + rst2.Fields(1).Value + "'" + "," + "'" + rst2.Fields(2).Value + "'" + "," + CStr(rst2.Fields(3).Value) + "," + CStr(rst2.Fields(4).Value) + "," + CStr(rst2.Fields(5).Value) + "," + CStr(rst2.Fields(6).Value) + "," + CStr(rst2.Fields(7).Value) + "," + CStr(rst2.Fields(8).Value) + "," + CStr(rst2.Fields(9).Value) + "," + CStr(rst2.Fields(10).Value) + ")"
       strsql = "INSERT INTO T_YHYJDXX(FYJDND,FYJDYF,FYHDM,FQCYE,FBYYSK,FBYSJSK,FQMYE,FNCS,FBNYS,FBNSS,FZCJSTS) " + strsql
       On Error Resume Next
       cnn2.Execute strsql
       If Err.Number <> 0 Then
        Print #1, "在将临时表数据中用户：'" + CStr(exsheet1.Cells(rown, 2)) + "'导入到时本系统数据库时出错!"
       Else
        counts1 = counts1 + 1
       End If
       ProgressBar1.Value = counts1
       rst2.MoveNext
    Loop
 rst2.Close
 
 cnn2.Open strcnn
 strsql2 = "select * from T_YHYJDXX"
 Call OpenSourceSet(strsql2, cnn2, rst1)
 Set Adomoney.Recordset = rst1
 
 Label5.Caption = "数据导入完成,累计共成功导入" + CStr(counts1) + "条记录!"
 Print #1, Label5.Caption
 Print #1,
 Close #1
 exwbook1.Close
 exwbook2.Close
 ex.Quit
 MsgBox Label5.Caption + Chr(13) + "传输日志文件为 " + App.Path + "\data_import.log ", vbOKOnly, "数据传输总结"
 
End If
 ProgressBar1.Visible = False
 ProgressBar1.Value = ProgressBar1.Min
 
End Sub

Private Sub openexcel1_Click()
Call openfile(Text1)
If Text1.text <> "" Then
 sheetname1 = getsheetname(Trim(Text1.text))
 If CInt(Mid(sheetname1, 1, 2)) <> CInt(Combo2.List(Combo2.ListIndex)) Then
  MsgBox "所选月报盘与所选月份不同，请核对后重新选择月份或报盘！", vbOKOnly, "警告"
  Text1.text = ""
 End If
End If
End Sub

Private Sub openexcel2_Click()
Call openfile(Text2)
End Sub

Private Sub setreftab_Click()
Load reftab
reftab.Show
End Sub

Private Sub Form_Load()
 For i = 0 To 19
  Combo1.AddItem CStr(1990 + i), i
 Next i
 For i = 0 To 11
  Combo2.AddItem CStr(1 + i), i
 Next i
 Combo1.text = Combo1.List(11)
 Combo2.text = Combo2.List(0)
 Combo1.ListIndex = 11
 Combo2.ListIndex = 0
End Sub
Private Sub OpenSourceSet(sqlstr As String, cnn As Connection, ByRef rst As Recordset)
   If rst.State = adStateOpen Then
      rst.Close
   End If
   rst.CursorType = adOpenKeyset
   rst.LockType = adLockOptimistic
   rst.CursorLocation = adUseClient '必须设置此属性，否则相应的grid表不显示数据
   rst.Open sqlstr, cnn, , , adCmdText
End Sub

Public Function getsheetname(excelname As String) As String
  Dim i As Integer
  Dim len1, len2 As Integer
  For i = 1 To Len(excelname)
   If Mid(excelname, i, 1) = "\" Then
      len1 = i + 1
   End If
   If Mid(excelname, i, 1) = "." Then
      len2 = i
   End If
  Next i
  getsheetname = Mid(excelname, len1, len2 - len1)
End Function

Public Sub openfile(ByRef text As TextBox)
 CommonDialog1.CancelError = True
On Error GoTo ErrHandler
 'CommonDialog1.Flags = cdlOFNHideReadOnly ' 设置标志
 CommonDialog1.Flags = &H200&
 CommonDialog1.InitDir = "A:\"
 CommonDialog1.Filter = "All Files (*.*)|*.*|Excel Files(*.xls)|*.xls"  ' 设置过滤器
 CommonDialog1.FilterIndex = 2 ' 指定缺省的过滤器
 CommonDialog1.ShowOpen   ' 显示“打开”对话框
 text.text = CommonDialog1.FileName  ' 显示选定文件的名字
Exit Sub
ErrHandler:
 ' 用户按了“取消”按钮
Exit Sub
End Sub
Public Function getcount(exsheets As Excel.Worksheet) As Long
  Dim i As Integer
  i = 0
  Do While exsheets.Cells(i + 1, 2) <> ""
      i = i + 1
  Loop
  getcount = i
End Function