frmdbsprop.frm

数据库属性,页面的设置

'**************************************************
Option Explicit
Private Declare Function DrawIcon Lib "user32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, ByVal hIcon As Long) As Long

Private Const attrReadOnly = 0
Private Const attrArchive = 1
Private Const attrCompressed = 2
Private Const attrHidden = 3
Private Const attrSystem = 4
Private Const attrTemporary = 5
Dim fi As CFileInfo
Dim dbs As Database
Private m_UserFile As String
Function GetSummaryInfo(strPropName As String) As String
    Dim cnt As Container
    Dim doc As Document, prp As Property

    ' 属性没有找到错误。
    Const conPropertyNotFound = 3270
    On Error Resume Next
    
    Set cnt = dbs.Containers!Databases
    Set doc = cnt.Documents!SummaryInfo
    doc.Properties.Refresh
    GetSummaryInfo = doc.Properties(strPropName)
    If Err = conPropertyNotFound Then GetSummaryInfo = ""
   

    Exit Function

End Function
Private Sub UpdateInfo()
   txtFilename.Text = fi.DisplayName
   txtType.Text = fi.TypeName
   txtLocation = fi.FilePath
   txtSize.Text = fi.FormatFileSize(fi.FileSize)
   
   txtDosPath.Text = fi.ShortPath
   txtDosName.Text = fi.ShortName
   txtCreated.Text = fi.FormatFileDate(fi.CreationTime)
   txtCreaDate.Text = txtCreated.Text
   txtModified.Text = fi.FormatFileDate(fi.ModifyTime)
   txtModiDate.Text = txtModified.Text
   txtAccessed.Text = fi.FormatFileDate(fi.LastAccessTime)
   txtAccessDate.Text = txtAccessed.Text
   chkAttr(attrReadOnly).Value = Abs(fi.attrReadOnly)
   chkAttr(attrArchive).Value = Abs(fi.attrArchive)
   chkAttr(attrHidden).Value = Abs(fi.attrHidden)
   chkAttr(attrSystem).Value = Abs(fi.attrSystem)
   picIcon.Cls
   Call DrawIcon(picIcon.hdc, 0, 0, fi.hIcon)

 
End Sub

Private Sub CmdADD_Click()
Dim cnt As Container
Dim doc As Document, prp As Property, GetProp As String, AddValue
    On Error Resume Next
    Select Case propCmb.Text
        Case "日期"
            AddValue = CDate(txtValue)
        Case "数字"
            AddValue = CLng(txtValue)
        Case "是或否"
            If Option1.Value = True Then
                AddValue = True
            Else
                AddValue = False
            End If
        Case "文本"
            AddValue = txtValue.Text
    End Select
    If Err <> 0 Then
        MsgBox "自定义属性错误：" & Err.Description, vbOKOnly + vbCritical, "自定义属性"
        Exit Sub
    End If
    ' 属性没有找到错误。
    Const conPropertyNotFound = 3270
    On Error GoTo GetSummary_Err
    Set cnt = dbs.Containers!Databases
    Set doc = cnt.Documents!UserDefined '用户定义
    doc.Properties.Refresh
    GetProp = doc.Properties(txtZDYName.Text)
    doc.Properties(txtZDYName.Text) = AddValue
    
GetSummary_Bye:
    GetUserInfo
    Exit Sub

GetSummary_Err:
    If Err = conPropertyNotFound Then
        
        Set prp = doc.CreateProperty(txtZDYName.Text, m_DataType, AddValue)
        ' 向集合中追加。
        doc.Properties.Append prp
        Resume GetSummary_Bye
    Else
        ' 未知错误。
       MsgBox Err.Description
       Resume GetSummary_Bye
    End If
End Sub

Private Sub CmdCancel_Click()
    Unload Me
End Sub

Private Sub Command2_Click()
GetUserInfo
End Sub

Private Sub Command3_Click()

End Sub

Private Sub CmdDel_Click()
Dim cnt As Container
Dim doc As Document, prp As Property, GetProp As String

 
    On Error Resume Next
    Set cnt = dbs.Containers!Databases
    Set doc = cnt.Documents!UserDefined '用户定义
    doc.Properties.Refresh
    doc.Properties.Delete txtZDYName.Text
    CmdADD.Caption = "添加(&A "
    GetUserInfo

End Sub


Private Sub CmdOk_Click()
    ChangProp "Title", txtTitle.Text
    ChangProp "Subject", txtSubject.Text
    ChangProp "Author", txtAuthor.Text
    ChangProp "Category", txtCategory.Text
    ChangProp "Manager", txtManager.Text
    ChangProp "Comments", txtComments.Text
    ChangProp "Keywords", txtKeywords.Text
    ChangProp "Hyperlink Base", txtHyperlink.Text
    ChangProp "Company", txtCompany.Text
    Unload Me
End Sub
Private Sub ChangProp(strPropName As String, strValue As String)
Dim cnt As Container, GetSummaryInfo As String
Dim doc As Document, prp As Property

    ' 属性没有找到错误。
    Const conPropertyNotFound = 3270
    On Error GoTo GetSummary_Err
    Set cnt = dbs.Containers!Databases
    Set doc = cnt.Documents!SummaryInfo
    doc.Properties.Refresh
    GetSummaryInfo = doc.Properties(strPropName)
    If Trim(strValue) = "" Then
        doc.Properties.Delete strPropName
    Else
        doc.Properties(strPropName) = strValue
    End If
GetSummary_Bye:
    Exit Sub

GetSummary_Err:
    If Err = conPropertyNotFound Then
        If strValue <> "" Then
            Set prp = doc.CreateProperty(strPropName, dbText, strValue)
            ' 向集合中追加。
            doc.Properties.Append prp
        End If
       ' Resume
    Else
        ' 未知错误。
        Resume GetSummary_Bye
    End If


End Sub

Private Sub Form_Load()
Dim i As Long, sTable As TableDef
Dim style As Long
Dim hHeader As Long
    
    propLV.ColumnHeaders.Add 1, , "名称", propLV.Width \ 3 - 20
    propLV.ColumnHeaders.Add 2, , "值", propLV.Width \ 3 - 20
    propLV.ColumnHeaders.Add 3, , "类型", propLV.Width \ 3 - 20
    hHeader = SendMessageLong(propLV.hwnd, LVM_GETHEADER, 0, ByVal 0&)

    style = GetWindowLong(hHeader, GWL_STYLE)

    style = style Xor HDS_BUTTONS

    If style Then
        Call SetWindowLong(hHeader, GWL_STYLE, style)
        Call SetWindowPos(propLV.hwnd, Me.hwnd, 0, 0, 0, 0, SWP_FLAGS)
    End If

    m_UserFile = "d:\Microsoft Visual Studio\vb98\Nwind.mdb"

    Set fi = New CFileInfo
    fi.FullPathName = UCase(m_UserFile)
    Set dbs = OpenDatabase(m_UserFile)
    Me.Caption = fi.DisplayName & "：属性"
    Me.Icon = LoadPicture("")
    For i = 0 To tabfrm.Count - 1
        tabfrm(i).Top = 480
        tabfrm(i).Left = 180
        tabfrm(i).BackColor = Me.BackColor
    Next i
    With lstZDY
        .AddItem "办公室"
        .AddItem "编辑器"
        .AddItem "布置"
        .AddItem "部门"
        .AddItem "参考"
        .AddItem "出版商"
        .AddItem "打字员"
        .AddItem "电话号码"
        .AddItem "工作组"
        .AddItem "记录日期"
        .AddItem "记录者"
        .AddItem "检查者"
        .AddItem "接收自"
        .AddItem "科室"
        .AddItem "客户"
        .AddItem "目标"
        .AddItem "内容"
        .AddItem "所有者"
        .AddItem "完成日期"
        .AddItem "文档编号"
        .AddItem "项目"
        .AddItem "用途"
        .AddItem "邮局"
        .AddItem "语言"
        .AddItem "源"
        .AddItem "转发到"
        .AddItem "状态"
    End With
    With propCmb
        .AddItem "文本"
        .AddItem "日期"
        .AddItem "是或否"
        .AddItem "数字"
        .ListIndex = 0
    End With
    With List1
        
        .AddItem "表"
        For Each sTable In dbs.TableDefs
            If Left(sTable.Name, 4) <> "MSys" Then
                .AddItem vbTab & sTable.Name
            End If
        Next
        .AddItem "查询"
        .AddItem ""
        .AddItem "窗体"
        .AddItem ""
        .AddItem "报表"
        .AddItem ""
        .AddItem "数据访问页"
        .AddItem ""
        .AddItem "宏"
        .AddItem ""
        .AddItem "模块"
        
    End With
    UpdateInfo
    tabs.tabs("ZY").Selected = True
    txtTitle.Text = GetSummaryInfo("Title")
    txtSubject.Text = GetSummaryInfo("Subject")
    txtAuthor.Text = GetSummaryInfo("Author")
    txtCategory.Text = GetSummaryInfo("Category")
    txtManager.Text = GetSummaryInfo("Manager")
    txtComments.Text = GetSummaryInfo("Comments")
    txtKeywords.Text = GetSummaryInfo("Keywords")
    txtHyperlink.Text = GetSummaryInfo("Hyperlink Base")
    txtCompany.Text = GetSummaryInfo("Company")
    
    GetUserInfo
    
    
    
   
End Sub



Private Sub lstZDY_Click()
    txtZDYName.Text = lstZDY.List(lstZDY.ListIndex)
    CmdADD.Enabled = False
End Sub
Private Sub Option1_Click()
 CmdADD.Enabled = True
End Sub

Private Sub Option2_Click()
 CmdADD.Enabled = True
End Sub

Private Sub propCmb_Click()
    If propCmb.Text = "是或否" Then
        txtValue.Visible = False
        frmValue.Visible = True
         CmdADD.Enabled = True
    Else
        txtValue.Visible = True
        frmValue.Visible = False
    End If
       

End Sub

Private Sub propLV_ItemClick(ByVal Item As MSComctlLib.ListItem)
Dim i As Long
    txtZDYName.Text = Item.Text
    
    For i = 0 To propCmb.ListCount - 1
        If propCmb.List(i) = Item.SubItems(2) Then
             CmdADD.Enabled = False
             CmdDel.Enabled = True
            propCmb.ListIndex = i
            
            Exit For
        End If
    Next i
    If propCmb.Text = "是或否" Then
        Option1.Value = IIf(Item.SubItems(1) = "是", True, False)
      
        Option2.Value = IIf(Item.SubItems(1) = "否", True, False)
       
    Else
        txtValue.Text = Item.SubItems(1)
    End If
End Sub

Private Sub tabs_Click()
Static PreTab As Long
    If PreTab = 0 Then PreTab = 1
    If PreTab = tabs.SelectedItem.Index Then Exit Sub
    tabfrm(PreTab - 1).Visible = False
    tabfrm(tabs.SelectedItem.Index - 1).Visible = True
    PreTab = tabs.SelectedItem.Index
End Sub

Private Sub GetUserInfo()
Dim dbs As Database, cnt As Container
    Dim doc As Document, prp As Property, ff As Property, i As Long
    propLV.ListItems.Clear
    ' 属性没有找到错误。
    Const conPropertyNotFound = 3270
    On Error Resume Next
    Set dbs = OpenDatabase(m_UserFile)
    Set cnt = dbs.Containers!Databases
    Set doc = cnt.Documents!UserDefined '用户定义
    doc.Properties.Refresh
    For Each ff In doc.Properties
        If ff.Name <> "Name" And ff.Name <> "Owner" And ff.Name <> "UserName" _
            And ff.Name <> "Permissions" And ff.Name <> "AllPermissions" _
            And ff.Name <> "Container" And ff.Name <> "DateCreated" And ff.Name <> "LastUpdated" Then

            i = i + 1
            propLV.ListItems.Add i, , ff.Name
            propLV.ListItems(i).SubItems(1) = ConvertTXT(ff.Value)
            propLV.ListItems(i).SubItems(2) = ConvertType(ff.Type)
        End If
    Next
End Sub
Function ConvertType(data As Long) As String
    Select Case data
        Case dbText
            ConvertType = "文本"
        Case dbDate
            ConvertType = "日期"
        Case dbBoolean
            ConvertType = "是或否"
        Case dbLong
            ConvertType = "数字"
        Case Else
            ConvertType = data
    End Select
End Function
Function ConvertTXT(txt)
    If txt = "True" Then
        ConvertTXT = "是"
    ElseIf txt = "False" Then
        ConvertTXT = "否"
    Else
        ConvertTXT = txt
    End If
End Function

Private Sub txtValue_Change()
    CmdADD.Enabled = True
End Sub

Private Sub txtZDYName_Change()
Dim i As Long
    For i = 1 To propLV.ListItems.Count
        If txtZDYName.Text = propLV.ListItems(i).Text Then
            CmdADD.Caption = "更改(&C)"
            CmdDel.Enabled = True
            Call propLV_ItemClick(propLV.ListItems(i))
            Exit For
        Else
            CmdADD.Caption = "添加(&A)"
            txtValue.Text = ""
            txtValue.Visible = True
            frmValue.Visible = False
            propCmb.ListIndex = 0
            CmdDel.Enabled = False
        End If
    Next i
End Sub
Function m_DataType() As Long
    Select Case propCmb.Text
        Case "文本"
            m_DataType = dbText
        Case "日期"
            m_DataType = dbDate
        Case "是或否"
            m_DataType = dbBoolean
        Case "数字"
            m_DataType = dbLong
    End Select
End Function