Menyimpan file gambar di database SQL Server & vb6

Mungkin ini sudah jadul, tapi saya yakin masih ada rekan2 kita yg masih susah dalam mengolah data type image di database Sql nya...
mudah2an trik ini bisa membantu rekan2 yg lagi susah untuk hal ini...

silahkan pelajari dan fungsi2 dibawah ini ...



'*** Untuk Menghapus fot dari field
Private Sub cmddelfoto_Click()
   If MsgBox("Anda yakin akan menghapus Foto ini?", vbQuestion + vbYesNo, "Hapus") = vbNo Then
     Exit Sub
   End If
   strSQL = "update FBARANG set foto =null  Where Kode=" & cStrSQL(txtKode.Text)
   gConn.Execute strSQL, , adCmdText
   Image1.Picture = Nothing
   CommonDialog1.FileName = ""
End Sub

Public Function LoadPictureFromDB(rs As ADODB.Recordset)
On Error GoTo procNoPicture

'If Recordset is Empty, Then Exit
If rs Is Nothing Then
  GoTo procNoPicture
End If

Set strstream = New ADODB.Stream
strstream.Type = adTypeBinary
strstream.Open

strstream.Write rs.Fields("FOTO").Value


strstream.SaveToFile App.Path & "\Temp.bmp", adSaveCreateOverWrite
Image1.Picture = LoadPicture(App.Path & "\Temp.bmp")
Kill (App.Path & "\Temp.bmp")
LoadPictureFromDB = True

procExitFunction:
Exit Function
procNoPicture:
LoadPictureFromDB = False
GoTo procExitFunction
End Function

Public Function SavePictureToDB(rs As ADODB.Recordset, _
sFileName As String)

On Error GoTo procNoPicture
Dim oPict As StdPicture

Set oPict = LoadPicture(sFileName)
Image1.Picture = LoadPicture(sFileName)

'Exit Function if this is NOT a picture file
If oPict Is Nothing Then
MsgBox "file gambar tidak Valid!", vbOKOnly, "Oops!"
SavePictureToDB = False
GoTo procExitSub
End If


procExitSub:
Exit Function
procNoPicture:
SavePictureToDB = False
GoTo procExitSub
End Function

Private Function SaveImage()
If Not CommonDialog1.FileName = "" Then
  Dim mStream As New ADODB.Stream
 
  strSQL = "update FBARANG set foto =null  Where Kode=" & cStrSQL(txtKode.Text)
  gConn.Execute strSQL, , adCmdText
 
  Set rs2 = Nothing
  Set rs2 = New ADODB.Recordset
  rs2.Open "Select * from FBARANG where Kode=" & cStrSQL(txtKode.Text), gConn, adOpenKeyset, adLockOptimistic
  With mStream
    .Type = adTypeBinary
    .Open
    .LoadFromFile CommonDialog1.FileName
    rs2("FOTO").Value = .Read
    rs2.Update
  End With
  Set mStream = Nothing
  Set rs2 = Nothing
 
End If
End Function

Mouse scroll di vsflexgrid & VB6

Bagi rekan-rekan yg sedang "SUSAH" menggunakan scroll mouse di vsflexgrid 7
ini ada trik untuk mengakalinya semoga bermanfaat ...

Tambahkan coding di bawah ini :

Option Explicit
' Store WndProcs
Private Declare Function GetProp Lib "user32.dll" Alias "GetPropA" ( _
                ByVal hWnd As Long, _
                ByVal lpString As String) As Long
Private Declare Function SetProp Lib "user32.dll" Alias "SetPropA" ( _
                ByVal hWnd As Long, _
                ByVal lpString As String, _
                ByVal hData As Long) As Long
Private Declare Function RemoveProp Lib "user32.dll" Alias "RemovePropA" ( _
                ByVal hWnd As Long, _
                ByVal lpString As String) As Long
' Hooking
Private Declare Function CallWindowProc Lib "user32.dll" Alias "CallWindowProcA" ( _
                ByVal lpPrevWndFunc As Long, _
                ByVal hWnd As Long, _
                ByVal Msg As Long, _
                ByVal wParam As Long, _
                ByVal lParam As Long) As Long
Private Declare Function SetWindowLong Lib "user32.dll" Alias "SetWindowLongA" ( _
                ByVal hWnd As Long, _
                ByVal nIndex As Long, _
                ByVal dwNewLong As Long) As Long
Private Declare Function SendMessage Lib "user32.dll" Alias "SendMessageA" ( _
                ByVal hWnd As Long, _
                ByVal Msg As Long, _
                wParam As Any, _
                lParam As Any) As Long
' Position Checking
Private Declare Function GetWindowRect Lib "user32" ( _
                ByVal hWnd As Long, _
                lpRect As RECT) As Long
               
Private Declare Function GetParent Lib "user32" ( _
                ByVal hWnd As Long) As Long
Private Declare Function GetIpAddrTable_API Lib "IpHlpApi" Alias "GetIpAddrTable" (pIPAddrTable As Any, pdwSize As Long, ByVal bOrder As Long) As Long
Private Const GWL_WNDPROC = -4
Private Const WM_MOUSEWHEEL = &H20A
Private Const CB_GETDROPPEDSTATE = &H157
Private Type RECT
  Left As Long
  Top As Long
  Right As Long
  Bottom As Long
End Type
' Check Messages
' ================================================
Private Function WindowProc(ByVal Lwnd As Long, ByVal Lmsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
  Dim MouseKeys As Long
  Dim Rotation As Long
  Dim Xpos As Long
  Dim Ypos As Long
  Dim fFrm As Form
  Select Case Lmsg
 
    Case WM_MOUSEWHEEL
   
      MouseKeys = wParam And 65535
      Rotation = wParam / 65536
      Xpos = lParam And 65535
      Ypos = lParam / 65536
     
      Set fFrm = GetForm(Lwnd)
      If fFrm Is Nothing Then
        ' it's not a form
        If Not IsOver(Lwnd, Xpos, Ypos) And IsOver(GetParent(Lwnd), Xpos, Ypos) Then
          ' it's not over the control and is over the form,
          ' so fire mousewheel on form (if it's not a dropped down combo)
          If SendMessage(Lwnd, CB_GETDROPPEDSTATE, 0&, 0&) <> 1 Then
            GetForm(GetParent(Lwnd)).MouseWheel MouseKeys, Rotation, Xpos, Ypos
            Exit Function ' Discard scroll message to control
          End If
        End If
      Else
        ' it's a form so fire mousewheel
        If IsOver(fFrm.hWnd, Xpos, Ypos) Then fFrm.MouseWheel MouseKeys, Rotation, Xpos, Ypos
      End If
  End Select
 
  WindowProc = CallWindowProc(GetProp(Lwnd, "PrevWndProc"), Lwnd, Lmsg, wParam, lParam)
End Function
' Hook / UnHook
' ================================================
Public Sub WheelHook(ByVal hWnd As Long)
  On Error Resume Next
  SetProp hWnd, "PrevWndProc", SetWindowLong(hWnd, GWL_WNDPROC, AddressOf WindowProc)
End Sub
Public Sub WheelUnHook(ByVal hWnd As Long)
  On Error Resume Next
  SetWindowLong hWnd, GWL_WNDPROC, GetProp(hWnd, "PrevWndProc")
  RemoveProp hWnd, "PrevWndProc"
End Sub
' Window Checks
' ================================================
Public Function IsOver(ByVal hWnd As Long, ByVal lX As Long, ByVal lY As Long) As Boolean
  Dim rectCtl As RECT
  GetWindowRect hWnd, rectCtl
  With rectCtl
    IsOver = (lX >= .Left And lX <= .Right And lY >= .Top And lY <= .Bottom)
  End With
End Function
Private Function GetForm(ByVal hWnd As Long) As Form
  For Each GetForm In Forms
    If GetForm.hWnd = hWnd Then Exit Function
  Next GetForm
  Set GetForm = Nothing
End Function
' Control Specific Behaviour
' ================================================
Public Sub FlexGridScroll(ByRef fg As VSFlexGrid, ByVal MouseKeys As Long, ByVal Rotation As Long, ByVal Xpos As Long, ByVal Ypos As Long)
  Dim NewValue As Long
  Dim Lstep As Single
  On Error Resume Next
  With fg
    Lstep = .Height / .RowHeight(0)
    Lstep = Int(Lstep)
    If .Rows < Lstep Then Exit Sub
    Do While Not (.RowIsVisible(.TopRow + Lstep))
      Lstep = Lstep - 1
    Loop
    If Rotation > 0 Then
        NewValue = .TopRow - Lstep
        If NewValue < 1 Then
            NewValue = 1
        End If
    Else
        NewValue = .TopRow + Lstep
        If NewValue > .Rows - 1 Then
            NewValue = .Rows - 1
        End If
    End If
    .TopRow = NewValue
  End With
End Sub
Public Sub PictureBoxZoom(ByRef picBox As PictureBox, ByVal MouseKeys As Long, ByVal Rotation As Long, ByVal Xpos As Long, ByVal Ypos As Long)
  picBox.Cls
  picBox.Print "MouseWheel " & IIf(Rotation < 0, "Down", "Up")
End Sub
********************************

di form yg terdapat vsflexgrid nya di tambah satu fungsi dengan coding :

Public Sub MouseWheel(ByVal MouseKeys As Long, ByVal Rotation As Long, ByVal Xpos As Long, ByVal Ypos As Long)
  Dim ctl As Control
  Dim bHandled As Boolean
  Dim bOver As Boolean
 
  For Each ctl In Controls
    ' Is the mouse over the control
    On Error Resume Next
    bOver = (ctl.Visible And IsOver(ctl.hWnd, Xpos, Ypos))
    On Error GoTo 0
   
    If bOver Then
      ' If so, respond accordingly
      bHandled = True
      Select Case True
     
        Case TypeOf ctl Is VSFlexGrid
          FlexGridScroll ctl, MouseKeys, Rotation, Xpos, Ypos
         
        Case Else
          bHandled = False
      End Select
      If bHandled Then Exit Sub
    End If
    bOver = False
  Next ctl
 
  ' Scroll was not handled by any controls, so treat as a general message send to the form
  'Me.Caption = "Form Scroll " & IIf(Rotation < 0, "Down", "Up")
End Sub
*****************************

 dan di prosedur Form Load di tambahkan

Call WheelHook(Me.hWnd)

Selamat mencoba, semoga bisa membantu menghilangkan SUSAH Anda ...

Hakikat Susah

Banyak orang di dunia ini jangankan untuk mengalaminya, menyebutnya saja sudah enggan...
padahal "susah" itu seperti jelangkung datang ga di undang pulang gak diantar ....

Disini saya coba berbagi tip & trik (bukan untuk mengusir "susah" tapi justru untuk menyatu dengan "susah" itu sendiri ( Pusing dah ..... )

Ada 2 hal yang penting untuk menyatu dengan kesusahan :
1. Jangan pernah berkeluh kesah, karena sekali anda berkeluh kesah berarti anda sudah gagal menjadi orang susah. (mau di cap gagal jadi orang susah?)
2. Cobalah buat tulisan di tempat-tempat yang selalu anda lihat, seperti di tembok kamar, buku diary atau wallpaper komputer anda, tulisan nya adalah

" SAYA SUSAH SAAT INI SAJA, TIDAK MAU SUSAH SELAMANYA"

Jika anda baca ini setiap saat, maka anda akan merasa susahnya saat ini saja, jadi jika anda diberi kesempatan hidup 50 tahun lagi di dunia ini, maka selama 50 tahun itu lah anda masih susah (hahahhahaha).
Tapi ada hikmah yang bisa kita ambil dari kebiasaan diatas. paling tidak anda memiliki harapan akan bisa hidup 50 tahun lagi kedepan.
Lain dengan orang yang tidak punya moto diatas, mereka enggan lagi untuk hidup karena mereka takut susah selamanya .....

Semoga bermanfaat

Hidup Anda Susah....? ( sama dong ama ane ...)
Mau berubah ....? ( mari kita cari solusi sama-sama )