frmpicadd.frm

利用VB+SQL2000开发的照片管理系统

      Caption         =   "图片名称："
      BeginProperty Font 
         Name            =   "宋体"
         Size            =   10.5
         Charset         =   134
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Height          =   210
      Left            =   180
      TabIndex        =   13
      Top             =   1395
      Width           =   1050
   End
   Begin VB.Label Label19 
      Alignment       =   1  'Right Justify
      AutoSize        =   -1  'True
      BackStyle       =   0  'Transparent
      Caption         =   "图片描述："
      BeginProperty Font 
         Name            =   "宋体"
         Size            =   10.5
         Charset         =   134
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Height          =   210
      Left            =   180
      TabIndex        =   12
      Top             =   2385
      Width           =   1050
   End
   Begin VB.Label Label4 
      Alignment       =   1  'Right Justify
      AutoSize        =   -1  'True
      BackStyle       =   0  'Transparent
      Caption         =   "图片分类："
      BeginProperty Font 
         Name            =   "宋体"
         Size            =   10.5
         Charset         =   134
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Height          =   210
      Left            =   180
      TabIndex        =   11
      Top             =   345
      Width           =   1050
   End
End
Attribute VB_Name = "FrmPicAdd"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Dim Rec As New ADODB.Recordset
Dim i As Integer
Dim Fname As String
Dim Clear_Pic As Boolean

Private Sub Command1_Click(Index As Integer)
    Select Case Index
        Case 1              '保存修改
            If Trim(Text1(1).Text) = "" Then
                MsgBox "图片名称不能为空！", vbOKOnly + vbInformation, "提示窗口"
                Exit Sub
            End If
            With FrmMain.Rec
'                .Fields("pid").Value = Trim(Text1(0).Text)
                .Fields("pname").Value = Trim(Text1(1).Text)
                .Fields("tid").Value = Trim(Left(Combo1.Text, InStr(Combo1.Text, " | ")))
                .Fields("pdis").Value = IIf(Len(Trim(Text1(2).Text)) = 0, " ", Trim(Text1(2).Text))
                .Fields("pdate").Value = DTPicker1.Value
                
                .Update
            End With
            If Rec.State = 1 Then Rec.Close: Set Rec = Nothing
            With Rec
                .CursorLocation = adUseClient
                .Open "select * from TblPicture where pid='" & Trim(Text1(0).Text) & "'", _
                    MdlMain.Cn, adOpenDynamic, adLockOptimistic
                If Not .EOF And Not .BOF Then
                    If Len(Trim(Fname)) <> 0 Then
                        MdlMain.Chunk = MdlMain.Image2Chunk(Fname)
                        .Fields("pic").AppendChunk MdlMain.Chunk
                    Else
                        If Clear_Pic = True Then
                            ReDim MdlMain.Chunk(0)
                            .Fields("pic").AppendChunk MdlMain.Chunk
                        End If
                    End If
                    .Update
                Else
                    .AddNew
                    .Fields("pid").Value = Trim(Text1(0).Text)
                    If Len(Trim(Fname)) <> 0 Then
                        MdlMain.Chunk = MdlMain.Image2Chunk(Fname)
                        .Fields("pic").AppendChunk MdlMain.Chunk
                    End If
                    .Update
                End If
            End With
            MdlMain.ReturnSql = "已修改"
            Unload Me
        Case 0          '新增保存
            If Combo1.Text = "" Then
                MsgBox "请选择图片类型！", vbOKOnly + vbInformation, "提示窗口"
                Combo1.SetFocus
                Exit Sub
            End If
            If Len(Trim(Text1(0).Text)) = 0 Then
                MsgBox "图片编号不能为空！", vbOKOnly + vbInformation, "提示窗口"
                Text1(0).SetFocus
                Exit Sub
            End If
            If Len(Trim(Text1(0).Text)) > 10 Then
                MsgBox "图片编号不能超过10位数！", vbOKOnly + vbInformation, "提示窗口"
                Text1(0).SetFocus
                Exit Sub
            End If
            If Trim(Text1(1).Text) = "" Then
                MsgBox "图片名称不能为空！", vbOKOnly + vbInformation, "提示窗口"
                Text1(1).SetFocus
                Exit Sub
            End If
            If Rec.State = 1 Then Rec.Close: Set Rec = Nothing
            Rec.CursorLocation = adUseClient
            Rec.Open "select * from TblPic where pid='" & Trim(Text1(0).Text) & "'", _
                MdlMain.Cn, adOpenDynamic, adLockOptimistic
            If Not Rec.BOF And Not Rec.EOF Then
                MsgBox "此图片编号已存在，请重新输入编号！", vbOKOnly + vbExclamation, "校验出错..."
            Else
                MdlMain.Cn.BeginTrans
                    With Rec
                        .AddNew
                            .Fields("pid").Value = Trim(Text1(0).Text)
                            .Fields("pname").Value = Trim(Text1(1).Text)
                            .Fields("tid").Value = Trim(Left(Combo1.Text, InStr(Combo1.Text, " | ")))
                            .Fields("pdis").Value = IIf(Len(Trim(Text1(2).Text)) = 0, " ", Trim(Text1(2).Text))
                            .Fields("pdate").Value = DTPicker1.Value
                        .Update
                        MdlMain.ReturnSql = "已增加"
                    End With
                    Rec.Close: Set Rec = Nothing
                
                    With Rec
                        .CursorLocation = adUseClient
                        .Open "TblPicture", MdlMain.Cn, adOpenDynamic, adLockOptimistic
                        .AddNew
                        
                        .Fields("pid").Value = Trim(Text1(0).Text)
                        If Len(Trim(Fname)) <> 0 Then
                            MdlMain.Chunk = MdlMain.Image2Chunk(Fname)
                            .Fields("pic").AppendChunk MdlMain.Chunk
                        End If
                        
                        .Update
                    End With
                MdlMain.Cn.CommitTrans
                Call InitControlBox
            End If
            Rec.Close
            Set Rec = Nothing
            Text1(0).SetFocus
        Case 2
            Unload Me
    End Select
End Sub

Private Sub Command2_Click()
    Fname = ""
    Clear_Pic = True
    Text2.Text = ""
    ReDim MdlMain.Chunk(0)
    Call PicDisplay
End Sub

Private Sub Form_KeyPress(KeyAscii As Integer)
    If KeyAscii = vbKeyEscape Then Unload Me
End Sub

Private Sub Form_Load()
    Me.KeyPreview = True
    Fname = ""
    Clear_Pic = False
    
    If Rec.State = 1 Then Rec.Close: Set Rec = Nothing
    
    Combo1.Clear
    
    Set Rec = MdlMain.Cn.Execute("select * from tbltype order by tid")
    If Not Rec.EOF And Not Rec.BOF Then
        While Not Rec.EOF
            Combo1.AddItem Rec.Fields("tid").Value & " | " & Rec.Fields("tname").Value
            Rec.MoveNext
        Wend
    End If
    
    Call InitControlBox
End Sub

Private Sub Form_Unload(Cancel As Integer)
    On Error Resume Next
    Rec.Close
    Set Rec = Nothing
End Sub

Private Sub Image1_DblClick()
    Dim Rec11 As New ADODB.Recordset
    If Command1(0).Enabled = False Then
        If Len(Trim(Fname)) = 0 Then
            Set Rec11 = MdlMain.Cn.Execute("select * from TblPicture where pid='" & Text1(0).Text & "'")
            If Not Rec11.EOF And Not Rec11.BOF Then
                If Rec11.Fields("pic").ActualSize <> 0 Then
                    MdlMain.Chunk() = Rec11.Fields("pic").GetChunk(Rec11.Fields("pic").ActualSize)
                Else
                    ReDim MdlMain.Chunk(0)
                End If
            End If
            Rec11.Close: Set Rec11 = Nothing
            If UBound(MdlMain.Chunk) = 0 Then Exit Sub
        End If
        FrmPicLl.Show vbModal
    Else
        If Len(Trim(Fname)) <> 0 Then
            FrmPicLl.Show vbModal
        End If
    End If
End Sub

Private Sub Text1_GotFocus(Index As Integer)
    Text1(Index).SelStart = 0
    Text1(Index).SelLength = Len(Text1(Index).Text)
End Sub

Private Sub InitControlBox()
    Text2.Text = ""
    For i = 0 To 2
        Text1(i).Text = ""
    Next i
    DTPicker1.Value = Now
    ReDim MdlMain.Chunk(0)
    Call PicDisplay
End Sub

Private Sub Text1_KeyPress(Index As Integer, KeyAscii As Integer)
    Select Case Index
        Case 2
'            If (KeyAscii < 48 Or KeyAscii > 57) And KeyAscii <> 46 And _
                KeyAscii <> vbKeyBack And KeyAscii <> vbKeyReturn Then KeyAscii = 0
    End Select
End Sub

Private Sub Command5_Click()
    On Error Resume Next
    With CommonDialog1
        .Filter = "*.jpg|*.jpg|*.gif|*.gif|*.bmp|*.bmp|*.wmf|*.wmf" & _
            "|*.emf|*.emf|*.ico|*.ico|*.cur|*.cur|*.dib|*.dib|*.*|*.*"
        .DialogTitle = "选择照片"
        .Filename = ""
        .CancelError = True
        .ShowOpen
    End With
    If Len(Trim(CommonDialog1.Filename)) <> 0 Then
        If Dir(CommonDialog1.Filename) <> "" Then
            Fname = CommonDialog1.Filename
            If Trim(Text1(1).Text) = "" Then
                Text1(1).Text = GetFileName(CommonDialog1.Filename)
            End If
            Text2.Text = Fname
            MdlMain.Chunk = Image2Chunk(Fname)
            Call PicDisplay
        End If
    End If
End Sub

Private Function GetFileName(FilenameStr As String) As String
    Dim i As Integer
    For i = Len(Trim(FilenameStr)) To 0 Step -1
        If Mid(Trim(FilenameStr), i, 1) = "\" Then Exit For
    Next i
    GetFileName = Right(Trim(FilenameStr), Len(Trim(FilenameStr)) - i)
End Function


Public Sub PicDisplay()
    On Error Resume Next
    Image1.Picture = LoadPicture()
    Image1.Stretch = False
    Image1.Picture = MdlMain.Chunk2Image(MdlMain.Chunk, "")
    
    Dim Wr As Double
    Dim Hr As Double
    Dim r As Double
    Image1.Visible = False
    Wr = Picture3.Width / Image1.Width
    Hr = Picture3.Height / Image1.Height
    If Wr > Hr Then r = Hr Else r = Wr
    Image1.Width = Image1.Width * r
    Image1.Height = Image1.Height * r
    Image1.Top = (Picture3.Height - Image1.Height) / 2
    Image1.Left = (Picture3.Width - Image1.Width) / 2
    Image1.Stretch = True
    Image1.Visible = True
End Sub