gys.frm

VB,图片保存/删除/修改/为二进制 VB运行环境

               StrNum = 1
           End If
   Text1(1).SetFocus
   Cmd_save.Enabled = True
   Cmd_del.Enabled = False
   Cmd_edit.Enabled = False
End Sub
'*** “删除”供应商信息按钮的事件过程 ***
Private Sub Cmd_del_Click()
rtn = SetWindowPos(Me.hWnd, -2, 0, 0, 0, 0, 3)      '运用API函数SetWindowPos，来实现取消窗体置前的功能
    If Adodc1.Recordset.EOF = False Then
          c = MsgBox("您确认要删除该记录吗?", 17, "删除提示信息")
                 If c = vbOK Then
                      Adodc1.Recordset.Delete     '删除所选中的记录信息
                      Adodc1.Refresh
                      ETemp = 1                   '删除标识
                      Call joinRZ                 '调用添加日志过程，添加删除信息日志
                         For i = 0 To 5           '在删除完信息之后，清空文本框中的内容
                           Text1(i).Text = ""
                         Next i
                    Cmd_del.Enabled = False
                    Call TRefresh                 '调用数据刷新过程
                 End If
     Else
               MsgBox "当前数据库中已经没有可删除的记录", 64, "提示信息"
     End If
End Sub
'*** “修改”供应商信息按钮的事件过程 ***
Private Sub Cmd_edit_Click()
rtn = SetWindowPos(Me.hWnd, -2, 0, 0, 0, 0, 3)      '运用API函数SetWindowPos，来实现取消窗体置前的功能
   If Text1(0).Text = "" Or Text1(1).Text = "" Then
      MsgBox "请选择需要改动的记录信息!", 48, "信息提示"
   Else
        c = MsgBox("确认要修改该记录吗?", 33, "修改信息提示")
           If c = vbOK Then                                   '如果确认修改的话进行修改操作
               If Text1(1).Text = "" Then
                  MsgBox "供应商名称不能为空值!", 48, "修改信息提示"
               Else
                          Call main     '调用公共模块中的连接数据库函数
                            '利用SQL语句修改供应商信息
                            Set adoRs = adoCon.Execute("UPDATE tb_gys SET gys_Name='" + Text1(1).Text + "',gys_lxr='" + Text1(2).Text + "',gys_phone='" + Text1(3).Text + "',gys_fax='" + Text1(4).Text + "',gys_remark='" + Text1(5).Text + "',gys_date='" + Str(Now) + "',gys_jlxgr='" + Name1 + "' where gys_ID='" + Text1(0) + "'")
                            ETemp = 0                   '修改标识
                            Call joinRZ                 '调用添加日志过程，添加修改信息日志
                            MsgBox "信息修改成功", 64, "修改信息提示"
                            Cmd_edit.Enabled = False
                          adoCon.Close                  '关闭数据连接
                          Call TRefresh                 '调用数据刷新过程
                End If
            Else
            End If
   End If
End Sub
Private Sub Cmd_exit_Click()
  Unload Me
End Sub
'*** “保存”供应商信息按钮的事件过程 ***
Private Sub Cmd_save_Click()

    Dim BufferFileArray() As String
    Dim i As Integer
    
 ask = True
    
    With CommonDialog1
        .DialogTitle = "添加多个文件..."
        .Filter = "全部图像文件|*.jpg;*.jpeg;*.gif;*.bmp;*.ico;*.wmf"
        .Flags = cdlOFNAllowMultiselect Or cdlOFNExplorer Or cdlOFNHideReadOnly
        .InitDir = CurDir
        .MaxFileSize = 32767
        .Filename = ""
        .ShowOpen
    BufferFileArray = Split(.Filename, Chr(0))
    End With
  
    ' If no files are selected
    If UBound(BufferFileArray) = -1 Then Exit Sub
    
    ' If only one file was chosen.
    If UBound(BufferFileArray) = 0 Then
        saveimage CommonDialog1.Filename
        Exit Sub
    End If
    
    ' If multiple files chosen.
    ProgressBar1.Max = UBound(BufferFileArray)
    For i = LBound(BufferFileArray) + 1 To UBound(BufferFileArray)
        ProgressBar1.Value = i
        saveimage CurDir & "\" & BufferFileArray(i)
    Next i
    ProgressBar1.Value = 0
    List1.Selected(List1.ListCount - 1) = True
   
End Sub
Private Sub saveimage(strImage As String)
    ' Save image to database
    On Error Resume Next
    
    Dim NumBlocks As Integer, SourceFile As Integer, i As Integer
    Dim FileLength As Long, LeftOver As Long
    Dim FileData() As Byte, retval As Variant
    Dim Recordset As Recordset
    Dim strHex As String
    
    Set m_CRC = New clsCRC
    
    Picture1.Cls
    Picture1.Picture = LoadPicture(strImage)
     Image1.Picture = LoadPicture(strFile)
    StatusBar1.Panels(2).Text = "导入中" & GetFileName(Replace(strImage, "'", ""))
    
    strHex = Hex(m_CRC.CalculateFile(strImage))
    
    Adodc1.RecordSource = "SELECT * FROM tb_gys where crc = '" & strHex & "';"
    Adodc1.Refresh
    m_CRC.Algorithm = CRC32
    If Adodc1.Recordset.RecordCount > 0 Then
        MsgBox "该信息已经存在,信息保存不成功", 64, "保存信息提示"
    Else
        c = MsgBox("您确认要保存该信息吗?", 33, "保存信息提示")
          If c = vbOK Then
               If Text1(1).Text = "" Or Text1(2).Text = "" Then                  '确保供应商名称及联系人信息输入不为空值
                  MsgBox "供应商名称及联系人等信息不能为空值!", 48, "保存信息提示"
               Else
               Call main
                            NumId = Val(Mid(Text1(0).Text, 2, Len(Text1(0).Text)))
                               '保存供应商信息
    Adodc1.Recordset.AddNew
    Adodc1.Recordset.Fields("gys_ids") = StrNum
    Adodc1.Recordset.Fields("gys_id") = Text1(0).Text
    Adodc1.Recordset.Fields("GYS_Name") = Text1(1).Text
    Adodc1.Recordset.Fields("GYS_lxr") = Text1(2).Text
    Adodc1.Recordset.Fields("gys_phone") = Text1(3).Text
    Adodc1.Recordset.Fields("gys_fax") = Text1(4).Text
    Adodc1.Recordset.Fields("gys_remark") = Text1(5).Text
    Adodc1.Recordset.Fields("title") = GetFileName(Replace(strImage, "'", ""))
    Adodc1.Recordset.Fields("crc") = strHex
    Adodc1.Recordset.Fields("size") = FileLen(strImage)
    Adodc1.Recordset.Fields("width") = Picture1.Width / 15
    Adodc1.Recordset.Fields("height") = Picture1.Height / 15
    Adodc1.Recordset.Fields("type") = LCase(GetFileExtension(strImage))
    SourceFile = FreeFile
        Open strImage For Binary Access Read As SourceFile
        FileLength = LOF(SourceFile)
            NumBlocks = FileLength \ Blocksize
            LeftOver = FileLength Mod Blocksize 'remainder appended first
            ReDim FileData(LeftOver)
            Get SourceFile, , FileData()
            Adodc1.Recordset.Fields("BinData").AppendChunk FileData() 'store the first image chunk
            ReDim FileData(Blocksize)
            For i = 1 To NumBlocks
                Get SourceFile, , FileData()
                Adodc1.Recordset.Fields("BinData").AppendChunk FileData() 'remaining chunks
                DoEvents
            Next i
        Close SourceFile
        Adodc1.Recordset.Update
        List1.AddItem GetFileName(Replace(strImage, "'", ""))
        List1.ListIndex = List1.ListCount - 1
    
        ' duplicate image found
        If ask = True Then response = MsgBox("图像已存在." & vbCrLf & vbCrLf & "源文件: " & GetFileName(Replace(strImage, "'", "")) & vbCrLf & "发现: " & Adodc1.Recordset.Fields("title") & vbCrLf & vbCrLf & "是否继续?", vbYesNo + vbInformation, "复制")
        If response = 7 Or response = 0 Then
            ask = False
        Else
            ask = True
        End If
    End If
           MsgBox "信息保存成功", 64, "保存信息提示"
                                  Cmd_save.Enabled = False
                             adoCon.Close
                             Call TRefresh                               '调用数据刷新过程
                End If
          
          End If
     
    
    ' Delete the source file if user wants
    If Check1.Value = 1 Then Kill strImage
    StatusBar1.Panels(2).Text = ""
    
  
End Sub

Private Sub Command2_Click()
frm.Show
End Sub

Private Sub DataGrid1_Click()
  Call JionBack                                        '调用数据信息反绑定过程
  Cmd_del.Enabled = True
  Cmd_edit.Enabled = True
  Cmd_save.Enabled = False
   End Sub
Private Sub Form_Load()
Adodc1.ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & App.path & "\db1.mdb;Persist Security Info=False"
Adodc1.RecordSource = "select * from tb_gys"
Adodc1.Refresh
   Me.Left = (Screen.Width - Me.Width) / 2
   Me.Top = (Screen.Height - Me.Height) / 2
End Sub
Private Sub Timer1_Timer()
If Adodc1.Recordset.RecordCount > 0 Then
           Label7.Caption = "有 " & Adodc1.Recordset.RecordCount & " 条数据"
      End If
End Sub
Private Sub Command1_Click()
  On Error Resume Next                    '执行错误处理
  '执行模糊查询
  Adodc1.RecordSource = "select * from tb_gys where gys_Name like '%" + Text1(6).Text + "%'"
  Adodc1.Refresh
End Sub
'*** 自定义添加系统操作日志的过程 ***
Private Sub joinRZ()
    Open (App.path & "\xr.ini") For Input As #1
          Do While Not EOF(1)
               Line Input #1, Intext
               TStr = TStr + Intext + Chr(13) + Chr(10)
          Loop
      Close #1
        If ETemp = 0 Then         '添加修改信息日志
            TStr = TStr + "   " + Name1 + "               " + Format(Now, "yyyy-mm-dd hh:mm:ss") + "            " + "修改票号 " + Text1(0).Text + "(" + Text1(1).Text + ")" + Chr(13) + Chr(10)
        ElseIf ETemp = 1 Then     '添加删除信息日志
            TStr = TStr + "   " + Name1 + "               " + Format(Now, "yyyy-mm-dd hh:mm:ss") + "            " + "删除票号 " + Text1(0).Text + "(" + Text1(1).Text + ")" + Chr(13) + Chr(10)
        End If
      Open (App.path & "\xr.ini") For Output As #1   '将日志信息保存到文件当中
      Print #1, TStr
      Close #1
End Sub
'*** 自定义数据信息反绑定的过程 ***
Private Sub JionBack()
On Error Resume Next     '执行错误处理
Dim SLen As Integer
  If Adodc1.Recordset.RecordCount > 0 Then
      StrNum = Val(Adodc1.Recordset.Fields("gys_ID"))
      SLen = Len(Trim(StrNum))
      Select Case SLen    '位数不足者补0
         Case 1
           strtemp = "00000"
         Case 2
           strtemp = "0000"
         Case 3
           strtemp = "000"
         Case 4
           strtemp = "00"
         Case 5
           strtemp = "0"
         Case 6
           strtemp = ""
     End Select
     '将数据信息反绑定到文本框当中
     Text1(0).Text = Adodc1.Recordset(1)
     Text1(1).Text = Adodc1.Recordset(2)
     Text1(2).Text = Adodc1.Recordset(3)
     Text1(3).Text = Adodc1.Recordset(4)
     Text1(4).Text = Adodc1.Recordset(5)
     Text1(5).Text = Adodc1.Recordset(6)
     Label4(1).Caption = Adodc1.Recordset("title")
     StatusBar1.Panels(2).Text = "图像: " & Adodc1.Recordset.Fields("width") & " x " & Adodc1.Recordset.Fields("height") & " - " & SetBytes(Adodc1.Recordset.Fields("size"))
  End If
End Sub
Private Sub Text1_KeyDown(Index As Integer, KeyCode As Integer, Shift As Integer)
  If KeyCode = 13 Then
      If Index = 1 Then
          Text1(2).SetFocus
      ElseIf Index = 2 Then
          Text1(3).SetFocus
      ElseIf Index = 3 Then
          Text1(4).SetFocus
      ElseIf Index = 4 Then
          Text1(5).SetFocus
      ElseIf Index = 5 Then
         Call Cmd_save_Click
         Cmd_Add.SetFocus
      End If
  End If
End Sub
'*** 自定义数据刷新的过程 ***
Private Sub TRefresh()
    Adodc1.RecordSource = "select * from tb_gys order by gys_ID"
    Adodc1.Refresh
End Sub
Private Sub Form_Unload(Cancel As Integer)
   frm.Enabled = True
End Sub