Need Macro to create a new worksheet and insert image
Hi I need a macro that will create a new worksheet and insert an image into
it based on all the images in a particular directory. The worksheet name should be the name of the image file. Where do I start? |
Need Macro to create a new worksheet and insert image
This should get you started:
Option Explicit Sub testme() Dim myNames() As String Dim fCtr As Long Dim myFile As String Dim myPath As String Dim myExt As String Dim NewWks As Worksheet Dim myPict As Picture 'change to point at the folder to check myPath = "C:\yourpathtothepictures" If Right(myPath, 1) < "\" Then myPath = myPath & "\" End If myFile = Dir(myPath & "*.*") If myFile = "" Then MsgBox "no files found" Exit Sub End If 'get the list of files fCtr = 0 Do While myFile < "" If InStr(1, myFile, ".", vbTextCompare) = 0 Then 'do nothing, no extension Else myExt = LCase(Mid(myFile, InStrRev(myFile, "."))) Select Case myExt Case Is = ".jpg", ".bmp", ".tif", ".tiff" fCtr = fCtr + 1 ReDim Preserve myNames(1 To fCtr) myNames(fCtr) = myFile End Select End If 'keep looking myFile = Dir() Loop Application.ScreenUpdating = False If fCtr 0 Then For fCtr = LBound(myNames) To UBound(myNames) Set NewWks = Worksheets.Add NewWks.Move after:=Sheets(Sheets.Count) On Error Resume Next NewWks.Name = myNames(fCtr) If Err.Number < 0 Then Err.Clear MsgBox "Rename failed on: " & vbLf _ & NewWks.Name End If On Error GoTo 0 Set myPict = NewWks.Pictures.Insert _ (Filename:=myPath & myNames(fCtr)) Next fCtr End If End Sub If you're new to macros: Debra Dalgleish has some notes how to implement macros he http://www.contextures.com/xlvba01.html David McRitchie has an intro to macros: http://www.mvps.org/dmcritchie/excel/getstarted.htm Ron de Bruin's intro to macros: http://www.rondebruin.nl/code.htm (General, Regular and Standard modules all describe the same thing.) wrote: Hi I need a macro that will create a new worksheet and insert an image into it based on all the images in a particular directory. The worksheet name should be the name of the image file. Where do I start? -- Dave Peterson |
Need Macro to create a new worksheet and insert image
ps. This used instrrev() and that was added in xl2k. So if you need to support
xl97 or earlier, this won't work without modification. Dave Peterson wrote: This should get you started: Option Explicit Sub testme() Dim myNames() As String Dim fCtr As Long Dim myFile As String Dim myPath As String Dim myExt As String Dim NewWks As Worksheet Dim myPict As Picture 'change to point at the folder to check myPath = "C:\yourpathtothepictures" If Right(myPath, 1) < "\" Then myPath = myPath & "\" End If myFile = Dir(myPath & "*.*") If myFile = "" Then MsgBox "no files found" Exit Sub End If 'get the list of files fCtr = 0 Do While myFile < "" If InStr(1, myFile, ".", vbTextCompare) = 0 Then 'do nothing, no extension Else myExt = LCase(Mid(myFile, InStrRev(myFile, "."))) Select Case myExt Case Is = ".jpg", ".bmp", ".tif", ".tiff" fCtr = fCtr + 1 ReDim Preserve myNames(1 To fCtr) myNames(fCtr) = myFile End Select End If 'keep looking myFile = Dir() Loop Application.ScreenUpdating = False If fCtr 0 Then For fCtr = LBound(myNames) To UBound(myNames) Set NewWks = Worksheets.Add NewWks.Move after:=Sheets(Sheets.Count) On Error Resume Next NewWks.Name = myNames(fCtr) If Err.Number < 0 Then Err.Clear MsgBox "Rename failed on: " & vbLf _ & NewWks.Name End If On Error GoTo 0 Set myPict = NewWks.Pictures.Insert _ (Filename:=myPath & myNames(fCtr)) Next fCtr End If End Sub If you're new to macros: Debra Dalgleish has some notes how to implement macros he http://www.contextures.com/xlvba01.html David McRitchie has an intro to macros: http://www.mvps.org/dmcritchie/excel/getstarted.htm Ron de Bruin's intro to macros: http://www.rondebruin.nl/code.htm (General, Regular and Standard modules all describe the same thing.) wrote: Hi I need a macro that will create a new worksheet and insert an image into it based on all the images in a particular directory. The worksheet name should be the name of the image file. Where do I start? -- Dave Peterson -- Dave Peterson |
Need Macro to create a new worksheet and insert image
Thank you so much, it worked perfectly.
"Dave Peterson" wrote: This should get you started: Option Explicit Sub testme() Dim myNames() As String Dim fCtr As Long Dim myFile As String Dim myPath As String Dim myExt As String Dim NewWks As Worksheet Dim myPict As Picture 'change to point at the folder to check myPath = "C:\yourpathtothepictures" If Right(myPath, 1) < "\" Then myPath = myPath & "\" End If myFile = Dir(myPath & "*.*") If myFile = "" Then MsgBox "no files found" Exit Sub End If 'get the list of files fCtr = 0 Do While myFile < "" If InStr(1, myFile, ".", vbTextCompare) = 0 Then 'do nothing, no extension Else myExt = LCase(Mid(myFile, InStrRev(myFile, "."))) Select Case myExt Case Is = ".jpg", ".bmp", ".tif", ".tiff" fCtr = fCtr + 1 ReDim Preserve myNames(1 To fCtr) myNames(fCtr) = myFile End Select End If 'keep looking myFile = Dir() Loop Application.ScreenUpdating = False If fCtr 0 Then For fCtr = LBound(myNames) To UBound(myNames) Set NewWks = Worksheets.Add NewWks.Move after:=Sheets(Sheets.Count) On Error Resume Next NewWks.Name = myNames(fCtr) If Err.Number < 0 Then Err.Clear MsgBox "Rename failed on: " & vbLf _ & NewWks.Name End If On Error GoTo 0 Set myPict = NewWks.Pictures.Insert _ (Filename:=myPath & myNames(fCtr)) Next fCtr End If End Sub If you're new to macros: Debra Dalgleish has some notes how to implement macros he http://www.contextures.com/xlvba01.html David McRitchie has an intro to macros: http://www.mvps.org/dmcritchie/excel/getstarted.htm Ron de Bruin's intro to macros: http://www.rondebruin.nl/code.htm (General, Regular and Standard modules all describe the same thing.) wrote: Hi I need a macro that will create a new worksheet and insert an image into it based on all the images in a particular directory. The worksheet name should be the name of the image file. Where do I start? -- Dave Peterson . |
All times are GMT +1. The time now is 10:29 PM. |
Powered by vBulletin® Copyright ©2000 - 2024, Jelsoft Enterprises Ltd.
ExcelBanter.com