打开APP
userphoto
未登录

开通VIP,畅享免费电子书等14项超值服

开通VIP
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 = adStateOpenThen
       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("SELECTname,create_date,state FROM sys.databases ORDER BY 1DESC")
       If rct.EOF =True And rct.BOF = True Then
           MsgBox"Excel未能正确返回查询结果,请检查SQL语句是否正确!", vbExclamation, "操作失败"
           ExitSub
       Else
           Dim r AsInteger
          ComboBox2.Clear
           While Notrct.EOF
             ComboBox2.AddItemrct.Fields(0).Value
             'ComboBox2.AddItem rct.Fields("name").Value
             r = r +1
             rct.MoveNext
          Wend
       EndIf
       MsgBox"请选择相应的数据库!", vbInformation, "连接成功!"
       ComboBox2.SetFocus
    Else
        MsgBox"数据库服务器连接失败!", vbInformation, "连接服务器"
    End If
    Exit Sub
err:
    MsgBox "无法在指定的SqlServer服务器查找到数据库,请检查服务器的地址或名称是否正确!", 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 AsString  '用于保存新增凭证表的名称
n = 1
'根据是否指定登录ID,构建连接字符串
If CheckBox1.Value = flase Then
    strCnn = "Driver={SQLServer};Server=" & ComboBox4.Value &";Trusted_Connection=yes;DataBase=" & ComboBox2.Value &""
Else
    strCnn = "Driver={SQLServer};Server=" & ComboBox4.Value & ";UID=" &TextBox1.Value & ";PWD=" & TextBox4.Value &";DataBase=" & ComboBox2.Value & ""
End If
'打开数据库连接
cn.Open strCnn
'判断数据库服务器连接是否成功
   If cn.State = adStateOpenThen
       '在状态栏显示当前进度
       Application.StatusBar= "正在导入凭证库,请稍候..."
       '打开记录集,导入凭证库
       Set rs =cn.Execute("SELECT Gl_accvouch.dbill_date, Gl_accvouch.ino_id,Gl_accvouch.ccode, Gl_accvouch.cdigest,fx=case whenGl_accvouch.md=0 then'贷'when Gl_accvouch.md<>0then'借'end,(Gl_accvouch.nd_s+Gl_accvouch.nc_s) ASsl,Gl_accvouch.cexch_name, (Gl_accvouch.md_f+Gl_accvouch.mc_f) ASwb, (Gl_accvouch.md+Gl_accvouch.mc) AS jin, '' as gj,''asxm,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 Notrs.EOF
         '增加一个新表,并将其名称命名为凭证n
          stname ="凭证" & n
         ThisWorkbook.Sheets.AddAfter:=ThisWorkbook.Sheets(Sheets.Count)
         '设置凭证表的样式,并导入记录
          WithActiveSheet
             .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
          EndWith
          n = n +1
       Wend
       '清空记录集
       Set rs =Nothing
    Else
        MsgBox"数据库服务器连接失败!", vbInformation, "连接服务器"
    End If
   'U8中设置了辅助核算,导入部门表
   Application.StatusBar ="正在导入部门表,请稍候..."
   Set rs = cn.Execute("SELECTcDepCode,cDepName from department")
  Sheets("部门").Range("A2").CopyFromRecordsetrs
   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 DISTINCTgl_accass.ccode, '' AS kmmc, gl_accass.csup_id, Vendor.cVenNameFROM gl_accass LEFT JOIN Vendor ONgl_accass.csup_id=Vendor.cVenCode WHERE(((gl_accass.csup_id)<>0)))  ASclist 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 cqcON (clist.csup_id=cqc.csup_id) AND (clist.ccode=cqc.ccode)) INNERJOIN (SELECT gl_accass.ccode, gl_accass.csup_id, Sum(gl_accass.md)AS jie, Sum(gl_accass.mc) AS dai FROM gl_accass GROUP BYgl_accass.ccode, gl_accass.csup_id HAVING(((gl_accass.csup_id)<>0)))  AScjd 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)))  AScqm ON (clist.csup_id=cqm.csup_id) AND(clist.ccode=cqm.ccode)")
  Sheets("供应商").Range("A2").CopyFromRecordsetrs
   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 DISTINCTgl_accass.ccode, '' AS kmmc, gl_accass.ccus_id, customer.cCusNameFROM gl_accass LEFT JOIN customer ONgl_accass.ccus_id=customer.cCusCode WHERE(((gl_accass.ccus_id)<>0)))  ASclist 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 cqcON (clist.ccus_id=cqc.ccus_id) AND (clist.ccode=cqc.ccode)) INNERJOIN (SELECT gl_accass.ccode, gl_accass.ccus_id, Sum(gl_accass.md)AS jie, Sum(gl_accass.mc) AS dai FROM gl_accass GROUP BYgl_accass.ccode, gl_accass.ccus_id HAVING(((gl_accass.ccus_id)<>0)))  AScjd 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)))  AScqm ON (clist.ccus_id=cqm.ccus_id) AND(clist.ccode=cqm.ccode)")
  Sheets("客户").Range("A2").CopyFromRecordsetrs
   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 DISTINCTgl_accass.ccode, '' AS kmmc, gl_accass.cperson_id,Person.cPersonName FROM gl_accass LEFT JOIN Person ONgl_accass.cperson_id=Person.cPersonCode WHERE(((gl_accass.cperson_id)<>0)))  ASclist 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 cqcON (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_accassGROUP BY gl_accass.ccode, gl_accass.cperson_id HAVING(((gl_accass.cperson_id)<>0)))  AScjd 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 FROMgl_accass WHERE (((gl_accass.cperson_id)<>0) AND((gl_accass.iperiod)=12)))  AScqm ON (clist.cperson_id=cqm.cperson_id) AND(clist.ccode=cqm.ccode)")
  Sheets("人名").Range("A2").CopyFromRecordsetrs
   Set rs = Nothing
   '导入科目余额表
   Application.StatusBar ="正在导入余额表,请稍候..."
   Set rs = cn.Execute("SELECTCode.ccode, Code.ccode_name, 期初.期初借方, 期初.期初贷方, 借贷方.借方, 借贷方.贷方,期末.期末借方, 期末.期末贷方 FROM ((Code LEFT JOIN (SELECT Gl_accsum.ccode,期初借方=case when Gl_accsum.cbegind_c='借' then Gl_accsum.mb whenGl_accsum.cbegind_c<>'借' then 0 end, 期初贷方=case whenGl_accsum.cbegind_c='贷' then Gl_accsum.mb whenGl_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_accsumGROUP BY Gl_accsum.ccode)  AS 借贷方ON Code.ccode=借贷方.ccode) LEFT JOIN (SELECT Gl_accsum.ccode,期末借方=case when Gl_accsum.cendd_c='借' then Gl_accsum.mewhen  Gl_accsum.cendd_c<>'借'then 0 end, 期末贷方=case when Gl_accsum.cendd_c='贷' then Gl_accsum.mewhen 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").CopyFromRecordsetrs
   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 = -2147217865Then
       MsgBox"请确定选择的数据文件为用友U8的数据库", vbExclamation, "提示"
    Else
       MsgBoxerr.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函数搜索局域网中的SQLServer服务器
    x = GetSQLServers
    '将搜索到信息添加到服务器下拉框中
    If InStr(x, ",")Then
    y = split(x, ",")
    For i = 0 ToUBound(y)
    ComboBox4.AddItem y
    Next
    Else
    ComboBox4.Text = x
    End If
    MsgBox"已经搜索完毕!如果目标服务器没有找到,可以直接输入服务器的信息。", vbInformation, "提示"
    Exit Sub
err:
    MsgBox "无法搜索到SqlServer服务器,请在下拉框中输入服务器的地址或名称!", 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 = adStateOpenThen
       MsgBox"数据库服务器连接成功!", vbInformation, "连接服务器"
       Set rstSchema= cn.Execute("select 表名=name from sysobjects where xtype='U'orxtype='V'")
       Do UntilrstSchema.EOF
       tablename =rstSchema(0)
       rstSchema.MoveNext
       ComboBox3.AddItemtablename
       Loop
    Else
        MsgBox"数据库服务器连接失败!", vbInformation, "连接服务器"
    End If

End Sub
本站仅提供存储服务,所有内容均由用户发布,如发现有害或侵权内容,请点击举报
打开APP,阅读全文并永久保存 查看更多类似文章
猜你喜欢
类似文章
【热】打开小程序,算一算2024你的财运
通过实例来学习VBA代码
vba word基本操作(经典)
Excel VBA 读取Access数据库字段信息
在VB中创建word文档?
VB.NET下遍历TextBox组件的方法
VBA窗体-实现二级菜单功能
更多类似文章 >>
生活服务
热点新闻
分享 收藏 导长图 关注 下载文章
绑定账号成功
后续可登录账号畅享VIP特权!
如果VIP功能使用有故障,
可点击这里联系客服!

联系客服