frmbasetonew.frm

金算盘软件代码

VERSION 5.00
Object = "{D252F124-F62C-11D1-9ABD-444553540000}#1.0#0"; "GADATE.DLL"
Object = "{6B7E6392-850A-101B-AFC0-4210102A8DA7}#1.3#0"; "COMCTL32.OCX"
Begin VB.Form FrmBaseToNew 
   BorderStyle     =   1  'Fixed Single
   Caption         =   "帐套结转"
   ClientHeight    =   1665
   ClientLeft      =   45
   ClientTop       =   330
   ClientWidth     =   6600
   KeyPreview      =   -1  'True
   LinkTopic       =   "Form2"
   MaxButton       =   0   'False
   MinButton       =   0   'False
   ScaleHeight     =   1665
   ScaleWidth      =   6600
   Begin VB.TextBox txtNewBase 
      Height          =   300
      Left            =   2880
      TabIndex        =   9
      Top             =   480
      Width           =   1890
   End
   Begin VB.TextBox txtOldBase 
      Height          =   300
      Left            =   165
      TabIndex        =   1
      Top             =   480
      Width           =   1890
   End
   Begin ComctlLib.ProgressBar prgStep 
      Height          =   195
      Left            =   60
      TabIndex        =   7
      Top             =   1935
      Width           =   6195
      _ExtentX        =   10927
      _ExtentY        =   344
      _Version        =   327682
      Appearance      =   1
   End
   Begin VB.CommandButton cmdButton 
      Height          =   350
      Index           =   0
      Left            =   5250
      Style           =   1  'Graphical
      TabIndex        =   4
      Tag             =   "1001"
      Top             =   120
      UseMaskColor    =   -1  'True
      Width           =   1215
   End
   Begin VB.CommandButton cmdButton 
      Cancel          =   -1  'True
      Height          =   350
      Index           =   1
      Left            =   5250
      Style           =   1  'Graphical
      TabIndex        =   5
      Tag             =   "1002"
      Top             =   555
      UseMaskColor    =   -1  'True
      Width           =   1215
   End
   Begin GACALENDARLibCtl.Calendar CalDate 
      Height          =   285
      Left            =   165
      OleObjectBlob   =   "frmBaseToNew.frx":0000
      TabIndex        =   3
      Top             =   1140
      Width           =   1875
   End
   Begin VB.Label lblNote 
      AutoSize        =   -1  'True
      Caption         =   "——>"
      Height          =   180
      Index           =   4
      Left            =   2235
      TabIndex        =   11
      Top             =   555
      Width           =   450
   End
   Begin VB.Label lblNote 
      AutoSize        =   -1  'True
      Caption         =   "新帐套名(&N)："
      Height          =   180
      Index           =   3
      Left            =   2970
      TabIndex        =   10
      Top             =   240
      Width           =   1170
   End
   Begin VB.Label lblNote 
      Caption         =   "将旧帐套数据转入新帐套，其中结转日期前的数据作为期初数转入。"
      Height          =   345
      Index           =   2
      Left            =   2175
      TabIndex        =   8
      Top             =   1110
      Width           =   2775
   End
   Begin VB.Label lblNote 
      Caption         =   "结转日期(&D)："
      Height          =   165
      Index           =   1
      Left            =   255
      TabIndex        =   2
      Top             =   900
      Width           =   1245
   End
   Begin VB.Label lblNote 
      AutoSize        =   -1  'True
      Caption         =   "旧帐套名(&N)："
      Height          =   180
      Index           =   0
      Left            =   255
      TabIndex        =   0
      Top             =   240
      Width           =   1170
   End
   Begin VB.Label lblExplan 
      AutoSize        =   -1  'True
      Caption         =   "(信息提示)"
      Height          =   180
      Left            =   75
      TabIndex        =   6
      Top             =   1740
      Width           =   900
   End
End
Attribute VB_Name = "FrmBaseToNew"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' 帐套结转
' 1998.7.13
' 作者：邹俊
'
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Option Explicit
Private mstrTurnDate As String                           '当前结转日期
Private mstrStartDate As Date                            '新帐套启用日期
Private mintTurnYear As Integer                          '当前结转日期的年份
Private mbytTurnPeriod As Integer                        '当前结转日期的月份
Private mstrOldUser As String
Private mstrNewUser As String

Private Sub Form_Load()
    prgStep.Visible = False
    lblExplan.Visible = False
    CalDate.Value = Date
    cmdButton(0).Picture = Utility.GetFormResPicture(1001, 0)
    cmdButton(1).Picture = Utility.GetFormResPicture(1002, 0)
    Me.Icon = Utility.GetFormResPicture(139, vbResIcon)
End Sub

Private Sub Form_Paint()
    FrameBox Me.hwnd, 80, 80, 5250, 1600
End Sub

Private Sub Form_Unload(Cancel As Integer)
    On Error Resume Next
    Utility.RemoveFormResPicture (1001)
    Utility.RemoveFormResPicture (1002)
    Utility.RemoveFormResPicture (139)
End Sub

Private Sub cmdButton_Click(Index As Integer)
    On Error Resume Next
    Select Case Index
    Case 0  '确定
        If ValidUser() Then
            If ValidDate() Then
                OldBaseTurnToNewBase
            End If
        End If
    Case 1  '取消
        Unload Me
    End Select
End Sub

Private Function ValidUser() As Boolean
    Dim strSql As String
    Dim recUser As rdoResultset
    Dim blnNewFind As Boolean
    Dim blnOldFind As Boolean
    
    On Error Resume Next
    mstrNewUser = UCase(txtNewBase.Text)
    mstrOldUser = UCase(txtOldBase.Text)
    strSql = "SELECT Name FROM SYS.USER$ WHERE TYPE#=1 AND (NAME='" & UCase(mstrNewUser) & "' OR NAME='" & UCase(mstrOldUser) & "')"
    Set recUser = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
    Do While Not recUser.EOF
        If recUser!Name = UCase(mstrOldUser) Then
            blnOldFind = True
        ElseIf recUser!Name = UCase(mstrNewUser) Then
            blnNewFind = True
        End If
        recUser.MoveNext
    Loop
    recUser.Close
    Set recUser = Nothing
    
    If Not blnOldFind Then
        ShowMsg hwnd, "旧帐套不存在！", vbExclamation + vbOKOnly, Caption
    ElseIf Not blnNewFind Then
        ShowMsg hwnd, "新帐套不存在！", vbExclamation + vbOKOnly, Caption
    Else
        blnOldFind = True
        blnNewFind = True
        strSql = "SELECT * FROM " & mstrOldUser & ".Business"
        Set recUser = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
        If Not (recUser Is Nothing) Then
            If Not recUser.EOF Then
                blnOldFind = True
            End If
        End If
        recUser.Close
        Set recUser = Nothing
        
        strSql = "SELECT * FROM " & mstrNewUser & ".Business"
        Set recUser = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
        If Not (recUser Is Nothing) Then
            If Not recUser.EOF Then
                blnNewFind = True
            End If
        End If
        recUser.Close
        Set recUser = Nothing
        
        If Not blnOldFind Then
            ShowMsg hwnd, "旧帐套非法！", vbExclamation + vbOKOnly, Caption
        ElseIf Not blnNewFind Then
            ShowMsg hwnd, "新帐套非法！", vbExclamation + vbOKOnly, Caption
        Else
            ValidUser = True
        End If
    End If
End Function


'当前结转日期是否已经结帐
Private Function ValidDate() As Boolean
    Dim strSql As String
    Dim recUser As rdoResultset
    Dim strMsg As String
    
    strSql = "SELECT strStartDate FROM " & mstrOldUser & ".Business "
    Set recUser = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
    If Not recUser.EOF Then
        mstrStartDate = Format(recUser!strStartDate, "yyyy-mm-dd")