VBA实现Excel调用系统默认图片浏览器打开图片

y5230024

[Visual Basic] 纯文本查看 复制代码

Option Explicit

#If VBA7 Then
    Private Declare PtrSafe Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hWnd As LongPtr, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As LongPtr
#Else
    Private Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hWnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
#End If

Private Const SW_SHOWNORMAL As Long = 1

Sub OpenImageInSystemViewer()
    On Error GoTo EH
    
    Dim tempPath As String, copyFile As String, zipFile As String
    Dim extractPath As String, mediaFolder As String, imgPath As String
    Dim uniqueID As String, fso As Object, wsh As Object
    Dim fileList() As String, fileCount As Long
    Dim targetShp As Object
    
    If Not IsPictureSelected(targetShp) Then
        MsgBox "请先选中一张图片!", vbExclamation
        Exit Sub
    End If
    
    If ThisWorkbook.Path = "" Then
        MsgBox "请先保存当前工作簿!", vbExclamation
        Exit Sub
    End If
    
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set wsh = CreateObject("WScript.Shell")
    
    Randomize
    uniqueID = Format(Now, "yyyymmddhhnnss") & "_" & Int(Rnd() * 10000)
    tempPath = Environ("TEMP") & "\ExcelImg_" & uniqueID
    fso.CreateFolder tempPath
    
    copyFile = tempPath & "\orig.xlsm"
    ThisWorkbook.SaveCopyAs copyFile
    zipFile = tempPath & "\workbook.zip"
    Name copyFile As zipFile
    
    extractPath = tempPath & "\extracted"
    fso.CreateFolder extractPath
    wsh.Run "powershell -NoProfile -ExecutionPolicy Bypass -Command ""Add-Type -AssemblyName System.IO.Compression.FileSystem; [System.IO.Compression.ZipFile]::ExtractToDirectory('" & zipFile & "', '" & extractPath & "')""", 0, True
    
    mediaFolder = extractPath & "\xl\media\"
    If Not fso.FolderExists(mediaFolder) Then
        MsgBox "解压失败或无图片!", vbCritical
        GoTo Cleanup
    End If
    
    Dim fileObj As Object, ext As String
    fileCount = 0
    ReDim fileList(0 To 99) As String
    For Each fileObj In fso.GetFolder(mediaFolder).Files
        ext = LCase(fso.GetExtensionName(fileObj.Path))
        If ext = "jpg" Or ext = "jpeg" Or ext = "png" Or ext = "gif" Or ext = "bmp" Then
            If fileCount > UBound(fileList) Then ReDim Preserve fileList(0 To UBound(fileList) + 50)
            fileList(fileCount) = fileObj.Path
            fileCount = fileCount + 1
        End If
    Next
    If fileCount = 0 Then GoTo Cleanup
    ReDim Preserve fileList(0 To fileCount - 1)
    
    imgPath = MatchPicture(targetShp, extractPath, fileList, fso)
    If imgPath = "" Then
        MsgBox "匹配失败", vbExclamation
        GoTo Cleanup
    End If
    
    #If VBA7 Then
        Dim r As LongPtr
    #Else
        Dim r As Long
    #End If
    r = ShellExecute(0, "open", imgPath, "", "", SW_SHOWNORMAL)
    
Cleanup:
    Exit Sub
EH:
    MsgBox "Err: " & Err.Description, vbCritical
    Resume Cleanup
End Sub

Private Function IsPictureSelected(ByRef outShp As Object) As Boolean
    Set outShp = Nothing
    If TypeName(Selection) = "Picture" Then
        Set outShp = Selection
        IsPictureSelected = True
    ElseIf TypeName(Selection) = "ShapeRange" Then
        If Selection.Count = 1 Then
            Dim obj As Object: Set obj = Selection.Item(1)
            On Error Resume Next
            If obj.Type = 13 Then Set outShp = obj: IsPictureSelected = True
            On Error GoTo 0
        End If
    End If
End Function

Private Function MatchPicture(ByVal targetShp As Object, ByVal extractPath As String, ByRef fileList() As String, ByVal fso As Object) As String
    MatchPicture = ""
    On Error GoTo ErrExit
    
    Dim ws As Object, sheetIndex As Long
    Set ws = targetShp.Parent
    sheetIndex = ws.Index
    
    Dim shp As Object, shpIndex As Long, curIndex As Long
    shpIndex = 0: curIndex = 0
    For Each shp In ws.Shapes
        On Error Resume Next
        If shp.Type = 13 Then
            curIndex = curIndex + 1
            If shp.Name = targetShp.Name Then
                shpIndex = curIndex
                Exit For
            End If
        End If
        On Error GoTo 0
    Next
    If shpIndex = 0 Then Exit Function
    
    Dim srPath As String, srText As String
    srPath = extractPath & "\xl\worksheets\_rels\sheet" & sheetIndex & ".xml.rels"
    If Not fso.FileExists(srPath) Then Exit Function
    srText = fso.OpenTextFile(srPath, 1).ReadAll
    
    Dim tgtStart As Long, tgtEnd As Long, dfn As String
    tgtStart = InStr(1, srText, "Target=""../drawings/", vbBinaryCompare)
    If tgtStart = 0 Then tgtStart = InStr(1, srText, "Target=""drawings/", vbBinaryCompare)
    If tgtStart = 0 Then Exit Function
    tgtStart = tgtStart + 8
    tgtEnd = InStr(tgtStart, srText, """")
    If tgtEnd = 0 Then Exit Function
    dfn = fso.GetFileName(Mid(srText, tgtStart, tgtEnd - tgtStart))
    
    Dim drPath As String, drText As String
    drPath = extractPath & "\xl\drawings\" & dfn
    If Not fso.FileExists(drPath) Then Exit Function
    drText = fso.OpenTextFile(drPath, 1).ReadAll
    
    Dim rids() As String, ridCount As Long
    ReDim rids(0 To 199): ridCount = 0
    
    Dim sp As Long: sp = 1
    Do While sp < Len(drText)
        Dim es As Long
        es = InStr(sp, drText, "embed=""", vbBinaryCompare)
        If es = 0 Then es = InStr(sp, drText, "r:embed=""", vbBinaryCompare)
        If es = 0 Then Exit Do
        
        If Mid(drText, es, 2) = "r:" Then es = es + 2
        es = es + 7
        Dim ee As Long: ee = InStr(es, drText, """")
        If ee = 0 Then Exit Do
        
        rids(ridCount) = Mid(drText, es, ee - es)
        ridCount = ridCount + 1
        sp = ee + 1
    Loop
    
    If shpIndex > ridCount Then Exit Function
    ReDim Preserve rids(0 To ridCount - 1)
    Dim targetRid As String: targetRid = rids(shpIndex - 1)
    
    Dim drRelsPath As String, relsText As String
    drRelsPath = extractPath & "\xl\drawings\_rels\" & dfn & ".rels"
    If Not fso.FileExists(drRelsPath) Then Exit Function
    relsText = fso.OpenTextFile(drRelsPath, 1).ReadAll
    
    Dim searchPat As String, matchPos As Long
    searchPat = "Id=""" & targetRid & """"
    matchPos = InStr(1, relsText, searchPat, vbBinaryCompare)
    If matchPos = 0 Then Exit Function
    
    Dim tPos As Long, mediaName As String
    tPos = InStr(matchPos, relsText, "Target=""", vbBinaryCompare)
    If tPos = 0 Then Exit Function
    tPos = tPos + 8
    Dim tEnd2 As Long: tEnd2 = InStr(tPos, relsText, """")
    If tEnd2 = 0 Then Exit Function
    mediaName = fso.GetFileName(Mid(relsText, tPos, tEnd2 - tPos))
    
    Dim j As Long
    For j = 0 To UBound(fileList)
        If LCase(fso.GetFileName(fileList(j))) = LCase(mediaName) Then
            MatchPicture = fileList(j)
            Exit Function
        End If
    Next
    
ErrExit:
End Function

按 Alt + F11 → 粘贴代码后保存
快捷键设置
按 Alt + F8 → 选择 OpenImageInSystemViewer → 点击「选项」
设置快捷键（如 Ctrl + Q）
现在每次打开带图片的 Excel，选中图片按快捷键就能直接用系统图片浏览器看原始大图了！

[Visual Basic] 纯文本查看 复制代码

Option Explicit

#If VBA7 Then
    Private Declare PtrSafe Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hWnd As LongPtr, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As LongPtr
#Else
    Private Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hWnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
#End If

Private Const SW_SHOWNORMAL As Long = 1

Sub OpenImageInSystemViewer()
    On Error GoTo EH
    
    Dim tempPath As String, copyFile As String, zipFile As String
    Dim extractPath As String, mediaFolder As String, imgPath As String
    Dim uniqueID As String, fso As Object, wsh As Object
    Dim fileList() As String, fileCount As Long
    Dim targetShp As Object
    Dim wb As Object
    
    ' ★ 用 ActiveWorkbook 而不是 ThisWorkbook ★
    Set wb = ActiveWorkbook
    If wb Is Nothing Then
        MsgBox "没有打开的工作簿!", vbExclamation
        Exit Sub
    End If
    
    If Not IsPictureSelected(targetShp) Then
        MsgBox "请先选中一张图片!", vbExclamation
        Exit Sub
    End If
    
    If wb.Path = "" Then
        MsgBox "请先保存当前工作簿!", vbExclamation
        Exit Sub
    End If
    
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set wsh = CreateObject("WScript.Shell")
    
    Randomize
    uniqueID = Format(Now, "yyyymmddhhnnss") & "_" & Int(Rnd() * 10000)
    tempPath = Environ("TEMP") & "\ExcelImg_" & uniqueID
    fso.CreateFolder tempPath
    
    ' ★ 复制的是数据工作簿,不是 personal.xlsb ★
    copyFile = tempPath & "\orig.xlsm"
    wb.SaveCopyAs copyFile
    zipFile = tempPath & "\workbook.zip"
    Name copyFile As zipFile
    
    extractPath = tempPath & "\extracted"
    fso.CreateFolder extractPath
    wsh.Run "powershell -NoProfile -ExecutionPolicy Bypass -Command ""Add-Type -AssemblyName System.IO.Compression.FileSystem; [System.IO.Compression.ZipFile]::ExtractToDirectory('" & zipFile & "', '" & extractPath & "')""", 0, True
    
    mediaFolder = extractPath & "\xl\media\"
    If Not fso.FolderExists(mediaFolder) Then
        MsgBox "解压失败或无图片!", vbCritical
        GoTo Cleanup
    End If
    
    Dim fileObj As Object, ext As String
    fileCount = 0
    ReDim fileList(0 To 99) As String
    For Each fileObj In fso.GetFolder(mediaFolder).Files
        ext = LCase(fso.GetExtensionName(fileObj.Path))
        If ext = "jpg" Or ext = "jpeg" Or ext = "png" Or ext = "gif" Or ext = "bmp" Then
            If fileCount > UBound(fileList) Then ReDim Preserve fileList(0 To UBound(fileList) + 50)
            fileList(fileCount) = fileObj.Path
            fileCount = fileCount + 1
        End If
    Next
    If fileCount = 0 Then GoTo Cleanup
    ReDim Preserve fileList(0 To fileCount - 1)
    
    imgPath = MatchPicture(targetShp, extractPath, fileList, fso)
    If imgPath = "" Then
        MsgBox "匹配失败", vbExclamation
        GoTo Cleanup
    End If
    
    #If VBA7 Then
        Dim r As LongPtr
    #Else
        Dim r As Long
    #End If
    r = ShellExecute(0, "open", imgPath, "", "", SW_SHOWNORMAL)
    
Cleanup:
    Exit Sub
EH:
    MsgBox "Err: " & Err.Description, vbCritical
    Resume Cleanup
End Sub

Private Function IsPictureSelected(ByRef outShp As Object) As Boolean
    Set outShp = Nothing
    If TypeName(Selection) = "Picture" Then
        Set outShp = Selection
        IsPictureSelected = True
    ElseIf TypeName(Selection) = "ShapeRange" Then
        If Selection.Count = 1 Then
            Dim obj As Object: Set obj = Selection.Item(1)
            On Error Resume Next
            If obj.Type = 13 Then Set outShp = obj: IsPictureSelected = True
            On Error GoTo 0
        End If
    End If
End Function

Private Function MatchPicture(ByVal targetShp As Object, ByVal extractPath As String, ByRef fileList() As String, ByVal fso As Object) As String
    MatchPicture = ""
    On Error GoTo ErrExit
    
    Dim ws As Object, sheetIndex As Long
    Set ws = targetShp.Parent
    sheetIndex = ws.Index
    
    Dim shp As Object, shpIndex As Long, curIndex As Long
    shpIndex = 0: curIndex = 0
    For Each shp In ws.Shapes
        On Error Resume Next
        If shp.Type = 13 Then
            curIndex = curIndex + 1
            If shp.Name = targetShp.Name Then
                shpIndex = curIndex
                Exit For
            End If
        End If
        On Error GoTo 0
    Next
    If shpIndex = 0 Then Exit Function
    
    Dim srPath As String, srText As String
    srPath = extractPath & "\xl\worksheets\_rels\sheet" & sheetIndex & ".xml.rels"
    If Not fso.FileExists(srPath) Then Exit Function
    srText = fso.OpenTextFile(srPath, 1).ReadAll
    
    Dim tgtStart As Long, tgtEnd As Long, dfn As String
    tgtStart = InStr(1, srText, "Target=""../drawings/", vbBinaryCompare)
    If tgtStart = 0 Then tgtStart = InStr(1, srText, "Target=""drawings/", vbBinaryCompare)
    If tgtStart = 0 Then Exit Function
    tgtStart = tgtStart + 8
    tgtEnd = InStr(tgtStart, srText, """")
    If tgtEnd = 0 Then Exit Function
    dfn = fso.GetFileName(Mid(srText, tgtStart, tgtEnd - tgtStart))
    
    Dim drPath As String, drText As String
    drPath = extractPath & "\xl\drawings\" & dfn
    If Not fso.FileExists(drPath) Then Exit Function
    drText = fso.OpenTextFile(drPath, 1).ReadAll
    
    Dim rids() As String, ridCount As Long
    ReDim rids(0 To 199): ridCount = 0
    
    Dim sp As Long: sp = 1
    Do While sp < Len(drText)
        Dim es As Long
        es = InStr(sp, drText, "embed=""", vbBinaryCompare)
        If es = 0 Then es = InStr(sp, drText, "r:embed=""", vbBinaryCompare)
        If es = 0 Then Exit Do
        
        If Mid(drText, es, 2) = "r:" Then es = es + 2
        es = es + 7
        Dim ee As Long: ee = InStr(es, drText, """")
        If ee = 0 Then Exit Do
        
        rids(ridCount) = Mid(drText, es, ee - es)
        ridCount = ridCount + 1
        sp = ee + 1
    Loop
    
    If shpIndex > ridCount Then Exit Function
    ReDim Preserve rids(0 To ridCount - 1)
    Dim targetRid As String: targetRid = rids(shpIndex - 1)
    
    Dim drRelsPath As String, relsText As String
    drRelsPath = extractPath & "\xl\drawings\_rels\" & dfn & ".rels"
    If Not fso.FileExists(drRelsPath) Then Exit Function
    relsText = fso.OpenTextFile(drRelsPath, 1).ReadAll
    
    Dim searchPat As String, matchPos As Long
    searchPat = "Id=""" & targetRid & """"
    matchPos = InStr(1, relsText, searchPat, vbBinaryCompare)
    If matchPos = 0 Then Exit Function
    
    Dim tPos As Long, mediaName As String
    tPos = InStr(matchPos, relsText, "Target=""", vbBinaryCompare)
    If tPos = 0 Then Exit Function
    tPos = tPos + 8
    Dim tEnd2 As Long: tEnd2 = InStr(tPos, relsText, """")
    If tEnd2 = 0 Then Exit Function
    mediaName = fso.GetFileName(Mid(relsText, tPos, tEnd2 - tPos))
    
    Dim j As Long
    For j = 0 To UBound(fileList)
        If LCase(fso.GetFileName(fileList(j))) = LCase(mediaName) Then
            MatchPicture = fileList(j)
            Exit Function
        End If
    Next
    
ErrExit:
End Function

上面是个人宏工作簿版本,放在个人宏工作簿中就不需要每次打开表格粘贴代码了

starry888

好用，感谢分享！

758586

感谢 感谢 分享！不错