📄 frmopenaccount.frm
字号:
VERSION 5.00
Object = "{F9043C88-F6F2-101A-A3C9-08002B2F49FB}#1.2#0"; "COMDLG32.OCX"
Begin VB.Form frmOpenAccount
BorderStyle = 3 'Fixed Dialog
Caption = "打开帐套"
ClientHeight = 2280
ClientLeft = 45
ClientTop = 330
ClientWidth = 5730
Icon = "frmOpenAccount.frx":0000
KeyPreview = -1 'True
LinkTopic = "Form1"
LockControls = -1 'True
MaxButton = 0 'False
MinButton = 0 'False
ScaleHeight = 2280
ScaleWidth = 5730
ShowInTaskbar = 0 'False
StartUpPosition = 1 '所有者中心
Begin MSComDlg.CommonDialog dlgOpenFile
Left = 4800
Top = 1380
_ExtentX = 847
_ExtentY = 847
_Version = 393216
End
Begin VB.ListBox lstAccount
Height = 1860
ItemData = "frmOpenAccount.frx":0442
Left = 90
List = "frmOpenAccount.frx":0444
TabIndex = 0
Top = 165
Width = 4155
End
Begin VB.CommandButton cmdOKorCanel
Height = 330
Index = 1
Left = 4440
Style = 1 'Graphical
TabIndex = 2
Top = 600
UseMaskColor = -1 'True
Width = 1110
End
Begin VB.CommandButton cmdOKorCanel
Default = -1 'True
Height = 330
Index = 0
Left = 4440
Style = 1 'Graphical
TabIndex = 1
Top = 150
UseMaskColor = -1 'True
Width = 1110
End
End
Attribute VB_Name = "frmOpenAccount"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
'打开帐套
Option Explicit
Private m_blnIsSuccess As Boolean
Private mstrOldFile As String '旧帐套文件名
Private mstrTempletBase As String '样板数据库路径及文件名
Private mstrTempleteData As String
Private mblnTempletIsNO As Boolean '样板数据库是否存在
Private mblnTempleteDataIsExist 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
Private mstrUser() As String '用户名
'打开帐套接口
Public Function OpenBase() As Boolean
Dim intCount As Integer
mstrOldFile = gclsBase.BaseFile
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
OpenBase = False
Utility.ClearListRecordSet
Exit Function
End If
gclsBase.CloseDatabase
Me.Show vbModal
OpenBase = m_blnIsSuccess
If m_blnIsSuccess Then ClearListRecordSet
frmMain.UpdateMenuStatus
frmMain.UpdateStatus
End Function
Private Sub cmdOKorCanel_Click(Index As Integer)
Dim StrFileName
Dim strTmp As String
Dim blnTmp As Boolean
Dim intErrnumber As Long
Dim blnFlag As Boolean
On Error GoTo ErrProc
blnFlag = False
Select Case Index
Case 0
' If lstAccount.ListIndex = 2 Then
' If mblnTempleteDataIsExist Then
' StrFileName = mstrTempleteData
' Else
' StrFileName = lstAccount.list(lstAccount.ListIndex)
' End If
' Else
StrFileName = lstAccount.list(lstAccount.ListIndex) '& "/" & mstrUser(lstAccount.ListIndex)
' End If
If Len(StrFileName) > 0 Then
' If Len(Dir(StrFileName)) = 0 Or FileLen(StrFileName) = 0 Then
' blnFlag = True
' ShowMsg hwnd, "此帐套不存在", vbExclamation + vbOKOnly, Me.Caption
' If lstAccount.ItemData(lstAccount.ListIndex) < 10 Then
' DeleteSetting App.title, "FET", "File" & lstAccount.ItemData(lstAccount.ListIndex)
' Else
' DeleteSetting App.title, "MRU", "File" & (lstAccount.ItemData(lstAccount.ListIndex) - 10)
' End If
' Exit Sub
' End If
If gclsBase.BaseFile = StrFileName Then
'MsgBox "此帐套已被打开!", vbInformation, App.title
blnFlag = True
Unload Me
Exit Sub
End If
Me.Visible = False
If mblnTempletIsNO Then
If UCase(Trim(StrFileName)) = UCase(mstrTempletBase) Then
blnFlag = True
ShowMsg hwnd, "不能打开样板数据库!", vbExclamation, Caption
If lstAccount.ItemData(lstAccount.ListIndex) < 10 Then
DeleteSetting App.title, "FET", "File" & lstAccount.ItemData(lstAccount.ListIndex)
Else
DeleteSetting App.title, "MRU", "File" & (lstAccount.ItemData(lstAccount.ListIndex) - 10)
End If
Exit Sub
End If
End If
#If conVersionType = 1 Then
If gclsBase.OpenDatabase(StrFileName, , , intErrnumber) Then
blnFlag = True
If Not ActiveAccount Then
m_blnIsSuccess = False
gclsBase.CloseDatabase
Exit Sub
End If
m_blnIsSuccess = True
Else
Err.Number = intErrnumber
GoTo ErrProc
End If
#Else
#If conVersionType = 2 Then
If gclsBase.OpenDatabase(StrFileName, , , intErrnumber) Then
blnFlag = True
If Not ActiveAccount Then
m_blnIsSuccess = False
gclsBase.CloseDatabase
Exit Sub
End If
m_blnIsSuccess = True
Else
Err.Number = intErrnumber
GoTo ErrProc
End If
#Else
#If conVersionType = 4 Then
If gclsBase.OpenDatabase(StrFileName, , , intErrnumber, True) Then
blnFlag = True
If Not ActiveAccount Then
m_blnIsSuccess = False
gclsBase.CloseDatabase
Exit Sub
End If
m_blnIsSuccess = True
Else
Err.Number = intErrnumber
GoTo ErrProc
End If
#Else
#If conVersionType = 8 Then
If gclsBase.OpenDatabase(StrFileName, , , intErrnumber) Then
blnFlag = True
If Not ActiveAccount Then
m_blnIsSuccess = False
gclsBase.CloseDatabase
Exit Sub
End If
m_blnIsSuccess = True
Else
Err.Number = intErrnumber
GoTo ErrProc
End If
#ElseIf conVersionType = 16 Then
If gclsBase.OpenDatabase(StrFileName, , , intErrnumber) Then
blnFlag = True
If Not ActiveAccount Then
m_blnIsSuccess = False
gclsBase.CloseDatabase
Exit Sub
End If
m_blnIsSuccess = True
Else
Err.Number = intErrnumber
GoTo ErrProc
End If
#End If
#End If
#End If
#End If
End If
Unload Me
frmMain.UpdateMenuStatus
frmMain.UpdateStatus
'UpdateMenuStatus
Case 1
blnFlag = True
If mstrOldFile <> "" Then
If gclsBase.OpenDatabase(mstrOldFile, False, True) Then SetMenuRight
End If
frmMain.UpdateMenuStatus
frmMain.UpdateStatus
Unload Me
'Case 2
' Dim lPosition As Long
' lPosition = Me.Left
' Me.Left = -30000
' If frmNewAccount.NewBase Then
' Unload Me
' Else
' Me.Left = lPosition
' End If
End Select
Exit Sub
ErrProc:
m_blnIsSuccess = False
If blnFlag Then Exit Sub
Select Case Err.Number
Case 7
ShowMsg hwnd, "内存溢出，不能打开帐套。", vbInformation, Me.Caption
gclsBase.CloseDatabase
Case 31001
ShowMsg hwnd, "内存不足，不能打开帐套。", vbInformation, Me.Caption
gclsBase.CloseDatabase
Case 3356, 3196, 3576 '共享
ShowMsg hwnd, "其他用户正在使用该帐套，不能打开帐套。", vbInformation, Me.Caption
gclsBase.CloseDatabase
Case 3045, 3006, 3008, 3009, 3261, 3266 '独占
ShowMsg hwnd, "该文件正在被使用，不能打开帐套。", vbInformation, Me.Caption
gclsBase.CloseDatabase
Case 3343, 3049, 3340, 3428 '数据库出错
ShowMsg hwnd, "帐套可能被损坏，请整理。", vbInformation, Me.Caption
' frmBaseRepair.GBaseName = StrFileName
' frmBaseRepair.Show vbModal
Case 3056 '数据库不能修复
ShowMsg hwnd, "该帐套已被严重损坏，不能打开帐套。", vbInformation, Me.Caption
Case 3176 '打不开文件
ShowMsg hwnd, "该帐套不能打开。", vbInformation, Me.Caption
gclsBase.CloseDatabase
Case 3051
ShowMsg hwnd, "它已经被别的用户以独占方式打开，或没有查看数据的权限。", vbInformation, Me.Caption
gclsBase.CloseDatabase
Case 0
blnFlag = True
If mstrOldFile <> "" Then
If gclsBase.OpenDatabase(mstrOldFile, False, True) Then SetMenuRight
End If
frmMain.UpdateMenuStatus
frmMain.UpdateStatus
Case Else
ShowMsg hwnd, Err.Description & "未知错误，不能打开帐套。", vbInformation, Me.Caption
gclsBase.CloseDatabase
End Select
Unload Me
End Sub
Private Sub Form_KeyPress(KeyAscii As Integer)
If KeyAscii = vbKeyEscape Then
cmdOKorCanel_Click 1
'Unload Me
ElseIf KeyAscii = vbKeyReturn Then
BKKEY Me.ActiveControl.hwnd, vbKeyTab
End If
End Sub
Private Sub Form_Load()
Dim strFile As String
Dim strINIFile As String
Dim intCint As Integer
Dim intMaxSection As Integer
Dim strAccountName As String
Dim StrUserName As String
Dim lngTmp As String
Me.HelpContextID = 20002
SetHelpID Me.HelpContextID
Set cmdOKorCanel(0).Picture = GetFormResPicture(1001, vbResBitmap)
Set cmdOKorCanel(1).Picture = GetFormResPicture(1002, vbResBitmap)
' Set cmdOKorCanel(2).Picture = GetFormResPicture(1009, vbResBitmap)
Me.Icon = Utility.GetFormResPicture(139, vbResIcon)
m_blnIsSuccess = False
On Error GoTo ErrHandle
' mblnTempleteDataIsExist = GetDemostrateDatePathFile(mstrTempleteData)
' If mblnTempleteDataIsExist Then lstAccount.AddItem "演示数据"
strINIFile = GetAccountlistFilePathName()
ReDim mstrUser(0)
If strINIFile = "" Then Exit Sub
strAccountName = Space(255)
lngTmp = GetPrivateProfileString("目录", "最大帐套序号", "", strAccountName, 255, strINIFile)
strAccountName = Left(strAccountName, lngTmp)
intMaxSection = C2lng(strAccountName)
If intMaxSection = 0 Then Exit Sub
For intCint = 0 To 99
strAccountName = Space(255)
StrUserName = Space(255)
lngTmp = GetPrivateProfileString("帐套" & (intCint + 1), "帐套名", "", strAccountName, 255, strINIFile)
strAccountName = SubStr(strAccountName, 1, lngTmp)
lngTmp = GetPrivateProfileString("帐套" & (intCint + 1), "用户名", "", StrUserName, 255, strINIFile)
StrUserName = SubStr(StrUserName, 1, lngTmp)
If strAccountName <> "" And StrUserName <> "" Then
If UBound(mstrUser) < intCint Then
ReDim Preserve mstrUser(intCint)
End If
mstrUser(intCint) = StrUserName
strAccountName = strAccountName & "/" & StrUserName
lstAccount.AddItem strAccountName
lstAccount.ItemData(lstAccount.ListCount - 1) = intCint
End If
If intCint >= intMaxSection Then Exit For
Next
lstAccount.ListIndex = 0
Exit Sub
ErrHandle:
Resume Next
Err.Clear
End Sub
'取得样板数据库路径及文件名称
Private Function GetTempletBasePathFileName(ByRef strBasePathFile 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
Dim strByteKey As String
Dim strWinSysPath As String
GetTempletBasePathFileName = False
#If conVersionType = 1 Then
strByteName = "金算盘商务管理软件标准版"
#Else
#If conVersionType = 2 Then
strByteName = "金算盘商务管理软件行政事业版"
#Else
#If conVersionType = 4 Then
strByteName = "金算盘商务管理软件实达专用版"
#Else
#If conVersionType = 8 Then
strByteName = "金算盘商务管理软件标准版"
#End If
#End If
#End If
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -