Help needed with pictures.

K

karenros

New Member
Joined
Nov 21, 2008
Messages
32
Hi,
I have a excel spreadsheet that i want to import to Sql server. At present we only have text so the import was easy. But now we want to a logo to each row in the excel spread sheet. The schema of my excel spread sheet is as follows:

PlanId PhoneInfo ContInfo MessageBoard Logo(file name and Path)
01212 123-456-4512 Abc somemessage Picture
01245 PhoneNo. bca message picture


So when i add a picture into excel it doesnt insert that picture on the cell that i want to have it on .. What happens if i have a picture at the next row.

I have written the following macro that will place the picture in the active cell and this my code for it..

Code: 
Dim Pict
Dim ImgFileFormat As String
Dim PictCell As Range
Dim Ans As Integer
'ActiveSheet.Protect True, True, True, True, True
ImgFileFormat = "Image Files (*.jpg),others, tif (*.tif),*.tif, jpg (*.jpg),*.jpg"
GetPict:
Pict = Application.GetOpenFilename(ImgFileFormat)
'Note you can load in any nearly file format
If Pict = False Then End
'Ans = MsgBox("Open : " & Pict, vbYesNo, "Insert Picture")
'If Ans = vbNo Then GoTo GetPict
'Now paste to userselected cell
GetCell:
Set PictCell = Application.ActiveCell  'Application.InputBox("Select the cell to insert into", Type:=8)
If PictCell.Count > 1 Then MsgBox "Select ONE cell only": GoTo GetCell
PictCell.Select
ActiveSheet.Pictures.Insert(Pict).Select
ActiveWindow.ScrollColumn = 2
   ActiveWindow.ScrollColumn = 3
   Selection.ShapeRange.ScaleWidth 0.4, msoFalse, msoScaleFromTopLeft
  Selection.ShapeRange.ScaleHeight 0.4, msoFalse, msoScaleFromTopLeft
and this one to activate the macro when the User clicks on G2
Code: 
Private Sub Worksheet_SelectionChange(ByVal Target As Excel.Range)
    If Target.Address = "$G$2" Then
        'do stuff
        Call Macro1
    End If
End Sub


So my first question is Can i resize the picture to fit the Cell size?
and Is there a way I can specify Target.Address = "$G$*"

Like i want the macro to run when the G cell is been clicked. and last.. How to get the pictures to be exported out of excel..

Any help will be appreciated.

Thanks a lot,
Karen
 

Excel Facts

Is there a shortcut key for strikethrough?
Ctrl+S is used for Save. Ctrl+5 is used for Strikethrough. Why Ctrl+5? When you use hashmarks to count |||| is 4, strike through to mean 5.
Sort by date Sort by votes
Here is some basic code to insert & resize a picture to fit a cell.
It works from doubleclick in a cell.
Your code runs when the selection is moved from one cell to another.
Code: 
'=============================================================================
'- INSERT PICTURE INTO A CELL. RESIZE PICTURE TO FIT CELL
'- Double click cell
'- Goes into Worksheet code module. (Right click tab/View code)
'=============================================================================
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
    With ActiveCell         ' or .. With Target/With Range("G2")/ etc.
     '--------------------------------------------------------------------
     '- INSERT PICTURE FROM FILE
        ActiveSheet.Pictures.Insert("F:\My Pictures\test.bmp").Select
        '--------------------------------------------------------------------
        '- POSITION PICTURE
        Selection.Name = "MyPicture" & Cstr(Pictures.Count+1)
        Selection.Top = .Top
        Selection.Left = .Left
        Selection.Height = .Height
        Selection.Width = .Width
    End With
End Sub
'=============================================================================
I have put code to export pictures from worksheet to .bmp files in the following message.
 
Upvote 0
Rich (BB code): 
'=============================================================================
'- COPY PICTURES FROM A WORKSHEET TO .BMP FILES
'- VERSION 2 : uses code to save file instead of SendKeys/MS Paint
'---------------------------------------------------------------------
'- Thanks to the code attributed to JAAFAR of MrExcel forum (with no messages present now)
'- Ref : http://www.ozgrid.com/forum/showthread.php?t=45682
'---------------------------------------------------------------------
'- Picks up Embedded objects (OLEObjects) and Pictures (Picture objects)
'=============================================================================
'- *** AMEND THESE CONST VALUES AND RUN THE MACRO FROM THE SHEET
Const BitmapFileName As String = "XLpicture" 'file name without "_00x.bmp"
Const MyPictureFolder As String = "F:\TEMP\" ' target folder for files
'-------------------------------------------------------------------------
'- 1. Copies all pictures from sheet.
'- 2. Gets next file name in the series (filenames format like "xxx_001.bmp")
'- 3. Saves file in target folder.
'- Brian Baulsom November 2008
'=============================================================================
'- VERSION 1 : Userform Screen copy July 2008 using SendKeys/MS Paint
'- http://www.mrexcel.com/forum/showthread.php?t=331211
'=============================================================================
'- DECLARATIONS & VARIABLES TO SAVE PICTURE FILE FROM CLIPBOARD
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 OleCreatePictureIndirect Lib "olepro32.dll" _
    (PicDesc As uPicDesc, RefIID As GUID, ByVal fPictureOwnsHandle As Long, IPic As IPicture) As Long
'------------------------------------------------------------------------------
'- IPicture OLE Interface
Private Type GUID
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(0 To 7) As Byte
End Type
'-store the bitmap information
Private Type uPicDesc
Size As Long
Type As Long
    hPic As Long
    hPal As Long
End Type
'-------------------------------------------------------------------------------
Const CF_BITMAP = 2
Const CF_PALETTE = 9
Const IMAGE_BITMAP = 0
Const LR_COPYRETURNORG = &H4
Const PICTYPE_BITMAP = 1
Dim IID_IDispatch As GUID
Dim uPicinfo As uPicDesc
Dim IPic As IPicture
Dim hPtr As Long
'=============================================================================
'- WORKSHEET/PICTURE VARIABLES
Dim MyShapeRange As ShapeRange
Dim MyPicture As Object        ' PICTURES IN SHEET
Dim PictureCount As Integer
'-----------------------------------------------------------------------------
'- BITMAP FILE : FULL PATH & FILE NAME
Dim FullFileName As String '= MyPictureFolder & BitmapFileName & "_00x.bmp"
'-----------------------------------------------------------------------------
'- GET NEXT FILE NAME (Uses FileSystemObject)
Dim FSO As Object
Dim FileNumber As Integer
Dim LastFileNumber As Integer
'-- end of declarations ------------------------------------------------------
 
'*****************************************************************************
'- MAIN ROUTINE - LOOP PICTURES IN ACTIVE SHEET
'- Picks up Embedded objects (OLEObjects) and Pictures (Picture objects)
'*****************************************************************************
Sub PICTURES_TO_FILES()
    Application.Calculation = xlCalculationManual
    ActiveSheet.Range("A1").Select  ' focus from button or picture to sheet
    LastFileNumber = 0              ' counter
    Set FSO = CreateObject("Scripting.FileSystemObject") ' FOR NEXTFILENAME
    '------------------------------------------------------------------------
    '- LOOP ALL PICTURES IN THE WORKSHEET
    Set MyShapeRange = ActiveSheet.Pictures.ShapeRange
    For Each MyPicture In MyShapeRange
        PictureCount = PictureCount + 1
        '- COPY PICTURE
        MyPicture.CopyPicture Appearance:=xlScreen, Format:=xlBitmap       ' MyPicture.Copy
        '--------------------------------------------------------------------
        '- NEXT FILE NAME IN THE SERIES
        GET_NEXT_FILENAME       ' SUBROUTINE
        '--------------------------------------------------------------------
        '- SAVE PICTURE FROM CLIPBOARD
        SAVE_PICTURE            ' SUBROUTINE
    Next
    '------------------------------------------------------------------------
    '- FINISH
    MsgBox ("Saved " & PictureCount & " file(s)." & vbCr _
            & "To Folder : " & MyPictureFolder & vbCr _
            & "Last file name : " & BitmapFileName & Format(LastFileNumber, "000"))
    Application.Calculation = xlCalculationAutomatic
End Sub
'- END OF MAIN ROUTINE =======================================================
'=============================================================================
'- SUBROUTINE : SAVE PICTURE FROM CLIPBOARD AS A BITMAP FILE (JAAFAR'S CODE)
'- Called from main routine
'=============================================================================
Private Sub SAVE_PICTURE()
    '-----------------------------------------------------------------
    OpenClipboard 0
    hPtr = GetClipboardData(CF_BITMAP)
    CloseClipboard
    '-------------------------------------------------------------------------
     'Create the interface GUID for the picture
    With IID_IDispatch
        .Data1 = &H7BF80980
        .Data2 = &HBF32
        .Data3 = &H101A
        .Data4(0) = &H8B
        .Data4(1) = &HBB
        .Data4(2) = &H0
        .Data4(3) = &HAA
        .Data4(4) = &H0
        .Data4(5) = &H30
        .Data4(6) = &HC
        .Data4(7) = &HAB
    End With
    '------------------------------------------------------------------------
     '  Fill uPicInfo with necessary parts.
    With uPicinfo
        .Size = Len(uPicinfo) ' Length of structure.
        .Type = PICTYPE_BITMAP ' Type of Picture
        .hPic = hPtr ' Handle to image.
        .hPal = 0 ' Handle to palette (if bitmap).
    End With
    '------------------------------------------------------------------------
     'Create the Picture Object
    OleCreatePictureIndirect uPicinfo, IID_IDispatch, True, IPic
    '------------------------------------------------------------------------
     'Save Picture
    stdole.SavePicture IPic, FullFileName
    '------------------------------------------------------------------------
     'fix the clipboard (it seems to go messed up)
    Selection.CopyPicture Appearance:=xlScreen, Format:=xlBitmap
    '------------------------------------------------------------------------
End Sub
'======== EOP ===============================================================
'=============================================================================
'- SUBROUTINE : GET NEXT FILE NAME -> BitMapFileName + "_00x"
'- Called from Sub SAVE_PICTURE()
'=============================================================================
Private Sub GET_NEXT_FILENAME()
    Dim f, f1, fc
    Dim Fname As String
    Dim F3 As String    ' number
    Dim Flen As Integer ' length
    '-------------------------------------------------------------------------
    ' Set FSO = CreateObject("Scripting.FileSystemObject")' MOVED TO BEGINNING
    Set f = FSO.GetFolder(MyPictureFolder)
    Set fc = f.Files
    '- length of file name = name + number + suffix
    Flen = Len(BitmapFileName) + 4 + 4
    '-------------------------------------------------------------------------
    '- LOOP FILES IN FOLDER
    For Each f1 In fc
        Fname = f1.Name
        '---------------------------------------------------------------------
        '- check valid file and number
        F3 = Mid(Fname, Len(Fname) - 6, 3) ' number string
        If InStr(1, Fname, BitmapFileName, vbTextCompare) <> 0 _
            And IsNumeric(F3) And Len(Fname) = Flen Then
            FileNumber = CInt(F3)
            If FileNumber > LastFileNumber Then
                LastFileNumber = FileNumber
            End If
        End If
        '---------------------------------------------------------------------
    Next
    LastFileNumber = LastFileNumber + 1
    '-------------------------------------------------------------------------
    '- Next file name in series
    FullFileName = MyPictureFolder _
        & BitmapFileName & "_" & Format(LastFileNumber, "000") & ".bmp"
End Sub
'======== EOP ================================================================
 
Upvote 0
Thanks Brian for your help. will try your piece of code when i get back to work on monday.

thanks,
Karen
 
Upvote 0
BrianB said:
Rich (BB code): 
'=============================================================================
'- COPY PICTURES FROM A WORKSHEET TO .BMP FILES
'- VERSION 2 : uses code to save file instead of SendKeys/MS Paint
'---------------------------------------------------------------------
'- Thanks to the code attributed to JAAFAR of MrExcel forum (with no messages present now)
'- Ref : http://www.ozgrid.com/forum/showthread.php?t=45682
'---------------------------------------------------------------------
'- Picks up Embedded objects (OLEObjects) and Pictures (Picture objects)
'=============================================================================
'- *** AMEND THESE CONST VALUES AND RUN THE MACRO FROM THE SHEET
Const BitmapFileName As String = "XLpicture" 'file name without "_00x.bmp"
Const MyPictureFolder As String = "F:\TEMP\" ' target folder for files
'-------------------------------------------------------------------------
'- 1. Copies all pictures from sheet.
'- 2. Gets next file name in the series (filenames format like "xxx_001.bmp")
'- 3. Saves file in target folder.
'- Brian Baulsom November 2008
'=============================================================================
'- VERSION 1 : Userform Screen copy July 2008 using SendKeys/MS Paint
'- http://www.mrexcel.com/forum/showthread.php?t=331211
'=============================================================================
'- DECLARATIONS & VARIABLES TO SAVE PICTURE FILE FROM CLIPBOARD
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 OleCreatePictureIndirect Lib "olepro32.dll" _
    (PicDesc As uPicDesc, RefIID As GUID, ByVal fPictureOwnsHandle As Long, IPic As IPicture) As Long
'------------------------------------------------------------------------------
'- IPicture OLE Interface
Private Type GUID
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(0 To 7) As Byte
End Type
'-store the bitmap information
Private Type uPicDesc
Size As Long
Type As Long
    hPic As Long
    hPal As Long
End Type
'-------------------------------------------------------------------------------
Const CF_BITMAP = 2
Const CF_PALETTE = 9
Const IMAGE_BITMAP = 0
Const LR_COPYRETURNORG = &H4
Const PICTYPE_BITMAP = 1
Dim IID_IDispatch As GUID
Dim uPicinfo As uPicDesc
Dim IPic As IPicture
Dim hPtr As Long
'=============================================================================
'- WORKSHEET/PICTURE VARIABLES
Dim MyShapeRange As ShapeRange
Dim MyPicture As Object        ' PICTURES IN SHEET
Dim PictureCount As Integer
'-----------------------------------------------------------------------------
'- BITMAP FILE : FULL PATH & FILE NAME
Dim FullFileName As String '= MyPictureFolder & BitmapFileName & "_00x.bmp"
'-----------------------------------------------------------------------------
'- GET NEXT FILE NAME (Uses FileSystemObject)
Dim FSO As Object
Dim FileNumber As Integer
Dim LastFileNumber As Integer
'-- end of declarations ------------------------------------------------------
 
'*****************************************************************************
'- MAIN ROUTINE - LOOP PICTURES IN ACTIVE SHEET
'- Picks up Embedded objects (OLEObjects) and Pictures (Picture objects)
'*****************************************************************************
Sub PICTURES_TO_FILES()
    Application.Calculation = xlCalculationManual
    ActiveSheet.Range("A1").Select  ' focus from button or picture to sheet
    LastFileNumber = 0              ' counter
    Set FSO = CreateObject("Scripting.FileSystemObject") ' FOR NEXTFILENAME
    '------------------------------------------------------------------------
    '- LOOP ALL PICTURES IN THE WORKSHEET
    Set MyShapeRange = ActiveSheet.Pictures.ShapeRange
    For Each MyPicture In MyShapeRange
        PictureCount = PictureCount + 1
        '- COPY PICTURE
        MyPicture.CopyPicture Appearance:=xlScreen, Format:=xlBitmap       ' MyPicture.Copy
        '--------------------------------------------------------------------
        '- NEXT FILE NAME IN THE SERIES
        GET_NEXT_FILENAME       ' SUBROUTINE
        '--------------------------------------------------------------------
        '- SAVE PICTURE FROM CLIPBOARD
        SAVE_PICTURE            ' SUBROUTINE
    Next
    '------------------------------------------------------------------------
    '- FINISH
    MsgBox ("Saved " & PictureCount & " file(s)." & vbCr _
            & "To Folder : " & MyPictureFolder & vbCr _
            & "Last file name : " & BitmapFileName & Format(LastFileNumber, "000"))
    Application.Calculation = xlCalculationAutomatic
End Sub
'- END OF MAIN ROUTINE =======================================================
'=============================================================================
'- SUBROUTINE : SAVE PICTURE FROM CLIPBOARD AS A BITMAP FILE (JAAFAR'S CODE)
'- Called from main routine
'=============================================================================
Private Sub SAVE_PICTURE()
    '-----------------------------------------------------------------
    OpenClipboard 0
    hPtr = GetClipboardData(CF_BITMAP)
    CloseClipboard
    '-------------------------------------------------------------------------
     'Create the interface GUID for the picture
    With IID_IDispatch
        .Data1 = &H7BF80980
        .Data2 = &HBF32
        .Data3 = &H101A
        .Data4(0) = &H8B
        .Data4(1) = &HBB
        .Data4(2) = &H0
        .Data4(3) = &HAA
        .Data4(4) = &H0
        .Data4(5) = &H30
        .Data4(6) = &HC
        .Data4(7) = &HAB
    End With
    '------------------------------------------------------------------------
     '  Fill uPicInfo with necessary parts.
    With uPicinfo
        .Size = Len(uPicinfo) ' Length of structure.
        .Type = PICTYPE_BITMAP ' Type of Picture
        .hPic = hPtr ' Handle to image.
        .hPal = 0 ' Handle to palette (if bitmap).
    End With
    '------------------------------------------------------------------------
     'Create the Picture Object
    OleCreatePictureIndirect uPicinfo, IID_IDispatch, True, IPic
    '------------------------------------------------------------------------
     'Save Picture
    stdole.SavePicture IPic, FullFileName
    '------------------------------------------------------------------------
     'fix the clipboard (it seems to go messed up)
    Selection.CopyPicture Appearance:=xlScreen, Format:=xlBitmap
    '------------------------------------------------------------------------
End Sub
'======== EOP ===============================================================
'=============================================================================
'- SUBROUTINE : GET NEXT FILE NAME -> BitMapFileName + "_00x"
'- Called from Sub SAVE_PICTURE()
'=============================================================================
Private Sub GET_NEXT_FILENAME()
    Dim f, f1, fc
    Dim Fname As String
    Dim F3 As String    ' number
    Dim Flen As Integer ' length
    '-------------------------------------------------------------------------
    ' Set FSO = CreateObject("Scripting.FileSystemObject")' MOVED TO BEGINNING
    Set f = FSO.GetFolder(MyPictureFolder)
    Set fc = f.Files
    '- length of file name = name + number + suffix
    Flen = Len(BitmapFileName) + 4 + 4
    '-------------------------------------------------------------------------
    '- LOOP FILES IN FOLDER
    For Each f1 In fc
        Fname = f1.Name
        '---------------------------------------------------------------------
        '- check valid file and number
        F3 = Mid(Fname, Len(Fname) - 6, 3) ' number string
        If InStr(1, Fname, BitmapFileName, vbTextCompare) <> 0 _
            And IsNumeric(F3) And Len(Fname) = Flen Then
            FileNumber = CInt(F3)
            If FileNumber > LastFileNumber Then
                LastFileNumber = FileNumber
            End If
        End If
        '---------------------------------------------------------------------
    Next
    LastFileNumber = LastFileNumber + 1
    '-------------------------------------------------------------------------
    '- Next file name in series
    FullFileName = MyPictureFolder _
        & BitmapFileName & "_" & Format(LastFileNumber, "000") & ".bmp"
End Sub
'======== EOP ================================================================
Click to expand...


I tried using the Save picture code and got an error called run-time error 7 out of memory?
and points to this line
stdole.SavePicture IPic, filename
 
Upvote 0
I do not have time to go through all the code to see if you have made any amendments. It works well on my machine running XL2000.

I see that you have not changed the 'Const MyPictureFolder =' line to a different folder.

My VB Editor Tools/References contain :-

Visual Basic for Applications
Microsoft Excel 9.0 Object Library
OLE Automation .......................... this might be the one you need
Microsoft Forms 2.0
Microsoft Office 9.0 Object Library

Hope this helps.
 
Upvote 0
You must log in or register to reply here.

Similar threads

A
  • Question
VBA (help with picture pasting formula)
2 3
Replies
21
Views
1K
Siddharth Rout
Siddharth Rout
A
  • Question
Help with pasting picture MACRO
Replies
0
Views
334
alekun86
A
muhammad susanto
  • Question
Macro: Inserting Pictures With Multiple Select Picture & Consecutive Placing
Replies
1
Views
1K
muhammad susanto
muhammad susanto
K
  • Question
Inserting a picture in a worksheet
Replies
1
Views
261
yky
Y
J
  • Question
Pictures Placed Using VBA - Results in Different Locations for Horizontal or Vertical
Replies
0
Views
2K
joefish
J

Forum statistics

Threads
1,215,432
Messages
6,124,856
Members
449,194
Latest member
HellScout

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top