u8取数代码

1

Public Rep As String

Private Sub CheckBox1_Change()
   '确定是否使用默认登录
If Me.CheckBox1.Value = True Then
    Me.TextBox1.Enabled = True
    Me.TextBox4.Enabled = True
Else
    Me.TextBox1.Enabled = False
    Me.TextBox4.Enabled = False
End If
End Sub
Private Sub CommandButton18_Click()
'这段代码用于搜索指定数据库服务器中的数据库
'设置出错跳转
On Error GoTo err
'声明相关变量
Dim databasename As String         '保存数据名称
Dim cn As ADODB.Connection         'ADO连接
Dim strCnn As String               '保存连接字符串
Set cn = New ADODB.Connection      '初始连接
Dim rct As ADODB.Recordset         '记录集
'根据是否指定登录ID，构建连接字符串
If CheckBox1.Value = flase Then
strCnn = "Driver={SQL Server};Server=" & ComboBox4.Value & ";Trusted_Connection=yes;DataBase=" & ComboBox2.Value
Else
strCnn = "Driver={SQL Server};Server=" & ComboBox4.Value & ";UID=" & TextBox1.Value & ";PWD=" & TextBox4.Value & ";DataBase=" & ComboBox2.Value
End If
'打开连接
cn.Open strCnn
'判断数据库服务器连接是否成功
    If cn.State = adStateOpen Then
        MsgBox "Excel正在列举SQLServer服务器:" & ComboBox4.Value & "上的数据库！", vbInformation, "连接成功"
        '连接成功后，将连接信息保存到当前工作薄中，以便下次调用
        [U8SERVER] = Me.ComboBox4.Value
        [U8ID] = Me.TextBox1.Value
        [U8PW] = Me.TextBox4.Value
        '返回所有数据库名称
       Set rct = cn.Execute("sp_helpdb")
       'Set rct = cn.Execute("SELECT name,create_date,state FROM sys.databases ORDER BY 1 DESC")
        If rct.EOF = True And rct.BOF = True Then
             MsgBox "Excel未能正确返回查询结果，请检查SQL语句是否正确！", vbExclamation, "操作失败"
             Exit Sub
        Else
             Dim r As Integer
             ComboBox2.Clear
             While Not rct.EOF
                 ComboBox2.AddItem rct.Fields(0).Value
                ' ComboBox2.AddItem rct.Fields("name").Value
                 r = r + 1
                 rct.MoveNext
             Wend
        End If
        MsgBox "请选择相应的数据库！", vbInformation, "连接成功！"
        ComboBox2.SetFocus
    Else
         MsgBox "数据库服务器连接失败！", vbInformation, "连接服务器"
    End If
    Exit Sub
err:
    MsgBox "无法在指定的Sql Server服务器查找到数据库，请检查服务器的地址或名称是否正确！", vbExclamation, "提示信息"
    Me.ComboBox4.SetFocus
End Sub
Private Sub CommandButton19_Click()
'这段代码用于导入指定的U8数据库到当前的模板中
'关闭屏幕更新
Application.ScreenUpdating = False
'首先判断是否选择了想要导入的数据库
If ComboBox2.Value = "" Then
    MsgBox "请选择数据库文件", vbExclamation, "提示"
    Exit Sub
End If
'设置出错跳转信息
On Error GoTo err
'声明所需变量
Dim cn As ADODB.Connection
Dim rs As ADODB.Recordset
Dim strCnn As String
Set cn = New ADODB.Connection
Dim n As Integer   'n用于保存凭证表编号
Dim stname As String  '用于保存新增凭证表的名称
n = 1
'根据是否指定登录ID，构建连接字符串
If CheckBox1.Value = flase Then
    strCnn = "Driver={SQL Server};Server=" & ComboBox4.Value & ";Trusted_Connection=yes;DataBase=" & ComboBox2.Value & ""
Else
    strCnn = "Driver={SQL Server};Server=" & ComboBox4.Value & ";UID=" & TextBox1.Value & ";PWD=" & TextBox4.Value & ";DataBase=" & ComboBox2.Value & ""
End If
'打开数据库连接
cn.Open strCnn
'判断数据库服务器连接是否成功
   If cn.State = adStateOpen Then
        '在状态栏显示当前进度
        Application.StatusBar = "正在导入凭证库，请稍候..."
        '打开记录集，导入凭证库
        Set rs = cn.Execute("SELECT Gl_accvouch.dbill_date, Gl_accvouch.ino_id, Gl_accvouch.ccode, Gl_accvouch.cdigest,fx=case when Gl_accvouch.md=0 then'贷'when Gl_accvouch.md<>0 then'借'end,(Gl_accvouch.nd_s+Gl_accvouch.nc_s) AS sl,Gl_accvouch.cexch_name, (Gl_accvouch.md_f+Gl_accvouch.mc_f) AS wb, (Gl_accvouch.md+Gl_accvouch.mc) AS jin, '' as gj,''as xm,Gl_accvouch.cdept_id,Gl_accvouch.cperson_id, Gl_accvouch.ccus_id, Gl_accvouch.csup_id FROM Gl_accvouch WHERE (((Gl_accvouch.iperiod) > 0 And (Gl_accvouch.iperiod) < 13)) ORDER BY Gl_accvouch.dbill_date, Gl_accvouch.ino_id")
'以65000条记录为单位，循环读取记录集，因为EXCEL2003以前的版本，
        '单表记录不超过65536，在EXCEL2007中可以修改为100万
        While Not rs.EOF
            '增加一个新表，并将其名称命名为凭证n
            stname = "凭证" & n
            ThisWorkbook.Sheets.Add After:=ThisWorkbook.Sheets(Sheets.Count)
            '设置凭证表的样式，并导入记录
            With ActiveSheet
                .Name = stname
                .Range("A1").Value = "日期"
                .Range("B1").Value = "凭证号数"
                .Range("C1").Value = "科目编码"
                .Range("D1").Value = "摘要"
                .Range("E1").Value = "方向"
                .Range("F1").Value = "数量"
                .Range("G1").Value = "外币名称"
                .Range("H1").Value = "外币"
                .Range("I1").Value = "金额"
                .Range("J1").Value = "国家"
                .Range("K1").Value = "项目代码"
                .Range("L1").Value = "部门代码"
                .Range("M1").Value = "人名代码"
                .Range("N1").Value = "客户代码"
                .Range("O1").Value = "供应商代码"
                .Range("P1").Value = "货物代码"
                .Range("Q1").Value = "结算单"
                .Range("J:Q,H:H,B:E").NumberFormatLocal = "@"
                .Range("H:H,I:I").NumberFormatLocal = "#,##0.00_ "
                .Columns("F:F").NumberFormatLocal = "G/通用格式"
                .Columns("A:A").NumberFormatLocal = "yyyy-m-d"
                .Range("A2").CopyFromRecordset rs, 65000
                .Cells.Font.Size = 10
            End With
            n = n + 1
        Wend
        '清空记录集
        Set rs = Nothing
    Else
         MsgBox "数据库服务器连接失败！", vbInformation, "连接服务器"
    End If
   'U8中设置了辅助核算，导入部门表
   Application.StatusBar = "正在导入部门表，请稍候..."
   Set rs = cn.Execute("SELECT cDepCode,cDepName from department")
   Sheets("部门").Range("A2").CopyFromRecordset rs
   Set rs = Nothing
   'U8中设置了辅助核算，导入供应商表
   Application.StatusBar = "正在导入供应商表，请稍候..."
Set rs = cn.Execute("SELECT clist.*, cqc.cbegind_c, cqc.mb, cjd.jie, cjd.dai, cqm.cendd_c, cqm.me FROM (((SELECT DISTINCT gl_accass.ccode, '' AS kmmc, gl_accass.csup_id, Vendor.cVenName FROM gl_accass LEFT JOIN Vendor ON gl_accass.csup_id=Vendor.cVenCode WHERE (((gl_accass.csup_id)<>0)))  AS clist INNER JOIN (SELECT gl_accass.ccode, gl_accass.csup_id," _
& "gl_accass.cbegind_c, gl_accass.mb FROM gl_accass WHERE (((gl_accass.csup_id)<>0) AND ((gl_accass.iperiod)=1)))  AS cqc ON (clist.csup_id=cqc.csup_id) AND (clist.ccode=cqc.ccode)) INNER JOIN (SELECT gl_accass.ccode, gl_accass.csup_id, Sum(gl_accass.md) AS jie, Sum(gl_accass.mc) AS dai FROM gl_accass GROUP BY gl_accass.ccode, gl_accass.csup_id HAVING (((gl_accass.csup_id)<>0)))  AS cjd ON (clist.csup_id=cjd.csup_id) AND (clist.ccode=cjd.ccode)) INNER JOIN (SELECT gl_accass.ccode, gl_accass.csup_id, gl_accass.cendd_c, gl_accass.me FROM gl_accass WHERE (((gl_accass.csup_id)<>0) AND ((gl_accass.iperiod)=12)))  AS cqm ON (clist.csup_id=cqm.csup_id) AND (clist.ccode=cqm.ccode)")
   Sheets("供应商").Range("A2").CopyFromRecordset rs
   Set rs = Nothing
   'U8中设置了辅助核算，导入客户表
   Application.StatusBar = "正在导入客户表，请稍候..."
Set rs = cn.Execute("SELECT clist.*, cqc.cbegind_c, cqc.mb, cjd.jie, cjd.dai, cqm.cendd_c, cqm.me FROM (((SELECT DISTINCT gl_accass.ccode, '' AS kmmc, gl_accass.ccus_id, customer.cCusName FROM gl_accass LEFT JOIN customer ON gl_accass.ccus_id=customer.cCusCode WHERE (((gl_accass.ccus_id)<>0)))  AS clist INNER JOIN (SELECT gl_accass.ccode, gl_accass.ccus_id," _
& "gl_accass.cbegind_c, gl_accass.mb FROM gl_accass WHERE (((gl_accass.ccus_id)<>0) AND ((gl_accass.iperiod)=1)))  AS cqc ON (clist.ccus_id=cqc.ccus_id) AND (clist.ccode=cqc.ccode)) INNER JOIN (SELECT gl_accass.ccode, gl_accass.ccus_id, Sum(gl_accass.md) AS jie, Sum(gl_accass.mc) AS dai FROM gl_accass GROUP BY gl_accass.ccode, gl_accass.ccus_id HAVING (((gl_accass.ccus_id)<>0)))  AS cjd ON (clist.ccus_id=cjd.ccus_id) AND (clist.ccode=cjd.ccode)) INNER JOIN (SELECT gl_accass.ccode, gl_accass.ccus_id, gl_accass.cendd_c, gl_accass.me FROM gl_accass WHERE (((gl_accass.ccus_id)<>0) AND ((gl_accass.iperiod)=12)))  AS cqm ON (clist.ccus_id=cqm.ccus_id) AND (clist.ccode=cqm.ccode)")
   Sheets("客户").Range("A2").CopyFromRecordset rs
   Set rs = Nothing
   'U8中设置了辅助核算，导入个人往来核算表
   Application.StatusBar = "正在导入人名表，请稍候..."
Set rs = cn.Execute("SELECT clist.*, cqc.cbegind_c, cqc.mb, cjd.jie, cjd.dai, cqm.cendd_c, cqm.me FROM (((SELECT DISTINCT gl_accass.ccode, '' AS kmmc, gl_accass.cperson_id, Person.cPersonName FROM gl_accass LEFT JOIN Person ON gl_accass.cperson_id=Person.cPersonCode WHERE (((gl_accass.cperson_id)<>0)))  AS clist INNER JOIN (SELECT gl_accass.ccode, gl_accass.cperson_id," _
& "gl_accass.cbegind_c, gl_accass.mb FROM gl_accass WHERE (((gl_accass.cperson_id)<>0) AND ((gl_accass.iperiod)=1)))  AS cqc ON (clist.cperson_id=cqc.cperson_id) AND (clist.ccode=cqc.ccode)) INNER JOIN (SELECT gl_accass.ccode, gl_accass.cperson_id, Sum(gl_accass.md) AS jie, Sum(gl_accass.mc) AS dai FROM gl_accass GROUP BY gl_accass.ccode, gl_accass.cperson_id HAVING (((gl_accass.cperson_id)<>0)))  AS cjd ON (clist.cperson_id=cjd.cperson_id) AND (clist.ccode=cjd.ccode)) INNER JOIN (SELECT gl_accass.ccode, gl_accass.cperson_id, gl_accass.cendd_c, gl_accass.me FROM gl_accass WHERE (((gl_accass.cperson_id)<>0) AND ((gl_accass.iperiod)=12)))  AS cqm ON (clist.cperson_id=cqm.cperson_id) AND (clist.ccode=cqm.ccode)")
   Sheets("人名").Range("A2").CopyFromRecordset rs
   Set rs = Nothing
   '导入科目余额表
   Application.StatusBar = "正在导入余额表，请稍候..."
   Set rs = cn.Execute("SELECT Code.ccode, Code.ccode_name, 期初.期初借方, 期初.期初贷方, 借贷方.借方, 借贷方.贷方, 期末.期末借方, 期末.期末贷方 FROM ((Code LEFT JOIN (SELECT Gl_accsum.ccode, 期初借方=case when Gl_accsum.cbegind_c='借' then Gl_accsum.mb when Gl_accsum.cbegind_c<>'借' then 0 end, 期初贷方=case when Gl_accsum.cbegind_c='贷' then Gl_accsum.mb when Gl_accsum.cbegind_c<>'贷' then 0 end FROM Gl_accsum WHERE (((Gl_accsum.iperiod)=1)))  AS 期初 ON Code.ccode=期初.ccode) LEFT JOIN (SELECT Gl_accsum.ccode, sum(Gl_accsum.md) AS 借方, Sum(Gl_accsum.mc) AS 贷方 FROM Gl_accsum GROUP BY Gl_accsum.ccode)  AS 借贷方 ON Code.ccode=借贷方.ccode) LEFT JOIN (SELECT Gl_accsum.ccode, 期末借方=case when Gl_accsum.cendd_c='借' then Gl_accsum.me when  Gl_accsum.cendd_c<>'借' then 0 end, 期末贷方=case when Gl_accsum.cendd_c='贷' then Gl_accsum.me when Gl_accsum.cendd_c<>'贷' then 0 end FROM Gl_accsum WHERE (((Gl_accsum.iperiod)=12)))  AS 期末 ON Code.ccode=期末.ccode ORDER BY Code.ccode")
   Sheets("余额表").Range("C2").CopyFromRecordset rs
   Set rs = Nothing
Application.StatusBar = "OK！"
'更新辅助核算余额表中的相关信息
Call update("余额表", "供应商")
Call update("余额表", "客户")
Call update("余额表", "人名")
Unload UserForm2
MsgBox "相关数据已导入！请检查一下各个余额表是否与财务软件输出的余额表是否一致！", vbExclamation, "提示！"
'恢复默认设置
Application.StatusBar = False
Application.ScreenUpdating = True
Exit Sub
err:
    '设置出错提示信息
    If err.Number = -2147217865 Then
        MsgBox "请确定选择的数据文件为用友U8的数据库", vbExclamation, "提示"
    Else
        MsgBox err.Number
    End If
End Sub

Private Sub CommandButton4_Click()
'这段代码用于搜索局域网中的SQL Server服务器
    '设置出错跳转信息
    On Error GoTo err
    Dim i As Integer
    Dim x As String
    Dim y
    '调用odbc函数搜索局域网中的SQL Server服务器
    x = GetSQLServers
    '将搜索到信息添加到服务器下拉框中
    If InStr(x, ",") Then
    y = split(x, ",")
    For i = 0 To UBound(y)
    ComboBox4.AddItem y
    Next
    Else
    ComboBox4.Text = x
    End If
    MsgBox "已经搜索完毕！如果目标服务器没有找到，可以直接输入服务器的信息。", vbInformation, "提示"
    Exit Sub
err:
    MsgBox "无法搜索到Sql Server服务器，请在下拉框中输入服务器的地址或名称！", vbExclamation, "提示信息"
    Me.ComboBox4.SetFocus
End Sub

Private Sub MultiPage1_Change()

End Sub

Private Sub UserForm_Initialize()
    '初始化窗体显示
    '默认登录为服务器登录
    Me.TextBox1.Enabled = False
    Me.TextBox4.Enabled = False
    
    '默认数据库为空
    Me.ComboBox2.Text = ""
    '恢复保存的数据库地址
    If [U8SERVER] <> "" Then Me.ComboBox4.Value = [U8SERVER]
    Me.TextBox1.Value = [U8ID]
    Me.TextBox4.Value = [U8PW]
End Sub


Private Sub CommandButton17_Click()
'获取选定数据库中的数据表
ComboBox3.Clear
Dim tablename As String
Dim cn As ADODB.Connection
Dim rstSchema As ADODB.Recordset
Dim strCnn As String
Set cn = New ADODB.Connection

If CheckBox1.Value = flase Then
strCnn = "Driver={SQL Server};Server=" & ComboBox4.Value & ";Trusted_Connection=yes;DataBase=" & ComboBox2.Value & ""
Else
strCnn = "Driver={SQL Server};Server=" & ComboBox4.Value & ";UID=" & TextBox1.Value & ";PWD=" & TextBox4.Value & ";DataBase=" & ComboBox2.Value & ""
End If

cn.Open strCnn
'判断数据库服务器连接是否成功
   If cn.State = adStateOpen Then
        MsgBox "数据库服务器连接成功！", vbInformation, "连接服务器"
        Set rstSchema = cn.Execute("select 表名=name from sysobjects where xtype='U'or xtype='V'")
        Do Until rstSchema.EOF
        tablename = rstSchema(0)
        rstSchema.MoveNext
        ComboBox3.AddItem tablename
        Loop
    Else
         MsgBox "数据库服务器连接失败！", vbInformation, "连接服务器"
    End If

End Sub