modmain.bas

VB税控的源代码 主要用于地方税务局的税控引用 有完整的控件和代码

    iPos = InStr(dMoney, ".")
    If iPos > 0 Then
        sNum = CStr(Mid(dMoney, 1, iPos - 1))
    Else
        sNum = CStr(dMoney)
    End If
    
    iTotalLen = Len(CStr(sNum))
    For i = 1 To iTotalLen
        iValue = Mid(sNum, i, 1)
        sValue = sChangeType(iValue)          '''把数据转化为大写
        If sValue <> "" Then                  '''如果数据不为空
            sPlace = sValuePlace(iTotalLen - i + 1)       '''算出该数据所对应的位置
            Call ChangeStatus(i, iValue, sPlace)
            
            sValue = sValue + sPlace
            sTotalValue = sTotalValue + sValue
        End If
    Next
    
    
    If iPos > 0 Then
'        sNum = CStr(Mid(dMoney, 1, iPos - 1))
        sValue = Mid(dMoney, iPos + 1, 1)
        If sValue <> "" Then
            sCent = sChangeType(CInt(sValue)) + "角"
            Call ChangeStatus(i, CInt(sValue), "角")
        End If
        
        sValue = Mid(dMoney, iPos + 2, 1)
        If sValue <> "" Then
            sCent = sCent + sChangeType(CInt(sValue)) + "分"
            Call ChangeStatus(i + 1, CInt(sValue), "分")
        Else
            sCent = sCent + "零分"
            vsDecimal = "0"
            Call ChangeStatus(i + 1, CInt(0), "分")
        End If
    Else
'        sNum = CStr(dMoney)
        sCent = "零角零分"
        vsDecimal = ".00"
        Call ChangeStatus(i, CInt(0), "角")
        Call ChangeStatus(i + 1, CInt(0), "分")
    End If
     
    sGetTotalMoney = sMinus + sTotalValue + sCent
    
End Function

Private Sub ChangeStatus(ByVal vIndex As Integer, ByVal vIvalue As Integer, ByVal sPlace As String)
    If gsChequeType = "B" Then
        frmBuild.img9((vIndex - 1) * 10 + vIvalue).Visible = True
        frmBuild.lbl9(vIndex - 1).Visible = True
        frmBuild.lbl9(vIndex - 1).Caption = sPlace
    ElseIf gsChequeType = "E" Then
        frmEstate.img9((vIndex - 1) * 10 + vIvalue).Visible = True
        frmEstate.lbl9(vIndex - 1).Visible = True
        frmEstate.lbl9(vIndex - 1).Caption = sPlace
    Else
        frmCommol.img9((vIndex - 1) * 10 + vIvalue).Visible = True
        frmCommol.lbl9(vIndex - 1).Visible = True
        frmCommol.lbl9(vIndex - 1).Caption = sPlace
    End If
End Sub

'取消位数的显示
Private Sub CancelLabelView()
On Error Resume Next
    Dim i As Integer
    
    
    
    For i = 0 To 10
        If gsChequeType = "B" Then
            frmBuild.lbl9(i).Visible = False
        ElseIf gsChequeType = "C" Then
            If i > 9 Then Exit For
            frmCommol.lbl9(i).Visible = False
        Else
            frmEstate.lbl9(i).Visible = False
        End If
    Next
    i = 0
    For i = 0 To 109
        If gsChequeType = "B" Then
            frmBuild.img9(i).Visible = False
        ElseIf gsChequeType = "C" Then
            If i > 99 Then Exit For
            frmCommol.img9(i).Visible = False
        Else
            frmEstate.img9(i).Visible = False
        End If
    Next
    
End Sub

'数值的位置
Private Function sValuePlace(viPlace As Integer)
    Dim sPlace As String
    
    Select Case viPlace
        Case 1
            sPlace = "元"
        Case 2
            sPlace = "拾"
        Case 3
            sPlace = "佰"
        Case 4
            sPlace = "仟"
        Case 5
            sPlace = "万"
        Case 6
            sPlace = "拾"
        Case 7
            sPlace = "佰"
        Case 8
            sPlace = "仟"
        Case 9
            sPlace = "亿"
        Case 10
            sPlace = "拾"

    End Select
    
    sValuePlace = sPlace
End Function

'把数据类型转换为大写
Private Function sChangeType(vIvalue As Integer)
    Dim sValue As String
    
    Select Case vIvalue
        Case 0
            sValue = "零"
        Case 1
            sValue = "壹"
        Case 2
            sValue = "贰"
        Case 3
            sValue = "叁"
        Case 4
            sValue = "肆"
        Case 5
            sValue = "伍"
        Case 6
            sValue = "陆"
        Case 7
            sValue = "柒"
        Case 8
            sValue = "捌"
        Case 9
            sValue = "玖"
    End Select
    
    sChangeType = sValue
    
End Function

'检查发票号是否唯一
Public Function bChequeCode(vsCode As String, vsTable As String, Optional vsDate As String) As Boolean
On Error GoTo Err
    Dim StrSQL As String
    Dim recCode As ADODB.Recordset
    
    Set recCode = New ADODB.Recordset
    StrSQL = "select * from " + gsconTabel + vsTable + " where chequecode='" + _
              vsCode + "' and chequedate like '" + vsDate + "%'"
              
    If recCode.State = 1 Then recCode.Close
    recCode.CursorLocation = adUseClient
    recCode.Open StrSQL, gConn, adOpenStatic, adLockReadOnly
    
    If recCode.RecordCount > 0 Then
        bChequeCode = False
    Else
        bChequeCode = True
    End If
    
    Exit Function
Err:
    bChequeCode = False
End Function

'发票作废
Public Function bBlankoutCheque(vsUpdateValue As String, vsCode As String, _
                              vsTable As String, Optional ByVal vdMoney As Double, _
                                                  Optional ByVal vsItemName As String, _
                                                  Optional ByVal vsDate As String) As Boolean
On Error GoTo Err
    Dim StrSQL As String
    Dim sTable As String
    Dim recMoney As ADODB.Recordset
    Dim objEncrypt As encrypt
    Dim dTotalMoney As Double
    Dim sErr As String
    Dim sMoeny As String
    Dim recCheck As ADODB.Recordset
    Dim sInfo As String
    
    bBlankoutCheque = True
    
    If vsUpdateValue = "作废" Then
        StrSQL = "select count(*) from " + gsconTabel + vsTable + " where chequecode ='" + vsCode + "' and chequestatus ='作废'"
        Set recCheck = gConn.Execute(StrSQL)
    
        If recCheck.Fields(0).Value > 0 Then Exit Function              '''检查是否已经作废过了
    End If
    
    StrSQL = "update " + gsconTabel + vsTable + " set chequestatus ='" + _
             vsUpdateValue + "',chequenote ='" + gsBlankOutNote + _
             "' where chequecode ='" + vsCode + "' and chequedate ='" + vsDate + "' and unitcode ='" + gsUnitCode + "'"
    If gsChequeType = "C" And gbChequeLine = True Then
        If gConnServer Is Nothing Then
            If bConnectDB = False Then Exit Function
        End If
        gConnServer.Execute (StrSQL)
    ElseIf gbChequeLine = True Then
        sInfo = mobjData.binsertdata("", StrSQL, gsUnitCode, gsOpenCode)
        If bConverOpenInfo(sInfo) = False Then
            Set mobjData = Nothing
            Exit Function
        End If
    End If
    
    gConn.Execute (StrSQL)
    
    If vsItemName = "" Or vsUpdateValue = "正常" Then
        Exit Function
    End If
    
    sTable = Mid(vsTable, 1, Len(vsTable) - 4)
    
    If gsChequeType <> "E" Then
        StrSQL = "select totalmoney from " + gsconTabel + sTable + " where itemname= '" + vsItemName + "'" '''建筑和通用发票以项目为标识
    Else
        StrSQL = "select totalmoney from " + gsconTabel + sTable + " where estatecode= '" + vsItemName + "'" '''不动产以合同号为标识
    End If
    
    Set recMoney = New ADODB.Recordset
    Set objEncrypt = New encrypt
    If recMoney.State = 1 Then recMoney.Close
    recMoney.CursorLocation = adUseClient
    recMoney.Open StrSQL, gConn, adOpenStatic, adLockReadOnly
    
    If recMoney.RecordCount = 0 Then Exit Function
    If IsNull(recMoney.Fields(0)) Then Exit Function
    
    dTotalMoney = CDbl(objEncrypt.unencrypt_str(recMoney.Fields(0), "12345678", sErr))   '''对数据进行解密
    If sErr <> "" Then Exit Function
    dTotalMoney = dTotalMoney - vdMoney                                                  '''减去作废的数量
    sMoeny = objEncrypt.encrypt_str(dTotalMoney, "12345678", sErr)                       '''对数据进行加密
    If sErr <> "" Then Exit Function
    
    If gsChequeType <> "E" Then
        StrSQL = "update " + gsconTabel + sTable + " set totalmoney ='" + _
             sMoeny + "'  where itemname= '" + vsItemName + "'"
    Else
        StrSQL = "update " + gsconTabel + sTable + " set totalmoney ='" + _
             sMoeny + "' where estatecode= '" + vsItemName + "'"
    End If
    
    gConn.Execute StrSQL
    
    bBlankoutCheque = True
    Exit Function
Err:

End Function

'=======================================================================
'描 述：完成往软盘、电子邮件目录复制数据。
'输 入：无
'输 出：True - 成功；False - 失败；
'调用关系：被调用 -外部函数
'         调  用 -无
'========================================================================
'========================================================================
    
Public Function bCompressFiles(vsFildPath As String, vsSendType As String) As Boolean
 On Error GoTo Err
    Dim oCpress As New clsCompress                  ''' 压缩文件类
    Dim fo As Folder
    Dim f As file
    
    ''' 删除同名的文件
    bCompressFiles = False
    Set fo = fs.GetFolder(vsFildPath)
    For Each f In fo.Files
        If InStr(1, LCase(f.Name), "archive") > 0 Then
            f.Delete True
        End If
    Next
    
    ''' 压缩文件
    oCpress.CompressPath = vsFildPath
    oCpress.FileName = vsFildPath & "\Archive001.dat"
    If vsSendType = "P" Then
        oCpress.FileSize = 1300
    Else
        oCpress.FileSize = 0
    End If
    
    If oCpress.Compress = False Then Exit Function
    
    bCompressFiles = True
    Exit Function
Err:
    MsgBox "文件压缩不能压缩，数据上报失败！", vbOKOnly + vbCritical, "提示信息"
End Function

'=======================================================================
'描 述：把数据复制到软盘。
'输 入：无
'输 出：True - 成功；False - 失败；
'调用关系：被调用 -外部函数
'         调  用 -无
'========================================================================
'========================================================================

Public Function CopyToDriverA(vsFilePath As String) As Boolean
    Dim iCount As Integer                       ''' 总文件数
    Dim i As Integer                            ''' 当前文件
    Dim fo As Folder                            ''' 文件夹
    Dim iFileNum As Integer                     ''' 文件
    Dim sFile As String                         ''' 文件名
    Dim bReady As Boolean                       ''' 软驱是否准备好
    Dim bCancel As Boolean
    Dim iRtn As Integer
    Dim oFile As file
    Dim fc, f1
    
    Set fo = fs.GetFolder(vsFilePath)
    
    Set fc = fo.Files
    For Each f1 In fc
        If LCase(Left(f1.Name, 7)) = "archive" Then
            iCount = iCount + 1
        End If
    Next
    
    iFileNum = FreeFile
    CopyToDriverA = False