Need Macro to create a new worksheet and insert image

[gloria.lewis]

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]

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 here:
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.)

 

[Dave Peterson]

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.

 

[gloria.lewis]

Thank you so much, it worked perfectly.

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 here:
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.)