Excel'de, SQL image field göstermek

Belirtilen işlemi gerçekleştirdiniz mi?

Maalesef olmadı...

Merhaba,

Resim alanı ile ifade ettiğin, resmin pathinin saklandığı alan mı, yoksa type ı image olan bir alan mıdır ?

ilki zaten kolay ve nette yüzlerce örnek var, ikinci zor gibi;
sorunu ikincisi kabul edersek:

Bildiğim kadarıyla fieldı direk olarak kullanman imkansız.

Image type kolonda, data, binary olarak saklanıyor.

Bu binary datayı resim olarak temp dizine kaydedip
(aşağıya ekleyeceğim 2.örnekdeki, blobtofile fonksiyonu bu işi yapıyor),
kayıt yerinden okuyarak sayfa üzerinde istediğin hücreye resim objesi olarak ekleyebilirsin..

1- Bu örnek, "dosya halindeki" bir resmi istediğin hücreye denk gelen konuma
resim objesi olarak ekleme örneğidir.
--------------------------------------------------------------------------------

Sub TestResimekle()
    Resimekle "C:\test.jpg", _
        Range("D10"), True, True
End Sub

Sub Resimekle(PictureFileName As String, TargetCell As Range, _
    CenterH As Boolean, CenterV As Boolean)
' inserts a picture at the top left position of TargetCell
' the picture can be centered horizontally and/or vertically
Dim p As Object, t As Double, l As Double, w As Double, h As Double
    If TypeName(ActiveSheet) <> "Worksheet" Then Exit Sub
    If Dir(PictureFileName) = "" Then Exit Sub
    ' import picture
    Set p = ActiveSheet.Pictures.Insert(PictureFileName)
    ' determine positions
    With TargetCell
        t = .Top
        l = .Left
        If CenterH Then
            w = .Offset(0, 1).Left - .Left
            l = l + w / 2 - p.Width / 2
            If l < 1 Then l = 1
        End If
        If CenterV Then
            h = .Offset(1, 0).Top - .Top
            t = t + h / 2 - p.Height / 2
            If t < 1 Then t = 1
        End If
    End With
    ' position picture
    With p
        .Top = t
        .Left = l
    End With
    Set p = Nothing
End Sub

--------------------------------------------------------------------------------

2-Bu örnek ise biraz karışık gelebilir ama içinden ihtiyaç
duyacağın fonksiyonları çekip kullanabilirsin.
db olarak Access kullanılmış burada ama mssql içinde geçerli bu yöntem.
Buradan "blobtofile" fonksiyonunu alıp ilk örneğimizle sonuca varabilirsin.
--------------------------------------------------------------------------------

Option Explicit
Private Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function GetClipboardData Lib "user32" (ByVal wFormat As Integer) As Long
Private Declare Function CloseClipboard Lib "user32" () As Long
Private Declare Function CopyImage Lib "user32" (ByVal hImage As Long, ByVal uType As Long, ByVal PixelWidth As Long, ByVal PixelHeight As Long, ByVal Flags As Long) As Long
Private Declare Function OleCreatePictureIndirect Lib "olepro32.dll" (pPictDesc As PictDesc, riid As Guid, ByVal fOwn As Long, ppvObj As IPicture) As Long
 
Type Guid
    Data1 As Long
    Data2 As Integer
    Data3 As Integer
    Data4(0 To 7) As Byte
End Type
       
Type PictDesc
    cbSizeofStruct As Long
    picType As Long
    hImage As Long
    xExt As Long
    yExt As Long
End Type
 
Private Const BLOCK_SIZE = 16384
Private Const CF_BITMAP = 2
Private Const S_OK As Long = &H0
Private Const LR_COPYRETURNORG = &H4
 
Function IPictureFromCopyPicture(Source As Object, Optional StretchWidth As Single, Optional StretchHeight As Single) As IPictureDisp
    Dim hBmp As Long
    Dim PictDesc As PictDesc
    Dim IDispatch As Guid
    Dim SaveWidth As Single
    Dim SaveHeight As Single
    Dim PicIsRng As Boolean
      
    If StretchWidth <> 0 Or StretchHeight <> 0 Then
        If TypeOf Source Is Range Then
            Source.CopyPicture
            ActiveSheet.PasteSpecial "Picture (Enhanced Metafile)"
            Set Source = Selection
            PicIsRng = True
        End If
       
        SaveWidth = Source.Width
        SaveHeight = Source.Height
        Source.Width = IIf(StretchWidth = 0, Source.Width, StretchWidth)
        Source.Height = IIf(StretchHeight = 0, Source.Height, StretchHeight)
        Source.CopyPicture xlScreen, xlBitmap
       
        If PicIsRng Then
            Source.Delete
        Else
            Source.Width = SaveWidth
            Source.Height = SaveHeight
        End If
    Else
        Source.CopyPicture xlScreen, xlBitmap
    End If
 
    If OpenClipboard(0) <> 0 Then
        hBmp = GetClipboardData(CF_BITMAP)
        hBmp = CopyImage(hBmp, 0, 0, 0, LR_COPYRETURNORG)
        CloseClipboard
        If hBmp <> 0 Then
                 
            With IDispatch
               .Data1 = &H20400
               .Data4(0) = &HC0
               .Data4(7) = &H46
            End With
           
            With PictDesc
               .cbSizeofStruct = Len(PictDesc)
               .picType = 1
               .hImage = hBmp
            End With
           
            If OleCreatePictureIndirect(PictDesc, IDispatch, False, IPictureFromCopyPicture) <> S_OK Then
                Set IPictureFromCopyPicture = Nothing
            End If
        End If
    End If
End Function
 
Function SaveObjectPictureToFile(ByVal Source As Object, FileName As String, Optional StretchWidth As Single, Optional StretchHeight As Single) As Boolean
    Dim Ipic As IPictureDisp
   
    Set Ipic = IPictureFromCopyPicture(Source, StretchWidth, StretchHeight)
    If Not Ipic Is Nothing Then
        SavePicture Ipic, FileName
        SaveObjectPictureToFile = True
    End If
End Function
 
 
      Sub BlobToFile(fld As ADODB.Field, ByVal FName As String, _
                     Optional FieldSize As Long = -1, _
                     Optional Threshold As Long = 1048576)
      Dim F As Long, bData() As Byte, sData As String
        F = FreeFile
        Open FName For Binary As #F
        Select Case fld.Type
          Case adLongVarBinary
            If FieldSize = -1 Then   ' blob field is of unknown size
              WriteFromUnsizedBinary F, fld
            Else                     ' blob field is of known size
              If FieldSize > Threshold Then   ' very large actual data
                WriteFromBinary F, fld, FieldSize
              Else                            ' smallish actual data
                bData = fld.Value
                Put #F, , bData  ' PUT tacks on overhead if use fld.Value
              End If
            End If
          Case adLongVarChar, adLongVarWChar
            If FieldSize = -1 Then
              WriteFromUnsizedText F, fld
            Else
              If FieldSize > Threshold Then
                WriteFromText F, fld, FieldSize
              Else
                sData = fld.Value
                Put #F, , sData  ' PUT tacks on overhead if use fld.Value
              End If
            End If
        End Select
        Close #F
      End Sub
 
      Sub WriteFromBinary(ByVal F As Long, fld As ADODB.Field, _
                          ByVal FieldSize As Long)
      Dim data() As Byte, BytesRead As Long
        Do While FieldSize <> BytesRead
          If FieldSize - BytesRead < BLOCK_SIZE Then
            data = fld.GetChunk(FieldSize - BLOCK_SIZE)
            BytesRead = FieldSize
          Else
            data = fld.GetChunk(BLOCK_SIZE)
            BytesRead = BytesRead + BLOCK_SIZE
          End If
          Put #F, , data
        Loop
      End Sub
 
      Sub WriteFromUnsizedBinary(ByVal F As Long, fld As ADODB.Field)
      Dim data() As Byte, Temp As Variant
        Do
          Temp = fld.GetChunk(BLOCK_SIZE)
          If IsNull(Temp) Then Exit Do
          data = Temp
          Put #F, , data
        Loop While LenB(Temp) = BLOCK_SIZE
      End Sub
 
      Sub WriteFromText(ByVal F As Long, fld As ADODB.Field, _
                        ByVal FieldSize As Long)
      Dim data As String, CharsRead As Long
        Do While FieldSize <> CharsRead
          If FieldSize - CharsRead < BLOCK_SIZE Then
            data = fld.GetChunk(FieldSize - BLOCK_SIZE)
            CharsRead = FieldSize
          Else
            data = fld.GetChunk(BLOCK_SIZE)
            CharsRead = CharsRead + BLOCK_SIZE
          End If
          Put #F, , data
        Loop
      End Sub
 
      Sub WriteFromUnsizedText(ByVal F As Long, fld As ADODB.Field)
      Dim data As String, Temp As Variant
        Do
          Temp = fld.GetChunk(BLOCK_SIZE)
          If IsNull(Temp) Then Exit Do
          data = Temp
          Put #F, , data
        Loop While Len(Temp) = BLOCK_SIZE
      End Sub
 
      Sub FileToBlob(ByVal FName As String, fld As ADODB.Field, _
                     Optional Threshold As Long = 1048576)
      '
      ' Assumes file exists
      ' Assumes calling routine does the UPDATE
      ' File cannot exceed approx. 2Gb in size
      '
      Dim F As Long, data() As Byte, FileSize As Long
        F = FreeFile
        Open FName For Binary As #F
        FileSize = LOF(F)
        Select Case fld.Type
          Case adLongVarBinary
            If FileSize > Threshold Then
              ReadToBinary F, fld, FileSize
            Else
              data = InputB(FileSize, F)
              fld.Value = data
            End If
          Case adLongVarChar, adLongVarWChar
            If FileSize > Threshold Then
              ReadToText F, fld, FileSize
            Else
              fld.Value = Input(FileSize, F)
            End If
        End Select
        Close #F
      End Sub
 
      Sub ReadToBinary(ByVal F As Long, fld As ADODB.Field, _
                       ByVal FileSize As Long)
      Dim data() As Byte, BytesRead As Long
        Do While FileSize <> BytesRead
          If FileSize - BytesRead < BLOCK_SIZE Then
            data = InputB(FileSize - BytesRead, F)
            BytesRead = FileSize
          Else
            data = InputB(BLOCK_SIZE, F)
            BytesRead = BytesRead + BLOCK_SIZE
          End If
          fld.AppendChunk data
        Loop
      End Sub
 
      Sub ReadToText(ByVal F As Long, fld As ADODB.Field, _
                     ByVal FileSize As Long)
      Dim data As String, CharsRead As Long
        Do While FileSize <> CharsRead
          If FileSize - CharsRead < BLOCK_SIZE Then
            data = Input(FileSize - CharsRead, F)
            CharsRead = FileSize
          Else
            data = Input(BLOCK_SIZE, F)
            CharsRead = CharsRead + BLOCK_SIZE
          End If
          fld.AppendChunk data
        Loop
      End Sub
 

Option Compare Database
 
 
Dim xl As Excel.Application
Dim xlsht As Excel.Worksheet
Dim xlWrkBk As Excel.Workbook
Dim myrec As DAO.Recordset
Dim sho As Shape
Set myrec = CurrentDb.OpenRecordset("reportfc")
Set xl = CreateObject("Excel.Application")
Set xlWrkBk = GetObject("C:/Data_Local_old/book1.xls")
Set xlsht = xlWrkBk.Worksheets(5)
Dim idrfc As Integer, idr As Integer, ido As Integer, idv As Integer
dim i As Integer
Dim r As Long
Dim lastrow As Long, startrow As Long
idrfc = 1
idr = 1
ido = 1
idv = 0
i = 0
startrow = 1
' count the total number of rows in the excel sheet.
With xlsht.UsedRange
 lastrow = .Rows.Count + .Row - 1
 End With
'start reading the sheet, from the first record and up to the last one
For r = startrow To lastrow
If r > 1 Then
myrec.AddNew
myrec.Fields("idrfc") = idrfc
idrfc = idrfc + 1
myrec.Fields("idr") = idr
myrec.Fields("ido") = ido
myrec.Fields("idv") = idv
myrec.Fields("nume") = xlsht.Cells(r, "A")
myrec.Fields("numeteh") = xlsht.Cells(r, "B")
myrec.Fields("flag_activ") = 1
myrec.Fields("data") = "10.02.2009"
' the field IMGR will keep track of the number of the excel row.
myrec.Fields("imgr") = r
myrec.Fields("imge") = 0
' I use the integer field IMGRH to remember the height of each cell
myrec.Fields("imgrh") = xlsht.Cells(r, "A").Height
myrec.Fields("imgh") = 0
myrec.Fields("imgw") = 0
myrec.Fields("nota") = "no comment!"
myrec.Update
End If
Next r
myrec.Close
' now that we loaded the data into Access, but we STILL do not have
' any pictures in our OLE OBJECT field FILE, we will read each shape
' in the sheet and we will insert the shape into the database where
'
Dim sqlcon As String
Dim con As ADODB.Connection
Dim rs As ADODB.Recordset
Dim crow As Integer
Set con = New ADODB.Connection
Set rs = New ADODB.Recordset
On Error GoTo Except
   Set con = New ADODB.Connection
    con.Provider = "Microsoft.Jet.OLEDB.4.0"
    con.ConnectionString = "data source=C:\Documents and Settings\x01020750\My Documents\SAPBW1.mdb"
    con.Mode = adModeReadWrite
    con.Open
    MsgBox "Connected via " & con.Provider & " OLE DB Provider!", vbInformation
Except:
    MsgBox Err.Description, vbCritical
For Each sho In xlsht.Shapes
 
'because we have stored the number of the EXCEL row in the access table
'on our first run, now we know which row of the table needs to
' be update. So we will get the SHAPE row and launch a SELECT query to
' determine the correspondent row in the ACCESS database.
 
 crow = sho.TopLeftCell.Row
 sqlcon = "SELECT * FROM reportfc WHERE imgr=" & crow
 rs.Open sqlcon, con, adOpenKeyset, adLockOptimistic
 rs.Update
 If Not SaveObjectPictureToFile(sho, "C:\Data_Local\" + sho.Name + ".bmp") Then
        MsgBox "Picture was not saved!"
 End If
 FileToBlob "C:\Data_Local\" + sho.Name + ".bmp", rs!file, 16384
' we need rs!image to keep track of access table rows that have a
' value in the OLE OBJECT column. Otherwise we will get some weird
' errors if we do something like IF ISNULL(rs!file) then ... when
' we try to export the data back to excel and we obviously need to
' know if we have (or not) a picture in the table row.
 rs!imge = 1
' we keep track of shape Height and Width (with export in mind)
 rs!imgh = sho.Height
 rs!imgw = sho.Width
 rs.Update
 rs.Close
Next sho
con.Close
MsgBox ("The import of data from EXCEL has been completed!")
end sub
 
 
Private Sub cmdexport_Click()
Dim xl As Excel.Application
Dim xlsht As Excel.Worksheet
Dim xlWrkBk As Excel.Workbook
Set xlWrkBk = Workbooks.Add
xlWrkBk.Worksheets.Add
xlWrkBk.Worksheets.Add
xlWrkBk.Worksheets(1).Name = "GENERAL"
xlWrkBk.Worksheets(2).Name = "ROWS"
xlWrkBk.Worksheets(3).Name = "COLUMNS"
xlWrkBk.Worksheets(4).Name = "FILTER"
xlWrkBk.Worksheets(5).Name = "FREE"
' apply some formatting for xls sheet - Model
Set xlsht = xlWrkBk.Worksheets(5)
xlsht.Cells(1, "A") = "NAME"
xlsht.Cells(1, "A").Font.Bold = True
xlsht.Cells(1, "A").Font.size = 14
xlsht.Cells(1, "A").HorizontalAlignment = xlCenter
xlsht.Cells(1, "B") = "TECHNICAL"
xlsht.Cells(1, "B").Font.Bold = True
xlsht.Cells(1, "B").Font.size = 14
xlsht.Cells(1, "B").HorizontalAlignment = xlCenter
xlsht.Cells(1, "C") = "IMAGE"
xlsht.Cells(1, "C").Font.Bold = True
xlsht.Cells(1, "C").Font.size = 14
xlsht.Cells(1, "C").HorizontalAlignment = xlCenter
xlsht.Columns(1).ColumnWidth = 40
xlsht.Columns(2).ColumnWidth = 55
xlsht.Columns(3).ColumnWidth = 70
xlsht.Rows(1).RowHeight = 22
 
' Now I will read from the table REPORTFC and export to ONE excel sheet
 
Dim sqlcon As String
Dim con As ADODB.Connection
Dim rs As ADODB.Recordset
Dim shp As Shape
Set con = New ADODB.Connection
Set rs = New ADODB.Recordset
Dim col As Integer, size As Integer, size2 As Integer, zece As Integer
Dim shpnr As Integer
Set con = New ADODB.Connection
con.Provider = "Microsoft.Jet.OLEDB.4.0"
con.ConnectionString = "data source=C:\Documents and Settings\x01020750\My Documents\SAPBW1.mdb"
con.Mode = adModeReadWrite
con.Open
sqlcon = "SELECT * FROM reportfc where idr=1"
rs.Open sqlcon, con, adOpenStatic, adLockReadOnly
shpnr = 0
zece = 0
size = xlsht.Cells(1, "A").Height + 1
rs.MoveFirst
Do While Not rs.EOF
col = rs!imgr
xlsht.Cells(col, "A") = rs!nume
xlsht.Cells(col, "B") = rs!numeteh
xlsht.Rows(col).RowHeight = rs!imgrh
If rs!imge = 1 Then
If shpnr = 0 Then
size2 = xlsht.Cells(1, "C").Width / 0.75 + 12
End If
' export the picture using the function BlobToFile to a temporary
' HDD location. Then I use XLSHT.SHAPES.ADDPICTURE to load the
' picture into the excel sheet. Variable Size will keep track of the
' height for each cell so that the excel file will have the same
' formatting (looks) as the original one.
BlobToFile rs!file, "C:\Data_Local\picexport.bmp"
MsgBox "Size:" & (size)
xlsht.Shapes.AddPicture "C:\Data_Local\picexport.bmp", True, True, Left:=size2, Top:=size, Width:=rs!imgw, Height:=rs!imgh
shpnr = shpnr + 1
End If
size = size + rs!imgrh
rs.MoveNext
Loop
rs.Close
con.Close
' end of export sequence
xlWrkBk.SaveAs FileName:="C:/Data_Local/test.xls"
xlWrkBk.Close
MsgBox "Export was successfull!"
End Sub