module1.bas

供应用友财务通、U8软件、速达全系列软件. ... l 报表数据接口：提供与久其报表的接口：符合财政部统计评价司要求的数据接口软件

Attribute VB_Name = "Fun"
Option Explicit

Public Function makeSdjID(s As String, sl As String, Optional isChange5 As Boolean = False) As String
Dim f() As String
Dim ss As String
Dim st As String
f() = Split(sl, ",")
Dim i As Integer
For i = 0 To UBound(f)
   st = Left(s, CInt(f(i)))
   
   If Len(st) < 3 Then
     ss = ss & String(3 - CInt(f(i)), "0") & st
   Else
     ss = ss & Right(st, 3)
   End If
   s = Right(s, Len(s) - Len(st))
   If s = "" Then Exit For
Next i
  If isChange5 Then
     If Left(ss, 1) = "4" Then
        ss = "5" & Right(ss, Len(ss) - 1)
     End If
  End If
  makeSdjID = ss
End Function
Public Function GetOneValueFromDB(sql As String, cnString As String) As String
On Error GoTo errH:
    
    Dim cn As ADODB.Connection
    Dim rs As ADODB.Recordset
    Set cn = New ADODB.Connection
    Set rs = New ADODB.Recordset
    cn.Open cnString
    rs.Open sql, cn
    On Error Resume Next
    If Not rs.EOF Then
       GetOneValueFromDB = rs.Fields(0) & ""
    Else
       GetOneValueFromDB = ""
    End If
    
    rs.Close
    cn.Close
    
    Set rs = Nothing
    Set cn = Nothing
Exit Function
errH:
  MsgBox "取值错误：" & Err.Number & " " & Err.Description, vbInformation
  GetOneValueFromDB = ""
  Resume Next
End Function

Public Function getSubjectName(scn As ADODB.Connection, subjectID As String) As String
    Dim subjectname As String
    subjectname = ""
    Dim rs As ADODB.Recordset
    Set rs = New ADODB.Recordset
    Dim a As Integer
    For a = 1 To Len(subjectID) / 3
       rs.Open "select 科目名称 from subject where 科目代码='" & Left(subjectID, 3 * a) & "'", scn
       If Not rs.EOF Then
         If subjectname = "" Then
           subjectname = rs.Fields(0)
         Else
           subjectname = subjectname & "→" & rs.Fields(0)
         End If
       End If
       rs.Close
    Next a
    Set rs = Nothing
    getSubjectName = subjectname
End Function