Forum
Selamlar,
SQL'deki bir resim alanını, Excel hücresinde göstermek için nasıl bir makro yazmalıyım ?
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