|
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
|
|