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

drewking8843

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

drewking8843

这么久了 都没人解答？

drewking8843

这都快2年了 还没人解决

drewking8843

求大神老师看看 解答下啊

YZC51

drewking8843 发表于 2020-1-4 12:42
求大神老师看看 解答下啊

没有附件，大师们没办法调试！！！

bayuejun

从代码看不出来和年份有相关性，最有可能的是数据库连接问题，可能是数据库密码在18年改掉了，所以这段代码用不了。