Option Explicit
Private Type Rect
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Private Declare Function EnumDisplayMonitors Lib "user32" (ByVal hDC As Long, ByVal lprcClip As Long, ByVal lpfnEnum As Long, dwData As Long) As Long
Private Declare Function CombineRgn Lib "gdi32.dll" (ByVal hDestRgn As Long, ByVal hSrcRgn1 As Long, ByVal hSrcRgn2 As Long, ByVal nCombineMode As Long) As Long
Private Declare Function CreateRectRgnIndirect Lib "gdi32.dll" (ByRef lpRect As Rect) As Long
Private Declare Function GetWindowRect Lib "user32.dll" (ByVal hWnd As Long, ByRef lpRect As Rect) As Long
Private Declare Function DeleteObject Lib "gdi32.dll" (ByVal hObject As Long) As Long
Private Const API_TRUE = 1
Private Const RGN_OR As Long = 2
Private Const RGN_DIFF As Long = 4
Private Const NULLREGION As Long = 1
Private Function MonitorEnumProc(ByVal lngMonitorHandle As Long, _
ByVal lngMonitorHDC As Long, _
ByRef typWorkingScreen As Rect, _
ByRef lngDesktopRegionHandle As Long) As Long
Dim lngWorkingScreenRegion As Long
' Make the screen's rect into a region
lngWorkingScreenRegion = CreateRectRgnIndirect(typWorkingScreen)
' Combine it with all the desktops so far.
CombineRgn lngDesktopRegionHandle, lngWorkingScreenRegion, lngDesktopRegionHandle, RGN_OR
' Dispose of the screen's region
DeleteObject lngWorkingScreenRegion
' Proceeed to the next screen
MonitorEnumProc = API_TRUE
End Function
Public Function hWndIsInDesktopRegion(ByVal hWnd As Long) As Boolean
Dim typRect As Rect
Dim lngSrcRegionHandle As Long
Dim lngDesktopRegionHandle As Long
' Create an empty region that will be used to combine the desktop regions into
' typRect is empty at init per VB convention
lngDesktopRegionHandle = CreateRectRgnIndirect(typRect)
' Create a region that is the window we are interested in
GetWindowRect hWnd, typRect
lngSrcRegionHandle = CreateRectRgnIndirect(typRect)
' Enum the monitors to create the desktop region.
Call EnumDisplayMonitors(0&, 0&, AddressOf MonitorEnumProc, lngDesktopRegionHandle)
' Test to see if our region is in the combined region
If CombineRgn(lngDesktopRegionHandle, lngSrcRegionHandle, lngDesktopRegionHandle, RGN_DIFF) = NULLREGION Then
hWndIsInDesktopRegion = True
Else
hWndIsInDesktopRegion = False
End If
' Dispose of the local and desktop regions
DeleteObject lngSrcRegionHandle
DeleteObject lngDesktopRegionHandle
End Function
Option Explicit
Public Declare Function ILCreateFromPathW Lib "shell32" (ByVal pwszPath As Long) As Long
Public Declare Sub ILFree Lib "shell32" (ByVal pidl As Long)
Public Declare Function SHBindToParent Lib "shell32" (ByVal pidl As Long, riid As UUID, ppv As Any, pidlLast As Long) As Long
Public Declare Function SHCreateStreamOnFileEx Lib "shlwapi" (ByVal pszFile As Long, ByVal grfMode As STGM, ByVal dwAttributes As FILE_ATTRIBUTES, ByVal fCreate As Long, ByVal pstmTemplate As Long, ppstm As oleexp3.IStream) As Long
Public Declare Function PathFileExistsW Lib "shlwapi" (ByVal lpszPath As Long) As Long
Public Declare Function CreateDirectoryW Lib "kernel32" (ByVal lpPathName As Long, ByVal lpSecurityAttributes As Any) As Long
Public Declare Function SysReAllocString Lib "oleaut32.dll" (ByVal pBSTR As Long, Optional ByVal pszStrPtr As Long) As Long
Public Declare Sub CoTaskMemFree Lib "ole32.dll" (ByVal PV As Long) ' Frees memory allocated by the shell
Public Const NOERROR = 0&
Public Const FILE_ATTRIBUTE_NORMAL = &H80
Public Sub UnzipFile(sFile As String, Optional ByVal sTo As String = "")
'unzip without 3rd party dll
Dim psfParent As oleexp3.IShellFolder
Dim pidlFQ As Long
Dim pidlChild As Long
Dim pszDest As String
If sTo = "" Then
'defaults to create a folder with the zip's name in the same folder as the zip
pszDest = sFile
pszDest = Left$(pszDest, Len(pszDest) - 4) 'remove .zip
Else
pszDest = sTo
End If
'First, we need the parent pidl, child pidl, and IShellFolder
'These are all references to the file very common in shell programming
pidlFQ = ILCreateFromPathW(StrPtr(sFile))
Call SHBindToParent(pidlFQ, IID_IShellFolder, psfParent, pidlChild)
If (psfParent Is Nothing) Or (pidlChild = 0) Then
Debug.Print "UnzipFile.Failed to bind to file"
Exit Sub
End If
'Now that we have the IShellFolder, we want the IStorage object
'That is what we'll be able to extract from, thanks to the
'very low level system zip integration with zipfldr.dll
Dim pStg As oleexp3.IStorage
psfParent.BindToObject pidlChild, 0, IID_IStorage, pStg
If (pStg Is Nothing) Then
Debug.Print "UnzipFile.Failed to bind to storage"
Exit Sub
End If
Debug.Print "UnzipFile.extract to " & pszDest
StgExtract pStg, pszDest
Set pStg = Nothing
Set psfParent = Nothing
ILFree pidlFQ
End Sub
Private Sub StgExtract(pStg As oleexp3.IStorage, pszTargetDir As String, Optional fOverwrite As Long = 0)
'This function is recursively called to extract zipped files and folders
'First, create the target directory (even if you're extracting to an existing folder, it create subfolders from the zip)
If (PathFileExistsW(StrPtr(pszTargetDir)) = 0) Then
Call CreateDirectoryW(StrPtr(pszTargetDir), ByVal 0&)
If (PathFileExistsW(StrPtr(pszTargetDir)) = 0) Then
Debug.Print "StgExtract.Failed to create directory " & pszTargetDir
Exit Sub
End If
End If
'The enumerator will loop through each storage object
'Here, that will be zipped files and folders
Dim pEnum As IEnumSTATSTG
Set pEnum = pStg.EnumElements(0, 0, 0)
If (pEnum Is Nothing) Then
Debug.Print "StgExtract.pEnum==nothing"
Exit Sub
End If
Dim celtFetched As Long
Dim stat As STATSTG
Dim pszPath As String
Do While (pEnum.Next(1, stat, celtFetched) = NOERROR)
pszPath = SysAllocString(stat.pwcsName) 'contains a file name
' Debug.Print "pszPath on alloc=" & pszPath
If (Len(pszPath) > 1) Then
pszPath = AddBackslash(pszTargetDir) & pszPath 'combine that with the path (recursive, so can be zipped folder path)
' Debug.Print "pszPath on combine=" & pszPath
If stat.Type = STGTY_STORAGE Then 'subfolder
Dim pStgSubfolder As oleexp3.IStorage
Set pStgSubfolder = pStg.OpenStorage(SysAllocString(stat.pwcsName), 0, STGM_READ, 0, 0)
If (pStgSubfolder Is Nothing) Then
Debug.Print "StgExtract.pstgsubfolder==nothing"
Exit Sub
End If
StgExtract pStgSubfolder, pszPath 'and if there's more subfolders, we'll go deeper
ElseIf stat.Type = STGTY_STREAM Then 'file
'the basic idea here is that we obtain an IStream representing the existing file,
'and an IStream representing the new extracted file, and copy the contents into the new file
Dim pStrm As oleexp3.IStream
Set pStrm = pStg.OpenStream(SysAllocString(stat.pwcsName), 0, STGM_READ, 0)
Dim pStrmFile As oleexp3.IStream
'here we add an option to not overwrite existing files; but the default is to overwrite
'set fOverwrite to anything non-zero and the file is skipped
'If we are extracting it, we call an API to create a new file with an IStream to write to it
If PathFileExistsW(StrPtr(pszPath)) Then
If fOverwrite Then
Call SHCreateStreamOnFileEx(StrPtr(pszPath), STGM_CREATE Or STGM_WRITE, FILE_ATTRIBUTE_NORMAL, 1, 0, pStrmFile)
End If
Else
Call SHCreateStreamOnFileEx(StrPtr(pszPath), STGM_CREATE Or STGM_WRITE, FILE_ATTRIBUTE_NORMAL, 1, 0, pStrmFile)
End If
If (pStrmFile Is Nothing) = False Then
'Debug.Print "StgExtract.Got pstrmfile"
Dim cbSize As Currency 'the STATSTG cbSize is ULONGLONG (equiv. to Currency), so files >2GB should be fine
pStrm.CopyTo pStrmFile, stat.cbSize, 0, cbSize
Set pStrmFile = Nothing
'Debug.Print "StgExtract.bytes written=" & CStr(cbSize)
Else
'either an error or skipped an existing file; either way we don't exit, we'll move on to the next
'Debug.Print "StgExtract.pstrmfile==nothing"
End If
Set pStrm = Nothing
End If
End If
pszPath = ""
Call CoTaskMemFree(stat.pwcsName) 'this memory needs to be freed, otherwise you'll leak memory
Loop
Set pEnum = Nothing
End Sub
Public Function LPWSTRtoStr(lPtr As Long, Optional ByVal fFree As Boolean = True) As String
SysReAllocString VarPtr(LPWSTRtoStr), lPtr
If fFree Then
Call CoTaskMemFree(lPtr)
End If
End Function
Public Function AddBackslash(s As String) As String
If Len(s) > 0 Then
If Right$(s, 1) <> "\" Then
AddBackslash = s & "\"
Else
AddBackslash = s
End If
Else
AddBackslash = "\"
End If
End Function
Public Function IID_IStorage() As UUID
'({0000000B-0000-0000-C000-000000000046})
Static iid As UUID
If (iid.Data1 = 0) Then Call DEFINE_OLEGUID(iid, &HB, 0, 0)
IID_IStorage = iid
End Function
'-----------------------------------------------------------
'Below this is not needed if you're using mIID.bas
'(check if the above IID_IStorage exists or not, because this was released before the update that included it)
'-----------------------------------------------------------
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_IShellFolder() As UUID
Static iid As UUID
If (iid.Data1 = 0) Then Call DEFINE_OLEGUID(iid, &H214E6, 0, 0)
IID_IShellFolder = iid
End FunctionPublic Function GetFileSecurityZone(sFile As String) As URLZONE
'returns the Zone Identifier of a file, using IZoneIdentifier
'This could also be done by ready the Zone.Identifier alternate
'data stream directly; readfile C:\file.txt:Zone.Identifier
Dim lz As Long
Dim pZI As PersistentZoneIdentifier
Set pZI = New PersistentZoneIdentifier
Dim pIPF As IPersistFile
Set pIPF = pZI
pIPF.Load sFile, STGM_READ
pZI.GetId lz
GetFileSecurityZone = lz
Set pIPF = Nothing
Set pZI = Nothing
End Function
Public Sub SetFileSecurityZone(sFile As String, nZone As URLZONE)
'As suggested in the enum, you technically can set it to custom values
'If you do, they should be between 1000 and 10000.
Dim pZI As PersistentZoneIdentifier
Set pZI = New PersistentZoneIdentifier
pZI.SetId nZone
Dim pIPF As IPersistFile
Set pIPF = pZI
pIPF.Save sFile, 1
Set pIPF = Nothing
Set pZI = Nothing
End Sub
Public Sub RemoveFileSecurityZone(sFile As String)
Dim pZI As PersistentZoneIdentifier
Set pZI = New PersistentZoneIdentifier
pZI.Remove
Dim pIPF As IPersistFile
Set pIPF = pZI
pIPF.Save sFile, 1
Set pIPF = Nothing
Set pZI = Nothing
End Sub EnumSvcs v1.0.zip (7.3 KB) |
' a Long array was sized as: myArray(0 to 49, 0 to 2499) and you want to save it
cStrmMgr.AddStreamFromPointer myArray(0,0), 500000, "Spreadsheet1"
' now lets say you want to recall that data
Dim bytesRead As Long
ReDim myArray(0 to 49, 0 to 2499)
' next line identifies the receiving buffer, bytes to read, variable to return bytes read, where to start reading & what Key
cStrmMgr.ReadStream myArray(0, 0), 500000, bytesRead, 0, "SpreadSheet1"
If bytesRead = 500000 Then ' read all datacStrmMgr.AddStreamFromFile "C:\Temp\SomeFile.any", "History"
' Let's say you don't need the history file any longer and just want to purge it
cStrmMgr.ReleaseStream "History"cStrmMgr.AddStreamFromStringVB RTB.TextRTF, "RTFbackup"
' and lets say you want to return that stream into a VB string:
Dim sText As String
cStrmMgr.SaveStreamToStringVB sText, "RTFbackup"Dim myStream As IUnknown ' or IStream if you have such a TLB
Set myStream = cStrmMgr.StreamObject(myKey) ' get instance of stream
cStrmMgr.ReleaseStream myKey ' detach from class, no longer maintained by the classcStrmMgr.AddStreamFromPointer pDIBits, picScanWidth * picHeight, "Undo1"
' And now let's say you want to apply that Undo back to the DIB directly
DIm bytesRead As Long, amoutToRead As Long
amountToRead = picScanWidth * picHeight
cStrmMgr.ReadStream pDIBits, amountToRead, bytesRead, 0, "Undo1"
If bytesRead = amountToRead Then ' read all data
pShImg.ScaleImage CLng(Text5.Text), CLng(Text6.Text), InterpolationModeBicubic
pShImg.NextFrame
pShImg.Rotate CLng(Text4.Text)
'saving is equally easy:
Dim ipf As IPersistFile
Set ipf = pShImg
ipf.Save sFullPath, 1Private Sub DoTranscode(psiSrc As IShellItem, psiDest As IShellItem, nTo As TI_FLAGS)
'The included module provides a standalone implemention of this routine if you're starting
'from only the file paths. This version uses a number of shortcuts getting an IShellItem
'directly from FileOpenDialog gives us
Dim lpDest As Long
Dim pStrm As IStream
Dim pTI As ImageTranscode
Dim pwi As Long, phg As Long
Set pTI = New ImageTranscode
psiDest.GetDisplayName SIGDN_FILESYSPATH, lpDest
Call SHCreateStreamOnFileEx(lpDest, STGM_CREATE Or STGM_READWRITE, FILE_ATTRIBUTE_NORMAL, 1, 0, pStrm)
pTI.TranscodeImage psiSrc, 0, 0, nTo, pStrm, pwi, phg
pStrm.Commit STGC_DEFAULT
Set pStrm = Nothing
Set pTI = Nothing
Call CoTaskMemFree(lpDest)
End SubPrivate RPCListener As cRPCListener 'define the RPC-Server-Listener
Private IP As String, Port As Long, DllPath As String 'Start-Parameters
Private Sub Form_Load()
'normally this part is contained in a Windows-Service-Executable (without any UI)
IP = New_c.TCPServer.GetIP("") 'get the default-IP of the current machine
Port = 22222 'set a Port (22222 is the RC5-RPC default-port)
DllPath = App.Path & "\RPCDlls\" 'Path, where the Server is looking for the RPCDlls
Set RPCListener = New_c.RPCListener 'create the RPC-Listener-instance
If RPCListener.StartServer(IP, Port, , , , , DllPath) Then '... now we try to start the RPC-Server
Caption = "Server is listening on: " & IP & ":" & Port
Else
Caption = "Server-Start was not successful"
End If
End Sub
Private Sub Form_Terminate()
If Forms.Count = 0 Then New_c.CleanupRichClientDll
End SubPrivate Cnn As ADODB.Connection
Public Function StringReflection(S As String) As String
StringReflection = StrReverse(S)
End Function
Public Function AddTwoLongs(ByVal L1 As Long, ByVal L2 As Long) As Long
AddTwoLongs = L1 + L2
End Function
Public Function GetADORs(SQL As String) As ADODB.Recordset
If Cnn Is Nothing Then OpenCnn
Set GetADORs = New ADODB.Recordset
GetADORs.Open SQL, Cnn, adOpenStatic, adLockBatchOptimistic 'return the ADO-Rs (its content will be auto-serialized)
End Function
Private Sub OpenCnn()
Set Cnn = New Connection
Cnn.CursorLocation = adUseClient
Cnn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & App.Path & "\Test.mdb"
End SubPrivate Const ServerDll$ = "SimpleServerLib.dll" 'Name of the used Dll in the \RPCDlls\-Folder
Private Const ServerCls$ = "cServerClass" 'Name of the Class, which is contained in above Dll
Private RPCConn As cRPCConnection 'define the Var for the clientside RPC-connection
Private Sub Form_Load()
Set RPCConn = New_c.RPCConnection 'create the clientside-RPCConnection-instance
RPCConn.DebugMode = (chkDEBUGMode.Value = vbChecked) 'Debug-Mode (should be switched Off when running as an Executable)
RPCConn.Host = "" 'put an explicit Server-IP here later on, e.g. read from an Ini-File
RPCConn.Port = 22222 'Port-Nr the Server is listening on (22222 is the RC5-RPC-default)
RPCConn.KeepAlive = True 'set KeepAlive for better performance
End Sub
'... snipped the two other Methods, which we also wrap in this Form
Private Sub cmdAddTwoLongs_Click() 'an example Remote-Method-Call
On Error GoTo ErrMsg
txtAdd.Text = RPCConn.RPC(ServerDll, ServerCls, "AddTwoLongs", 3, _
CLng(txtL1.Text), CLng(txtL2.Text)) '<- Parameter-List (two Long-Values in this case)
ErrMsg: If Err Then MsgBox Err.Description
End Sub| typedef enum _tagPSUACTION { PSU_DEFAULT = 1 // gets security URL and returns its domain. ,PSU_SECURITY_URL_ONLY // gets just the security URL } PSUACTION; |
Public Enum PSUACTION PSU_DEFAULT=1 ' gets security URL and returns its domain. PSU_SECURITY_URL_ONLY = 2 ' gets just the security URL End Enum |
| typedef struct SMDATA { DWORD dwMask; // SMDM_* values DWORD dwFlags; // Not used long hmenu; // Static HMENU portion. HWND hwnd; // HWND owning the HMENU UINT uId; // Id of the item in the menu (-1 for menu itself) UINT uIdParent; // Id of the item spawning this menu UINT uIdAncestor[80]; // Id of the very top item in the chain of ShellFolders //IUnknown* punk; // IUnkown of the menuband long punk; //use pointer?? long pidlFolder;// pidl of the ShellFolder portion long pidlItem; // pidl of the item in the ShellFolder portion //IShellFolder* psf; // IShellFolder for the shell folder portion long psf; //use pointer?? WCHAR pvUserData[MAX_PATH]; // User defined Data associated with a pane. } SMDATA; |
Public Type SMDATA dwMask As Long ' SMDM_* values dwFlags As Long ' Not used hmenu As long ' Static HMENU portion. hwnd As Long ' HWND owning the HMENU uId As Long ' Id of the item in the menu (-1 for menu itself) uIdParent As Long ' Id of the item spawning this menu uIdAncestor(0 To 79) As Long ' Id of the very top item in the chain of ShellFolders 'IUnknown* punk; // IUnkown of the menuband punk As long 'use pointer?? pidlFolder As long ' pidl of the ShellFolder portion pidlItem As long ' pidl of the item in the ShellFolder portion 'IShellFolder* psf; // IShellFolder for the shell folder portion psf As long 'use pointer?? pvUserData(0 To (MAX_PATH - 1)) As Integer ' User defined Data associated with a pane. End Type |
Public Enum AmbientUserModeENUM
aumDefault = 0
aumDesignTime = 1
aumRuntime = 2
End Enum
Private m_UserMode As AmbientUserModeENUM
Public Property Let UserMode(newVal As AmbientUserModeENUM)
If Not (newVal < aumDefault Or newVal > aumRuntime) Then
m_UserMode = newVal
Call pvCheckUserMode
PropertyChanged "UserMode"
End If
End Property
Public Property Get UserMode() As AmbientUserModeENUM
UserMode = m_UserMode And &HFF
End Property
Private Sub pvCheckUserMode()
Select Case (m_UserMode And &HFF)
Case aumDefault
m_UserMode = (m_UserMode And &HFF) Or UserControl.Ambient.UserMode * &H100&
Case aumRuntime
m_UserMode = (m_UserMode And &HFF) Or &H100
Case Else
m_UserMode = m_UserMode And &HFF
End Select
If (m_UserMode And &H100) Then ' user mode is considered True
' do whatever is needed. Maybe set the UserMode property of any child usercontrols
Else ' user mode is considered False
' do whatever is needed. Maybe set the UserMode property of any child usercontrols
End If
End Sub
Private Sub UserControl_InitProperties()
' set any new control, initial properties
' apply any actions needed for UserMode
Call pvCheckUserMode
End Sub
Private Sub UserControl_ReadProperties(PropBag As PropertyBag)
' read all written properties
' apply any actions needed for UserMode
m_UserMode = PropBag.ReadProperty("AUM", aumDefault)
Call pvCheckUserMode
End Sub
Private Sub UserControl_WriteProperties(PropBag As PropertyBag)
PropBag.WriteProperty "AUM", (m_UserMode And &HFF), aumDefault
End Sub
Public Function SelectFolderEx(hWnd As Long, sPrompt As String, dwFlags As BF_Flags, out_Folders() As String, Optional sStartDir As String, Optional sRoot As String) As Long
'Enhanced folder chooser
Dim pidlStart As Long
Dim pidlRoot As Long
Dim lpRes As Long, szRes As String
ReDim out_Folders(0)
If sStartDir <> "" Then
pidlStart = ILCreateFromPathW(StrPtr(sStartDir))
End If
If sRoot <> "" Then
pidlRoot = ILCreateFromPathW(StrPtr(sRoot))
End If
lpRes = BrowseDialogEx(hWnd, sPrompt, dwFlags, pidlRoot, pidlStart)
If lpRes = 0 Then
SelectFolderEx = -1
Exit Function
End If
szRes = GetPathFromPIDLW(lpRes)
If (szRes = "") Or (szRes = vbNullChar) Then
'here's where we do some magic. if GetPathFromPIDLW returned nothing, but we did receive
'a valid pidl, we may have a location that still might be valid. at this time, i've made
'functions that will return the paths for the Library object, any individual library,
'My Computer, and the main Network object and network paths
Dim sAPP As String 'absolute parsing path
sAPP = GetAbsoluteParsingPath(lpRes)
If (Left$(sAPP, 2) = "\\") Or (Left$(sAPP, 2) = "//") Then
'network locations can't be resolved as normal, but are valid locations
'for most things you'll be passing a folder location to, including FindFirstFile
'the only caveat here, is the network pc itself resolves here but can't be passed
'so we want it enumed too, but not past that
Dim sTMP As String
sTMP = Mid$(sAPP, 3)
If (InStr(sTMP, "/") = 0) And (InStr(sTMP, "\") = 0) Then
'so this should be a top-level computer needing to be enum'd
SelectFolderEx = EnumSpecialObjectPaths(sAPP, out_Folders)
GoTo cfdone
End If
out_Folders(0) = sAPP
SelectFolderEx = 1
GoTo cfdone
End If
SelectFolderEx = EnumSpecialObjectPaths(sAPP, out_Folders)
Else
out_Folders(0) = szRes
SelectFolderEx = 1
End If
cfdone:
Call CoTaskMemFree(lpRes)
End FunctionPublic Function EnumSpecialObjectPaths(szID As String, sPaths() As String) As Long
'objects like Libraries and My Computer can't be passed to a file search algorithm
'but they contain objects which can. this function enumerates the searchable paths
'return value is the count of sPaths, or -1 if the GUID was not an enumerable loc
Debug.Print "esop enter " & szID
If szID = FolderGUID_Computer Then
'here we can just use the GetLogicalDriveStrings API
Dim sBuff As String * 255
Dim i As Long
i = GetLogicalDriveStrings(255, sBuff)
sPaths = Split(Left$(sBuff, i - 1), Chr$(0))
ElseIf (szID = FolderGUID_Libraries) Then 'library master
ListAllLibraryPaths sPaths
ElseIf (Left$(szID, 41) = FolderGUID_Libraries & "\") Then 'specific library
ListLibraryPaths szID, sPaths
ElseIf (szID = FolderGUID_Network) Then 'Network master
ListNetworkLocs sPaths
ElseIf (Left$(szID, 2) = "\\") Then
ListNetComputerLocs szID, sPaths
Else 'not supported or not file system
EnumSpecialObjectPaths = -1
Exit Function
End If
EnumSpecialObjectPaths = UBound(sPaths) + 1
End FunctionPublic Sub ListAllLibraryPaths(sOut() As String)
'Lists all paths in all libraries
Dim psi As IShellItem
Dim piesi As IEnumShellItems
Dim psiLib As IShellItem
Dim isia As IShellItemArray
Dim pLibEnum As IEnumShellItems
Dim pLibChild As IShellItem
Dim lpPath As Long
Dim szPath As String
Dim pLib As ShellLibrary
Set pLib = New ShellLibrary
Dim nPaths As Long
Dim pclt As Long
ReDim sOut(0)
Call SHCreateItemFromParsingName(StrPtr(FolderGUID_Libraries), ByVal 0&, IID_IShellItem, psi)
If (psi Is Nothing) Then
Debug.Print "could't parse lib master"
Exit Sub
End If
psi.BindToHandler 0, BHID_EnumItems, IID_IEnumShellItems, piesi
Do While (piesi.Next(1, psiLib, pclt) = S_OK)
psiLib.GetDisplayName SIGDN_NORMALDISPLAY, lpPath
szPath = LPWSTRtoStr(lpPath)
Debug.Print "Enumerating Library " & szPath
pLib.LoadLibraryFromItem psiLib, STGM_READ
pLib.GetFolders LFF_ALLITEMS, IID_IShellItemArray, isia
isia.EnumItems pLibEnum
Do While (pLibEnum.Next(1, pLibChild, 0) = 0)
pLibChild.GetDisplayName SIGDN_FILESYSPATH, lpPath
szPath = LPWSTRtoStr(lpPath, True)
Debug.Print "lib folder->" & szPath
If Len(szPath) > 2 Then
ReDim Preserve sOut(nPaths)
sOut(nPaths) = szPath
nPaths = nPaths + 1
End If
Set pLibChild = Nothing
Loop
Set psiLib = Nothing
Loop
End Sub
Public Sub ListLibraryPaths(sPN As String, sOut() As String)
'list the paths of a single library
'sPN is the full parsing name- what is returned from ishellfolder.getdisplayname(SHGDN_FORPARSING)
Dim psiLib As IShellItem
Dim pLib As ShellLibrary
Set pLib = New ShellLibrary
Dim psia As IShellItemArray
Dim pEnum As IEnumShellItems
Dim psiChild As IShellItem
Dim lpPath As Long, szPath As String, nPaths As Long
Dim pclt As Long
Call SHCreateItemFromParsingName(StrPtr(sPN), ByVal 0&, IID_IShellItem, psiLib)
If (psiLib Is Nothing) Then
Debug.Print "Failed to load library item"
Exit Sub
End If
pLib.LoadLibraryFromItem psiLib, STGM_READ
pLib.GetFolders LFF_ALLITEMS, IID_IShellItemArray, psia
If (psia Is Nothing) Then
Debug.Print "Failed to enumerate library"
Exit Sub
End If
ReDim sOut(0)
psia.EnumItems pEnum
Do While (pEnum.Next(1, psiChild, pclt) = S_OK)
If (psiChild Is Nothing) = False Then
psiChild.GetDisplayName SIGDN_FILESYSPATH, lpPath
szPath = LPWSTRtoStr(lpPath)
If Len(szPath) > 2 Then
ReDim Preserve sOut(nPaths)
sOut(nPaths) = szPath
nPaths = nPaths + 1
End If
End If
Set psiChild = Nothing
Loop
Set pEnum = Nothing
Set psia = Nothing
Set pLib = Nothing
Set psiLib = Nothing
End Sub
Public Sub ListNetworkLocs(sOut() As String) '
Dim psi As IShellItem
Dim piesi As IEnumShellItems
Dim psiNet As IShellItem
Dim isia As IShellItemArray
Dim pNetEnum As IEnumShellItems
Dim pNetChild As IShellItem
Dim lpPath As Long
Dim szPath As String
Dim nPaths As Long
Dim pclt As Long
Call SHCreateItemFromParsingName(StrPtr(FolderGUID_Network), ByVal 0&, IID_IShellItem, psi)
If psi Is Nothing Then Exit Sub
ReDim sOut(0)
psi.BindToHandler 0, BHID_EnumItems, IID_IEnumShellItems, piesi
Do While (piesi.Next(1, pNetChild, pclt) = S_OK)
pNetChild.GetDisplayName SIGDN_DESKTOPABSOLUTEPARSING, lpPath
szPath = LPWSTRtoStr(lpPath)
If (Left$(szPath, 2) = "//") Or (Left$(szPath, 2) = "\\") Then 'objects besides valid paths come up, like routers, devices, etc
'but they don't start with //, only searchable network locations should
Debug.Print "netpath " & szPath
ReDim Preserve sOut(nPaths)
sOut(nPaths) = szPath
nPaths = nPaths + 1
End If
Set pNetChild = Nothing
Loop
Set piesi = Nothing
Set psi = Nothing
End Sub
Public Sub ListNetComputerLocs(szID As String, sOut() As String)
'lists an individual network computer
Dim psiComp As IShellItem
Dim pEnum As IEnumShellItems
Dim psiChild As IShellItem
Dim lpPath As Long
Dim szPath As String
Dim nPaths As Long
Dim pclt As Long
Debug.Print "ListNetComputerLocs " & szID
Call SHCreateItemFromParsingName(StrPtr(szID), ByVal 0&, IID_IShellItem, psiComp)
If psiComp Is Nothing Then Exit Sub
ReDim sOut(0)
psiComp.BindToHandler 0, BHID_EnumItems, IID_IEnumShellItems, pEnum
Do While (pEnum.Next(1, psiChild, pclt) = S_OK)
psiChild.GetDisplayName SIGDN_DESKTOPABSOLUTEPARSING, lpPath
szPath = LPWSTRtoStr(lpPath)
If Len(szPath) > 2 Then
Debug.Print "netpath " & szPath
ReDim Preserve sOut(nPaths)
sOut(nPaths) = szPath
nPaths = nPaths + 1
End If
Loop
End SubPrivate Declare Function SHChangeNotifyRegister Lib "shell32" _
(ByVal hWnd As Long, _
ByVal fSources As SHCNRF, _
ByVal fEvents As SHCN_EventIDs, _
ByVal wMsg As Long, _
ByVal cEntries As Long, _
lpps As SHChangeNotifyEntry) As LongPublic Function F1WndProc(ByVal hWnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long, ByVal uIdSubclass As Long, ByVal dwRefData As Long) As Long
Select Case uMsg
Case WM_SHNOTIFY
Dim lEvent As Long
Dim pInfo As Long
Dim tInfo As SHNOTIFYSTRUCT
Dim hNotifyLock As Long
hNotifyLock = SHChangeNotification_Lock(wParam, lParam, pInfo, lEvent)
If hNotifyLock Then
CopyMemory tInfo, ByVal pInfo, LenB(tInfo)
Form1.HandleNotify tInfo.dwItem1, tInfo.dwItem2, lEvent
Call SHChangeNotification_Unlock(hNotifyLock)
End IfOption Explicit
Public m_hSHNotify As Long
Public Const WM_SHNOTIFY = &H488 'WM_USER through &H7FF
Public Enum SHCN_EventIDs
SHCNE_RENAMEITEM = &H1 '(D) A non-folder item has been renamed.
SHCNE_CREATE = &H2 '(D) A non-folder item has been created.
SHCNE_DELETE = &H4 '(D) A non-folder item has been deleted.
SHCNE_MKDIR = &H8 '(D) A folder item has been created.
SHCNE_RMDIR = &H10 '(D) A folder item has been removed.
SHCNE_MEDIAINSERTED = &H20 '(G) Storage media has been inserted into a drive.
SHCNE_MEDIAREMOVED = &H40 '(G) Storage media has been removed from a drive.
SHCNE_DRIVEREMOVED = &H80 '(G) A drive has been removed.
SHCNE_DRIVEADD = &H100 '(G) A drive has been added.
SHCNE_NETSHARE = &H200 'A folder on the local computer is being
' shared via the network.
SHCNE_NETUNSHARE = &H400 'A folder on the local computer is no longer
' being shared via the network.
SHCNE_ATTRIBUTES = &H800 '(D) The attributes of an item or folder have changed.
SHCNE_UPDATEDIR = &H1000 '(D) The contents of an existing folder have changed,
' but the folder still exists and has not been renamed.
SHCNE_UPDATEITEM = &H2000 '(D) An existing non-folder item has changed, but the
' item still exists and has not been renamed.
SHCNE_SERVERDISCONNECT = &H4000 'The computer has disconnected from a server.
SHCNE_UPDATEIMAGE = &H8000& '(G) An image in the system image list has changed.
SHCNE_DRIVEADDGUI = &H10000 '(G) A drive has been added and the shell should
' create a new window for the drive.
SHCNE_RENAMEFOLDER = &H20000 '(D) The name of a folder has changed.
SHCNE_FREESPACE = &H40000 '(G) The amount of free space on a drive has changed.
'#If (WIN32_IE >= &H400) Then
SHCNE_EXTENDED_EVENT = &H4000000 '(G) Not currently used.
'#End If
SHCNE_ASSOCCHANGED = &H8000000 '(G) A file type association has changed.
SHCNE_DISKEVENTS = &H2381F '(D) Specifies a combination of all of the disk
' event identifiers.
SHCNE_GLOBALEVENTS = &HC0581E0 '(G) Specifies a combination of all of the global
' event identifiers.
SHCNE_ALLEVENTS = &H7FFFFFFF
SHCNE_INTERRUPT = &H80000000 'The specified event occurred as a result of a system
'interrupt. It is stripped out before the clients
'of SHCNNotify_ see it.
End Enum
'#If (WIN32_IE >= &H400) Then
Public Const SHCNEE_ORDERCHANGED = &H2 'dwItem2 is the pidl of the changed folder
'#End If
Public Enum SHCNRF
SHCNRF_InterruptLevel = &H1
SHCNRF_ShellLevel = &H2
SHCNRF_RecursiveInterrupt = &H1000
SHCNRF_NewDelivery = &H8000&
End Enum
Public Enum SHCN_ItemFlags
SHCNF_IDLIST = &H0 ' LPITEMIDLIST
SHCNF_PATHA = &H1 ' path name
SHCNF_PRINTERA = &H2 ' printer friendly name
SHCNF_DWORD = &H3 ' DWORD
SHCNF_PATHW = &H5 ' path name
SHCNF_PRINTERW = &H6 ' printer friendly name
SHCNF_TYPE = &HFF
' Flushes the system event buffer. The function does not return until the system is
' finished processing the given event.
SHCNF_FLUSH = &H1000
' Flushes the system event buffer. The function returns immediately regardless of
' whether the system is finished processing the given event.
SHCNF_FLUSHNOWAIT = &H2000
'I prefer to always specify A or W, but you can also do it the way previous examples have
' (but this doesn't apply to SHChangeNotifyRegister, just SHChangeNotify, not covered here)
'#If UNICODE Then
' SHCNF_PATH = SHCNF_PATHW
' SHCNF_PRINTER = SHCNF_PRINTERW
'#Else
' SHCNF_PATH = SHCNF_PATHA
' SHCNF_PRINTER = SHCNF_PRINTERA
'#End If
End Enum
Private Type SHNOTIFYSTRUCT
dwItem1 As Long
dwItem2 As Long
End Type
Private Type SHChangeNotifyEntry
' Fully qualified pidl (relative to the desktop folder) of the folder to monitor changes in.
' 0 can also be specifed for the desktop folder.
pidl As Long
' Value specifying whether changes in the folder's subfolders trigger a change notification
' event (it's actually a Boolean, but we'll go Long because of VB's DWORD struct alignment).
fRecursive As Long
End Type
Private Declare Function SHChangeNotifyRegister Lib "shell32" _
(ByVal hWnd As Long, _
ByVal fSources As SHCNRF, _
ByVal fEvents As SHCN_EventIDs, _
ByVal wMsg As Long, _
ByVal cEntries As Long, _
lpps As SHChangeNotifyEntry) As Long
Private Declare Function SHChangeNotifyDeregister Lib "shell32" Alias "#4" (ByVal hNotify As Long) As Boolean
Private Declare Function SHChangeNotification_Lock Lib "shell32" (ByVal hChange As Long, _
ByVal dwProcId As Long, _
pppidl As Long, _
plEvent As Long) As Long
Private Declare Function SHChangeNotification_Unlock Lib "shell32" (ByVal hLock As Long) As Long
Private Declare Function SHGetPathFromIDListW Lib "shell32.dll" (ByVal pidl As Long, ByVal pszPath As Long) As Long
Public Declare Function SHGetSpecialFolderLocation Lib "shell32.dll" (ByVal hWndOwner As Long, ByVal nFolder As SHSpecialFolderIDs, pidl As Long) As Long
Public Enum SHSpecialFolderIDs
'See full project or somewhere else for the full enum, including it all ran over the post length limit
CSIDL_DESKTOP = &H0
End Enum
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Private Declare Function DefSubclassProc Lib "comctl32.dll" Alias "#413" (ByVal hWnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private Declare Function SetWindowSubclass Lib "comctl32.dll" Alias "#410" (ByVal hWnd As Long, ByVal pfnSubclass As Long, ByVal uIdSubclass As Long, Optional ByVal dwRefData As Long) As Long
Private Declare Function RemoveWindowSubclass Lib "comctl32.dll" Alias "#412" (ByVal hWnd As Long, ByVal pfnSubclass As Long, ByVal uIdSubclass As Long) As Long
Private Const WM_DESTROY = &H2
Public Const MAX_PATH = 260
Public Function StartNotify(hWnd As Long, Optional pidlPath As Long = 0) As Long
Dim tCNE As SHChangeNotifyEntry
Dim pidl As Long
If (m_hSHNotify = 0) Then
If pidlPath = 0 Then
tCNE.pidl = VarPtr(0) 'This is a shortcut for the desktop pidl (to watch all locations)
'only use this shortcut as a one-off reference immediately passed
'to an API and not used again
Else
tCNE.pidl = pidlPath 'You can specify any other fully qualified pidl to watch only that folder
'Use ILCreateFromPathW(StrPtr(path))
End If
tCNE.fRecursive = 1
'instead of SHCNE_ALLEVENTS you could choose to only monitor specific ones
m_hSHNotify = SHChangeNotifyRegister(hWnd, SHCNRF_ShellLevel Or SHCNRF_InterruptLevel Or SHCNRF_NewDelivery, SHCNE_ALLEVENTS Or SHCNE_INTERRUPT, WM_SHNOTIFY, 1, tCNE)
StartNotify = m_hSHNotify
End If ' (m_hSHNotify = 0)
End Function
Public Function StopNotify() As Boolean
StopNotify = SHChangeNotifyDeregister(m_hSHNotify)
End Function
Public Function LookUpSHCNE(uMsg As Long) As String
Select Case uMsg
Case &H1: LookUpSHCNE = "SHCNE_RENAMEITEM"
Case &H2: LookUpSHCNE = "SHCNE_CREATE"
Case &H4: LookUpSHCNE = "SHCNE_DELETE"
Case &H8: LookUpSHCNE = "SHCNE_MKDIR"
Case &H10: LookUpSHCNE = "SHCNE_RMDIR"
Case &H20: LookUpSHCNE = "SHCNE_MEDIAINSERTED"
Case &H40: LookUpSHCNE = "SHCNE_MEDIAREMOVED"
Case &H80: LookUpSHCNE = "SHCNE_DRIVEREMOVED"
Case &H100: LookUpSHCNE = "SHCNE_DRIVEADD"
Case &H200: LookUpSHCNE = "SHCNE_NETSHARE"
Case &H400: LookUpSHCNE = "SHCNE_NETUNSHARE"
Case &H800: LookUpSHCNE = "SHCNE_ATTRIBUTES"
Case &H1000: LookUpSHCNE = "SHCNE_UPDATEDIR"
Case &H2000: LookUpSHCNE = "SHCNE_UPDATEITEM"
Case &H4000: LookUpSHCNE = "SHCNE_SERVERDISCONNECT"
Case &H8000&: LookUpSHCNE = "SHCNE_UPDATEIMAGE"
Case &H10000: LookUpSHCNE = "SHCNE_DRIVEADDGUI"
Case &H20000: LookUpSHCNE = "SHCNE_RENAMEFOLDER"
Case &H40000: LookUpSHCNE = "SHCNE_FREESPACE"
Case &H4000000: LookUpSHCNE = "SHCNE_EXTENDED_EVENT"
Case &H8000000: LookUpSHCNE = "SHCNE_ASSOCCHANGED"
Case &H2381F: LookUpSHCNE = "SHCNE_DISKEVENTS"
Case &HC0581E0: LookUpSHCNE = "SHCNE_GLOBALEVENTS"
Case &H7FFFFFFF: LookUpSHCNE = "SHCNE_ALLEVENTS"
Case &H80000000: LookUpSHCNE = "SHCNE_INTERRUPT"
End Select
End Function
Public Function GetPathFromPIDLW(pidl As Long) As String
Dim pszPath As String
pszPath = String(MAX_PATH, 0)
If SHGetPathFromIDListW(pidl, StrPtr(pszPath)) Then
If InStr(pszPath, vbNullChar) Then
GetPathFromPIDLW = Left$(pszPath, InStr(pszPath, vbNullChar) - 1)
End If
End If
End Function
Public Function Subclass(hWnd As Long, lpfn As Long, Optional uId As Long = 0&, Optional dwRefData As Long = 0&) As Boolean
If uId = 0 Then uId = hWnd
Subclass = SetWindowSubclass(hWnd, lpfn, uId, dwRefData): Debug.Assert Subclass
End Function
Public Function UnSubclass(hWnd As Long, ByVal lpfn As Long, pid As Long) As Boolean
UnSubclass = RemoveWindowSubclass(hWnd, lpfn, pid)
End Function
Public Function FARPROC(pfn As Long) As Long
FARPROC = pfn
End Function
Public Function F1WndProc(ByVal hWnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long, ByVal uIdSubclass As Long, ByVal dwRefData As Long) As Long
Select Case uMsg
Case WM_SHNOTIFY
Dim lEvent As Long
Dim pInfo As Long
Dim tInfo As SHNOTIFYSTRUCT
Dim hNotifyLock As Long
hNotifyLock = SHChangeNotification_Lock(wParam, lParam, pInfo, lEvent)
If hNotifyLock Then
CopyMemory tInfo, ByVal pInfo, LenB(tInfo)
Form1.HandleNotify tInfo.dwItem1, tInfo.dwItem2, lEvent
Call SHChangeNotification_Unlock(hNotifyLock)
End If
Case WM_DESTROY
Call UnSubclass(hWnd, PtrF1WndProc, uIdSubclass)
'Exit Function
End Select
' Pass back to default message handler.
F1WndProc = DefSubclassProc(hWnd, uMsg, wParam, lParam)
Exit Function
End Function
Private Function PtrF1WndProc() As Long
PtrF1WndProc = FARPROC(AddressOf F1WndProc)
End FunctionOption Explicit
Public Function HandleNotify(dwItem1 As Long, dwItem2 As Long, idEvent As Long) As Long
Dim sArg1 As String, sArg2 As String
If dwItem1 Then
sArg1 = GetPathFromPIDLW(dwItem1)
End If
If dwItem2 Then
sArg2 = GetPathFromPIDLW(dwItem2)
End If
Dim sEvent As String
sEvent = LookUpSHCNE(idEvent)
List1.AddItem sEvent & ", Item1=" & sArg1 & ", Item2=" & sArg2
End Function
Private Sub cmdStart_Click()
StartNotify Me.hWnd
End Sub
Private Sub cmdStop_Click()
StopNotify
End Sub
Private Sub Form_Load()
Subclass Me.hWnd, AddressOf F1WndProc
End Sub
Private Sub Form_Unload(Cancel As Integer)
StopNotify
End Sub
Private Sub Form_Resize()
On Error Resume Next
List1.Width = Me.Width - 220
List1.Height = Me.Height - 1000
End Sub
