📄 frmmain.frm
字号:
VERSION 5.00
Object = "{831FDD16-0C5C-11D2-A9FC-0000F8754DA1}#2.0#0"; "mscomctl.ocx"
Begin VB.Form frmMain
Caption = "Form1"
ClientHeight = 3930
ClientLeft = 60
ClientTop = 630
ClientWidth = 6150
LinkTopic = "Form1"
ScaleHeight = 3930
ScaleWidth = 6150
StartUpPosition = 2 'CenterScreen
Begin MSComctlLib.StatusBar SB
Align = 2 'Align Bottom
Height = 255
Left = 0
TabIndex = 2
Top = 3675
Width = 6150
_ExtentX = 10848
_ExtentY = 450
_Version = 393216
BeginProperty Panels {8E3867A5-8586-11D1-B16A-00C0F0283628}
NumPanels = 1
BeginProperty Panel1 {8E3867AB-8586-11D1-B16A-00C0F0283628}
EndProperty
EndProperty
End
Begin MSComctlLib.ListView LV
Height = 1695
Left = 2640
TabIndex = 1
Top = 120
Width = 2775
_ExtentX = 4895
_ExtentY = 2990
LabelWrap = -1 'True
HideSelection = -1 'True
PictureAlignment= 5
_Version = 393217
ForeColor = -2147483640
BackColor = -2147483643
BorderStyle = 1
Appearance = 1
NumItems = 0
Picture = "frmMain.frx":0000
End
Begin MSComctlLib.TreeView TV
Height = 1665
Left = 120
TabIndex = 0
Top = 120
Width = 2280
_ExtentX = 4022
_ExtentY = 2937
_Version = 393217
Indentation = 353
LineStyle = 1
Style = 7
ImageList = "imgList"
Appearance = 1
BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851}
Name = "MS Sans Serif"
Size = 8.25
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
End
Begin MSComctlLib.ImageList imgList
Left = 120
Top = 1920
_ExtentX = 1005
_ExtentY = 1005
BackColor = -2147483643
MaskColor = 12632256
_Version = 393216
End
Begin VB.Menu mnuFile
Caption = "&Files"
Begin VB.Menu mnuFileOpenDB
Caption = "&Open Database"
End
Begin VB.Menu mnuFileAnalyzeDB
Caption = "&Analyze Database"
End
Begin VB.Menu mnuFileCompressDB
Caption = "&Compress"
Visible = 0 'False
End
Begin VB.Menu mnuFileLine1
Caption = "-"
End
Begin VB.Menu mnuFileExport
Caption = "&Export"
Begin VB.Menu mnuFileExportBAS
Caption = "BAS-module (Access 2000)"
Index = 0
End
Begin VB.Menu mnuFileExportBAS
Caption = "BAS-module (Access 97)"
Index = 1
End
Begin VB.Menu mnuFileExportLine1
Caption = "-"
Visible = 0 'False
End
Begin VB.Menu mnuFileExportSQL
Caption = "SQL"
Visible = 0 'False
End
End
Begin VB.Menu mnuMRUFiles
Caption = "-"
Index = 0
End
Begin VB.Menu mnuFileLine3
Caption = "-"
End
Begin VB.Menu mnuFileExit
Caption = "E&xit"
End
End
Begin VB.Menu mnuHelp
Caption = "&Help"
Begin VB.Menu mnuHelpAbout
Caption = "&About"
End
End
End
Attribute VB_Name = "frmMain"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
'{ -------------------------------[ NiKroWare ]-------------------------------
'$Archive:: /Visual Basic/NKW/NKWCreateMDB/frmMain.frm $
'$Author:: Enik $
'$Date:: 24-08-01 10:50 $
'$Modtime:: 24-08-01 10:47 $
'$Revision:: 5 $
'-------------------------------------------------------------------------------
'Purpose : To generate a BAS module to be included into a VB project...
'-------------------------------------------------------------------------------}
' For use when we are dragging the splitter.
Private Const SPLITTER_WIDTH = 60
Private mMRU As cMRU
Private mJetPassword As String
Private Percentage1 As Single
Private mbDragging As Boolean
Private Sub Form_Load()
On Error GoTo ErrTrap
Me.Icon = LoadResPicture("1ICON", vbResIcon)
Me.Caption = App.Title & " v" & App.Major & "." & App.Minor & "." & App.Revision
mnuFileAnalyzeDB.Enabled = 0 ' False
mnuFileExport.Enabled = 0 ' False
Me.Width = Screen.Width * 0.7
Me.Height = Screen.Height * 0.7
Percentage1 = 0.35
mbDragging = 0 ' False
ArrangeControls
Load_ImgList
TV_Setup
LV_Setup
SB_Setup
Menu_Setup
Exit Sub
ErrTrap:
MsgBox Err.Number & " / " & Err.Description, vbExclamation, "Error in Form_Load"
Exit Sub
Resume
End Sub
Private Sub Form_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
mbDragging = 1 ' True
End Sub
Private Sub Form_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
If Not mbDragging Then
If x > TV.Width And x < LV.Left Then Me.MousePointer = vbSizeWE
Exit Sub
End If
Percentage1 = x / Me.ScaleWidth ' VSPLIT
If Percentage1 < 0 Then Percentage1 = 0
If Percentage1 > 1 Then Percentage1 = 1
ArrangeControls
End Sub
Private Sub Form_MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)
mbDragging = 0 ' False
Me.MousePointer = vbDefault
End Sub
Private Sub Form_Resize()
ArrangeControls
End Sub
Private Sub LV_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
Me.MousePointer = vbDefault
End Sub
Private Sub mnuFileCompressDB_Click()
' Dim JRO2 As jro.JetEngine
' Set JRO2 = New jro.JetEngine
' JRO2.CompactDatabase "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=d:\\nwind2.mdb", _
' "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=d:\\abbc2.mdb;Jet OLEDB:Engine Type=4"
MsgBox "Not implemented jet..."
End Sub
Private Sub mnuFileExportBAS_Click(Index As Integer)
Dim EngineType As EngineTypeEnum
Dim DLG As clsOpenSave
On Error GoTo ErrTrap
Set DLG = New clsOpenSave
DLG.CancelError = 1 ' True
DLG.Flags = OFN_HIDEREADONLY + OFN_OVERWRITEPROMPT
DLG.Filter = "All Files (*.*)|*.*|Visual Basic Module Files (*.bas)|*.bas"
DLG.FilterIndex = 2
DLG.hWnd = Me.hWnd
DLG.DialogTitle = "Save BAS module"
DLG.InitDir = ""
DLG.FileName = "Create_" & Replace(DB_Title, ".mdb", "", , , vbTextCompare) & ".bas"
DLG.ShowSave
If Index = 0 Then
EngineType = adAccess40
Else
EngineType = adAccess35
End If
CreateBAS.CreateModule DLG.FileName, EngineType
MsgBox "BAS-module created.", vbApplicationModal + vbInformation, App.Title
ErrTrap:
' User pressed cancel...
Set DLG = Nothing
End Sub
Private Sub mnuFileExportSQL_Click()
' Not implemeted yet...
'Dim DLG As clsOpenSave
'On Error GoTo ErrTrap
'
' Set DLG = New clsOpenSave
'
' DLG.CancelError = 1 ' True
' DLG.Flags = OFN_HIDEREADONLY + OFN_OVERWRITEPROMPT
' DLG.Filter = "All Files (*.*)|*.*|SQL Files (*.sql)|*.sql"
' DLG.FilterIndex = 2
' DLG.hWnd = Me.hWnd
' DLG.DialogTitle = "Save SQL file"
' DLG.InitDir = ""
'
' DLG.FileName = "Create_" & Replace(DB_Title, ".mdb", "", , , vbTextCompare) & ".sql"
' DLG.ShowSave
'
' CreateSQL.CreateSQL DLG.FileName
'
' MsgBox "SQL-file created.", vbApplicationModal + vbInformation, App.Title
'
'ErrTrap:
'' User pressed cancel...
' Set DLG = Nothing
'
End Sub
Private Sub mnuFileOpenDB_Click()
Dim DLG As New clsOpenSave
On Error GoTo ErrTrap:
DLG.CancelError = 1 ' True
DLG.FileName = "*.mdb"
DLG.Flags = OFN_HIDEREADONLY + OFN_FILEMUSTEXIST
DLG.DialogTitle = "Open Access database"
DLG.InitDir = ""
DLG.hWnd = Me.hWnd
DLG.Filter = "All Files (*.*)|*.*|Access Database Files (*.mdb)|*.mdb"
DLG.FilterIndex = 2
DLG.ShowOpen
DB_Name = DLG.FileName
DB_Title = GetFileName(DB_Name)
Set DLG = Nothing
OpenDB DB_Name
Exit Sub
ErrTrap:
Set DLG = Nothing
Select Case Err.Number
Case 32755
' user pressed cancel...
Case Else
MsgBox Err.Number & " / " & Err.Description, vbExclamation, "Error in mnuFileOpenDB_Click"
Exit Sub
Resume
End Select
End Sub
Private Sub OpenDB(ByVal FileName As String)
Dim LoopTimes As Byte
mJetPassword = ""
LoopTimes = 3
On Error Resume Next
Do
Err.Clear
LoopTimes = LoopTimes - 1
If Not mCon Is Nothing Then Set mCon = Nothing
Set mCon = New ADODB.Connection
mCon.Provider = "Microsoft.Jet.OLEDB.4.0"
mCon.Mode = adModeRead
mCon.CursorLocation = adUseClient
mCon.Properties("Data Source") = FileName
mCon.Properties("Jet OLEDB:Database Password") = mJetPassword
mCon.Open
If Err.Number = 0 Then ' success let's get out of this loop...
LoopTimes = 0
ElseIf (Err.Number = -2147217843) And (LoopTimes = 2) Then ' try Access 97 Password
mJetPassword = Common.GetAccess97Password(FileName)
ElseIf (Err.Number = -2147217843) And (LoopTimes = 1) Then ' try the box...
mJetPassword = Common.GetDBPassword(FileName)
Else
MsgBox "Can't open DB : " & FileName
LoopTimes = 0
End If
Loop While (LoopTimes > 0)
If Not mCon Is Nothing Then
If mCon.State = adStateOpen Then
SB.SimpleText = "File : " & FileName
Set mCat = Nothing
Set mCat = New ADOX.Catalog
mCat.ActiveConnection = mCon
' the the db to the MRU list...
mMRU.Add FileName
mMRU.Update Me
AnalyzeDB
mnuFileAnalyzeDB.Enabled = 1 ' True
mnuFileExport.Enabled = 1 ' True
End If
End If
Exit Sub
ErrTrap:
MsgBox Err.Number & " / " & Err.Description, vbExclamation, "Error in OpenDB"
Exit Sub
Resume
End Sub
Private Sub AnalyzeDB()
On Error GoTo ErrTrap
Dim NodX As Node
Dim TBL As ADOX.Table
Dim Col As ADOX.Column
Dim IDX As ADOX.Index
Dim VIW As ADOX.View
Dim PROC As ADOX.Procedure
Screen.MousePointer = vbHourglass
LV.ListItems.Clear
TV.Nodes.Clear
Set NodX = TV.Nodes.Add(, , "DATABASE", "Database", "DATABASE")
NodX.Tag = "DATABASE"
NodX.ForeColor = vbBlue
NodX.Bold = True
Set NodX = TV.Nodes.Add("DATABASE", tvwChild, "TABLES", "Tables", "TABLES")
NodX.Tag = "TABLES"
NodX.ForeColor = vbBlue
Set NodX = TV.Nodes.Add("DATABASE", tvwChild, "QUERIES", "Queries", "TABLES")
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -