frmmain.frm

用VB写的和数据库联合编程的电子图档管理系统

    Data1.Recordset.Update
    Data1.Recordset.MoveLast
        
    SetStatusText ("加入图档成功!")
    reload = True
   
End Sub

Private Sub Edit_Click()
    
    If Len(PicName.text) = 0 Then
        SetStatusText ("请输入名称.")
        MsgBox "名称不能为空!"
        Exit Sub
    End If
    
    If Len(PicDate.text) > 0 And IsDate(PicDate.text) = 0 Then
        SetStatusText ("日期格式无效,请输入01-10-20的格式.")
        MsgBox "无效的日期格式!"
        Exit Sub
    End If
    
    If isnumber(PicCode.text) = 0 Then
        SetStatusText ("图号不能为空，而且必须是数字.")
        MsgBox "图号只能是数字!"
        Exit Sub
    End If

    reload = False
    Dim temp As String
    temp = picfilename
    
    Dim fit As String
    fit = "图号="
    fit = fit + PicCode.text
    '保存当前记录图号
    Dim code As String
    PicCode.DataChanged = False
    '保存当前记录号以便更新失败时恢复
    Dim mark As Long
    mark = Data1.Recordset.AbsolutePosition
    
    code = Data1.Recordset.Fields("图号").Value

    Data1.Recordset.FindFirst fit
    
    '如果找到并且不是以前的图号
    If Data1.Recordset.NoMatch = False And code <> PicCode.text Then
        SetStatusText ("图号已存在,请输入另一个图号")
        Data1.Recordset.Requery
        Data1.Recordset.Move mark
        MsgBox "图号已存在!"
        reload = True
        Exit Sub
    End If
    
    PicCode.DataChanged = True
  
    If Data1.Recordset.RecordCount > 0 Then
        If MyImage.Picture.Handle = 0 Then
            SetStatusText ("您还没有选择图片，在图片显示框中单击选择.")
            MsgBox "请选择图片!"
        Else
            
            Data1.Recordset.Edit
            picfilename = temp
            
            If Len(picfilename) <> 0 Then
                FileStreamToField Data1.Recordset.Fields("数据"), picfilename
            Else
                FileStreamToField Data1.Recordset.Fields("数据"), App.Path + "\pic.tmp"
            End If
            
            Data1.Recordset.Update
            SetStatusText ("更新图档成功!")
       End If
    Else
        SetStatusText ("当前无记录!")
    End If
    
    reload = True
    
End Sub

Private Sub Delete_Click()
    
    If Data1.Recordset.RecordCount > 0 Then

        Data1.Recordset.Delete
        Data1.Recordset.Requery
        
        If Data1.Recordset.RecordCount > 0 Then
            Data1.Recordset.MoveFirst
        Else
            cleardata
        End If
        
        SetStatusText ("删除图档成功!")
    Else
        MsgBox "当前无记录!"
    End If
    
End Sub

Private Sub Clear_Click()
    
    If Data1.Recordset.RecordCount > 0 Then
    
       reload = False
       SetStatusText ("正在清空图档,请稍候...")
       
       Dim i As Long
       Do While Data1.Recordset.EOF = False
          Data1.Recordset.MoveFirst
          Data1.Recordset.Delete
          Data1.Recordset.Requery
       Loop
       
       cleardata
       SetStatusText ("清空图档成功!")
       reload = True
    Else
       SetStatusText ("记录已为空.")
       MsgBox "记录已为空!"
    End If

End Sub

Private Sub FindFirst_Click()
    
    If FindData.text = "" Then
        SetStatusText ("您没有输入查找字符.")
        MsgBox "请输入查找字符!"
    Else
    
        Dim mark As Long
        mark = Data1.Recordset.AbsolutePosition
        
        '图号查找格式，图号=XXX
        '日期查找格式，日期=#XXX#
        '其它文件格式，其它='XXX'
        
        Dim fit As String
        If FindType.text = "图号" Then
            fit = FindType.text + "=" + FindData.text + ""
        ElseIf FindType.text = "日期" Then
            fit = FindType.text + "=#" + FindData.text + "#"
        Else
            fit = FindType.text + "='" + FindData.text + "'"
        End If
        
        Data1.Recordset.FindFirst fit
        
        If Data1.Recordset.NoMatch Then
            SetStatusText ("进行首次图档查找,但是没有成功!")
            Data1.Recordset.Move mark
        Else
            SetStatusText ("进行首次图档查找成功!")
        End If
        
    End If
    
End Sub

Private Sub FindNext_Click()

    If FindData.text = "" Then
        SetStatusText ("您没有输入查找字符.")
        MsgBox "请输入查找字符!"
    Else
    
        If Data1.Recordset.AbsolutePosition >= Data1.Recordset.RecordCount Then
            SetStatusText ("已经查找到数据末")
            Exit Sub
        End If
        
        Dim fit As String
        If FindType.text = "图号" Then
            fit = FindType.text + "=" + FindData.text + ""
        ElseIf FindType.text = "日期" Then
            fit = FindType.text + "=#" + FindData.text + "#"
        Else
            fit = FindType.text + "='" + FindData.text + "'"
        End If
        
        Data1.Recordset.FindNext fit
        
        If Data1.Recordset.NoMatch Then
            SetStatusText ("进行下一次图档查找,但是没有成功!")
        Else
            SetStatusText ("进行下一次图档查找成功!")
        End If
    End If
    
End Sub

Private Sub FindPre_Click()
    
    If FindData.text = "" Then
        SetStatusText ("您没有输入查找字符.")
        MsgBox "请输入查找字符!"
    Else
  
        If Data1.Recordset.AbsolutePosition <= 0 Then
            SetStatusText ("已经查找到数据首")
            Exit Sub
        End If
        
        Dim fit As String
        If FindType.text = "图号" Then
            fit = FindType.text + "=" + FindData.text + ""
        ElseIf FindType.text = "日期" Then
            fit = FindType.text + "=#" + FindData.text + "#"
        Else
            fit = FindType.text + "='" + FindData.text + "'"
        End If
        
        Data1.Recordset.FindPrevious fit
        
        If Data1.Recordset.NoMatch Then
            SetStatusText ("进行上一次图档查找,但是没有成功!")
        Else
            SetStatusText ("进行上一次图档查找成功!")
        End If
    End If

End Sub

Private Sub Form_Load()

    Me.left = GetSetting(App.Title, "Settings", "MainLeft", 1000)
    Me.Top = GetSetting(App.Title, "Settings", "MainTop", 1000)
    Me.Width = GetSetting(App.Title, "Settings", "MainWidth", 6500)
    Me.Height = GetSetting(App.Title, "Settings", "MainHeight", 6500)
    
    FindType.text = "名称"
    Data1.DatabaseName = App.Path + "\data.mdb"
    Data1.RecordSource = "picrec"
    
    picfilename = ""
    SetStatusText ("就绪")
    sbStatusBar.Panels(3).text = "用户:" + UserName + "  权限:" + Purview
    
    '没有增加的权限
    If Purview = "只读" Or Purview = "读改" Then
       mnuActionAdd.Enabled = False
       Add.Enabled = False
    End If
    
    '没有修改的权限
    If Purview = "只读" Then
       mnuActionEdit.Enabled = False
       Edit.Enabled = False
       
       PicName.Enabled = False
       Outhor.Enabled = False
       PicDate.Enabled = False
       Des.Enabled = False
       PicCode.Enabled = False
       PicSize.Enabled = False
       Commucation.Enabled = False
       Address.Enabled = False
       
       PicLoad.Enabled = False
       
    End If
    
    '没有删除的权限
    If Purview <> "所有" And Purview <> "管理员" Then
      mnuActionDel.Enabled = False
      Delete.Enabled = False
      mnuActionClear.Enabled = False
      Clear.Enabled = False
    End If
    
    '如果不是管理员，将用户设置菜单变灰
    If Purview <> "管理员" Then mnuUserSet.Enabled = False
    '如果用户是只读权限，将DBGRID控件的allowupdate置false
    If Purview = "只读" Then DBGrid2.AllowUpdate = False
    
    reload = True
    
End Sub


Private Sub Form_Unload(Cancel As Integer)
    Dim i As Integer

    'close all sub forms
    For i = Forms.count - 1 To 1 Step -1
        Unload Forms(i)
    Next
    If Me.WindowState <> vbMinimized Then
        SaveSetting App.Title, "Settings", "MainLeft", Me.left
        SaveSetting App.Title, "Settings", "MainTop", Me.Top
        SaveSetting App.Title, "Settings", "MainWidth", Me.Width
        SaveSetting App.Title, "Settings", "MainHeight", Me.Height
    End If
    
    '删除两个临时文件
    DeleteFile App.Path + "\pic.tmp"
    DeleteFile seefilename
    
End Sub


Private Sub mnuHelpSee_Click()
    '调用帮助文件，帮助文件和主程序文件同名，但扩展名为chm
    Dim name As String
    name = App.Path + "\" + App.EXEName + ".chm"
    ShellExecute 0, "", name, "", "", 5
    
End Sub

Private Sub mnuPasModify_Click()
    
    Dim dlg As New PasModify
    dlg.Show vbModal, Me
    
End Sub

Private Sub mnuUserSet_Click()
    
    Dim dlg As New FrmUser
    dlg.Show vbModal, Me
    
End Sub



Private Sub PicLoad_Click()
     
     With CommonDialog1
     
        .DialogTitle = "打开"
        .CancelError = False

        .Filter = "支持文件 (*.bmp,*.jpg,*.gif,*.wmf)|*.bmp;*.jpg;*.gif;*.wmf"
        .ShowOpen
        
        If Len(.filename) = 0 Then
            Exit Sub
        End If
        
        If Len(.filename) <> 0 Then
            MyImage.Picture = LoadPicture(.filename)
            picfilename = .filename
  
            Dim m, n As Integer
            m = CInt(MyImage.Picture.Width / 26.45)
            n = CInt(MyImage.Picture.Height / 26.45)
            
            PicSize.text = Right$(Str$(m), Len(Str$(m)) - 1) + "," + Right$(Str$(n), Len(Str$(n)) - 1)
        End If
        
    End With
    
End Sub

Private Sub PicSave_Click()

    With CommonDialog1
    
        .DialogTitle = "保存"
        .CancelError = False

        .Filter = "支持文件 (*.bmp,*.jpg,*.gif,*.wmf)|*.bmp;*.jpg;*.gif;*.wmf"
        .ShowSave
        
        If Len(.filename) = 0 Then
            Exit Sub
        End If
        
        If Len(.filename) <> 0 Then
           FieldToFileStream .filename, Data1.Recordset("数据")
        End If
        
    End With
    
End Sub

Private Sub PicSee_Click()
   
   If MyImage.Picture.Type = 2 Then
       seefilename = App.Path + "\pic.wmf"
   ElseIf MyImage.Picture.Type = 3 Then
       seefilename = App.Path + "\pic.ico"
   Else
       seefilename = App.Path + "\pic.jpg"
   End If
   
   FieldToFileStream seefilename, Data1.Recordset.Fields("数据")
   ShellExecute 0, "", seefilename, "", "", 5
   
End Sub

Private Sub sbStatusBar_PanelClick(ByVal Panel As MSComctlLib.Panel)
    
    If Panel.Index = 3 Then mnuUserSet_Click
    
End Sub