wizard.frm

金算盘软件代码

                If strPath = "\\" Or (strPath >= "A:" And strPath <= "Z:") Then
                    mstrFilepath = mStrFileName
                Else
                    mstrFilepath = ""
                End If
            Else
                mstrFilepath = ""
            End If
            If mstrFilepath = "" Then
                mstrFilepath = strSourcepathName
                strDestionFile = mstrFilepath & "\" & mStrFileName & ".gdb"
            Else
                strDestionFile = mstrFilepath
            End If
            strTmp = Trim(strDestionFile)
            If InStr(strTmp, ".") > 0 Then
                strRightString = Right(strTmp, Len(strTmp) - InStr(strTmp, "."))
                strLeftString = Left(strTmp, InStr(strTmp, "."))
                If UCase(strRightString) <> "GDB" Then
                    strDestionFile = strLeftString & "gdb"
                End If
            Else
                strDestionFile = strDestionFile & ".gdb"
            End If
                  
            strTmp = Trim(strDestionFile)
            If Len(strTmp) > 0 Then
                If InStr(strTmp, ":") > 0 And InStr(strTmp, "\\") > 0 Then
                    stbBuildNewAcnt.Tab = 0
                    Me.MousePointer = vbDefault
                    PBar1.Visible = False
                    Label1.Caption = ""
                    Label1.Visible = False
                    txtFileName.SetFocus
                    mblnFileIsRight = False
                    Me.Height = 4815
                    ShowMsg hwnd, "文件路径不正确，请重新选择或输入。", vbInformation, Caption
                    Exit Sub
                End If
                If InStr(strTmp, ":\") < 2 Then
                    If InStr(strTmp, "\\") = 0 Then
                        stbBuildNewAcnt.Tab = 0
                        Me.MousePointer = vbDefault
                        PBar1.Visible = False
                        Label1.Caption = ""
                        Label1.Visible = False
                        txtFileName.SetFocus
                        mblnFileIsRight = False
                        Me.Height = 4815
                        ShowMsg hwnd, "文件路径不正确，请重新选择或输入。", vbInformation, Caption
                        Exit Sub
                    End If
                End If
                If InStr(strTmp, ":") > 0 Then
                    strTmp = Right(strTmp, Len(strTmp) - InStr(strTmp, ":"))
                    If InStr(strTmp, ":") > 0 Then
                        stbBuildNewAcnt.Tab = 0
                        Me.MousePointer = vbDefault
                        PBar1.Visible = False
                        Label1.Caption = ""
                        Label1.Visible = False
                        txtFileName.SetFocus
                        txtFileName.SelStart = 0
                        txtFileName.SelLength = Len(txtFileName.Text)
                        mblnFileIsRight = False
                        Me.Height = 4815
                        ShowMsg hwnd, "文件路径或文件名称不正确，请重新输入。", vbInformation, Caption
                        Exit Sub
                    End If
                Else
                    If InStr(strTmp, "\\") = 0 Then
                        stbBuildNewAcnt.Tab = 0
                        Me.MousePointer = vbDefault
                        PBar1.Visible = False
                        Label1.Caption = ""
                        Label1.Visible = False
                        mblnFileIsRight = False
                        txtFileName.SetFocus
                        Me.Height = 4815
                        ShowMsg hwnd, "文件路径不正确，请重新选择或输入。", vbInformation, Caption
                        Exit Sub
                    End If
                End If
            End If
            PBar1.Value = 23
            strPath = FilePath(strDestionFile)
            If Not NewPathIsRight(strPath) Then
                Me.MousePointer = vbDefault
                PBar1.Visible = False
                Label1.Caption = ""
                Label1.Visible = False
                Me.Height = 4815
                mblnFileIsRight = False
                Exit Sub
            End If
            PBar1.Value = 25
            ' 整理注册表并查找文件是不是重名
            blnExist = False
            i = 0
            intFileNumber = 0
            For k = 0 To 9
                strFile = GetSetting(App.title, "FET", "File" & k, "")
                If strFile <> "" Then
                    If Dir(strFile) <> "" Then
                        If i < k Then
                            SaveSetting App.title, "FET", "File" & i, strFile
                            DeleteSetting App.title, "FET", "File" & k
                        End If
                        If strDestionFile = strFile Then
                            blnExist = True
                            intFileNumber = i
                        End If
                        i = i + 1
                    Else
                        DeleteSetting App.title, "FET", "File" & k
                    End If
                End If
            Next
            PBar1.Value = 30
            If blnExist Then
                intMsgBoxMessage = ShowMsg(hwnd, "此帐套名已经被使用，是否覆盖此帐套？", _
                    vbYesNo + vbQuestion, Caption)
                If intMsgBoxMessage = vbNo Then
                    txtFileName.SetFocus
                    mstrFilepath = ""
                    stbBuildNewAcnt.Tab = 0
                    WizardStep
                    Me.MousePointer = vbDefault
                    PBar1.Visible = False
                    Label1.Caption = ""
                    Label1.Visible = False
                    Me.Height = 4815
                    Exit Sub
                Else
                    SaveSetting App.title, "FET", "File" & intFileNumber, strDestionFile
                    PBar1.Value = 35
                End If
            Else
                intFileNumber = i
                If intFileNumber = 9 Then
                    For k = 0 To 8
                        strFile = GetSetting(App.title, "FET", "File" & k + 1, "")
                        SaveSetting App.title, "FET", "File" & k, strFile
                    Next
                End If
                PBar1.Value = 35
                SaveSetting App.title, "FET", "File" & intFileNumber, strDestionFile
            End If
            gclsBase.CloseDatabase
            PBar1.Value = 40
            i = MakeDestionFile(strSourceFile, strDestionFile)
            PBar1.Value = 80
            If i = 1 Then
                If Not MakeAccount(strDestionFile) Then
                    On Error GoTo errhandle2
                    gclsBase.CloseDatabase
                    Kill strDestionFile
                    Me.MousePointer = vbDefault
                    PBar1.Visible = False
                    Label1.Caption = ""
                    Label1.Visible = False
                    Me.Height = 4815
                    ShowMsg hwnd, "新帐套科目设置发生错误，新建帐套失败。", vbInformation, Caption
                    Exit Sub
                End If
                PBar1.Value = 87
                If Not SetEspicialAccount() Then
                    Me.MousePointer = vbDefault
                    On Error GoTo errhandle2
                    gclsBase.CloseDatabase
                    Kill strDestionFile
                    PBar1.Visible = False
                    Label1.Caption = ""
                    Label1.Visible = False
                    Me.Height = 4815
                    ShowMsg hwnd, "新帐套特殊科目设置发生错误，新建帐套失败。", vbInformation, Caption
                    Exit Sub
                End If
                PBar1.Value = 94
                If Not SetItemNature() Then
                    On Error GoTo errhandle2
                    gclsBase.CloseDatabase
                    Kill strDestionFile
                    Me.MousePointer = vbDefault
                    PBar1.Visible = False
                    Label1.Caption = ""
                    Label1.Visible = False
                    Me.Height = 4815
                    ShowMsg hwnd, "新帐套商品性质设置发生错误，新建帐套失败。", vbInformation, Caption
                    Exit Sub
                End If
                PBar1.Value = 100
                Me.Visible = False
                If GetSetting(App.title, "LogReg", "Operator") <> "Manager" Then
                    SaveSetting App.title, "LogReg", "Operator", "Manager"
                End If
                If gclsBase.OpenDatabase(strDestionFile) Then
                    gclsBase.BaseFile = strDestionFile
                    mblnIsSuccess = True
                    Me.MousePointer = vbDefault
                Else
                    mblnIsSuccess = False
                    Me.MousePointer = vbDefault
                End If
            ElseIf i = 5 Then
                Dim strBaseFilename As String, strPathName As String
                getSourcePathFileName strBaseFilename, strPathName, strErr
                gclsBase.OpenDatabase strBaseFilename, False, False
                stbBuildNewAcnt.Tab = 0
                txtFileName.SetFocus
                txtFileName.SelStart = 0
                txtFileName.SelLength = Len(txtFileName.Text)
                PBar1.Visible = False
                Label1.Caption = ""
                Label1.Visible = False
                Me.MousePointer = vbDefault
                Me.Height = 4815
                Exit Sub
            End If
            Unload Me
        Case 3
            Unload Me
    End Select
    Exit Sub
errhandle1:
    stbBuildNewAcnt.Tab = 0
    Me.MousePointer = vbDefault
    PBar1.Visible = False
    Label1.Caption = ""
    Label1.Visible = False
    mblnFileIsRight = False
    txtFileName.SetFocus
    Me.Height = 4815
    Select Case Err.Number
        Case 7
            ShowMsg hwnd, "内存溢出!", vbExclamation, Caption
        Case 31001
            ShowMsg hwnd, "内存不足!", vbExclamation, Caption
        Case 3171
            ShowMsg hwnd, "网络路径错误!", vbExclamation, Caption
        Case 51
            ShowMsg hwnd, "内部错误!", vbExclamation, Caption
        Case 52, 55, 64
            ShowMsg hwnd, "文件名非法!", vbExclamation, Caption
        Case 53, 75
            ShowMsg hwnd, "文件名或路径错误!", vbExclamation, Caption
        Case 57                  ' 错误 57
            ShowMsg hwnd, "内部磁盘错误", vbExclamation, Caption
        Case 58
            ShowMsg hwnd, "文件已经存在!", vbExclamation, Caption
        Case 61
            ShowMsg hwnd, "磁盘已满!", vbExclamation, Caption
        Case 68         ' 错误 68
            ShowMsg hwnd, "设备不可用!", vbExclamation, Caption
        Case 71             ' 错误 71
            ShowMsg hwnd, "在驱动器中插入一张软盘!", vbExclamation, Caption
        Case 76
            ShowMsg hwnd, "文件路径错误!", vbExclamation, Caption
        Case 320
            ShowMsg hwnd, "文件名不能使用字符设备名称!", vbExclamation, Caption
        Case Else
            If Err.Description <> "" Then
                ShowMsg hwnd, Err.Description, vbExclamation, Caption
                Unload Me
            Else
                ShowMsg hwnd, "未知错误!", vbExclamation, Caption
                Unload Me
            End If
    End Select
    Exit Sub
errhandle2:
    Resume Next
End Sub

'根据会计制度改变权限的设置
Private Function SetRight(ByVal iSys As Byte) As Boolean
    Dim strSql As String
    
    On Error GoTo ErrHandle
    SetRight = False
    '设置财务版非控制科目权限
    #If conVersionType = 16 Then
        If ChkSysAccount(1).Value = Unchecked Then
            strSql = "UPDATE [Right] SET strNotVersionNo='1,2,4,8,16,' WHERE lngRightID " _
                & "IN (16,19,25,36,37,38,39,40,41,43,44,45,46,48,52,53,70,71,210,212,213,214,215,224)"
            If Not gclsBase.ExecSQL(strSql) Then GoTo ErrHandle
            strSql = "DELETE FROM ViewField WHERE lngViewID=1104 AND (strViewFieldDesc='单据类型' OR strViewFieldDesc='单据号')"
            If Not gclsBase.ExecSQL(strSql) Then GoTo ErrHandle
        End If
    #End If
    '设置格力专版的权限
    #If conTest = 1 And conVersionType = 1 Then
        strSql = "UPDATE [Right] SET strNotVersionNo=' ' WHERE lngRightID IN (225,226)"
        If Not gclsBase.ExecSQL(strSql) Then GoTo ErrHandle
    #End If
    If iSys < 3 Then
        SetRight = True
        Exit Function
    Else
        If iSys = 4 Then
            strSql = "UPDATE [Right] SET strNotVersionNo=' ' WHERE lngRightID IN (221,222)"
            If Not gclsBase.ExecSQL(strSql) Then GoTo ErrHandle
        Else
            strSql = "UPDATE [Right] SET strNotVersionNo='1,2,4,8,16,' WHERE lngRightID=121"
            If Not gclsBase.ExecSQL(strSql) Then GoTo ErrHandle
        End If
    End If
    SetRight = True
ErrHandle:
End Function

'检测文件路径是否存在
Private Function NewPathIsRight(ByVal strPath As String) As Boolean
    Dim lngTmp As Long
    
    On Error GoTo errhandle1
    ChDir strPath
    NewPathIsRight = True
    Exit Function
errhandle1:
    If InStr(strPath, "\\") = 1 Then
        ShowMsg Me.hwnd, "网络路径不正确！请重新选择或输入。", vbExclamation, Me.Caption
        stbBuildNewAcnt.Tab = 0
        txtFileName.SetFocus
        NewPathIsRight = False
        Exit Function
    End If
    If InStr(strPath, "\\") > 1 Then
        ShowMsg Me.hwnd, "新帐套的路径不正确！请重新选择或输入。", vbExclamation, Me.Caption
        stbBuildNewAcnt.Tab = 0
        txtFileName.SetFocus
        NewPathIsRight = False
        Exit Function
    End If
    lngTmp = ShowMsg(Me.hwnd, "新帐套的路径不存在，确定要新建吗？", vbQuestion + vbOKCancel, Me.Caption)
    If lngTmp = vbOK Then