modulepublic.bas

用VB实现连接oracle817数据月报数输入并统计

Attribute VB_Name = "Modulepublic"
Global Const MSGTITLE As String = "财务月报表系统"
Public CONN As ADODB.Connection   '本地数据库连接名称
Public COMM As ADODB.Command      '本地数据库执行命令
Public RS   As ADODB.Recordset    '本地数据库记录集
Public DataName As String         '本地数据库名称

Public UID As String              '用户代号
Public PWD As String              '用户密码

Private fso As New FileSystemObject, fil1, fil2, txtfile
Public Const APP_ERROR = -110                          '错误编号
Public gOper As CZY                                    '全局的操作员信息
Public gBmdm(26) As BMDM                               '全省支队信息
Public nZdsl As Long                                   '全省支队数量
Public gCzyBmdm As BMDM                                '操作员部门信息
Public gSysDate As String                              '全局系统日期
Public gYbhz As YBHZ                                   '月报汇总
Public gYbmx(26) As YBMX                               '月报明细
Public l_ADORs As New ADODB.Recordset
Public l_adoRsCJ As New ADODB.Recordset
Public nQue As Long                                  '0 -- 还要检查  1 -- 确定保存
Public nBcbz As Long                                 '0 -- 输入未完  1 -- 输入完毕
Public nXgbz As Long                                 '0 -- 修改标志  1 -- 退出标志

Public Sub Main()                                    '根据配置文件xtcfg.ini确定启动界面
'判断程序是否已经运行
  If App.PrevInstance Then
     SM "程序已经运行！"
     Exit Sub
  End If
  UID = "FS"
  PWD = "FS"
  DataName = "CWYB"
  nZdsl = 0
  nQue = 0
  nBcbz = 0
  nXgbz = 1
  
  If fgetCFG Then
    If fConnServer Then
        frmLoginS.Show vbModal
    End If
  End If
  
End Sub

'CONN SERVER 连接本地数据库服务器
Public Function fConnServer() As Boolean
fConnServer = False
 Screen.MousePointer = vbHourglass
 Set CONN = New ADODB.Connection

 CONN.ConnectionString = "Provider=OraOLEDB.Oracle;" & _
                          "Data Source='" & DataName & "';" & _
                          "User ID=FS;" & _
                          "Password=" & PWD & ";" & _
                          "PLSQLRSet=1;"
CONN.CommandTimeout = 10
CONN.CursorLocation = adUseClient
  
On Error GoTo errorHandle
 CONN.Open
 fConnServer = True
 Screen.MousePointer = vbDefault
 
 Exit Function
errorHandle:
    Screen.MousePointer = vbDefault
    MsgBox "连接服务器失败！"
    Exit Function
End Function

'判断用户是否可以登陆
Public Function gf_bHaveRight(ByVal sCzydh As String, ByVal sPasswd As String) As Boolean
Dim m_sSql As String
Dim m_bHaveRs As Boolean
Dim m_myArry As Variant
  m_sSql = "select * from b_czy where vczydh='" & gOper.CZYDH & "' and vpasswd='" & sPasswd & "'"
  gf_bHaveRight = False
On Error GoTo errorHandle
  If Not fGetRS(m_sSql, m_myArry, m_bHaveRs) Then Exit Function
  If m_bHaveRs Then gf_bHaveRight = True
  If m_bHaveRs Then gOper.passwd = sPasswd

Exit Function

errorHandle:
   SM "查询用户信息表出错"

End Function
'执行sql查询游标语句，返回记录集
Public Function fGetSelVal(ByVal tmpSql As String, _
        ByRef tmpHaveRs As Boolean, ByRef tmpRs As ADODB.Recordset) As Boolean
  fGetSelVal = False
  tmpHaveRs = False
   
   Set COMM = New ADODB.Command
  
   On Error GoTo errHandle
  
   COMM.ActiveConnection = CONN
   COMM.CommandText = tmpSql
   Set tmpRs = COMM.Execute
   
   If tmpRs.RecordCount > 0 Then
        tmpHaveRs = True
   Else
        tmpHaveRs = False
   End If
       'MsgBox ("共有" & RS.RecordCount & "条记录")
  
  fGetSelVal = True
  Exit Function

errHandle:
  
   Err.Raise APP_ERROR, "财务月报.数据服务.打开数据游标", Err.Description

End Function

'/取得单条查询数据记录的序号
Public Function fGetStrVal(strSql As String, str As String) As Boolean
  Dim varRs As Variant
  Dim blnHave As Boolean
  Dim tmpId As String
  
  fGetStrVal = False
  blnHave = False
  
  If fGetRS(strSql, varRs, blnHave) Then
     If Not blnHave Then
        SM "没有满足条件的数据"
        Exit Function
     Else
        str = Trim(gCharVal(varRs(0, 0)))
        Erase varRs
        fGetStrVal = True
     End If
  Else
     SM "获取信息出错"
     Exit Function
  End If
End Function

'/取得用户信息
Public Function fGetUser(tmpOper As CZY) As Boolean
Dim strSql As String
Dim varRs As Variant
Dim blnHave As Boolean
  
  fGetUser = False

  If tmpOper.CZYDH <> "" Then
    strSql = "SELECT VCZYDH,VCZYMC,VBMDH,VPASSWD,NZXBZ FROM B_CZY WHERE VCZYDH='" & tmpOper.CZYDH & "'"
  Else
    SM "没有必要的查询条件"
    Exit Function
  End If
  
  If Not fGetRS(strSql, varRs, blnHave) Then
    
    SM "查询用户表出错"
    Exit Function
  
  Else
    If blnHave Then
      tmpOper.CZYDH = gCharVal(varRs(0, 0))
      tmpOper.CZYMC = gCharVal(varRs(1, 0))
      tmpOper.BMDH = gCharVal(varRs(2, 0))
      tmpOper.passwd = gCharVal(varRs(3, 0))
      tmpOper.ZXBZ = gNumVal(varRs(4, 0))
      fGetUser = True
      Erase varRs
    Else
      SM "该用户不存在"
      Exit Function
    End If
  End If
 
End Function

'/取得部门信息
Public Function fGetBmxx(tmpBmdm As BMDM) As Boolean
Dim strSql As String
Dim varRs As Variant
Dim blnHave As Boolean
  
  fGetBmxx = False
  strSql = "SELECT VBMMC,NBMLX FROM B_BMDM WHERE VBMDH='" & _
            Trim(gOper.BMDH) & "'"
 
  If Not fGetRS(strSql, varRs, blnHave) Then
    
    SM "查询部门信息出错"
    Exit Function
  
  Else
    If blnHave Then
      tmpBmdm.BMDH = gOper.BMDH
      tmpBmdm.BMMC = gCharVal(varRs(0, 0))
      tmpBmdm.BMLX = gNumVal(varRs(1, 0))
      fGetBmxx = True
      Erase varRs
    Else
      SM "该单位信息在本地不存在"
      Exit Function
    End If
  End If
 
End Function

'取得系统配置文件,系统数据库密码,服务器类型mode,数据库名称DBNAME
Private Function fgetCFG() As Boolean
Dim filename As String
Dim lpos, pos1 As Long
Dim str_line, str_get0, str_get1 As String
 
fgetCFG = False

filename = App.Path & "\xtcfg.ini"
If fso.FileExists(filename) = False Then
   MsgBox "缺少服务配置文件！ ~_~"
   Exit Function
End If

On Error GoTo errorHandle
    
    Open filename For Input Access Read As #1
    Do While Not EOF(1)
        Line Input #1, str_line
        lpos = Len(str_line)
        pos1 = InStr(1, str_line, "#", vbTextCompare)
        If pos1 <> 1 Then
           pos1 = InStr(1, str_line, "=", vbTextCompare)
           str_get0 = Mid(str_line, 1, pos1 - 1)
           str_get1 = Mid(str_line, pos1 + 1, lpos - pos1)
           
           If StrComp(str_get0, "DBNAME", 1) = 0 Then
              DataName = Trim(str_get1)                '系统数据库名称
           ElseIf StrComp(str_get0, "PASSWORD", 1) = 0 Then
              PWD = Trim(str_get1)                     '系统数据库密码
           End If
           
        End If
       Loop
       Close #1
       fgetCFG = True
     
     Exit Function
errorHandle:
 MsgBox (Err.Number & Err.Description)
 
End Function

'修改标值
Public Function gf_Xgjkbz(nBz As Long, strBh As String) As Boolean
Dim strSql As String

gf_Xgjkbz = False

strSql = "update B_KSBT set nkszt=" & nBz & " where vbh='" & strBh & "'"

On Error GoTo errHandle
    If Not fExecSql(strSql) Then
       Exit Function
    Else
       gf_Xgjkbz = True
    End If
errHandle:
    Exit Function
End Function
'/------------------------------------------------------------------------------------------------------
'/  功能：                    取系统时间
'/
'/
'/
'/------------------------------------------------------------------------------------------------------
Public Function GetServerTime() As Date
Dim strSql As String
Dim varRs As Variant
Dim blnHave As Boolean

  GetServerTime = #1/1/1900#
  strSql = "SELECT SYSDATE FROM DUAL"
  If Not fGetRS(strSql, varRs, blnHave) Then Exit Function
      
  If blnHave Then
    GetServerTime = Format(varRs(0, 0), gstrDateFormat)
    
    Erase varRs
  Else
    Exit Function
  End If
  
End Function

'/------------------------------------------------------------------------------------------------------
'/  功能：                    取汇总序号
'/
'/
'/
'/------------------------------------------------------------------------------------------------------
Public Function GetHzxh() As String
Dim strSql As String
Dim varRs As Variant
Dim blnHave As Boolean
  
  GetHzxh = ""
  strSql = "SELECT max(to_number(vhzxh)+1) FROM B_YBHZ"
  If Not fGetRS(strSql, varRs, blnHave) Then Exit Function
      
  If blnHave Then
     
     GetHzxh = gCharVal(varRs(0, 0))
     GetHzxh = Format(GetHzxh, "0000")
     Erase varRs
  End If
  
  If Len(Trim(GetHzxh)) < 1 Then
     GetHzxh = "0001"
  End If
  
End Function

'/取得准考证信息
Public Function gGetYbhz(ByRef tmpYbhz As YBHZ) As Boolean
Dim tmpErrxh As Integer
Dim strSql As String
Dim varRs As Variant
Dim blnHave As Boolean
  
  gGetYbhz = False
  
  strSql = "SELECT VHZXH,NYBND,NYBYF,DDJRQ,VZBRDH FROM B_YBHZ WHERE NYBND=" & tmpYbhz.YBND & _
           " AND NYBYF=" & tmpYbhz.YBYF
  
  
  If Not fGetRS(strSql, varRs, blnHave) Then
     Exit Function
  Else
      If blnHave Then
        tmpYbhz.HZXH = Trim(gCharVal(varRs(0, 0)))
        tmpYbhz.YBND = gNumVal(varRs(1, 0))
        tmpYbhz.YBYF = gNumVal(varRs(2, 0))
        Erase varRs
     
        If Not gGetYbmx(tmpYbhz.HZXH) Then Exit Function
      
      Else
        frmSm.Caption = "没有" & tmpYbhz.YBND & "年" & tmpYbhz.YBYF & "财务月报资料！"
        Exit Function
      End If
  End If
  gGetYbhz = True
      
End Function

'获得考试数据,装入全局数组arrKsxx中
Public Function gGetYbmx(ByRef strXh As String) As Boolean
 
  Dim strSql As String
  Dim varRs As Variant
  Dim blnHave As Boolean
  Dim iCount As Integer
  
  gGetYbmx = False
   
  strSql = "SELECT X.VHZXH VHZXH,X.VBMDH VBMDH,X.NBGSBGZF NBGSBGZF,X.NZYSBGZF NZYSBGZF," & _
           "X.NJTGJGZF NJTGJGZF,X.NCLGLCBF NCLGLCBF,X.NZXKJJSF NZXKJJSF,X.NBZGZF NBZGZF," & _
           "X.NQCGZF NQCGZF,X.NQT NQT,X.NGGFYFT NGGFYFT,X.NZJBC NZJBC,X.NBCFT NBCFT," & _
           "X.NSGJFXB NSGJFXB,X.NZFK NZFK,B.VBMMC VBMMC FROM B_YBMX X,B_BMDM B WHERE " & _
           "X.VBMDH=B.VBMDH AND X.VHZXH='" & strXh & "' ORDER BY B.NSX"
          
  

  
  If Not fGetRS(strSql, varRs, blnHave) Then Exit Function
  
  If blnHave Then
      
      iCount = UBound(varRs, 2)
      For i = 0 To iCount
       gYbmx(i).HZXH = Trim(gCharVal(varRs(0, i)))             '为编号变量赋值
       gYbmx(i).BMDH = Trim(gCharVal(varRs(1, i)))             '为答案变量赋值
       gYbmx(i).BGSBGZF = gNumVal(varRs(2, i))             '为结果变量赋值
       gYbmx(i).ZYSBGZF = gNumVal(varRs(3, i))             '为试题编号赋值
       gYbmx(i).JTGJGZF = gNumVal(varRs(4, i))             '为题型代码赋值
       gYbmx(i).CLGLCBF = gNumVal(varRs(5, i))             '选择题答案
       gYbmx(i).ZXKJJSF = gNumVal(varRs(6, i))             '判断题答案
       gYbmx(i).BZGZF = gNumVal(varRs(7, i))             '试题内容
       gYbmx(i).QCGZF = gNumVal(varRs(8, i))             '为题型变量赋值
       gYbmx(i).QT = gNumVal(varRs(9, i))             '是否含图像
       gYbmx(i).GGFYFT = gNumVal(varRs(10, i))             '为结果变量赋值
       gYbmx(i).ZJBC = gNumVal(varRs(11, i))             '为试题编号赋值
       gYbmx(i).BCFT = gNumVal(varRs(12, i))             '为题型代码赋值
       gYbmx(i).SGJFXB = gNumVal(varRs(13, i))             '选择题答案
       gYbmx(i).ZFK = gNumVal(varRs(14, i))             '试题内容
       gBmdm(i).BMDH = Trim(gCharVal(varRs(1, i)))
       gBmdm(i).BMMC = Trim(gCharVal(varRs(15, i)))
       
      Next i
      
         
  End If
  nZdsl = iCount
  gGetYbmx = True

End Function