有时候第一列有2个或者以上的图片,输出的时候，有的图片就不输出了,想要输出，以第三列的iten no为名称,重复的就在后面加个（1）或者字母a

Private Const BIF_RETURNONLYFSDIRS As Long = &H1
Private Const BIF_DONTGOBELOWDOMAIN As Long = &H2
Private Const BIF_RETURNFSANCESTORS As Long = &H8
Private Const BIF_BROWSEFORCOMPUTER As Long = &H1000
Private Const BIF_BROWSEFORPRINTER As Long = &H2000
Private Const BIF_BROWSEINCLUDEFILES As Long = &H4000
Private Const MAX_PATH As Long = 260

Type BrowseInfo
  hOwner As Long
  pidlRoot As Long
  pszDisplayName As String
  lpszINSTRUCTIONS As String
  ulFlags As Long
  lpfn As Long
  lParam As Long
  iImage As Long
End Type

Type SHFILEOPSTRUCT
  hwnd As Long
  wFunc As Long
  pFrom As String
  pTo As String
  fFlags As Integer
  fAnyOperationsAborted As Boolean
  hNameMappings As Long
  lpszProgressTitle As String
End Type

Declare Function SHGetPathFromIDListA Lib "shell32.dll" ( _
  ByVal pidl As Long, _
  ByVal pszBuffer As String) As Long

Declare Function SHBrowseForFolderA Lib "shell32.dll" ( _
  lpBrowseInfo As BrowseInfo) As Long
Function BrowseFolderA(Optional Caption As String = "") As String

Dim BrowseInfo As BrowseInfo
Dim FolderName As String
Dim ID As Long
Dim Res As Long

With BrowseInfo
  .hOwner = 0
  .pidlRoot = 0
  .pszDisplayName = String$(MAX_PATH, vbNullChar)
  .lpszINSTRUCTIONS = Caption
  .ulFlags = BIF_RETURNONLYFSDIRS
  .lpfn = 0
End With

FolderName = String$(MAX_PATH, vbNullChar)
ID = SHBrowseForFolderA(BrowseInfo)
If ID Then
  Res = SHGetPathFromIDListA(ID, FolderName)
  If Res Then
  BrowseFolderA = Left$(FolderName, InStr(FolderName, vbNullChar) - 1)
  End If
End If

End Function



Sub Picoutput()
  Dim myDir As String
myDir = BrowseFolderA(Caption:="??一个文件?")
myDir = myDir & "\"
If myDir = vbNullString Then
  Debug.Print "没有??文件?"
Else
  Debug.Print "??的文件?是： " & myDir
End If

 
 ' OpenFile = Application.GetOpenFilename("???任一文件后按?定(*.*),*.*", , "??任一文件?定?片?出文件?，或取消?得当前文件所在文件?。")
  'If OpenFile = False Then
 ' myDir = ThisWorkbook.Path & "\"
  'Else
 ' myDir = Left(OpenFile, InStrRev(OpenFile, "\"))
  'End If
  k = InputBox("1=列左,2=列右,3=上一行,4=下一行,取消=?片所在?元格或无名称", "???片名称位置：", 2)
  If k = 1 Then
  r = 0: c = -1
  ElseIf k = 2 Then
  r = 0: c = 2
  ElseIf k = 3 Then
  r = -1: c = 0
  ElseIf k = 4 Then
  r = 1: c = 0
  End If
   
  k = MsgBox("Yes=按原尺寸,No=按新?定,Cancel=按?在?示", vbYesNoCancel, "?出?片尺寸大小??")
  For Each p In ActiveSheet.Shapes
  ph = p.Height
  pw = p.Width
  On Error Resume Next
  pn = p.TopLeftCell.Offset(r, c).Value
  If Err.Number <> 0 Then Err.Clear
  If pn = "" Then n = n + 1: pn = Left(ThisWorkbook.Name, InStrRev(ThisWorkbook.Name, ".") - 1) & Format(n, "000")

GetPicName:
  On Error Resume Next
  p.Name = pn & ".jpg"
  'If Err.Number <> 0 Then
  ' p.Name = pn & 1 & ".jpg"
  'End If
   
  p.Select
  If k = vbYes Then
  Selection.Copy
  ActiveSheet.PasteSpecial Format:="?片 (JPEG)" '英文版?"Picture (JPEG)"
  Selection.Name = "myPic"
  ElseIf k = vbNo Then
  Selection.ShapeRange.LockAspectRatio = msoFalse
  f = InputBox("放大?小比率", "?片尺寸?定", 2)
  If IsNumeric(f) And f > 0 Then
  Selection.ShapeRange.Height = ph * f
  Selection.ShapeRange.Width = pw * f
  Else
  Selection.ShapeRange.Height = InputBox("重新?定?片高度", "?片高尺寸?定", ph)
  Selection.ShapeRange.Width = InputBox("重新?定?片?度", "?片?尺寸?定", pw)
  End If
  End If
  Selection.CopyPict
  With ActiveSheet.ChartObjects.Add(0, 0, Selection.Width + 5, Selection.Height + 5).Chart
  .Paste
  .Export myDir & p.Name, "JPG"
  .Parent.Delete
  End With
   
  If k = vbYes Then
  ActiveSheet.Shapes("myPic").Delete
  ElseIf k = vbNo Then
  p.Height = ph
  p.Width = pw
  End If
  p.TopLeftCell.Offset(, -1).Select
  Next
   
End Sub