wizard.frm

金算盘软件代码

''''''''''''''''''''''''''''''''''''''''''''
Option Explicit
Option Compare Text

Private Const intTop = 540
Private Const intLeft = 1680

Private mblnIsSuccess As Boolean
Private mblnIsInit As Boolean
Private mblnBaseIsValid As Boolean
Private mblnDateOK As Boolean
Private mblnBaseDateErr As Boolean
Private mclsGrid As Grid
Private mdtmDate(0 To 2) As Date     '0-帐套启用日期,1-帐套开始日期,2-帐套结束日期
Private mblnSDateIsChange As Boolean '帐套开始结束日期是否改变。
Private mstrBaseName As String       '新建帐套文件名
Private mintMsgORow As Integer
Private mintMsgOCol As Integer
Private mintPeriods As Integer
Private mintStep As Integer
Private mlngTradeID As Long
Private mstrCurrencyCode As String
Private mstrCurrencyName As String
Private mstrFilepath As String
Private mStrFileName As String
Private mstrAccountSystem As String
Private mblnFileIsRight As Boolean
Private Declare Function GetPrivateProfileString Lib "kernel32" Alias "GetPrivateProfileStringA" (ByVal lpApplicationName As String, ByVal lpKeyName As Any, ByVal lpDefault As String, _
ByVal lpReturnedString As String, ByVal nSize As Long, ByVal lpFileName As String) As Long
Private Declare Function GetWindowsDirectory Lib "kernel32" Alias "GetWindowsDirectoryA" (ByVal lpBuffer As String, ByVal nSize As Long) As Long

Public Function NewBase() As Boolean
    Dim blnTmp As Boolean
    Dim strPathName As String
    Dim strBaseFilename As String
    Dim intCount As Integer
    Dim strErr As String
    
    '关闭主控窗体
    On Error Resume Next
    For intCount = 1 To gclsSys.MainControls.Count
       Unload gclsSys.MainControls(gclsSys.MainControls.Count).Form
    Next
    If gclsSys.MainControls.Count > 0 Then
        ShowMsg frmMain.hwnd, "请先关闭其它窗体，再新建帐套。", vbInformation, frmMain.Caption
        Utility.ClearListRecordSet
        NewBase = False
        Exit Function
    End If
    mblnBaseIsValid = False
    blnTmp = getSourcePathFileName(strBaseFilename, strPathName, strErr)
    If Not blnTmp Then
        ShowMsg hwnd, strErr, vbExclamation, Caption
        Utility.ClearListRecordSet
        NewBase = False
        Exit Function
    End If
    
    If Not gclsBase.OpenDatabase(strBaseFilename, False, False) Then
        ShowMsg hwnd, "不能打开样板数据库，不能新建帐套!", vbExclamation, Caption
        Unload Me
        Exit Function
    End If
    mblnBaseIsValid = True
    Me.Show vbModal
    NewBase = mblnIsSuccess
End Function

Private Sub cboPeriod_Click()
    If mintPeriods <> cboPeriod.list(cboPeriod.ListIndex) Then
        mintPeriods = cboPeriod.list(cboPeriod.ListIndex)
        RefreshPeriod
    End If
End Sub

Private Function CheckValid() As Boolean
    CheckValid = False
    If txtFileName.Text = "" Then
        ShowMsg hwnd, "帐套名不能为空！", vbExclamation, Me.Caption
        stbBuildNewAcnt.Tab = 0
        txtFileName.SetFocus
        Exit Function
    End If
    If txtCurrency(0).Text = "" Then
        ShowMsg hwnd, "本位币编码不能为空！", vbExclamation, Me.Caption
        stbBuildNewAcnt.Tab = 3
        txtCurrency(0).SetFocus
        txtCurrency(0).SelText = mstrCurrencyCode
        txtCurrency(0).SelStart = 0
        txtCurrency(0).SelLength = Len(txtCurrency(0).Text)
        Exit Function
    End If
    If txtCurrency(1).Text = "" Then
        ShowMsg hwnd, "本位币名称不能为空！", vbExclamation, Me.Caption
        stbBuildNewAcnt.Tab = 3
        txtCurrency(1).SetFocus
        txtCurrency(1).SelText = mstrCurrencyName
        txtCurrency(1).SelStart = 0
        txtCurrency(1).SelLength = Len(txtCurrency(1).Text)
        Exit Function
    End If
    CheckValid = True
End Function

Private Sub cboPeriod_GotFocus()
'    stbBuildNewAcnt.Tab = 4
'    stbBuildNewAcnt_Click 4
End Sub

Private Sub cboPeriod_KeyPress(KeyAscii As Integer)
    If KeyAscii = 13 Then SendKeys "{TAB}"
End Sub

Private Sub ChkSysAccount_Click(Index As Integer)
    cmdInf.Enabled = (ChkSysAccount(0).Value = vbChecked)
End Sub

Private Sub cmdInf_Click()
    frmInformation.Show vbModal
End Sub

'取得样板数据库（样板数据库路径及文件名称，建帐路径）
Private Function getSourcePathFileName(ByRef strBasePathFile As String, ByRef strPath As String, ByRef strErr As String) As Boolean
    Dim strTmpPath As String
    Dim strININame As String
    Dim strDefault As String
    Dim lngTmp As Long
    Dim lngSize As Long
    Dim strByteName As String, StrBaseName As String
    Dim strByteKey As String
    Dim lngOK As Long
    Dim strWinSysPath As String
    
    #If conHospital = -1 Then
'        strBaseName = "HospBase.GDB"
        StrBaseName = "SysBase.GDB"
    #Else
        StrBaseName = "SysBase.GDB"
    #End If
    getSourcePathFileName = False
'    strByteName = App.title
    #If conWan = 1 Then
       strByteName = "万能软件"
    #Else
       strByteName = "金算盘软件"
    #End If
    strWinSysPath = Space(255)
    lngSize = Len(strWinSysPath)
    '取得WINDOWS系统的路径（返回路径及长度）
    lngTmp = GetWindowsDirectory(strWinSysPath, lngSize)
'    strWinSysPath = Left(strWinSysPath, lngTmp)
    strWinSysPath = App.Path
    If Dir(strWinSysPath & "\Account.ini", vbNormal) = "" Then
        If Dir(App.Path & "\" & StrBaseName, vbNormal) = "" Then
            strErr = "样板数据库不存在，不能新建帐套!"
            Exit Function
        Else
            strPath = App.Path
            strBasePathFile = App.Path & "\" & StrBaseName
        End If
    Else
        strDefault = "JJ9800ZZ001"
        strTmpPath = Space(255)
        lngSize = Len(strTmpPath)
        strByteKey = "SYSBASE"
        strININame = strWinSysPath & "\Account.ini"
        '取得INI文件中的字符串（节名，关键字，默认值，返回字符串，返回字符串长度，文件名）
        '取得INI文件中样板数据库路径
        lngTmp = GetPrivateProfileString(strByteName, strByteKey, strDefault, strTmpPath, lngSize, strININame)
        strTmpPath = Left(strTmpPath, lngTmp)
        If lngTmp > 0 Then
            If Dir(strTmpPath, vbNormal) = "" Then
                If Dir(App.Path & "\" & StrBaseName, vbNormal) = "" Then
                    strErr = "样板数据库不存在，不能新建帐套!"
                    Exit Function
                Else
                    strPath = App.Path
                    strBasePathFile = App.Path & "\" & StrBaseName
                End If
            Else
                strBasePathFile = strTmpPath
                strPath = FilePath(strTmpPath)
                strPath = strPath & IIf(Right(strPath, 1) <> "\", "\Data", "Data")
            End If
        Else
            If Dir(App.Path & "\" & StrBaseName, vbNormal) = "" Then
                strErr = "样板数据库不存在，不能新建帐套!"
                Exit Function
            Else
                strPath = App.Path
                strBasePathFile = App.Path & "\" & StrBaseName
            End If
        End If
    End If
    getSourcePathFileName = True
    strErr = ""
End Function

Private Sub cmdPNFC_Click(Index As Integer)
    Dim strSourceFile As String, strPath As String
    Dim strSourceFileName As String
    Dim strSourcepathName As String
    Dim strDestionFile As String
    Dim strFile As String, strSql As String
    Dim recBusiness As rdoResultset
    Dim intMsgBoxMessage As Integer
    Dim intFileNumber As Integer
    Dim blnExist As Boolean
    Dim i As Integer, k As Integer ' i ,k 注册表的指针
    Dim strLeftString As String
    Dim strRightString As String
    Dim strTmp As String
    Dim blnTmp As Boolean
    Dim lngTmp As Long
    Dim strErr As String
    Dim lngOK As Long
    
    Select Case Index
          Case 0
            mintStep = mintStep - 1
            While Not stbBuildNewAcnt.TabVisible(mintStep)
                mintStep = mintStep - 1
            Wend
            stbBuildNewAcnt.Tab = mintStep
            WizardStep
            ClearListRecordSet
          Case 1
            mintStep = mintStep + 1
            Do While Not stbBuildNewAcnt.TabVisible(mintStep)
                If mintStep < stbBuildNewAcnt.Tabs - 1 Then
                    mintStep = mintStep + 1
                Else
                    Exit Do
                End If
            Loop
            stbBuildNewAcnt.Tab = mintStep
            WizardStep
          Case 2
            If Not CheckValid Then Exit Sub
'            dteStartDate_LostFocus (0)
'            If Not mblnDateOK Then Exit Sub
'            dteStartDate_LostFocus (1)
            If Not mblnDateOK Then Exit Sub
'            dteStartDate_LostFocus (2)
'            If Not mblnDateOK Then Exit Sub
            If dteAffix.Visible = True Then
                dteAffix_LostFocus
            End If
            For i = 1 To msgPeriod.Rows - 1
                If CDate(dteStartDate(0).Text) = CDate(msgPeriod.TextMatrix(i, 2)) Then
                    Exit For
                ElseIf CDate(dteStartDate(0).Text) > CDate(msgPeriod.TextMatrix(i, 2)) _
                    And CDate(dteStartDate(0).Text) <= CDate(msgPeriod.TextMatrix(i, 3)) Then
                    dteStartDate(0).Text = msgPeriod.TextMatrix(i, 2)
                    ShowMsg hwnd, "帐套启用日期必须是会计期间的第一天!", vbExclamation, Caption
                    stbBuildNewAcnt.Tab = 4
                    Exit Sub
                End If
            Next i
'            If mblnSDateIsChange Then
'                RefreshPeriod
'            End If
            
            Me.MousePointer = vbHourglass
            On Error Resume Next
            Me.Height = 4905
            Label1.Visible = True
            Label1.Caption = "正在建帐套请稍候..."
            Label1.Refresh
            PBar1.Visible = True
            PBar1.Value = 5
            blnTmp = getSourcePathFileName(strSourceFileName, strSourcepathName, strErr)
            If Not blnTmp Then
                Me.MousePointer = vbDefault
                Label1.Caption = ""
                Label1.Visible = False
                PBar1.Visible = False
                Me.Height = 4815
                ShowMsg hwnd, strErr, vbExclamation, Caption
                Exit Sub
            End If
            strSourceFile = strSourceFileName
            mStrFileName = txtFileName.Text
            strTmp = Trim(mStrFileName)
            strLeftString = FilePath(strTmp)
            If strLeftString <> "" Then
                If Len(strTmp) <= Len(strLeftString) Then
                    stbBuildNewAcnt.Tab = 0
                    Me.MousePointer = vbDefault
                    PBar1.Visible = False
                    Label1.Caption = ""
                    Label1.Visible = False
                    txtFileName.SetFocus
                    txtFileName.SelStart = Len(txtFileName.Text)
                    mblnFileIsRight = False
                    Me.Height = 4815
                    ShowMsg hwnd, "请输入帐套文件名。", vbInformation, Caption
                    Exit Sub
                Else
                    strRightString = Right(strTmp, Len(strTmp) - Len(strLeftString))
                End If
            Else
                strRightString = strTmp
            End If
            If InStr(strRightString, ".") > 0 Then
                strRightString = Left(strRightString, InStr(strRightString, ".") - 1)
            End If
            If StrLen(strRightString) > 60 Then
                lngOK = ShowMsg(hwnd, "新帐套的文件名不能超过60个字符,是否自动取前60个字符？", vbQuestion + vbYesNo, Caption)
                If lngOK = vbNo Then
                    stbBuildNewAcnt.Tab = 0
                    Me.MousePointer = vbDefault
                    PBar1.Visible = False
                    Label1.Caption = ""
                    Label1.Visible = False
                    txtFileName.SetFocus
                    txtFileName.SelStart = Len(strLeftString)
                    txtFileName.SelLength = Len(txtFileName.Text) - Len(strLeftString)
                    Me.Height = 4815
                    Exit Sub
                Else
                    strRightString = strLeft(strRightString, 60)
                    If strLeftString <> "" Then
                        txtFileName.Text = strLeftString & "\" & strRightString & ".gdb"
                    Else
                        txtFileName.Text = strRightString & ".gdb"
                    End If
                End If
            End If
            mStrFileName = txtFileName.Text
            PBar1.Value = 10
            mstrBaseName = strRightString
'            gclsBase.BaseName = strRightString
            PBar1.Value = 20
            strPath = UCase(Left(mStrFileName, 2))
            If InStr(mStrFileName, "\") > 0 Or InStr(mStrFileName, ":") > 0 Then