J
JenCarlos
Guest
Good...
Could someone please help me translate this code from Visual Basic 6.0 to C #
Option Explicit
Private fod As FileOpenDialog
Private Sub Command1_Click()
Set fod = New FileOpenDialog
Dim isiRes As IShellItem
Dim lPtr As Long
Dim FileFilter() As COMDLG_FILTERSPEC
ReDim FileFilter(0)
FileFilter(0).pszName = "All Files"
FileFilter(0).pszSpec = "*.*"
With fod
.SetTitle "Pick any file except EXE, BAT, COM"
.SetOptions FOS_FILEMUSTEXIST Or FOS_DONTADDTORECENT
.SetFileTypes 1, VarPtr(FileFilter(0).pszName)
.Show Me.hWnd
.GetResult isiRes
isiRes.GetDisplayName SIGDN_FILESYSPATH, lPtr
Text1.Text = BStrFromLPWStr(lPtr, True)
End With
Set isiRes = Nothing
Set fod = Nothing
End Sub
Private Sub Command2_Click()
Dim sFile As String
Dim sExt As String
Dim nIcoIdx As Long
Dim MII() As MENUITEMINFO
Dim miiZ As MENUITEMINFO
Dim uRec() As AssocInfo
Dim i As Long, j As Long, k As Long
Dim ieah As IEnumAssocHandlers
Dim iah As IAssocHandler
Dim hr As Long
Dim lPtr As Long
Dim sApp As String
Dim sIcon As String
Dim hIcon As Long
Dim hBmp As Long
Dim PT As POINTAPI
Dim idCmd As Long
Dim hMenu As Long
Const widBase As Long = 1000
Const sCP As String = "Choose program..."
j = -1
ReDim MII(0)
ReDim uRec(0)
sFile = Text1.Text
sExt = Right(sFile, Len(sFile) - InStrRev(sFile, ".") + 1)
'First, we use an API call to get the object that will list the handlers
'The other flag value will show all handlers- the recommended ones are the
'ones that show up in Explorer's right click open-with menu
hr = SHAssocEnumHandlers(StrPtr(sExt), ASSOC_FILTER_RECOMMENDED, ieah)
If hr <> S_OK Then Exit Sub
'now we're ready to start enumerating the handlers, in this project
'we're going to load them into a popup menu
hMenu = CreatePopupMenu()
'Most IEnum______ classes work exactly like this. .Next fills the IAssocHandler iface
Do While (ieah.Next(1, iah, 0) = 0)
If (iah Is Nothing) = False Then
j = j + 1
ReDim Preserve MII(j)
ReDim Preserve uRec(j) 'in case we need the info later
Call iah.GetUIName(lPtr) 'can't receive a LPWSTR As String like sending it
sApp = BStrFromLPWStr(lPtr)
uRec(j).sUIName = sApp
Call iah.GetName(lPtr)
sApp = BStrFromLPWStr(lPtr)
uRec(j).sPath = sApp
Call iah.GetIconLocation(lPtr, i)
sIcon = BStrFromLPWStr(lPtr)
uRec(j).sIcon = sIcon
uRec(j).nIcon = i
'association interface includes icon info for our menu
Call ExtractIconEx(sIcon, i, ByVal 0&, hIcon, 1)
If pvIsAlphaIcon(hIcon) Then
hBmp = HBitmapFromHIcon(hIcon, 16, 16) 'can't use hIcon directly
Else
hBmp = HBitmapFromHIconNoAlpha(hIcon)
End If
With MII(j)
.cbSize = Len(MII(j))
.fMask = MIIM_ID Or MIIM_STRING Or MIIM_BITMAP
.wID = widBase + j
.cch = Len(uRec(j).sUIName)
.dwTypeData = uRec(j).sUIName
.hbmpItem = hBmp
Call InsertMenuItem(hMenu, j, True, MII(j))
Call DestroyIcon(hIcon)
End With
Else
Debug.Print "iah=Nothing"
End If
Set iah = Nothing
Loop
'Add separator and open with other
miiZ.cbSize = Len(miiZ)
miiZ.fMask = MIIM_ID Or MIIM_TYPE
miiZ.fType = MFT_SEPARATOR
miiZ.wID = 9999
Call InsertMenuItem(hMenu, -1, False, miiZ)
miiZ.fMask = MIIM_ID Or MIIM_STRING
miiZ.wID = 3000
miiZ.cch = Len(sCP)
miiZ.dwTypeData = sCP
Call InsertMenuItem(hMenu, -1, False, miiZ)
Call GetCursorPos(PT)
PT.y = PT.y + 5
idCmd = TrackPopupMenu(hMenu, TPM_LEFTBUTTON Or TPM_RIGHTBUTTON Or TPM_LEFTALIGN Or TPM_TOPALIGN Or TPM_HORIZONTAL Or TPM_RETURNCMD, PT.x, PT.y, 0, Me.hWnd, 0)
Set ieah = Nothing
If idCmd Then
If idCmd = 3000 Then
OpenWith Text1.Text, OAIF_ALLOW_REGISTRATION Or OAIF_EXEC, Me.hWnd
Else
k = idCmd - widBase
' MsgBox "Handler selected: " & uRec(k).sUIName & vbCrLf & _
' uRec(k).sPath & vbCrLf & _
' "Icon=" & uRec(k).sIcon & "," & uRec(k).nIcon, _
' vbOKOnly, App.Title
'
'i know.. pidl and ishellfolder stuff is confusing, but there's no other way
Dim isf As IShellFolder
Dim pidl As Long, pidlFQ As Long
Dim zc As Long
pidlFQ = PathToPidl(sFile)
pidl = GetPIDLParent(pidlFQ)
Set isf = GetIShellFolder(isfDesktop, pidl)
Dim pidlChild As Long
pidlChild = GetItemID(pidlFQ, GIID_LAST)
'Now that we have the pidl and shellfolder representing our file, we create
'an IDataObject for it, then re-enumerate the handlers- we still have the
'selected one stored in k. it may be possible to just have an array to avoid
'the reenumeration
Dim ido As oleexp.IDataObject
Call isf.GetUIObjectOf(0, 1, pidlChild, IID_IDataObject, 0, ido)
Dim invk As IAssocHandlerInvoker
hr = SHAssocEnumHandlers(StrPtr(sExt), ASSOC_FILTER_RECOMMENDED, ieah)
Do While (ieah.Next(1, iah, 0) = 0)
If (iah Is Nothing) = False Then
If zc = k Then
'theoretically, we could take the path to the executable and
'run a launch command, but the actual invoke interfacer is a
'far better choice
Call iah.CreateInvoker(ido, invk)
invk.Invoke
Exit Do
Else
zc = zc + 1
End If
End If
Set iah = Nothing
Loop
End If
End If
If pidlFQ Then CoTaskMemFree pidlFQ
If pidl Then CoTaskMemFree pidl
If pidlChild Then CoTaskMemFree pidlChild
Set ido = Nothing
Set isf = Nothing
Set invk = Nothing
Set iah = Nothing
Set ieah = Nothing
End Sub
Option Explicit
'Declares required for using association handlers in any context
Public Enum ASSOC_FILTER
ASSOC_FILTER_NONE = &H0
ASSOC_FILTER_RECOMMENDED = &H1
End Enum
Public Type AssocInfo
sUIName As String
sPath As String
sIcon As String
nIcon As Long
End Type
Public Const S_OK = 0
Public Declare Function SHAssocEnumHandlers Lib "shell32" (ByVal pszExtra As Long, ByVal afFilter As ASSOC_FILTER, ppEnumHandler As IEnumAssocHandlers) As Long
Public Declare Function ExtractIconEx Lib "shell32.dll" Alias "ExtractIconExA" (ByVal lpszFile As String, _
ByVal nIconIndex As Long, _
phiconLarge As Long, _
phiconSmall As Long, _
ByVal nIcons As Long) As Long
Private Declare Sub CoTaskMemFree Lib "ole32.dll" (ByVal pv As Long)
Private Declare Function SysReAllocString Lib "oleaut32" (ByVal pBSTR As Long, ByVal lpWStr As Long) As Long
Public Function BStrFromLPWStr(lpWStr As Long, Optional ByVal CleanupLPWStr As Boolean = True) As String
SysReAllocString VarPtr(BStrFromLPWStr), lpWStr
If CleanupLPWStr Then CoTaskMemFree lpWStr
End Function
Option Explicit
'Public Type COMDLG_FILTERSPEC
' pszName As String
' pszSpec As String
'End Type
Private Declare Function GetDC Lib "user32" (ByVal hWnd As Long) As Long
Private Declare Function ReleaseDC Lib "user32" (ByVal hWnd As Long, ByVal hDC As Long) As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hDC As Long) As Long
Private Declare Function CreateDIBSection Lib "gdi32" (ByVal hDC As Long, pBitmapInfo As BITMAPINFO, ByVal un As Long, ByRef lplpVoid As Any, ByVal Handle As Long, ByVal dw As Long) As Long
Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hDC As Long) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hDC As Long, ByVal hObject As Long) As Long
Private Declare Function DrawIconEx Lib "user32" (ByVal hDC As Long, ByVal XLeft As Long, ByVal YTop As Long, ByVal hIcon As Long, ByVal CXWidth As Long, ByVal CYWidth As Long, ByVal istepIfAniCur As Long, ByVal hbrFlickerFreeDraw As Long, ByVal diFlags As Long) As Long
Private Declare Function GetFullPathName Lib "kernel32" Alias "GetFullPathNameA" (ByVal lpFileName As String, ByVal nBufferLength As Long, ByVal lpBuffer As String, ByVal lpFilePart As String) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Public Declare Function GetIconInfo Lib "user32" (ByVal hIcon As Long, pIconInfo As ICONINFO) As Long
Public Declare Function DestroyIcon Lib "user32.dll" (ByVal hIcon As Long) As Long
Private Declare Sub FillMemory Lib "kernel32" Alias "RtlFillMemory" (pDest As Any, ByVal dwLength As Long, ByVal bFill As Byte)
Private Declare Function SHGetMalloc Lib "shell32" (ppMalloc As IMalloc) As Long
Public Const GIID_FIRST = 1
Public Const GIID_LAST = -1
Private Const DI_NORMAL = 3
Private Const DIB_RGB_COLORS As Long = 0&
Public Type ICONINFO
fIcon As Long
XHotspot As Long
YHotspot As Long
hBMMask As Long
hBMColor As Long
End Type
Private Type BITMAPINFOHEADER
biSize As Long
biWidth As Long
biHeight As Long
biPlanes As Integer
biBitCount As Integer
biCompression As Long
biSizeImage As Long
biXPelsPerMeter As Long
biYPelsPerMeter As Long
biClrUsed As Long
biClrImportant As Long
End Type
Private Type BITMAPINFO
bmiHeader As BITMAPINFOHEADER
bmiColors(3) As Byte
End Type
Public Declare Function CreatePopupMenu Lib "user32" () As Long
Public Declare Function InsertMenuItem Lib "user32" Alias "InsertMenuItemA" (ByVal hMenu As Long, ByVal uItem As Long, ByVal fByPosition As Boolean, lpmii As MENUITEMINFO) As Boolean
Public Type MENUITEMINFO
cbSize As Long
fMask As MII_Mask
fType As MF_Type ' MIIM_TYPE
fState As MF_State ' MIIM_STATE
wID As Long ' MIIM_ID
hSubMenu As Long ' MIIM_SUBMENU
hbmpChecked As Long ' MIIM_CHECKMARKS
hbmpUnchecked As Long ' MIIM_CHECKMARKS
dwItemData As Long ' MIIM_DATA
dwTypeData As String ' MIIM_TYPE
cch As Long ' MIIM_TYPE
hbmpItem As Long
End Type
Public Enum MII_Mask
MIIM_STATE = &H1
MIIM_ID = &H2
MIIM_SUBMENU = &H4
MIIM_CHECKMARKS = &H8
MIIM_TYPE = &H10
MIIM_DATA = &H20
MIIM_BITMAP = &H80
MIIM_STRING = &H40
End Enum
' win40 -- A lot of MF_* flags have been renamed as MFT_* and MFS_* flags
Public Enum MenuFlags
MF_INSERT = &H0
MF_ENABLED = &H0
MF_UNCHECKED = &H0
MF_BYCOMMAND = &H0
MF_STRING = &H0
MF_UNHILITE = &H0
MF_GRAYED = &H1
MF_DISABLED = &H2
MF_BITMAP = &H4
MF_CHECKED = &H8
MF_POPUP = &H10
MF_MENUBARBREAK = &H20
MF_MENUBREAK = &H40
MF_HILITE = &H80
MF_CHANGE = &H80
MF_END = &H80 ' Obsolete -- only used by old RES files
MF_APPEND = &H100
MF_OWNERDRAW = &H100
MF_DELETE = &H200
MF_USECHECKBITMAPS = &H200
MF_BYPOSITION = &H400
MF_SEPARATOR = &H800
MF_REMOVE = &H1000
MF_DEFAULT = &H1000
MF_SYSMENU = &H2000
MF_HELP = &H4000
MF_RIGHTJUSTIFY = &H4000
MF_MOUSESELECT = &H8000&
End Enum
Public Enum MF_Type
MFT_STRING = MF_STRING
MFT_BITMAP = MF_BITMAP
MFT_MENUBARBREAK = MF_MENUBARBREAK
MFT_MENUBREAK = MF_MENUBREAK
MFT_OWNERDRAW = MF_OWNERDRAW
MFT_RADIOCHECK = &H200
MFT_SEPARATOR = MF_SEPARATOR
MFT_RIGHTORDER = &H2000
MFT_RIGHTJUSTIFY = MF_RIGHTJUSTIFY
End Enum
Public Enum MF_State
MFS_GRAYED = &H3
MFS_DISABLED = MFS_GRAYED
MFS_CHECKED = MF_CHECKED
MFS_HILITE = MF_HILITE
MFS_ENABLED = MF_ENABLED
MFS_UNCHECKED = MF_UNCHECKED
MFS_UNHILITE = MF_UNHILITE
MFS_DEFAULT = MF_DEFAULT
End Enum
Public Enum TPM_wFlags
TPM_LEFTBUTTON = &H0
TPM_RIGHTBUTTON = &H2
TPM_LEFTALIGN = &H0
TPM_CENTERALIGN = &H4
TPM_RIGHTALIGN = &H8
TPM_TOPALIGN = &H0
TPM_VCENTERALIGN = &H10
TPM_BOTTOMALIGN = &H20
TPM_HORIZONTAL = &H0 ' Horz alignment matters more
TPM_VERTICAL = &H40 ' Vert alignment matters more
TPM_NONOTIFY = &H80 ' Don't send any notification msgs
TPM_RETURNCMD = &H100
End Enum
Public Type POINTAPI
x As Long
y As Long
End Type
Public Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
Public Declare Function TrackPopupMenu Lib "user32" (ByVal hMenu As Long, ByVal wFlags As TPM_wFlags, ByVal x As Long, ByVal y As Long, ByVal nReserved As Long, ByVal hWnd As Long, lprc As Any) As Long
Public Declare Function SHOpenWithDialog Lib "shell32" (ByVal hWnd As Long, poainfo As OPENASINFO) As Long
Private Declare Function SHGetDesktopFolder Lib "shell32" (ppshf As IShellFolder) As Long ' Retrieves the IShellFolder interface for the desktop folder.
Public Enum OPEN_AS_INFO_FLAGS
OAIF_ALLOW_REGISTRATION = &H1 'Enable the "always use this program" checkbox. If not passed, it will be disabled.
OAIF_REGISTER_EXT = &H2 'Do the registration after the user hits the OK button.
OAIF_EXEC = &H4 'Execute file after registering.
OAIF_FORCE_REGISTRATION = &H8 'Force the Always use this program checkbox to be checked. Typically, you won't use the OAIF_ALLOW_REGISTRATION flag when you pass this value.
OAIF_HIDE_REGISTRATION = &H20 'Introduced in Windows Vista. Hide the Always use this program checkbox. If this flag is specified, the OAIF_ALLOW_REGISTRATION and OAIF_FORCE_REGISTRATION flags will be ignored.
OAIF_URL_PROTOCOL = &H40 'Introduced in Windows Vista. The value for the extension that is passed is actually a protocol, so the Open With dialog box should show applications that are registered as capable of handling that protocol.
OAIF_FILE_IS_URI = &H80 'Introduced in Windows 8. The location pointed to by the pcszFile parameter is given as a URI.
End Enum
Public Type OPENASINFO
pcszFile As Long
pcszClass As Long 'file type description for registering the type with 'always open', if not set uses extension, as in 'XYZ File'
oafInFlags As OPEN_AS_INFO_FLAGS
End Type
Public gInitToken As Long
Private Const PixelFormat32bppRGB As Long = &H22009
Private Type GdiplusStartupInput
GdiplusVersion As Long
DebugEventCallback As Long
SuppressBackgroundThread As Long
SuppressExternalCodecs As Long
End Type
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Private Type ARGB
Blue As Byte
Green As Byte
Red As Byte
Alpha As Byte
End Type
Private Type BitmapData
Width As Long
Height As Long
Stride As Long
PixelFormat As Long
Scan0 As Long
Reserved As Long
End Type
Private Enum ImageLockMode
ImageLockModeRead = &H1
ImageLockModeWrite = &H2
ImageLockModeUserInputBuf = &H4
End Enum
Private Declare Function GdiplusStartup Lib "GdiPlus.dll" (Token As Long, gdipInput As GdiplusStartupInput, GdiplusStartupOutput As Long) As Long
Private Declare Sub GdiplusShutdown Lib "GdiPlus.dll" (ByVal Token As Long)
Private Declare Function GdipCreateBitmapFromHBITMAP Lib "GdiPlus.dll" (ByVal hBmp As Long, ByVal hPal As Long, GpBitmap As Long) As Long
Private Declare Function GdipCreateBitmapFromHICON Lib "GdiPlus.dll" (ByVal hIcon As Long, GpBitmap As Long) As Long
Private Declare Function GdipGetImagePixelFormat Lib "GDIplus" (ByVal Image As Long, ByRef PixelFormat As Long) As Long
Private Declare Function GdipGetImageDimension Lib "GDIplus" (ByVal Image As Long, ByRef Width As Single, ByRef Height As Single) As Long
Private Declare Function GdipBitmapLockBits Lib "GDIplus" (ByVal BITMAP As Long, ByRef RECT As RECT, ByVal Flags As ImageLockMode, ByVal PixelFormat As Long, ByRef LockedBitmapData As BitmapData) As Long
Private Declare Function GdipBitmapUnlockBits Lib "GDIplus" (ByVal BITMAP As Long, ByRef LockedBitmapData As BitmapData) As Long
Private Declare Function GdipDisposeImage Lib "GdiPlus.dll" (ByVal Image As Long) As Long
Private Declare Function GdipCreateHBITMAPFromBitmap Lib "GDIplus" ( _
ByVal BITMAP As Long, _
ByRef hbmReturn As Long, _
ByVal background As Long) As Long
Public Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Public Sub InitGDIP()
Static Token As Long
If Token = 0 Then
Dim gdipInit As GdiplusStartupInput
gdipInit.GdiplusVersion = 1
GdiplusStartup Token, gdipInit, ByVal 0&
gInitToken = Token
End If
End Sub
Public Function HBitmapFromHIconNoAlpha(hIcon As Long) As Long
Dim himg As Long
Dim hb As Long
GdipCreateBitmapFromHICON hIcon, himg
GdipCreateHBITMAPFromBitmap himg, hb, &HFF000000
GdipDisposeImage himg
HBitmapFromHIconNoAlpha = hb
End Function
Public Function pvIsAlphaIcon(ByVal IconHandle As Long) As Boolean
On Error GoTo e0
Dim tARGB() As ARGB
Dim tRECT As RECT
Dim tICONINFO As ICONINFO
Dim tBitmapData As BitmapData
Dim lPixelFormat As Long
Dim lngX As Long
Dim lngY As Long
Dim sngWidth As Single
Dim sngHeight As Single
Dim lngArgbBmp As Long
Dim lngColorBmp As Long
Dim bolRet As Boolean
Dim hr As Long
If gInitToken = 0 Then InitGDIP
hr = GetIconInfo(IconHandle, tICONINFO)
If hr <> 0 Then
If tICONINFO.hBMColor <> 0 Then
If GdipCreateBitmapFromHBITMAP(tICONINFO.hBMColor, 0&, lngColorBmp) = 0 Then
If GdipGetImagePixelFormat(lngColorBmp, lPixelFormat) = 0 Then
If lPixelFormat <> PixelFormat32bppRGB Then
bolRet = False
Else
If GdipGetImageDimension(lngColorBmp, sngWidth, sngHeight) = 0 Then
With tRECT
.Right = CLng(sngWidth)
.Bottom = CLng(sngHeight)
End With
ReDim tARGB(tRECT.Right - 1&, tRECT.Bottom - 1&)
With tBitmapData
.Scan0 = VarPtr(tARGB(0&, 0&))
.Stride = 4& * tRECT.Right
End With
If GdipBitmapLockBits(lngColorBmp, tRECT, ImageLockModeRead Or ImageLockModeUserInputBuf, lPixelFormat, tBitmapData) = 0 Then
For lngY = 0 To tBitmapData.Height - 1
For lngX = 0 To tBitmapData.Width - 1
If tARGB(lngX, lngY).Alpha > 0 Then
If tARGB(lngX, lngY).Alpha < 255 Then
bolRet = True
Exit For
End If
End If
Next lngX
If bolRet Then Exit For
Next lngY
Call GdipDisposeImage(lngArgbBmp)
Call GdipBitmapUnlockBits(lngColorBmp, tBitmapData)
End If
End If
End If
End If
Call GdipDisposeImage(lngColorBmp)
End If
Call DeleteObject(tICONINFO.hBMColor)
End If
Call DeleteObject(tICONINFO.hBMMask)
Else
bolRet = False
End If
pvIsAlphaIcon = bolRet
On Error GoTo 0
Exit Function
e0:
Debug.Print "pvIsAlphaIcon.Error->" & Err.Description & " (" & Err.Number & ")"
End Function
Public Sub ReleaseGDIP()
GdiplusShutdown gInitToken
End Sub
Public Function PathToPidl(sPath As String) As Long
Dim Folder As IShellFolder
Dim pidlMain As Long
Dim cParsed As Long
Dim afItem As Long
Dim lFilePos As Long
Dim lR As Long
Dim sRet As String
' Make sure the file name is fully qualified
sRet = String$(MAX_PATH, 0)
lR = GetFullPathName(sPath, MAX_PATH, sRet, lFilePos)
' debug.Assert c <= cMaxPath
sPath = Left$(sRet, lR)
' Convert the path name into a pointer to an item ID list (pidl)
Set Folder = isfDesktop
' Will raise an error if path cannpt be found:
Dim sPathConv As String
sPathConv = StrConv(sPath, vbUnicode)
Call Folder.ParseDisplayName(0&, 0&, StrPtr(sPath), cParsed, pidlMain, afItem)
'If S_OK >= (Folder.ParseDisplayName(0&, 0&, StrConv(sPath, vbUnicode), cParsed, pidlMain, afItem)) Then
PathToPidl = pidlMain
'End If
End Function
Public Function GetItemIDSize(ByVal pidl As Long) As Integer
' If we try to access memory at address 0 (NULL), then it's bye-bye...
If pidl Then CopyMemory GetItemIDSize, ByVal pidl, 2
End Function
' Returns the count of item IDs in a pidl.
Public Function GetItemIDCount(ByVal pidl As Long) As Integer
Dim nItems As Integer
' If the size of an item ID is 0, then it's the zero
' value terminating item ID at the end of the pidl.
Do While GetItemIDSize(pidl)
pidl = GetNextItemID(pidl)
nItems = nItems + 1
Loop
GetItemIDCount = nItems
End Function
Public Function isMalloc() As IMalloc
Static im As IMalloc
If (im Is Nothing) Then Call SHGetMalloc(im)
Set isMalloc = im
End Function
' Returns a pointer to the next item ID in a pidl.
' Returns 0 if the next item ID is the pidl's zero value terminating 2 bytes.
Public Function GetNextItemID(ByVal pidl As Long) As Long
Dim cb As Integer ' ****EMID.cb, 2 bytes
cb = GetItemIDSize(pidl)
' Make sure it's not the zero value terminator.
If cb Then GetNextItemID = pidl + cb
End Function
' If successful, returns the size in bytes of the memory occcupied by a pidl,
' including it's 2 byte zero terminator. Returns 0 otherwise.
Public Function GetPIDLSize(ByVal pidl As Long) As Integer
Dim cb As Integer
' Error handle in case we get a bad pidl and overflow cb.
' (most item IDs are roughly 20 bytes in size, and since an item ID represents
' a folder, a pidl can never exceed 260 folders, or 5200 bytes).
On Error GoTo out
If pidl Then
Do While pidl
cb = cb + GetItemIDSize(pidl)
pidl = GetNextItemID(pidl)
Loop
' Add 2 bytes for the zero terminating item ID
GetPIDLSize = cb + 2
End If
out:
End Function
Public Function GetPIDLParent(pidl As Long, Optional fReturnDesktop As Boolean = False, Optional fFreeOldPidl As Boolean = False) As Long
Dim nCount As Integer
Dim pidl1 As Long
Dim i As Integer
Dim cb As Integer
Dim pidlNew As Long
nCount = GetItemIDCount(pidl)
If (nCount = 0) And (fReturnDesktop = False) Then Exit Function
' Get the size of all but the pidl's last item ID and zero terminator.
' (maintain the value of the original pidl, it's passed ByRef !!)
pidl1 = pidl
For i = 1 To nCount - 1
cb = cb + GetItemIDSize(pidl1)
pidl1 = GetNextItemID(pidl1)
Next
' Allocate a new item ID list with a new terminating 2 bytes.
pidlNew = isMalloc.Alloc(cb + 2)
' If the memory was allocated...
If pidlNew Then
' Copy all but the last item ID from the original pidl
' to the new pidl and zero the terminating 2 bytes.
CopyMemory ByVal pidlNew, ByVal pidl, cb
FillMemory ByVal pidlNew + cb, 2, 0
If fFreeOldPidl Then Call CoTaskMemFree(pidl)
GetPIDLParent = pidlNew
End If
End Function
Public Function GetItemID(ByVal pidl As Long, ByVal nItem As Integer) As Long
Dim nCount As Integer
Dim i As Integer
Dim cb As Integer
Dim pidlNew As Long
nCount = GetItemIDCount(pidl)
If (nItem > nCount) Or (nItem = GIID_LAST) Then nItem = nCount
' GetNextItemID returns the 2nd item ID
For i = 1 To nItem - 1: pidl = GetNextItemID(pidl): Next
' Get the size of the specified item identifier.
' If cb = 0 (the zero terminator), the we'll return a desktop pidl, proceed
cb = GetItemIDSize(pidl)
' Allocate a new item identifier list.
pidlNew = isMalloc.Alloc(cb + 2)
If pidlNew Then
' Copy the specified item identifier.
' and append the zero terminator.
CopyMemory ByVal pidlNew, ByVal pidl, cb
CopyMemory ByVal pidlNew + cb, 0, 2
GetItemID = pidlNew
End If
End Function
Public Sub DEFINE_UUID(Name As UUID, l As Long, w1 As Integer, w2 As Integer, B0 As Byte, b1 As Byte, b2 As Byte, B3 As Byte, b4 As Byte, b5 As Byte, b6 As Byte, b7 As Byte)
With Name
.Data1 = l
.Data2 = w1
.Data3 = w2
.Data4(0) = B0
.Data4(1) = b1
.Data4(2) = b2
.Data4(3) = B3
.Data4(4) = b4
.Data4(5) = b5
.Data4(6) = b6
.Data4(7) = b7
End With
End Sub
Public Sub DEFINE_OLEGUID(Name As UUID, l As Long, w1 As Integer, w2 As Integer)
DEFINE_UUID Name, l, w1, w2, &HC0, 0, 0, 0, 0, 0, 0, &H46
End Sub
Public Function IID_IDataObject() As UUID
'0000010e-0000-0000-C000-000000000046
Static IID As UUID
If (IID.Data1 = 0) Then Call DEFINE_UUID(IID, &H10E, CInt(&H0), CInt(&H0), &HC0, &H0, &H0, &H0, &H0, &H0, &H0, &H46)
IID_IDataObject = IID
End Function
Public Function IID_IShellFolder() As UUID
Static IID As UUID
If (IID.Data1 = 0) Then Call DEFINE_OLEGUID(IID, &H214E6, 0, 0)
IID_IShellFolder = IID
End Function
Public Function isfDesktop() As IShellFolder
Static isf As IShellFolder
If (isf Is Nothing) Then Call SHGetDesktopFolder(isf)
Set isfDesktop = isf
End Function
Public Function GetIShellFolder(isfParent As IShellFolder, pidlRel As Long) As IShellFolder
Dim isf As IShellFolder
On Error GoTo out
Call isfParent.BindToObject(pidlRel, 0, IID_IShellFolder, isf)
out:
If Err Or (isf Is Nothing) Then
Set GetIShellFolder = isfDesktop
Else
Set GetIShellFolder = isf
End If
End Function
Public Function OpenWith(sFile As String, lFlags As OPEN_AS_INFO_FLAGS, Optional hWndParent As Long, Optional sClass As String) As Long
Dim oai As OPENASINFO
oai.pcszFile = StrPtr(sFile)
oai.oafInFlags = lFlags
If sClass <> "" Then oai.pcszClass = StrPtr(sClass)
OpenWith = SHOpenWithDialog(hWndParent, oai)
End Function
Public Function HBitmapFromHIcon(hIcon As Long, cx As Long, cy As Long) As Long
Dim hDC As Long
Dim hBackDC As Long
Dim hBitmap As Long
Dim hBackSV As Long
hDC = GetDC(0)
hBackDC = CreateCompatibleDC(hDC)
hBitmap = Create32BitHBITMAP(hBackDC, cx, cy)
hBackSV = SelectObject(hBackDC, hBitmap)
DrawIconEx hBackDC, 0, 0, hIcon, cx, cy, 0, 0, DI_NORMAL
Call SelectObject(hBackDC, hBackSV)
Call ReleaseDC(0, hDC)
Call DeleteDC(hBackDC)
HBitmapFromHIcon = hBitmap
End Function
Public Function Create32BitHBITMAP(hDC As Long, cx As Long, cy As Long) As Long
Dim bmi As BITMAPINFO
Dim hdcUsed As Long
bmi.bmiHeader.biSize = Len(bmi.bmiHeader)
bmi.bmiHeader.biPlanes = 1
bmi.bmiHeader.biCompression = 0
bmi.bmiHeader.biWidth = cx
bmi.bmiHeader.biHeight = cy
bmi.bmiHeader.biBitCount = 32
Create32BitHBITMAP = CreateDIBSection(hDC, bmi, DIB_RGB_COLORS, ByVal 0&, 0, 0)
End Function
I want to reach this result.
First of all, Thanks.
Continue reading...
Could someone please help me translate this code from Visual Basic 6.0 to C #
Option Explicit
Private fod As FileOpenDialog
Private Sub Command1_Click()
Set fod = New FileOpenDialog
Dim isiRes As IShellItem
Dim lPtr As Long
Dim FileFilter() As COMDLG_FILTERSPEC
ReDim FileFilter(0)
FileFilter(0).pszName = "All Files"
FileFilter(0).pszSpec = "*.*"
With fod
.SetTitle "Pick any file except EXE, BAT, COM"
.SetOptions FOS_FILEMUSTEXIST Or FOS_DONTADDTORECENT
.SetFileTypes 1, VarPtr(FileFilter(0).pszName)
.Show Me.hWnd
.GetResult isiRes
isiRes.GetDisplayName SIGDN_FILESYSPATH, lPtr
Text1.Text = BStrFromLPWStr(lPtr, True)
End With
Set isiRes = Nothing
Set fod = Nothing
End Sub
Private Sub Command2_Click()
Dim sFile As String
Dim sExt As String
Dim nIcoIdx As Long
Dim MII() As MENUITEMINFO
Dim miiZ As MENUITEMINFO
Dim uRec() As AssocInfo
Dim i As Long, j As Long, k As Long
Dim ieah As IEnumAssocHandlers
Dim iah As IAssocHandler
Dim hr As Long
Dim lPtr As Long
Dim sApp As String
Dim sIcon As String
Dim hIcon As Long
Dim hBmp As Long
Dim PT As POINTAPI
Dim idCmd As Long
Dim hMenu As Long
Const widBase As Long = 1000
Const sCP As String = "Choose program..."
j = -1
ReDim MII(0)
ReDim uRec(0)
sFile = Text1.Text
sExt = Right(sFile, Len(sFile) - InStrRev(sFile, ".") + 1)
'First, we use an API call to get the object that will list the handlers
'The other flag value will show all handlers- the recommended ones are the
'ones that show up in Explorer's right click open-with menu
hr = SHAssocEnumHandlers(StrPtr(sExt), ASSOC_FILTER_RECOMMENDED, ieah)
If hr <> S_OK Then Exit Sub
'now we're ready to start enumerating the handlers, in this project
'we're going to load them into a popup menu
hMenu = CreatePopupMenu()
'Most IEnum______ classes work exactly like this. .Next fills the IAssocHandler iface
Do While (ieah.Next(1, iah, 0) = 0)
If (iah Is Nothing) = False Then
j = j + 1
ReDim Preserve MII(j)
ReDim Preserve uRec(j) 'in case we need the info later
Call iah.GetUIName(lPtr) 'can't receive a LPWSTR As String like sending it
sApp = BStrFromLPWStr(lPtr)
uRec(j).sUIName = sApp
Call iah.GetName(lPtr)
sApp = BStrFromLPWStr(lPtr)
uRec(j).sPath = sApp
Call iah.GetIconLocation(lPtr, i)
sIcon = BStrFromLPWStr(lPtr)
uRec(j).sIcon = sIcon
uRec(j).nIcon = i
'association interface includes icon info for our menu
Call ExtractIconEx(sIcon, i, ByVal 0&, hIcon, 1)
If pvIsAlphaIcon(hIcon) Then
hBmp = HBitmapFromHIcon(hIcon, 16, 16) 'can't use hIcon directly
Else
hBmp = HBitmapFromHIconNoAlpha(hIcon)
End If
With MII(j)
.cbSize = Len(MII(j))
.fMask = MIIM_ID Or MIIM_STRING Or MIIM_BITMAP
.wID = widBase + j
.cch = Len(uRec(j).sUIName)
.dwTypeData = uRec(j).sUIName
.hbmpItem = hBmp
Call InsertMenuItem(hMenu, j, True, MII(j))
Call DestroyIcon(hIcon)
End With
Else
Debug.Print "iah=Nothing"
End If
Set iah = Nothing
Loop
'Add separator and open with other
miiZ.cbSize = Len(miiZ)
miiZ.fMask = MIIM_ID Or MIIM_TYPE
miiZ.fType = MFT_SEPARATOR
miiZ.wID = 9999
Call InsertMenuItem(hMenu, -1, False, miiZ)
miiZ.fMask = MIIM_ID Or MIIM_STRING
miiZ.wID = 3000
miiZ.cch = Len(sCP)
miiZ.dwTypeData = sCP
Call InsertMenuItem(hMenu, -1, False, miiZ)
Call GetCursorPos(PT)
PT.y = PT.y + 5
idCmd = TrackPopupMenu(hMenu, TPM_LEFTBUTTON Or TPM_RIGHTBUTTON Or TPM_LEFTALIGN Or TPM_TOPALIGN Or TPM_HORIZONTAL Or TPM_RETURNCMD, PT.x, PT.y, 0, Me.hWnd, 0)
Set ieah = Nothing
If idCmd Then
If idCmd = 3000 Then
OpenWith Text1.Text, OAIF_ALLOW_REGISTRATION Or OAIF_EXEC, Me.hWnd
Else
k = idCmd - widBase
' MsgBox "Handler selected: " & uRec(k).sUIName & vbCrLf & _
' uRec(k).sPath & vbCrLf & _
' "Icon=" & uRec(k).sIcon & "," & uRec(k).nIcon, _
' vbOKOnly, App.Title
'
'i know.. pidl and ishellfolder stuff is confusing, but there's no other way
Dim isf As IShellFolder
Dim pidl As Long, pidlFQ As Long
Dim zc As Long
pidlFQ = PathToPidl(sFile)
pidl = GetPIDLParent(pidlFQ)
Set isf = GetIShellFolder(isfDesktop, pidl)
Dim pidlChild As Long
pidlChild = GetItemID(pidlFQ, GIID_LAST)
'Now that we have the pidl and shellfolder representing our file, we create
'an IDataObject for it, then re-enumerate the handlers- we still have the
'selected one stored in k. it may be possible to just have an array to avoid
'the reenumeration
Dim ido As oleexp.IDataObject
Call isf.GetUIObjectOf(0, 1, pidlChild, IID_IDataObject, 0, ido)
Dim invk As IAssocHandlerInvoker
hr = SHAssocEnumHandlers(StrPtr(sExt), ASSOC_FILTER_RECOMMENDED, ieah)
Do While (ieah.Next(1, iah, 0) = 0)
If (iah Is Nothing) = False Then
If zc = k Then
'theoretically, we could take the path to the executable and
'run a launch command, but the actual invoke interfacer is a
'far better choice
Call iah.CreateInvoker(ido, invk)
invk.Invoke
Exit Do
Else
zc = zc + 1
End If
End If
Set iah = Nothing
Loop
End If
End If
If pidlFQ Then CoTaskMemFree pidlFQ
If pidl Then CoTaskMemFree pidl
If pidlChild Then CoTaskMemFree pidlChild
Set ido = Nothing
Set isf = Nothing
Set invk = Nothing
Set iah = Nothing
Set ieah = Nothing
End Sub
Option Explicit
'Declares required for using association handlers in any context
Public Enum ASSOC_FILTER
ASSOC_FILTER_NONE = &H0
ASSOC_FILTER_RECOMMENDED = &H1
End Enum
Public Type AssocInfo
sUIName As String
sPath As String
sIcon As String
nIcon As Long
End Type
Public Const S_OK = 0
Public Declare Function SHAssocEnumHandlers Lib "shell32" (ByVal pszExtra As Long, ByVal afFilter As ASSOC_FILTER, ppEnumHandler As IEnumAssocHandlers) As Long
Public Declare Function ExtractIconEx Lib "shell32.dll" Alias "ExtractIconExA" (ByVal lpszFile As String, _
ByVal nIconIndex As Long, _
phiconLarge As Long, _
phiconSmall As Long, _
ByVal nIcons As Long) As Long
Private Declare Sub CoTaskMemFree Lib "ole32.dll" (ByVal pv As Long)
Private Declare Function SysReAllocString Lib "oleaut32" (ByVal pBSTR As Long, ByVal lpWStr As Long) As Long
Public Function BStrFromLPWStr(lpWStr As Long, Optional ByVal CleanupLPWStr As Boolean = True) As String
SysReAllocString VarPtr(BStrFromLPWStr), lpWStr
If CleanupLPWStr Then CoTaskMemFree lpWStr
End Function
Option Explicit
'Public Type COMDLG_FILTERSPEC
' pszName As String
' pszSpec As String
'End Type
Private Declare Function GetDC Lib "user32" (ByVal hWnd As Long) As Long
Private Declare Function ReleaseDC Lib "user32" (ByVal hWnd As Long, ByVal hDC As Long) As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hDC As Long) As Long
Private Declare Function CreateDIBSection Lib "gdi32" (ByVal hDC As Long, pBitmapInfo As BITMAPINFO, ByVal un As Long, ByRef lplpVoid As Any, ByVal Handle As Long, ByVal dw As Long) As Long
Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hDC As Long) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hDC As Long, ByVal hObject As Long) As Long
Private Declare Function DrawIconEx Lib "user32" (ByVal hDC As Long, ByVal XLeft As Long, ByVal YTop As Long, ByVal hIcon As Long, ByVal CXWidth As Long, ByVal CYWidth As Long, ByVal istepIfAniCur As Long, ByVal hbrFlickerFreeDraw As Long, ByVal diFlags As Long) As Long
Private Declare Function GetFullPathName Lib "kernel32" Alias "GetFullPathNameA" (ByVal lpFileName As String, ByVal nBufferLength As Long, ByVal lpBuffer As String, ByVal lpFilePart As String) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Public Declare Function GetIconInfo Lib "user32" (ByVal hIcon As Long, pIconInfo As ICONINFO) As Long
Public Declare Function DestroyIcon Lib "user32.dll" (ByVal hIcon As Long) As Long
Private Declare Sub FillMemory Lib "kernel32" Alias "RtlFillMemory" (pDest As Any, ByVal dwLength As Long, ByVal bFill As Byte)
Private Declare Function SHGetMalloc Lib "shell32" (ppMalloc As IMalloc) As Long
Public Const GIID_FIRST = 1
Public Const GIID_LAST = -1
Private Const DI_NORMAL = 3
Private Const DIB_RGB_COLORS As Long = 0&
Public Type ICONINFO
fIcon As Long
XHotspot As Long
YHotspot As Long
hBMMask As Long
hBMColor As Long
End Type
Private Type BITMAPINFOHEADER
biSize As Long
biWidth As Long
biHeight As Long
biPlanes As Integer
biBitCount As Integer
biCompression As Long
biSizeImage As Long
biXPelsPerMeter As Long
biYPelsPerMeter As Long
biClrUsed As Long
biClrImportant As Long
End Type
Private Type BITMAPINFO
bmiHeader As BITMAPINFOHEADER
bmiColors(3) As Byte
End Type
Public Declare Function CreatePopupMenu Lib "user32" () As Long
Public Declare Function InsertMenuItem Lib "user32" Alias "InsertMenuItemA" (ByVal hMenu As Long, ByVal uItem As Long, ByVal fByPosition As Boolean, lpmii As MENUITEMINFO) As Boolean
Public Type MENUITEMINFO
cbSize As Long
fMask As MII_Mask
fType As MF_Type ' MIIM_TYPE
fState As MF_State ' MIIM_STATE
wID As Long ' MIIM_ID
hSubMenu As Long ' MIIM_SUBMENU
hbmpChecked As Long ' MIIM_CHECKMARKS
hbmpUnchecked As Long ' MIIM_CHECKMARKS
dwItemData As Long ' MIIM_DATA
dwTypeData As String ' MIIM_TYPE
cch As Long ' MIIM_TYPE
hbmpItem As Long
End Type
Public Enum MII_Mask
MIIM_STATE = &H1
MIIM_ID = &H2
MIIM_SUBMENU = &H4
MIIM_CHECKMARKS = &H8
MIIM_TYPE = &H10
MIIM_DATA = &H20
MIIM_BITMAP = &H80
MIIM_STRING = &H40
End Enum
' win40 -- A lot of MF_* flags have been renamed as MFT_* and MFS_* flags
Public Enum MenuFlags
MF_INSERT = &H0
MF_ENABLED = &H0
MF_UNCHECKED = &H0
MF_BYCOMMAND = &H0
MF_STRING = &H0
MF_UNHILITE = &H0
MF_GRAYED = &H1
MF_DISABLED = &H2
MF_BITMAP = &H4
MF_CHECKED = &H8
MF_POPUP = &H10
MF_MENUBARBREAK = &H20
MF_MENUBREAK = &H40
MF_HILITE = &H80
MF_CHANGE = &H80
MF_END = &H80 ' Obsolete -- only used by old RES files
MF_APPEND = &H100
MF_OWNERDRAW = &H100
MF_DELETE = &H200
MF_USECHECKBITMAPS = &H200
MF_BYPOSITION = &H400
MF_SEPARATOR = &H800
MF_REMOVE = &H1000
MF_DEFAULT = &H1000
MF_SYSMENU = &H2000
MF_HELP = &H4000
MF_RIGHTJUSTIFY = &H4000
MF_MOUSESELECT = &H8000&
End Enum
Public Enum MF_Type
MFT_STRING = MF_STRING
MFT_BITMAP = MF_BITMAP
MFT_MENUBARBREAK = MF_MENUBARBREAK
MFT_MENUBREAK = MF_MENUBREAK
MFT_OWNERDRAW = MF_OWNERDRAW
MFT_RADIOCHECK = &H200
MFT_SEPARATOR = MF_SEPARATOR
MFT_RIGHTORDER = &H2000
MFT_RIGHTJUSTIFY = MF_RIGHTJUSTIFY
End Enum
Public Enum MF_State
MFS_GRAYED = &H3
MFS_DISABLED = MFS_GRAYED
MFS_CHECKED = MF_CHECKED
MFS_HILITE = MF_HILITE
MFS_ENABLED = MF_ENABLED
MFS_UNCHECKED = MF_UNCHECKED
MFS_UNHILITE = MF_UNHILITE
MFS_DEFAULT = MF_DEFAULT
End Enum
Public Enum TPM_wFlags
TPM_LEFTBUTTON = &H0
TPM_RIGHTBUTTON = &H2
TPM_LEFTALIGN = &H0
TPM_CENTERALIGN = &H4
TPM_RIGHTALIGN = &H8
TPM_TOPALIGN = &H0
TPM_VCENTERALIGN = &H10
TPM_BOTTOMALIGN = &H20
TPM_HORIZONTAL = &H0 ' Horz alignment matters more
TPM_VERTICAL = &H40 ' Vert alignment matters more
TPM_NONOTIFY = &H80 ' Don't send any notification msgs
TPM_RETURNCMD = &H100
End Enum
Public Type POINTAPI
x As Long
y As Long
End Type
Public Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
Public Declare Function TrackPopupMenu Lib "user32" (ByVal hMenu As Long, ByVal wFlags As TPM_wFlags, ByVal x As Long, ByVal y As Long, ByVal nReserved As Long, ByVal hWnd As Long, lprc As Any) As Long
Public Declare Function SHOpenWithDialog Lib "shell32" (ByVal hWnd As Long, poainfo As OPENASINFO) As Long
Private Declare Function SHGetDesktopFolder Lib "shell32" (ppshf As IShellFolder) As Long ' Retrieves the IShellFolder interface for the desktop folder.
Public Enum OPEN_AS_INFO_FLAGS
OAIF_ALLOW_REGISTRATION = &H1 'Enable the "always use this program" checkbox. If not passed, it will be disabled.
OAIF_REGISTER_EXT = &H2 'Do the registration after the user hits the OK button.
OAIF_EXEC = &H4 'Execute file after registering.
OAIF_FORCE_REGISTRATION = &H8 'Force the Always use this program checkbox to be checked. Typically, you won't use the OAIF_ALLOW_REGISTRATION flag when you pass this value.
OAIF_HIDE_REGISTRATION = &H20 'Introduced in Windows Vista. Hide the Always use this program checkbox. If this flag is specified, the OAIF_ALLOW_REGISTRATION and OAIF_FORCE_REGISTRATION flags will be ignored.
OAIF_URL_PROTOCOL = &H40 'Introduced in Windows Vista. The value for the extension that is passed is actually a protocol, so the Open With dialog box should show applications that are registered as capable of handling that protocol.
OAIF_FILE_IS_URI = &H80 'Introduced in Windows 8. The location pointed to by the pcszFile parameter is given as a URI.
End Enum
Public Type OPENASINFO
pcszFile As Long
pcszClass As Long 'file type description for registering the type with 'always open', if not set uses extension, as in 'XYZ File'
oafInFlags As OPEN_AS_INFO_FLAGS
End Type
Public gInitToken As Long
Private Const PixelFormat32bppRGB As Long = &H22009
Private Type GdiplusStartupInput
GdiplusVersion As Long
DebugEventCallback As Long
SuppressBackgroundThread As Long
SuppressExternalCodecs As Long
End Type
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Private Type ARGB
Blue As Byte
Green As Byte
Red As Byte
Alpha As Byte
End Type
Private Type BitmapData
Width As Long
Height As Long
Stride As Long
PixelFormat As Long
Scan0 As Long
Reserved As Long
End Type
Private Enum ImageLockMode
ImageLockModeRead = &H1
ImageLockModeWrite = &H2
ImageLockModeUserInputBuf = &H4
End Enum
Private Declare Function GdiplusStartup Lib "GdiPlus.dll" (Token As Long, gdipInput As GdiplusStartupInput, GdiplusStartupOutput As Long) As Long
Private Declare Sub GdiplusShutdown Lib "GdiPlus.dll" (ByVal Token As Long)
Private Declare Function GdipCreateBitmapFromHBITMAP Lib "GdiPlus.dll" (ByVal hBmp As Long, ByVal hPal As Long, GpBitmap As Long) As Long
Private Declare Function GdipCreateBitmapFromHICON Lib "GdiPlus.dll" (ByVal hIcon As Long, GpBitmap As Long) As Long
Private Declare Function GdipGetImagePixelFormat Lib "GDIplus" (ByVal Image As Long, ByRef PixelFormat As Long) As Long
Private Declare Function GdipGetImageDimension Lib "GDIplus" (ByVal Image As Long, ByRef Width As Single, ByRef Height As Single) As Long
Private Declare Function GdipBitmapLockBits Lib "GDIplus" (ByVal BITMAP As Long, ByRef RECT As RECT, ByVal Flags As ImageLockMode, ByVal PixelFormat As Long, ByRef LockedBitmapData As BitmapData) As Long
Private Declare Function GdipBitmapUnlockBits Lib "GDIplus" (ByVal BITMAP As Long, ByRef LockedBitmapData As BitmapData) As Long
Private Declare Function GdipDisposeImage Lib "GdiPlus.dll" (ByVal Image As Long) As Long
Private Declare Function GdipCreateHBITMAPFromBitmap Lib "GDIplus" ( _
ByVal BITMAP As Long, _
ByRef hbmReturn As Long, _
ByVal background As Long) As Long
Public Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Public Sub InitGDIP()
Static Token As Long
If Token = 0 Then
Dim gdipInit As GdiplusStartupInput
gdipInit.GdiplusVersion = 1
GdiplusStartup Token, gdipInit, ByVal 0&
gInitToken = Token
End If
End Sub
Public Function HBitmapFromHIconNoAlpha(hIcon As Long) As Long
Dim himg As Long
Dim hb As Long
GdipCreateBitmapFromHICON hIcon, himg
GdipCreateHBITMAPFromBitmap himg, hb, &HFF000000
GdipDisposeImage himg
HBitmapFromHIconNoAlpha = hb
End Function
Public Function pvIsAlphaIcon(ByVal IconHandle As Long) As Boolean
On Error GoTo e0
Dim tARGB() As ARGB
Dim tRECT As RECT
Dim tICONINFO As ICONINFO
Dim tBitmapData As BitmapData
Dim lPixelFormat As Long
Dim lngX As Long
Dim lngY As Long
Dim sngWidth As Single
Dim sngHeight As Single
Dim lngArgbBmp As Long
Dim lngColorBmp As Long
Dim bolRet As Boolean
Dim hr As Long
If gInitToken = 0 Then InitGDIP
hr = GetIconInfo(IconHandle, tICONINFO)
If hr <> 0 Then
If tICONINFO.hBMColor <> 0 Then
If GdipCreateBitmapFromHBITMAP(tICONINFO.hBMColor, 0&, lngColorBmp) = 0 Then
If GdipGetImagePixelFormat(lngColorBmp, lPixelFormat) = 0 Then
If lPixelFormat <> PixelFormat32bppRGB Then
bolRet = False
Else
If GdipGetImageDimension(lngColorBmp, sngWidth, sngHeight) = 0 Then
With tRECT
.Right = CLng(sngWidth)
.Bottom = CLng(sngHeight)
End With
ReDim tARGB(tRECT.Right - 1&, tRECT.Bottom - 1&)
With tBitmapData
.Scan0 = VarPtr(tARGB(0&, 0&))
.Stride = 4& * tRECT.Right
End With
If GdipBitmapLockBits(lngColorBmp, tRECT, ImageLockModeRead Or ImageLockModeUserInputBuf, lPixelFormat, tBitmapData) = 0 Then
For lngY = 0 To tBitmapData.Height - 1
For lngX = 0 To tBitmapData.Width - 1
If tARGB(lngX, lngY).Alpha > 0 Then
If tARGB(lngX, lngY).Alpha < 255 Then
bolRet = True
Exit For
End If
End If
Next lngX
If bolRet Then Exit For
Next lngY
Call GdipDisposeImage(lngArgbBmp)
Call GdipBitmapUnlockBits(lngColorBmp, tBitmapData)
End If
End If
End If
End If
Call GdipDisposeImage(lngColorBmp)
End If
Call DeleteObject(tICONINFO.hBMColor)
End If
Call DeleteObject(tICONINFO.hBMMask)
Else
bolRet = False
End If
pvIsAlphaIcon = bolRet
On Error GoTo 0
Exit Function
e0:
Debug.Print "pvIsAlphaIcon.Error->" & Err.Description & " (" & Err.Number & ")"
End Function
Public Sub ReleaseGDIP()
GdiplusShutdown gInitToken
End Sub
Public Function PathToPidl(sPath As String) As Long
Dim Folder As IShellFolder
Dim pidlMain As Long
Dim cParsed As Long
Dim afItem As Long
Dim lFilePos As Long
Dim lR As Long
Dim sRet As String
' Make sure the file name is fully qualified
sRet = String$(MAX_PATH, 0)
lR = GetFullPathName(sPath, MAX_PATH, sRet, lFilePos)
' debug.Assert c <= cMaxPath
sPath = Left$(sRet, lR)
' Convert the path name into a pointer to an item ID list (pidl)
Set Folder = isfDesktop
' Will raise an error if path cannpt be found:
Dim sPathConv As String
sPathConv = StrConv(sPath, vbUnicode)
Call Folder.ParseDisplayName(0&, 0&, StrPtr(sPath), cParsed, pidlMain, afItem)
'If S_OK >= (Folder.ParseDisplayName(0&, 0&, StrConv(sPath, vbUnicode), cParsed, pidlMain, afItem)) Then
PathToPidl = pidlMain
'End If
End Function
Public Function GetItemIDSize(ByVal pidl As Long) As Integer
' If we try to access memory at address 0 (NULL), then it's bye-bye...
If pidl Then CopyMemory GetItemIDSize, ByVal pidl, 2
End Function
' Returns the count of item IDs in a pidl.
Public Function GetItemIDCount(ByVal pidl As Long) As Integer
Dim nItems As Integer
' If the size of an item ID is 0, then it's the zero
' value terminating item ID at the end of the pidl.
Do While GetItemIDSize(pidl)
pidl = GetNextItemID(pidl)
nItems = nItems + 1
Loop
GetItemIDCount = nItems
End Function
Public Function isMalloc() As IMalloc
Static im As IMalloc
If (im Is Nothing) Then Call SHGetMalloc(im)
Set isMalloc = im
End Function
' Returns a pointer to the next item ID in a pidl.
' Returns 0 if the next item ID is the pidl's zero value terminating 2 bytes.
Public Function GetNextItemID(ByVal pidl As Long) As Long
Dim cb As Integer ' ****EMID.cb, 2 bytes
cb = GetItemIDSize(pidl)
' Make sure it's not the zero value terminator.
If cb Then GetNextItemID = pidl + cb
End Function
' If successful, returns the size in bytes of the memory occcupied by a pidl,
' including it's 2 byte zero terminator. Returns 0 otherwise.
Public Function GetPIDLSize(ByVal pidl As Long) As Integer
Dim cb As Integer
' Error handle in case we get a bad pidl and overflow cb.
' (most item IDs are roughly 20 bytes in size, and since an item ID represents
' a folder, a pidl can never exceed 260 folders, or 5200 bytes).
On Error GoTo out
If pidl Then
Do While pidl
cb = cb + GetItemIDSize(pidl)
pidl = GetNextItemID(pidl)
Loop
' Add 2 bytes for the zero terminating item ID
GetPIDLSize = cb + 2
End If
out:
End Function
Public Function GetPIDLParent(pidl As Long, Optional fReturnDesktop As Boolean = False, Optional fFreeOldPidl As Boolean = False) As Long
Dim nCount As Integer
Dim pidl1 As Long
Dim i As Integer
Dim cb As Integer
Dim pidlNew As Long
nCount = GetItemIDCount(pidl)
If (nCount = 0) And (fReturnDesktop = False) Then Exit Function
' Get the size of all but the pidl's last item ID and zero terminator.
' (maintain the value of the original pidl, it's passed ByRef !!)
pidl1 = pidl
For i = 1 To nCount - 1
cb = cb + GetItemIDSize(pidl1)
pidl1 = GetNextItemID(pidl1)
Next
' Allocate a new item ID list with a new terminating 2 bytes.
pidlNew = isMalloc.Alloc(cb + 2)
' If the memory was allocated...
If pidlNew Then
' Copy all but the last item ID from the original pidl
' to the new pidl and zero the terminating 2 bytes.
CopyMemory ByVal pidlNew, ByVal pidl, cb
FillMemory ByVal pidlNew + cb, 2, 0
If fFreeOldPidl Then Call CoTaskMemFree(pidl)
GetPIDLParent = pidlNew
End If
End Function
Public Function GetItemID(ByVal pidl As Long, ByVal nItem As Integer) As Long
Dim nCount As Integer
Dim i As Integer
Dim cb As Integer
Dim pidlNew As Long
nCount = GetItemIDCount(pidl)
If (nItem > nCount) Or (nItem = GIID_LAST) Then nItem = nCount
' GetNextItemID returns the 2nd item ID
For i = 1 To nItem - 1: pidl = GetNextItemID(pidl): Next
' Get the size of the specified item identifier.
' If cb = 0 (the zero terminator), the we'll return a desktop pidl, proceed
cb = GetItemIDSize(pidl)
' Allocate a new item identifier list.
pidlNew = isMalloc.Alloc(cb + 2)
If pidlNew Then
' Copy the specified item identifier.
' and append the zero terminator.
CopyMemory ByVal pidlNew, ByVal pidl, cb
CopyMemory ByVal pidlNew + cb, 0, 2
GetItemID = pidlNew
End If
End Function
Public Sub DEFINE_UUID(Name As UUID, l As Long, w1 As Integer, w2 As Integer, B0 As Byte, b1 As Byte, b2 As Byte, B3 As Byte, b4 As Byte, b5 As Byte, b6 As Byte, b7 As Byte)
With Name
.Data1 = l
.Data2 = w1
.Data3 = w2
.Data4(0) = B0
.Data4(1) = b1
.Data4(2) = b2
.Data4(3) = B3
.Data4(4) = b4
.Data4(5) = b5
.Data4(6) = b6
.Data4(7) = b7
End With
End Sub
Public Sub DEFINE_OLEGUID(Name As UUID, l As Long, w1 As Integer, w2 As Integer)
DEFINE_UUID Name, l, w1, w2, &HC0, 0, 0, 0, 0, 0, 0, &H46
End Sub
Public Function IID_IDataObject() As UUID
'0000010e-0000-0000-C000-000000000046
Static IID As UUID
If (IID.Data1 = 0) Then Call DEFINE_UUID(IID, &H10E, CInt(&H0), CInt(&H0), &HC0, &H0, &H0, &H0, &H0, &H0, &H0, &H46)
IID_IDataObject = IID
End Function
Public Function IID_IShellFolder() As UUID
Static IID As UUID
If (IID.Data1 = 0) Then Call DEFINE_OLEGUID(IID, &H214E6, 0, 0)
IID_IShellFolder = IID
End Function
Public Function isfDesktop() As IShellFolder
Static isf As IShellFolder
If (isf Is Nothing) Then Call SHGetDesktopFolder(isf)
Set isfDesktop = isf
End Function
Public Function GetIShellFolder(isfParent As IShellFolder, pidlRel As Long) As IShellFolder
Dim isf As IShellFolder
On Error GoTo out
Call isfParent.BindToObject(pidlRel, 0, IID_IShellFolder, isf)
out:
If Err Or (isf Is Nothing) Then
Set GetIShellFolder = isfDesktop
Else
Set GetIShellFolder = isf
End If
End Function
Public Function OpenWith(sFile As String, lFlags As OPEN_AS_INFO_FLAGS, Optional hWndParent As Long, Optional sClass As String) As Long
Dim oai As OPENASINFO
oai.pcszFile = StrPtr(sFile)
oai.oafInFlags = lFlags
If sClass <> "" Then oai.pcszClass = StrPtr(sClass)
OpenWith = SHOpenWithDialog(hWndParent, oai)
End Function
Public Function HBitmapFromHIcon(hIcon As Long, cx As Long, cy As Long) As Long
Dim hDC As Long
Dim hBackDC As Long
Dim hBitmap As Long
Dim hBackSV As Long
hDC = GetDC(0)
hBackDC = CreateCompatibleDC(hDC)
hBitmap = Create32BitHBITMAP(hBackDC, cx, cy)
hBackSV = SelectObject(hBackDC, hBitmap)
DrawIconEx hBackDC, 0, 0, hIcon, cx, cy, 0, 0, DI_NORMAL
Call SelectObject(hBackDC, hBackSV)
Call ReleaseDC(0, hDC)
Call DeleteDC(hBackDC)
HBitmapFromHIcon = hBitmap
End Function
Public Function Create32BitHBITMAP(hDC As Long, cx As Long, cy As Long) As Long
Dim bmi As BITMAPINFO
Dim hdcUsed As Long
bmi.bmiHeader.biSize = Len(bmi.bmiHeader)
bmi.bmiHeader.biPlanes = 1
bmi.bmiHeader.biCompression = 0
bmi.bmiHeader.biWidth = cx
bmi.bmiHeader.biHeight = cy
bmi.bmiHeader.biBitCount = 32
Create32BitHBITMAP = CreateDIBSection(hDC, bmi, DIB_RGB_COLORS, ByVal 0&, 0, 0)
End Function
I want to reach this result.
First of all, Thanks.
Continue reading...
