Thanks for your message. But I think it can not help me really. To do the
job suggested by you,I prefer to insert the pictures into the sheet. The main
problem is if I insert the photos mannally, it is too much boring works.I
have thousands of record.
Hello Li Jianyong,
I wrote some code a while ago to add pictures to cell comments. I
modified it for your needs. Copy this code into a standard VBA module
in your workbook project. You will need to change the startup
information. This is the starting cell and worksheet for your data.
Currently, it is cell "A2" on "Sheet1". You can run the macro after
you have saved it, using ALT+F8 keys in Excel to bring up the Macro
Dialog.
'Start of Macro code..........
'Written: July 26, 2008
'Author: Leith Ross
'Summary: The user is prompted to open a jpg file in the chosen
directory. The macro
' scans a given worksheet column for picture names, less the
extension, in
' the chosen directory and places the corresponding picture in
the comment.
' The macro will contiue to process all files until there are
no more files
' or the file name in the cell can't be found.
Sub PicturesToCommentsUsingList()
Dim Answer As String
Dim C As Variant
Dim Cmnt As Excel.Comment
Dim ExtLen As Integer
Dim FileName As String
Dim FolderPath As String
Dim FSO As Object
Dim Pics As New Collection
Dim R As Long
Dim Wks As Worksheet
'Setup the starting cell and worksheet
C = "A"
R = 2
Set Wks = Worksheets("Sheet1")
'Prompt user to select a file from the directory selected
FolderPath = Application.GetOpenFilename("Picture Files (*.jpg),
*.jpg")
If FolderPath = "False" Then Exit Sub
Application.ScreenUpdating = False
Set FSO = CreateObject("Scripting.FileSystemObject")
FileName = FSO.GetFile(FolderPath).Name
ExtLen = Len(FSO.GetExtensionName(FolderPath)) + 1
FolderPath = Left(FolderPath, Len(FolderPath) - Len(FileName))
'Place pictures names and paths in collection object
For Each File In FSO.GetFolder(FolderPath).Files
On Error Resume Next
Pics.Add File.Path, Left(File.Name, Len(File.Name) -
ExtLen)
If Err.Number <> 0 Then Err.Clear
On Error GoTo 0
Next File
'Match picture names in the column with the collection
For I = 1 To Pics.Count
With Wks
Set Cmnt = .Cells(R, C).Comment
If Cmnt Is Nothing Then
Set Cmnt = .Cells(R, C).AddComment(Text:="")
End If
On Error Resume Next
Cmnt.Shape.Fill.UserPicture Pics(.Cells(R, C).Text)
If Err.Number <> 0 Then
Answer = MsgBox("The Picture " & .Cells(R, C).Text &
" could not be found." & vbCrLf _
& "Do you want to continue?", vbYesNo +
vbDefaultButton2 + vbQuestion)
If Answer = vbNo Then Exit For
End If
R = R + I
End With
Next I
Application.ScreenUpdating = True
Set FSO = Nothing
End Sub
'End of Macro Code..........
Sincerely,
Leith Ross
