ExcelHome技术论坛

 找回密码
 免费注册

QQ登录

只需一步,快速开始

快捷登录

搜索
EH技术汇-专业的职场技能充电站 妙哉!函数段子手趣味讲函数 Excel服务器-会Excel,做管理系统 效率神器,一键搞定繁琐工作
HR薪酬管理数字化实战 Excel 2021函数公式学习大典 Excel数据透视表实战秘技 打造核心竞争力的职场宝典
让更多数据处理,一键完成 数据工作者的案头书 免费直播课集锦 ExcelHome出品 - VBA代码宝免费下载
用ChatGPT与VBA一键搞定Excel WPS表格从入门到精通 Excel VBA经典代码实践指南
查看: 997|回复: 5

求助高手解答这段代码为什么到18年就不用了

[复制链接]

TA的精华主题

TA的得分主题

发表于 2018-3-18 09:54 | 显示全部楼层 |阅读模式
Option Explicit

Public Const YingSoftName As String = "X_ExcelFunc"
Public Const YingSoftVersion As String = "v2.3"
Public Const YingSoftCopyright As String = "Copyright 2010"
Public Const YingSoftCopyrightCompany As String = "(C) 财务部"

Public X_Connection As New ADODB.Connection
Public X_CMD As New ADODB.Command

Public Const X_IP As String = "10.10.3.3"
Public Const X_User As String = "sa"
Public Const X_PWD As String = "770770"
Public Const X_DefaultDB As String = "YAXIA_Co_LTD"

Private Declare Function GetSystemDirectory Lib "kernel32" Alias "GetSystemDirectoryA" (ByVal lpBuffer As String, ByVal nSize As Long) As Long

Private Function mGetSys32Path() As String
Dim sReturn As String, lReturn As Long
    sReturn = Space(255)
    'Get the system directory,GetSystemDirectory这个函数能取得Windows系统目录(System目录)的完整路径名
    lReturn = GetSystemDirectory(sReturn, 255)
    'Remove all unnecessary chr$(0)'s
    sReturn = Left$(sReturn, lReturn)
    'Show the windows directory
    mGetSys32Path = sReturn
    '    ====================================
    '    另一个方法,可不要 GetSystemDirectory函数
    '    Dim fso
    '    Set fso = CreateObject("scripting.filesystemobject")
    '    mGetSys32Path = fso.GetSpecialFolder(1)
    '    Set fso = Nothing
    '    ====================================
End Function

Public Sub gRegisterUDF(ByVal FunctionName As String, ByVal Category As String, ByVal Description As String, ByVal Args As String, ByVal DescriptionArgs As String)
    '借用 Excel Macro 4.0 的 Register 宏函数, 而通过 Application 的 ExecuteExcel4Macro 方法来调用 Excel 的宏函数命令。
    '这个方法可以自动注册一个 Excel 自定义工作表函数。在Excel函数向导中就可以显示出来函数参数的说明。
    '参数说明
    'FunctionName:    工作表函数名
    'Category:    函数类别
    'Descript ion: 函数说明
    'Args: 参数列表. 参数之间用 "," 分隔
    'DescriptionArgs: 参数说明.参数说明之间用 "," 分隔
    Dim S As String
    S = "REGISTER(""" & mGetSys32Path() & "\user32.dll"",""CharPrevA"",""PPP"",""" _
          & FunctionName & """,""" & Args & """,1" _
          & ",""" & Category & """,,,""" & Description & """," & DescriptionArgs & ")"
    Application.ExecuteExcel4Macro S
End Sub

Public Sub gUnRegisterUDF(ByVal FunctionName As String)
    With Application
        .ExecuteExcel4Macro "UNREGISTER(" & FunctionName & ")"
        .ExecuteExcel4Macro "REGISTER(""" & mGetSys32Path() & "\user32.dll""" & _
            ",""CharPrevA"",""P"",""" & FunctionName & """,,0)"
        .ExecuteExcel4Macro "UNREGISTER(""" & FunctionName & """)"
    End With
End Sub

Public Sub ConnectXEFServer()
  Dim StrConnection As String
  If X_Connection.State = adStateOpen Then Exit Sub
  With X_Connection
    .Provider = "SQLOLEDB.1"
    .ConnectionTimeout = 10
    .CursorLocation = adUseClient
    .ConnectionString = "Data Source=" & X_IP & ";User ID=" & X_User & ";Password=" & X_PWD
    .Open
    .DefaultDatabase = X_DefaultDB
  End With
  With X_CMD
    .ActiveConnection = X_Connection
    .CommandType = adCmdStoredProc
    .CommandText = "S_XK3Acct120711 "
  End With
End Sub

Public Function XK3Acct(ByVal 账套 As String, ByVal 科目 As String, Optional ByVal 项目类别 As String = "", Optional ByVal 项目代码 As String = "", Optional ByVal 取数类型 As String = "Y", Optional ByVal 年度 As Integer = 0, Optional ByVal 起始期间 As Integer = 1, Optional ByVal 终止期间 As Integer = 12, Optional ByVal 包含未过账凭证 As Boolean = True) As Variant
  Dim AS_Result As Currency
  Dim ARETURN_VALUE As Integer
  Dim AFuncErrorMsg As String
  If 年度 = 0 Then 年度 = VBA.Year(Now())
  If X_Connection.State <> adStateOpen Then ConnectXEFServer
  On Error Resume Next
  With X_CMD
    .Parameters.Append .CreateParameter("Account", adBSTR, adParamInput, 100)
    .Parameters.Append .CreateParameter("SubjectNumber", adBSTR, adParamInput, 50)
    .Parameters.Append .CreateParameter("ItemClass", adBSTR, adParamInput, 50)
    .Parameters.Append .CreateParameter("ItemNumber", adBSTR, adParamInput, 50)
    .Parameters.Append .CreateParameter("AcctType", adBSTR, adParamInput, 4)
    .Parameters.Append .CreateParameter("Year", adInteger, adParamInput)
    .Parameters.Append .CreateParameter("PeriodFrom", adInteger, adParamInput)
    .Parameters.Append .CreateParameter("PeriodTo", adInteger, adParamInput)
    .Parameters.Append .CreateParameter("IncludeV", adBoolean, adParamInput)
    .Parameters.Append .CreateParameter("S_Result", adCurrency, adParamOutput)
    .Parameters.Append .CreateParameter("RETURN_VALUE", adInteger, adParamReturnValue)
    .Parameters.Refresh
    .Parameters("@Account").Value = 账套
    .Parameters("@SubjectNumber").Value = 科目
    .Parameters("@ItemClass").Value = 项目类别
    .Parameters("@ItemNumber").Value = 项目代码
    .Parameters("@AcctType").Value = 取数类型
    .Parameters("@Year").Value = 年度
    .Parameters("@PeriodFrom").Value = 起始期间
    .Parameters("@PeriodTo").Value = 终止期间
    .Parameters("@IncludeV").Value = 包含未过账凭证
    .Parameters("@S_Result").Value = AS_Result
    .Parameters("@RETURN_VALUE").Value = ARETURN_VALUE
    .Execute
    If .Parameters("@RETURN_VALUE").Value = 0 Then
      XK3Acct = .Parameters("@S_Result").Value
    Else
      Select Case .Parameters("@RETURN_VALUE").Value
        Case 1
          AFuncErrorMsg = "指定的取数类型不正确"
        Case 2
          AFuncErrorMsg = "指定的年度或月份有错误"
        Case 3
          AFuncErrorMsg = "指定的账套名称或账套编号没有找到"
      End Select
      XK3Acct = AFuncErrorMsg
    End If
  End With
End Function


TA的精华主题

TA的得分主题

 楼主| 发表于 2018-3-27 13:15 | 显示全部楼层
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用  · 内置多项VBA编程加强工具       ★ 免费下载 ★      ★使用手册
这么久了 都没人解答?

TA的精华主题

TA的得分主题

 楼主| 发表于 2019-12-31 13:46 | 显示全部楼层

TA的精华主题

TA的得分主题

 楼主| 发表于 2020-1-4 12:42 | 显示全部楼层
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用  · 内置多项VBA编程加强工具       ★ 免费下载 ★      ★使用手册
求大神老师看看 解答下啊

TA的精华主题

TA的得分主题

发表于 2020-1-12 13:35 | 显示全部楼层

TA的精华主题

TA的得分主题

发表于 2020-1-30 19:45 | 显示全部楼层
从代码看不出来和年份有相关性,最有可能的是数据库连接问题,可能是数据库密码在18年改掉了,所以这段代码用不了。
您需要登录后才可以回帖 登录 | 免费注册

本版积分规则

手机版|关于我们|联系我们|ExcelHome

GMT+8, 2024-12-28 20:10 , Processed in 0.043608 second(s), 10 queries , Gzip On, MemCache On.

Powered by Discuz! X3.4

© 1999-2023 Wooffice Inc.

沪公网安备 31011702000001号 沪ICP备11019229号-2

本论坛言论纯属发表者个人意见,任何违反国家相关法律的言论,本站将协助国家相关部门追究发言者责任!     本站特聘法律顾问:李志群律师

快速回复 返回顶部 返回列表