Form1.frm.twin

[ FormDesignerId ("17EDB70C-6618-40A4-BF4D-48AF501F9E2F") ]
[ ClassId ("F604CC43-40F3-48C9-A1EE-4A304E225D87") ]
[ InterfaceId ("DEDC831F-9CA9-4856-8E2B-9D8860E1CAFE") ]
[ EventInterfaceId ("86072928-F3BE-4C2F-9B79-3D131127C8E5") ]
Class Form1
    Attribute VB_Name = "Form1"
    Attribute VB_GlobalNameSpace = False
    Attribute VB_Creatable = False
    Attribute VB_PredeclaredId = True
    Attribute VB_Exposed = False
    Option Explicit
    
    'Version 2 Revision 2
    ' --Adjusted DoPreview() failure check to retry if any error HRESULT instead of just E_FAIL
    
    'Version 2 Revision 1
    ' --Did not repeat DPI adjustment for handlers requiring SetRect after DoPreview()..
    
    ' Version 2 
    ' --Corrects infinite loop when both a local and inproc server handler has the same bug
    ' --Corrects local server being dpi aware when this app is not.
    ' --Better error handling
    
    Private ipv As IPreviewHandler
    Private hGlobal As LongPtr
 
    Private mZoom As Single
    Private mActualZoom As Single 'If we use a local server, and system dpi awareness is on
                                  'we must scale even though we're not DPI aware
                                  
    Private Sub Command1_Click()
    Dim isi As IShellItem
    Dim FileFilter() As COMDLG_FILTERSPEC
    Dim rc As RECT
    
    ReDim FileFilter(0)
    FileFilter(0).pszName = StrPtr("All Files")
    FileFilter(0).pszSpec = StrPtr("*.*")
    
    Dim fod As FileOpenDialog
    Set fod = New FileOpenDialog
    
    With fod
        .SetOkButtonLabel "Preview"
        .SetOptions FOS_FILEMUSTEXIST Or FOS_DONTADDTORECENT Or FOS_ALLNONSTORAGEITEMS
        .SetTitle "Select a file that can be previewed"
        .SetFileTypes 1, VarPtr(FileFilter(0))
        
        On Error Resume Next '.show throws an automation error if cancel is clicked
        .Show Me.hWnd
        On Error GoTo 0
        fod.GetResult isi
        If (isi Is Nothing) Then Exit Sub
    End With
    
        GetClientRect Picture1.hWnd, rc
    
    ShowPreviewForFile isi, Picture1.hWnd, rc, Picture1
    Set isi = Nothing
    Set fod = Nothing
    End Sub
    Private Sub ShowPreviewForFile(isi As IShellItem, hWnd As LongPtr, rc As RECT, objpic As Object, Optional sFileIn As String = "")
    Dim iif As IInitializeWithFile
    Dim iis As IInitializeWithStream
    Dim iisi As IInitializeWithItem
    Dim pVis As IPreviewHandlerVisuals
    Dim pUnk As IUnknownUnrestricted
    Dim hr As Long
    Dim sFile As String, sExt As String
    Dim lp As LongPtr
    Dim tHandler As UUID
    Dim bBreak As Boolean
    Dim bLocal As Boolean
    On Error GoTo e0
    
    If (isi Is Nothing) Then
        Debug.Print "no isi"
        If sFileIn <> "" Then
            sFile = sFileIn
        End If
    Else
        Debug.Print "using isi"
        isi.GetDisplayName SIGDN_FILESYSPATH, lp
        sFile = BStrFromLPWStr(lp)
    End If
        Debug.Print "sFile=" & sFile
        sExt = Right$(sFile, (Len(sFile) - InStrRev(sFile, ".")) + 1)
        Debug.Print "sExt=" & sExt
    
    If sExt = "" Then Exit Sub
    
    If (ipv Is Nothing) = False Then
        ipv.Unload
        Set ipv = Nothing
    End If
    
    
    hr = GetHandlerCLSID(sExt, tHandler)
    If hr = 1 Then
        Debug.Print "Got handler CLSID; attempting to create IPreviewHandler " & dbg_GUIDToString(tHandler)
        hr = CoCreateInstance(tHandler, Nothing, CLSCTX_INPROC_SERVER, IID_IPreviewHandler, ipv)
        ' If (ipv Is Nothing) Then
        '     Debug.Print "Failed to create IPreviewHandler interface, hr=" & hr
        '     Exit Sub
        ' End If
        If hr <> S_OK Then
            Debug.Print "CoCreateInstance failed, trying alternate args... (hr=0x" & Hex$(hr) & ")"
            hr = CoCreateInstance(tHandler, Nothing, CLSCTX_LOCAL_SERVER, IID_IPreviewHandler, ipv)
            Debug.Print "LOCAL hr=0x" & Hex$(hr)
            If hr <> S_OK Then
                hr = CoCreateInstance(tHandler, Nothing, CLSCTX_INPROC_SERVER, IID_IPreviewHandler, ipv)
                Debug.Print "INPROC hr=0x" & Hex$(hr)
            Else
            	bLocal = True
            End If
        End If
        restart:
        'Set iisi = ipv 'this normally can be used in place of Set pUnk / .QueryInterface, but we need the HRESULT
        Set pUnk = ipv
    '    Set iif = ipv
        Set pUnk = ipv
        If pUnk.QueryInterface(IID_IInitializeWithFile, iif) = S_OK Then
            hr = iif.Initialize(StrPtr(sFile), STGM_READ)
            GoTo gpvh
        Else
            Debug.Print "IInitializeWithFile not supported."
        End If
        If pUnk.QueryInterface(IID_IInitializeWithItem, iisi) = S_OK Then
            hr = iisi.Initialize(isi, STGM_READ)
            Debug.Print "iisi.init hr=" & hr
            If hr = S_OK Then GoTo gpvh
        Else
            Debug.Print "IInitializeWithItem not supported."
        End If
    
            'use IStream
            Dim hFile As LongPtr
            Dim pstrm As IStream
            Dim lpGlobal As LongPtr
            Dim dwSize As Long
            Debug.Print "Attempting to use IStream"
            hFile = CreateFile(sFile, FILE_READ_DATA, FILE_SHARE_READ, vbNullPtr, OPEN_EXISTING, 0, 0)
            If hFile Then
                dwSize = GetFileSize(hFile, ByVal 0&)
                Debug.Print "Got file size=" & dwSize
                If dwSize = 0 Then Exit Sub
                hGlobal = GlobalAlloc(GPTR, dwSize)
                lpGlobal = GlobalLock(hGlobal)
                If lpGlobal Then
                    Call ReadFile(hFile, ByVal lpGlobal, dwSize, dwSize, vbNullPtr)
                    Call GlobalUnlock(hGlobal)
                    Call CreateStreamOnHGlobal(hGlobal, 1, pstrm)
    '                Set iis = ipv
                    Set pUnk = ipv
                    hr = pUnk.QueryInterface(IID_IInitializeWithStream, iis)
                    Debug.Print "QI.hr=" & hr
                    If (iis Is Nothing) Then
                        Debug.Print "IInitializeWithStream not supported."
                        Call CloseHandle(hFile)
                        GoTo out
                    Else
                        hr = iis.Initialize(pstrm, STGM_READ)
                        Debug.Print "Initialize.hr=" & hr
                    End If
                End If
                
                Call CloseHandle(hFile)
    
        End If
    gpvh:
        If bLocal Then
        	If Abs(mActualZoom - mZoom) > 0.01 Then 'not the same, within floating point error
            	rc.Left *= mActualZoom
                rc.Bottom *= mActualZoom
                rc.Right *= mActualZoom
                rc.Top *= mActualZoom
        	End If
        End If
        hr = ipv.SetWindow(hWnd, rc)
        Debug.Print "SetWindow hr=" & hr
        If hr <> S_OK Then
        	Exit Sub
        End If

        hr = ipv.DoPreview()
        Debug.Print "DoPreview hr=" & hr
        Dim prc As RECT
        GetClientRect hWnd, prc
        If bLocal Then
            If Abs(mActualZoom - mZoom) > 0.01 Then 'not the same, within floating point error
                prc.Left *= mActualZoom
                prc.Bottom *= mActualZoom
                prc.Right *= mActualZoom
                prc.Top *= mActualZoom
            End If
        End If
        ipv.SetRect prc
        If SUCCEEDED(hr) = False Then
        	If bBreak = True Then
            	Debug.Print "All attempts to create a valid handler failed."
                Exit Sub
        	End If
        	'We've got a real problem here. Some handlers fail at this point with E_FAIL (LOOKING AT YOU, ADOBE)
            'Because it's an inproc server. But others will fail here if it's a local folder (shout out Microsoft!)
            'So we start with inproc, then we'll restart with local, because the MS handlers don't even give the
            'courtesy of an error. Just never draw anything.
            Set iisi = Nothing
            Set iif = Nothing
            Set iis = Nothing
            ipv.Unload
            Set ipv = Nothing
            Debug.Print "INPROC failed at DoPreview(); attempting again with LOCAL..."
            hr = CoCreateInstance(tHandler, Nothing, CLSCTX_LOCAL_SERVER, IID_IPreviewHandler, ipv)
            If hr = S_OK Then
                bBreak = True
                bLocal = True
                Debug.Print "Successfully created on local server, restarting..."
                GoTo restart
            Else
            	If ipv Is Nothing Then
                	Debug.Print "Couldn't recreate on local server; preview failed."
            	End If
            End If
        End If
        Dim piunk As IUnknownUnrestricted
        Set piunk = ipv
        hr = piunk.QueryInterface(IID_IPreviewHandlerVisuals, pVis)
        If (pVis Is Nothing) = False Then
            Debug.Print "Handler implements IPreviewHandlerVisuals; setting bk color to white"
            pVis.SetBackgroundColor &HFFFFFF
        End If
        isi.GetDisplayName SIGDN_NORMALDISPLAY, lp
        sFile = BStrFromLPWStr(lp)
        Label1.Caption = "DoPreview called for " & sFile
    Else
        'images and videos aren't handled that way normally, so we'll do it another way
        Debug.Print "No registered handler; trying alternate method for images..."
        Dim lPcv As Long
        lPcv = FilePtypeL(sExt)
        Debug.Print "Perceived type=" & lPcv
        If lPcv = PERCEIVED_TYPE_IMAGE Then
            If Right$(sFile, 4) = ".ico" Then
                'the below methods don't properly render icons transparent
                'so we'll use a different method that does
                If DoIcoPreview(sFile, objpic.hDC, 32) = -1 Then
                    GoTo gfthm
                End If
                objpic.Refresh
                Label1.Caption = "Manually generated preview for icon."
                GoTo out
            Else
    gfthm:
                Dim hbm As LongPtr
                hbm = GetFileThumbnail(sFile, 0, objpic.ScaleWidth, objpic.ScaleHeight)
                Debug.Print "hbm=" & hbm
                objpic.Cls
                hBitmapToPictureBox objpic, hbm
                objpic.Refresh
                Label1.Caption = "Manually generated preview for image."
            End If
        Else
            Label1.Caption = "Could not find registered preview handler for file type."
        
        End If
    End If
    out:
    
    Set iisi = Nothing
    Set iif = Nothing
    Set iis = Nothing
    
    On Error GoTo 0
    Exit Sub
    
    e0:
    Debug.Print "ShowPreviewForFile.Error->" & Err.Description & " (" & Err.Number & ")"
    End Sub
    
    Private Sub Command2_Click()
    Dim psi As IShellItem
    Dim rc As RECT
    Dim pidl As LongPtr
    pidl = ILCreateFromPathW(StrPtr(Text1.Text))
    Call SHCreateItemFromIDList(pidl, IID_IShellItem, psi)
    
    'Call SHCreateItemFromParsingName(StrPtr(Text1.Text), ByVal 0&, IID_IShellItem, psi)
        rc.Top = 16
        rc.Bottom = (Picture1.Height / Screen.TwipsPerPixelY) - 16
        rc.Left = 16
        rc.Right = (Picture1.Width / Screen.TwipsPerPixelX) - 16
        ShowPreviewForFile psi, Picture1.hWnd, rc, Picture1, Text1.Text
    End Sub
    
    Private Sub Form_Unload(Cancel As Integer)
    If (ipv Is Nothing) = False Then
        ipv.Unload
        Set ipv = Nothing
    End If
    
    
    End Sub
    
    Private Sub Form_Load() Handles Form.Load
        Dim hDC As LongPtr
        hDC = GetDC(0&)
        mZoom = GetDeviceCaps(hDC, LOGPIXELSX) / 96
        Debug.Print "dpix=" & GetDeviceCaps(hDC, LOGPIXELSX) / 96
        ReleaseDC 0&, hDC
        
        'Get the actual scale factor even if virtualized.
        'Thanks LaVolpe
        Dim tDC As LongPtr, lRez As Long, lDPI As Long
        tDC = GetDC(0)
        lRez = GetDeviceCaps(tDC, DESKTOPHORZRES)
        ReleaseDC 0, tDC
        lDPI = 96! * lRez / (Screen.Width / Screen.TwipsPerPixelX)
        mActualZoom = CSng(lDPI) / 96!
        
    End Sub
    

End Class