frmmain.frm

供应用友财务通、U8软件、速达全系列软件. ... l 报表数据接口：提供与久其报表的接口：符合财政部统计评价司要求的数据接口软件

VERSION 5.00
Object = "{831FDD16-0C5C-11D2-A9FC-0000F8754DA1}#2.0#0"; "mscomctl.ocx"
Object = "{F9043C88-F6F2-101A-A3C9-08002B2F49FB}#1.2#0"; "COMDLG32.OCX"
Begin VB.Form FrmMain 
   BackColor       =   &H0080C0FF&
   BorderStyle     =   1  'Fixed Single
   Caption         =   "用友财务M8->招财进宝"
   ClientHeight    =   3135
   ClientLeft      =   3330
   ClientTop       =   3480
   ClientWidth     =   5955
   Icon            =   "FrmMain.frx":0000
   LinkTopic       =   "Form1"
   LockControls    =   -1  'True
   MaxButton       =   0   'False
   MinButton       =   0   'False
   ScaleHeight     =   3135
   ScaleWidth      =   5955
   StartUpPosition =   2  '屏幕中心
   Begin MSComctlLib.ProgressBar PBar 
      Height          =   285
      Left            =   180
      TabIndex        =   7
      Top             =   2340
      Width           =   5685
      _ExtentX        =   10028
      _ExtentY        =   503
      _Version        =   393216
      Appearance      =   0
   End
   Begin MSComDlg.CommonDialog dlgFile 
      Left            =   4110
      Top             =   1170
      _ExtentX        =   847
      _ExtentY        =   847
      _Version        =   393216
      Filter          =   "数据库文件(*.MDB)|*.mdb"
   End
   Begin VB.CommandButton Command3 
      Caption         =   "退 出"
      Height          =   345
      Left            =   4590
      TabIndex        =   6
      Top             =   2700
      Width           =   1305
   End
   Begin VB.CommandButton cmdExec 
      Caption         =   "导出到接口数据库"
      Height          =   345
      Left            =   2430
      TabIndex        =   5
      Top             =   2700
      Width           =   2055
   End
   Begin VB.TextBox txtDB 
      Appearance      =   0  'Flat
      Height          =   315
      Left            =   1560
      Locked          =   -1  'True
      TabIndex        =   4
      Top             =   1530
      Width           =   4335
   End
   Begin VB.CommandButton Command1 
      Caption         =   "选择数据库"
      Height          =   315
      Left            =   210
      TabIndex        =   3
      Top             =   1530
      Width           =   1335
   End
   Begin VB.Label lblmsg 
      BackStyle       =   0  'Transparent
      Caption         =   "状态："
      Height          =   255
      Left            =   210
      TabIndex        =   8
      Top             =   2040
      Width           =   5115
   End
   Begin VB.Label Label3 
      BackStyle       =   0  'Transparent
      Caption         =   "*说明：???是帐套代码，1999是会计年度。"
      Height          =   375
      Left            =   270
      TabIndex        =   2
      Top             =   1260
      Width           =   5715
   End
   Begin VB.Label Label2 
      BackStyle       =   0  'Transparent
      Caption         =   "C:\UFSOFT80\ZT???\1999\ufdata.mdb"
      BeginProperty Font 
         Name            =   "宋体"
         Size            =   10.5
         Charset         =   134
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      ForeColor       =   &H00FF0000&
      Height          =   255
      Left            =   210
      TabIndex        =   1
      Top             =   990
      Width           =   5445
   End
   Begin VB.Label Label1 
      BackStyle       =   0  'Transparent
      Caption         =   $"FrmMain.frx":030A
      Height          =   825
      Left            =   210
      TabIndex        =   0
      Top             =   210
      Width           =   3795
   End
   Begin VB.Image Image1 
      Height          =   855
      Left            =   4050
      Picture         =   "FrmMain.frx":039C
      Top             =   120
      Width           =   1800
   End
End
Attribute VB_Name = "FrmMain"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Private Declare Function SetWindowPos Lib "user32" (ByVal hWnd As Long, ByVal hWndInsertAfter As Long, ByVal x As Long, ByVal y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long
' SetWindowPos Flags
Const SWP_NOSIZE = &H1
Const SWP_NOMOVE = &H2

' SetWindowPos() hwndInsertAfter values
Const HWND_TOPMOST = -1
Const HWND_NOTOPMOST = -2

Private Sub cmdExec_Click()
On Error GoTo errH
Dim cn As New ADODB.Connection
Dim rs As New ADODB.Recordset
If Me.txtDB.Text = "" Then
  MsgBox "你先选中用友财务的数据库文件。", vbInformation
  Exit Sub
End If
Dim cnstr As String
cnstr = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & Me.txtDB.Text & _
                             ";Jet OLEDB:Database password=" '";Persist Security Info=False"

lblmsg.Caption = "正在处理会计科目"
Dim sLevel As String
cn.Open cnstr
rs.Open "select cValue from AccInformation where cname='cGradeLevel' and cid='08'", cn
If rs.EOF Then
 MsgBox "不能得到科目设置级别数据！导入失败", vbInformation
 rs.Close
 cn.Close
 Set rs = Nothing
 Set cn = Nothing
 Exit Sub
Else
 sLevel = rs.Fields(0)
End If
rs.Close

'特别地，我们要判断它地损益类地科目是否5开头，（因为它可能是4开头）
Dim is5 As Boolean
is5 = False
rs.Open "select ccode from code where (ccode_name Like '%收入%' or ccode_name Like '*收入*') and left(ccode,1)<>5", cn
If Not rs.EOF Then
   is5 = True
End If
rs.Close
rs.Open "select * from [code]", cn, adOpenDynamic, adLockReadOnly
If Not rs.EOF Then
rs.MoveLast

PBar.Min = 0
PBar.Max = CLng(Fun.GetOneValueFromDB("select count(*) from code", cn.ConnectionString))
rs.MoveFirst
End If
Dim mycn As New ADODB.Connection
Dim myrs As New ADODB.Recordset
cnstr = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & App.Path & "\Interface.mdb" & _
                             ";Jet OLEDB:Database password=" '";Persist Security Info=False"

mycn.Open cnstr
mycn.Execute "delete from subject"
myrs.Open "select * from subject", mycn, 1, 3
Do While Not rs.EOF
  DoEvents
  myrs.AddNew
  myrs.Fields("科目代码") = Fun.makeSdjID(rs.Fields("ccode"), sLevel, is5) & ""
  myrs.Fields("科目名称") = rs.Fields("ccode_name") & ""
  myrs.Fields("核算现金流量") = 0 'rs.Fields("ccode_name") & ""
  If rs.Fields("bd_c") = True Then ':借方, False:贷方
    myrs.Fields("余额方向") = "借方"
  Else
    myrs.Fields("余额方向") = "贷方"
  End If
  If InStr(1, rs.Fields("cbook_type") & "", "数量") > 0 Then
     myrs.Fields("核算数量") = True
  Else
     myrs.Fields("核算数量") = False
  End If
  myrs.Fields("计量单位") = rs.Fields("cmeasure") & ""
  myrs.Fields("核算部门") = rs.Fields("bdept")
  myrs.Fields("核算项目") = rs.Fields("bitem")
  If rs.Fields("cexch_name") & "" <> "" Then
    myrs.Fields("核算外币") = True
  Else
    myrs.Fields("核算外币") = False
  End If
  myrs.Fields("外币种类") = rs.Fields("cexch_name") & ""
  myrs.Fields("isSys") = False
  myrs.Fields("isInit") = True
  myrs.Fields("折旧年限") = 0
  myrs.Fields("对应科目") = ""
  myrs.Fields("残值率") = 5
  myrs.Update
  rs.MoveNext
  If PBar.Value < PBar.Max Then PBar.Value = PBar.Value + 1
   
Loop
rs.Close
myrs.Close

lblmsg.Caption = "正在处理初始化数据...."
PBar.Value = 0
rs.Open "select min(iperiod) from GL_accSum", cn
Dim iperiod As Integer
iperiod = 1
If Not rs.EOF Then
iperiod = rs.Fields(0)
End If
rs.Close

rs.Open "select * from GL_accsum where iperiod=" & iperiod, cn, adOpenDynamic, adLockReadOnly
If Not rs.EOF Then
  rs.MoveLast
  PBar.Max = CLng(Fun.GetOneValueFromDB("select count(*) from GL_accsum where iperiod=" & iperiod, cn.ConnectionString))
  rs.MoveFirst
End If

mycn.Execute "delete from balance"
myrs.Open "select * from balance", mycn, 1, 3

Do While Not rs.EOF
  DoEvents
  myrs.AddNew
   Dim sid As String
   sid = Fun.makeSdjID(rs.Fields("ccode"), sLevel, is5) & ""
  myrs.Fields("Subject_id") = sid
  myrs.Fields("Subject_name") = Fun.GetOneValueFromDB("select ccode_name from code where ccode='" & rs.Fields("ccode") & "'", cn.ConnectionString)
  If rs.Fields("cbegind_c") = "借" Then
    myrs.Fields("subject_to") = 1
    mycn.Execute "update subject set 余额方向='借方' where 科目代码='" & sid & "'"
  Else
    If rs.Fields("cbegind_c") = "贷" Then
      myrs.Fields("subject_to") = -1
      mycn.Execute "update subject set 余额方向='贷方' where 科目代码='" & sid & "'"
    Else
      If Fun.GetOneValueFromDB("select bd_c from code where ccode='" & rs.Fields("ccode") & "'", cn.ConnectionString) Then
         myrs.Fields("subject_to") = 1
         mycn.Execute "update subject set 余额方向='借方' where 科目代码='" & sid & "'"
      Else
         myrs.Fields("subject_to") = -1
         mycn.Execute "update subject set 余额方向='贷方' where 科目代码='" & sid & "'"
      End If
    End If
  End If
  myrs.Fields("year_balance") = rs.Fields("mb")
  myrs.Fields("month_balance") = rs.Fields("mb")
  myrs.Fields("year_amount") = rs.Fields("nb_s")
  myrs.Fields("month_amount") = rs.Fields("nb_s")
  myrs.Update
  rs.MoveNext
  If PBar.Value < PBar.Max Then PBar.Value = PBar.Value + 1
   
Loop
rs.Close
myrs.Close

lblmsg.Caption = "正在处理凭证...."
PBar.Value = 0
rs.Open "select * from GL_accvouch where (iflag is null) and  (not (ino_id is null)) and iperiod>=0 and iperiod<13 order by i_id", cn
If Not rs.EOF Then
  rs.MoveLast
  PBar.Max = CLng(Fun.GetOneValueFromDB("select count(*) from GL_accvouch", cn.ConnectionString))
  rs.MoveFirst
End If

mycn.Execute "delete from credence"
myrs.Open "select * from credence where credence_id=0", mycn, 1, 3
Do While Not rs.EOF
  DoEvents
  Dim id As String
  id = Year(rs.Fields("dbill_date")) & "-" & Month(rs.Fields("dbill_date")) & "-" & rs.Fields("ino_id")  'rs.Fields("")
   If Fun.GetOneValueFromDB("select * from credence where id='" & id & "'", mycn.ConnectionString) = "" Then
        myrs.AddNew
        myrs.Fields("credence_no") = rs.Fields("ino_id")
        myrs.Fields("credence_date") = rs.Fields("dbill_date")
        myrs.Fields("credence_attach") = rs.Fields("idoc")
        myrs.Fields("credence_maker") = rs.Fields("cbill")
        myrs.Fields("credence_tallier") = rs.Fields("ccheck")
        myrs.Fields("credence_assessor") = rs.Fields("cbook")
        'myrs.Fields("credence_closeoff") = "" ' rs.Fields("")
        myrs.Fields("id") = id
        myrs.Fields("inputtime") = Now() 'rs.Fields("")
        myrs.Fields("credence_type") = "用友M8导入" 'rs.Fields("")
        myrs.Update
    End If
    myrs.Requery
  rs.MoveNext
  If PBar.Value < PBar.Max Then PBar.Value = PBar.Value + 1
   
Loop
myrs.Close

If Not rs.BOF Then
rs.MoveFirst
PBar.Value = 0
End If
mycn.Execute "delete from credenceItem"
myrs.Open "select * from credenceitem where item_id=0", mycn, 1, 3
Do While Not rs.EOF
  id = Year(rs.Fields("dbill_date")) & "-" & Month(rs.Fields("dbill_date")) & "-" & rs.Fields("ino_id")  'rs.Fields("")
  id = Fun.GetOneValueFromDB("select credence_id from credence where id='" & id & "'", mycn.ConnectionString)
  sid = Fun.makeSdjID(rs.Fields("ccode"), sLevel, is5) & ""
  myrs.AddNew
        myrs.Fields("credence_id") = id 'rs.Fields("ino_id")
        myrs.Fields("summary") = rs.Fields("cdigest")
        myrs.Fields("subject_id") = sid 'rs.Fields("idoc")
        myrs.Fields("subject_name") = Fun.getSubjectName(mycn, sid) 'rs.Fields("cbill")
        myrs.Fields("debit_money") = rs.Fields("mc")
        myrs.Fields("lender_money") = rs.Fields("md")
        myrs.Fields("amount") = rs.Fields("nd_s") + rs.Fields("nc_s")
        If (rs.Fields("nd_s") + rs.Fields("nc_s")) <> 0 Then
           myrs.Fields("price") = (rs.Fields("mc") + rs.Fields("md")) / (rs.Fields("nd_s") + rs.Fields("nc_s"))
        Else
           myrs.Fields("price") = 0
        End If
        myrs.Fields("dept") = rs.Fields("cdept_id")
        myrs.Fields("project") = rs.Fields("citem_id")
  myrs.Update
  rs.MoveNext
  If PBar.Value < PBar.Max Then PBar.Value = PBar.Value + 1
Loop
myrs.Close
rs.Close
cn.Close
mycn.Close
Set myrs = Nothing
Set cn = Nothing
Set rs = Nothing
Set mycn = Nothing
MsgBox "完成数据的导出！请注意：本工具不保证导出数据100%正确，请检查导进系统后作一次检查！", vbInformation
Unload Me
Exit Sub
errH:
MsgBox "不能继续导出工作。" & vbCrLf & "遇到错误：" & Err.Number & " " & Err.Description
End Sub


Private Sub Command1_Click()
dlgFile.ShowOpen
txtDB = dlgFile.FileName
End Sub



Private Sub Command3_Click()
End
End Sub

Private Sub Form_Load()
 AllwaysOnTop Me
 Me.WindowState = 0
 Me.ZOrder 0
End Sub
Private Sub AllwaysOnTop(frm As Form, Optional OnTop As Boolean = True)
    If OnTop Then
        SetWindowPos frm.hWnd, HWND_TOPMOST, 0, 0, 0, 0, SWP_NOSIZE Or SWP_NOMOVE
    Else
        SetWindowPos frm.hWnd, HWND_NOTOPMOST, 0, 0, 0, 0, SWP_NOSIZE Or SWP_NOMOVE
    End If

End Sub

Private Sub Form_Unload(Cancel As Integer)
AllwaysOnTop Me, False
End Sub