frmimgpathset.frm

用vb编了一个数据库程序

VERSION 5.00
Begin VB.Form frmImgPathSet 
   BorderStyle     =   3  'Fixed Dialog
   Caption         =   "图片路径设置"
   ClientHeight    =   4395
   ClientLeft      =   2700
   ClientTop       =   2430
   ClientWidth     =   6375
   ControlBox      =   0   'False
   LinkTopic       =   "Form1"
   LockControls    =   -1  'True
   MaxButton       =   0   'False
   MinButton       =   0   'False
   ScaleHeight     =   4395
   ScaleWidth      =   6375
   ShowInTaskbar   =   0   'False
   StartUpPosition =   2  '屏幕中心
   Begin VB.CommandButton CmdGetPath 
      Caption         =   " 浏览(&B)"
      Height          =   375
      Left            =   4920
      TabIndex        =   1
      Top             =   570
      Width           =   1300
   End
   Begin VB.TextBox txtNewPath 
      Height          =   350
      Left            =   210
      TabIndex        =   0
      Top             =   570
      Width           =   4515
   End
   Begin VB.CommandButton CmdSure 
      Caption         =   " 确定(&S)"
      Height          =   375
      Left            =   3585
      TabIndex        =   5
      Top             =   3765
      Width           =   1300
   End
   Begin VB.CommandButton CmdCancel 
      Caption         =   " 取消(&C)"
      Height          =   375
      Left            =   4905
      TabIndex        =   6
      Top             =   3765
      Width           =   1300
   End
   Begin VB.CommandButton CmdDeletePath 
      Caption         =   "删除路径"
      Height          =   375
      Left            =   4920
      TabIndex        =   4
      Top             =   1950
      Width           =   1300
   End
   Begin VB.CommandButton CmdAddPath 
      Caption         =   "添加路径"
      Default         =   -1  'True
      Height          =   375
      Left            =   4920
      TabIndex        =   3
      Top             =   1320
      Width           =   1300
   End
   Begin VB.ListBox lstPath 
      Height          =   2040
      Left            =   210
      TabIndex        =   2
      Top             =   990
      Width           =   4530
   End
   Begin VB.Frame Frame1 
      Height          =   125
      Index           =   0
      Left            =   45
      TabIndex        =   7
      Top             =   3420
      Width           =   6300
   End
   Begin VB.Label Label1 
      AutoSize        =   -1  'True
      Caption         =   "系统图片路径设置"
      Height          =   180
      Index           =   1
      Left            =   255
      TabIndex        =   8
      Top             =   165
      Width           =   1440
   End
End
Attribute VB_Name = "frmImgPathSet"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Dim Msg As String

Private Sub CmdAddPath_Click()

On Error GoTo ErrorHandler

If Trim(txtNewPath) = vbNullString Then
    Exit Sub
End If
'检测新路径是否已在库中,
'如果存在,则提示重新选择路径
'否则,下一步
Dim i
For i = 0 To lstPath.ListCount
    If txtNewPath = lstPath.List(i) Then
        MsgBox "该路径已存在,请重新选择!", vbInformation
        Exit Sub
    End If
Next i

'检测新路径是否有效,
'如果有效,则检测是否存在,
'         如果存在,则添加该路径
'         否则,提示是否添加
'否则,提示重新输入
If Dir(Mid(txtNewPath, 1, 2), vbDirectory) = vbNullString Then
    MsgBox "路径无效，请重新输入或选择", vbInformation
Else
    If Dir(txtNewPath, vbDirectory) <> vbNullString Then
        '添加路径
        lstPath.AddItem txtNewPath
    Else
        Dim Msg
        Msg = MsgBox("该路径不存在，是否创建？", vbYesNo + vbInformation)
        If Msg = vbYes Then
            MkDir (txtNewPath)
            lstPath.AddItem txtNewPath
        Else
            Exit Sub
        End If
    End If
End If

'添加以后,将txtNewPath中的路径删除
txtNewPath = vbNullString

Exit Sub

ErrorHandler:
If Err Then
    MsgBox Err.Description, vbExclamation
    Err.Clear
End If
txtNewPath = vbNullString

End Sub

Private Sub CmdBrowse_Click()
frmFindPath.Tag = "SystemPicPath"
frmFindPath.Show 1
End Sub

Private Sub CmdAddPath_KeyPress(KeyAscii As Integer)
If KeyAscii = vbKeyEscape Then
    Call cmdCancel_Click
End If

End Sub

Private Sub cmdCancel_Click()
Unload Me
End Sub

Private Sub CmdDeletePath_Click()
'1 检查该路径下是否有图片存在
'  如果有 , 提示将该路径下的图片移动到新的图片目录下
'           <确定>以后,将该路径下的图片移动导指定目录下
'           在List中删除该路径
'  如果没有,在List中删除该路径
'2 在List中删除该路径
Dim ThisList As Integer

ThisList = lstPath.ListIndex
If lstPath.ListCount > 0 Then
    If ThisList = 0 Then
        lstPath.RemoveItem ThisList
        If lstPath.ListCount > 0 Then
            lstPath.Selected(ThisList) = True
        End If
    End If
    If ThisList > 0 Then
        lstPath.RemoveItem ThisList
        lstPath.Selected(ThisList - 1) = True
    End If
End If
End Sub

Private Sub CmdDeletePath_KeyPress(KeyAscii As Integer)
If KeyAscii = vbKeyEscape Then
    Call cmdCancel_Click
End If

End Sub

Private Sub CmdGetPath_Click()
frmFindPath.Tag = "ImgPathSet"
frmFindPath.Show vbModal
End Sub

Private Sub CmdGetPath_KeyPress(KeyAscii As Integer)
If KeyAscii = vbKeyEscape Then
    Call cmdCancel_Click
End If

End Sub

Private Sub cmdSure_Click()
'********************************************
'1 检查List中的路径是否在库中都有
'    如果没有,则添加该路径
'2 检查库中有的图片，在List中是否都有，
'    如果没有, 则删除该路径
'结束
'********************************************
Dim i As Integer
Dim FoundSQL As String
Dim rstImgPath As ADODB.Recordset

Set rstImgPath = New ADODB.Recordset
FoundSQL = "SELECT * FROM sys_Path"
rstImgPath.Open FoundSQL, conCaseMain, adOpenDynamic, adLockOptimistic, adCmdTableDirect
With rstImgPath
    If Not .EOF Then .MoveLast
    If Not .BOF Then .MoveFirst
    For i = 0 To lstPath.ListCount - 1
        .Find "Img_Path='" & lstPath.List(i) & "'"
        If .EOF Then
            .AddNew
            !Img_Path = lstPath.List(i)
            .Update
        End If
    Next i
    Dim ExistPath As Boolean
    If Not .BOF Then .MoveFirst
    Do While Not .EOF
        For i = 0 To lstPath.ListCount - 1
            If !Img_Path = lstPath.List(i) Then
                ExistPath = True
            End If
        Next i
        If ExistPath = False Then
            .Delete
            If Not .BOF Then .MoveFirst
        Else
            .MoveNext
        End If
    Loop
End With
rstImgPath.Close
Set rstImgPath = Nothing

Unload Me

End Sub

Private Sub CmdSure_KeyPress(KeyAscii As Integer)
If KeyAscii = vbKeyEscape Then
    Call cmdCancel_Click
End If
End Sub

Private Sub Form_Activate()
txtNewPath.SetFocus
End Sub

Private Sub Form_Load()

Dim FoundSQL As String
Dim rstImgPath As ADODB.Recordset

Me.Left = fMainForm.Left + (fMainForm.Width - Me.Width) / 2
Me.Top = fMainForm.Top + (fMainForm.Height - Me.Height) / 2

CmdAddPath.Tag = "添加路径"
CmdDeletePath.Tag = "删除路径"
CmdDeletePath.Enabled = False    '[删除]按钮置灰
txtNewPath.Text = vbNullString

'此处添加从数据库中导出路径,并显示在List1中的代码

Set rstImgPath = New ADODB.Recordset
FoundSQL = "SELECT * FROM sys_Path"
rstImgPath.Open FoundSQL, conCaseMain, 1, 3 'adOpenDynamic, adLockOptimistic, adCmdTableDirect

With rstImgPath
    Do While Not .EOF
        If !Img_Path <> vbNullString Then
            lstPath.AddItem !Img_Path
        End If
        .MoveNext
    Loop
End With
rstImgPath.Close

Set rstImgPath = Nothing

End Sub

Private Sub lstPath_Click()
CmdDeletePath.Enabled = True     '[删除]按钮点亮

End Sub

Private Sub lstPath_KeyPress(KeyAscii As Integer)
If KeyAscii = vbKeyEscape Then
    Call cmdCancel_Click
End If
End Sub

Private Sub txtNewPath_KeyPress(KeyAscii As Integer)

On Error GoTo ErrorHandler

If KeyAscii = vbKeyEscape Then
    Call cmdCancel_Click
End If

Dim i As Integer

If Trim(txtNewPath) = vbNullString Then
    Exit Sub
End If
If KeyAscii = vbKeyReturn Then
    If Dir(Mid(Trim(txtNewPath), 1, 2), vbDirectory) <> vbNullString _
       And Mid(Trim(txtNewPath), 3, 1) = "\" Then
        If Dir(Trim(txtNewPath), vbDirectory) = vbNullString Then
            Msg = MsgBox("该路径不存在，是否创建?", vbYesNo + vbInformation)
            Select Case Msg
                Case vbYes
                    MkDir (txtNewPath)
                    lstPath.AddItem txtNewPath
                    txtNewPath = vbNullString
                Case vbNo
            End Select
        Else
            For i = 0 To lstPath.ListCount - 1
                If txtNewPath = lstPath.List(i) Then
                    MsgBox "该路径已存在!", vbInformation
                    txtNewPath.SetFocus
                    SendKeys "{Home}+{End}"
                    Exit Sub
                End If
            Next i
            lstPath.AddItem txtNewPath
            txtNewPath = vbNullString
        End If
    Else
        MsgBox "不是有效路径,请重新输入!", vbInformation
        Exit Sub
    End If
End If
Exit Sub

ErrorHandler:
    If Err Then
        MsgBox Err.Description, vbExclamation
        Err.Clear
    End If
End Sub