Notes

Private Declare Function GetPixel Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long) As Long
Private Declare Function CreateCompatibleDC Lib "gdi32" _
(ByVal hdc As Long) As Long
Private Declare Function DeleteDC Lib "gdi32" _
(ByVal hdc As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" _
(ByVal hObject As Long) As Long
Private Declare Function SelectObject Lib "gdi32" _
(ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare Function StretchBlt Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal nSrcWidth As Long, ByVal nSrcHeight As Long, ByVal dwRop As Long) As Long

Sub Button1_Click()
Dim rWidth As Long, rHeight As Long
rWidth = Int(Range("E3").Value)
rHeight = Int(Range("E4").Value)

Dim filename As String
filename = Range("B2").Value

Dim wStep As Integer, hStep As Integer
wStep = Int(Range("B3").Value / rWidth)
hStep = Int(Range("B4").Value / rHeight)

Dim iSize As Integer
iSize = CDbl(Range("B6").Value)

Sheets("Sheet2").Select

Dim i As Integer
For i = 1 To rWidth
ActiveSheet.Columns(i).ColumnWidth = iSize
Next i

For i = 1 To rHeight
ActiveSheet.Rows(i).RowHeight = iSize * 10
Next i

Dim hNewDC As Long
Dim hOldPic As Long

Dim pic As StdPicture
Set pic = LoadPicture(filename)
hNewDC = CreateCompatibleDC(0)
SelectObject hNewDC, pic.Handle
'hOldPic =
'Dim stretchDC As Long
'stretchDC = CreateCompatibleDC(hNewDC)
''pic.Render hNewDC, 0, 0, rWidth, rHeight, 0, 0, pic.Width, pic.Height, ByVal 0&
'StretchBlt stretchDC, 0, 0, rWidth, rHeight, hNewDC, 0, 0, picWidth, picHeight, vbSrcCopy

Application.ScreenUpdating = False
Dim a As Integer, b As Integer
For a = 0 To rWidth - 1
For b = 0 To rHeight - 1
Dim pixelColor As Long
pixelColor = GetPixel(hNewDC, a * wStep, b * hStep)

If pixelColor <> -1 Then
Dim red As Long
Dim blu As Long
Dim gre As Long


red = pixelColor Mod 256
gre = ((pixelColor& And &HFF00FF00) / 256&)
blu = (pixelColor& And &HFF0000) / 65536

ActiveSheet.Cells(b + 1, a + 1).Interior.Color = RGB(red, gre, blu)
End If
Next b
Next a
Application.ScreenUpdating = True

Call DeleteObject(SelectObject(hdc, hOldPic))
Call DeleteDC(hNewDC)
Call DeleteDC(hdc)
Call DeleteDC(stretchDC)
End Sub