iBase.ru Forum

Код: Выделить всё

' таблица для хранения изображений
' IB6.5  3 диалект 

'CREATE TABLE IMG1 (
'    ID_EXP   INTEGER NOT NULL,
'    ID_PERS  INTEGER NOT NULL,
'    IMAGE1   BLOB SUB_TYPE 0 SEGMENT SIZE 80
');

Private cur_id_exp As String
Private cur_id_emp As String

Private strFilename As String

Public Sub SetSize()
  Me.Height = 4950
  Me.Width = 7560
  Me.Top = (frmMDIHead.ScaleHeight - Me.Height) / 2
  Me.Left = (frmMDIHead.ScaleWidth - Me.Width) / 2
End Sub

Private Sub CmdDel_Click()
  Dim cmd1 As ADODB.Command
  
  If lblNoPhoto.Visible = False Then
    If MsgBox("Óäàëèòü ôîòîãðàôèþ '" & lblFIO.Caption & "' ?", vbYesNo) = vbYes Then
      Set cmd1 = New ADODB.Command
      With cmd1
        .ActiveConnection = cnn_ib
        .CommandType = adCmdText
        .CommandText = "DELETE FROM img1 where id_exp=" & _
        cur_id_exp & " and id_pers=" & cur_id_emp
        .Execute
      End With
      Call LoadImgFromBase
    End If
  End If
End Sub

Private Sub cmdExit_Click()
  Unload Me
End Sub

Private Sub cmdFromFile_Click()
On Error GoTo ErrExit
  With CommonDialog1
    .DialogTitle = "Çàãðóçêà èçîáðàæåíèÿ"
    .CancelError = False
    .Filter = "jpg|*.jpg|Gif|*.gif|Bmp|*.bmp|All|*.*"
    .ShowOpen
    If .FileName = "" Then
      lblNoPhoto.Visible = True
      Image1.Picture = Nothing
      Exit Sub
    Else
      strFilename = .FileName
      Image1.Picture = LoadPicture(strFilename)
      lblNoPhoto.Visible = False
    End If
  End With
ErrExit:
End Sub

Private Sub cmdWrite_Click()
  Dim s1 As ADODB.Stream
  Dim cmd1 As ADODB.Command
  Dim par1 As ADODB.Parameter
   
  If lblNoPhoto.Visible = True Then Exit Sub
  
cnn_ib.BeginTrans

On Error GoTo ErrIns

  Set s1 = New ADODB.Stream
    With s1
      .Type = adTypeBinary
      .Open
      .LoadFromFile (strFilename)
    End With
  
  Set cmd1 = New ADODB.Command
  
  ' ñíà÷àëà óäàëÿåì âîçìîæíî ñóùåñòâóþùóþ ïðåäûäóùóþ çàïèñü
  With cmd1
      .ActiveConnection = cnn_ib
      .CommandType = adCmdText
      .CommandText = "DELETE FROM img1 where id_exp=" & _
          cur_id_exp & " and id_pers=" & cur_id_emp
      .Execute
    End With
  Set cmd1 = Nothing
  
  ' ïîòîì çàïèñûâàåì íîâîå èçîáðàæåíèå
  ' //////// ñ èñïîëüçîâàíèåì Command  - ok /////////////////
  Set cmd1 = New ADODB.Command
    
    cmd1.CommandText = "insert into img1(id_exp,id_pers,Image1) values(" & _
    cur_id_exp & "," & cur_id_emp & ",?)"
  
    Set par1 = cmd1.CreateParameter()
    par1.Attributes = adParamLong
    par1.Direction = adParamInput
    par1.Size = 1000000
    par1.Type = adLongVarBinary
  
    cmd1.Parameters.Append par1
  
    cmd1.Parameters(0).Value = s1.Read
  
    cmd1.ActiveConnection = cnn_ib
    cmd1.CommandType = adCmdText
  
    cmd1.Execute
On Error GoTo 0

  cnn_ib.CommitTrans
  Set cmd1 = Nothing
  Set s1 = Nothing
  MsgBox ("Èçîáðàæåíèå óñïåøíî ñîõðàíåíî")
  Unload Me
  Exit Sub
  
ErrIns:
  cnn_ib.RollbackTrans
  Set cmd1 = Nothing
  Set s1 = Nothing
  MsgBox ("Îøèáêà çàïèñè èçîáðàæåíèÿ")
  
End Sub

Private Sub Form_Load()
  cur_id_exp = frmListEmp.sel_id_exp
  cur_id_emp = frmListEmp.sel_id_emp

  lblFIO.Caption = frmListEmp.sel_fio
  Me.Caption = "Ôîòîãðàôèÿ - " & lblFIO.Caption
  
  Image1.Stretch = True
  
  Call SetSize
  Call LoadImgFromBase
End Sub

Private Sub LoadImgFromBase()
  ' çàãðóçêà èçîáðàæåíèÿ èç áàçû âî âðåì.ôàéë è ïîòîì â Image1
   Dim s1 As ADODB.Stream
   Dim rs1 As ADODB.Recordset
   
   Image1.Picture = Nothing
   Set rs1 = New ADODB.Recordset
   
On Error GoTo errMF
    With rs1
      .ActiveConnection = cnn_ib
      .CursorLocation = adUseServer
      .CursorType = adOpenStatic
      .Source = "select image1 from img1 where id_exp=" & _
        cur_id_exp & " and id_pers=" & cur_id_emp
      .Open
      .MoveFirst
    End With
    
    Set s1 = New ADODB.Stream
    strFilename = App.Path & "\tmpImg.bmp"
    
    With s1
     .Type = adTypeBinary
     .Open
     .Write (rs1.Fields("Image1").Value)
     .SaveToFile strFilename, adSaveCreateOverWrite
    End With
    
    If s1.Size > 0 Then
      Image1.Picture = LoadPicture(App.Path & "\tmpImg.bmp")
    Else
      Image1.Picture = Nothing
    End If
    lblNoPhoto.Visible = False
    Set rs1 = Nothing
    Set s1 = Nothing
    
On Error GoTo 0
Exit Sub
errMF:
  lblNoPhoto.Visible = True
  Set rs1 = Nothing
  Set s1 = Nothing
End Sub