分享
 
 
 

Windows未公开函数揭密(3)

王朝vb·作者佚名  2006-01-08
窄屏简体版  字體: |||超大  

Windows未公开函数揭密

'根据一个特定文件夹对象的ID获得它的目录pidl

Public Function GetPIDLFromFolderID(hOwner As Long, nFolder As SHSpecialFolderIDs) As Long

Dim pidl As Long

If SHGetSpecialFolderLocation(hOwner, nFolder, pidl) = NOERROR Then

GetPIDLFromFolderID = pidl

End If

End Function

Public Function GetDisplayNameFromPIDL(pidl As Long) As String

Dim sfib As SHFILEINFOBYTE

If SHGetFileInfoPidl(pidl, 0, sfib, Len(sfib), SHGFI_PIDL Or SHGFI_DISPLAYNAME) Then

GetDisplayNameFromPIDL = GetStrFromBufferA(StrConv(sfib.szDisplayName, vbUnicode))

End If

End Function

Public Function GetPathFromPIDL(pidl As Long) As String

Dim sPath As String * MAX_PATH

If SHGetPathFromIDList(pidl, sPath) Then

GetPathFromPIDL = GetStrFromBufferA(sPath)

End If

End Function

Public Function GetStrFromBufferA(sz As String) As String

If InStr(sz, vbNullChar) Then

GetStrFromBufferA = Left$(sz, InStr(sz, vbNullChar) - 1)

Else

GetStrFromBufferA = sz

End If

End Function

在mShell.Bas中加入以下代码:

'mShell.Bas函数包含注册和反注册系统通告以及文件夹信息转换的函数

Option Explicit

Private m_hSHNotify As Long

'系统消息通告句柄

Private m_pidlDesktop As Long

'定义系统通告的消息值

Public Const WM_SHNOTIFY = &H401

Public Type PIDLSTRUCT

pidl As Long

bWatchSubFolders As Long

End Type

Declare Function SHChangeNotifyRegister Lib ″shell32″ Alias ″#2″ _

(ByVal hWnd As Long, _

ByVal uFlags As SHCN_ItemFlags, _

ByVal dwEventID As SHCN_EventIDs, _

ByVal uMsg As Long, _

ByVal cItems As Long, _

lpps As PIDLSTRUCT) As Long

Type SHNOTIFYSTRUCT

dwItem1 As Long

dwItem2 As Long

End Type

Declare Function SHChangeNotifyDeregister Lib ″shell32″ Alias ″#4″ _

(ByVal hNotify As Long) As Boolean

Declare Sub SHChangeNotify Lib ″shell32″ _

(ByVal wEventId As SHCN_EventIDs,

ByVal uFlags As SHCN_ItemFlags, _

ByVal dwItem1 As Long, _

ByVal dwItem2 As Long)

Public Enum SHCN_EventIDs

SHCNE_RENAMEITEM = &H1

SHCNE_CREATE = &H2

SHCNE_DELETE = &H4

SHCNE_MKDIR = &H8

SHCNE_RMDIR = &H10

SHCNE_MEDIAINSERTED = &H20

SHCNE_MEDIAREMOVED = &H40

SHCNE_DRIVEREMOVED = &H80

SHCNE_DRIVEADD = &H100

SHCNE_NETSHARE = &H200

SHCNE_NETUNSHARE = &H400

SHCNE_ATTRIBUTES = &H800

SHCNE_UPDATEDIR = &H1000

SHCNE_UPDATEITEM = &H2000

SHCNE_SERVERDISCONNECT = &H4000

SHCNE_UPDATEIMAGE = &H8000&

SHCNE_DRIVEADDGUI = &H10000

SHCNE_RENAMEFOLDER = &H20000

SHCNE_FREESPACE = &H40000

SHCNE_ASSOCCHANGED = &H8000000

SHCNE_DISKEVENTS = &H2381F

SHCNE_GLOBALEVENTS = &HC0581E0

SHCNE_ALLEVENTS = &H7FFFFFFF

SHCNE_INTERRUPT = &H80000000

End Enum

#If (WIN32_IE >= &H400) Then

Public Const SHCNEE_ORDERCHANGED = &H2

#End If

Public Enum SHCN_ItemFlags

SHCNF_IDLIST = &H0

SHCNF_PATHA = &H1

SHCNF_PRINTERA = &H2

SHCNF_DWORD = &H3

SHCNF_PATHW = &H5

SHCNF_PRINTERW = &H6

SHCNF_TYPE = &HFF

SHCNF_FLUSH = &H1000

SHCNF_FLUSHNOWAIT = &H2000

#If UNICODE Then

SHCNF_PATH = SHCNF_PATHW

SHCNF_PRINTER = SHCNF_PRINTERW

#Else

SHCNF_PATH = SHCNF_PATHA

SHCNF_PRINTER = SHCNF_PRINTERA

#End If

End Enum

Public Function SHNotify_Register(hWnd As Long) As Boolean

Dim ps As PIDLSTRUCT

If (m_hSHNotify = 0) Then

m_pidlDesktop = GetPIDLFromFolderID(0, CSIDL_DESKTOP)

If m_pidlDesktop Then

ps.pidl = m_pidlDesktop

ps.bWatchSubFolders = True

'注册Windows监视,将获得的句柄保存到m_hSHNotify中

m_hSHNotify = SHChangeNotifyRegister(hWnd, SHCNF_TYPE Or SHCNF_IDLIST, NE_ALLEVENTS Or SHCNE_INTERRUPT, WM_SHNOTIFY, 1, ps)

SHNotify_Register = CBool(m_hSHNotify)

Else

Call CoTaskMemFree(m_pidlDesktop)

End If

End If

End Function

Public Function SHNotify_Unregister() As Boolean

If m_hSHNotify Then

If SHChange Notify Deregister(m_h SHNotify) Then

m_hSHNotify = 0

Call CoTaskMemFree(m_pidlDesktop)

m_pidlDesktop = 0

SHNotify_Unregister = True

End If

End If

End Function

Public Function SHNotify_GetEventStr(strPath1, strPath2 As String, dwEventID As Long) As String

Dim sEvent As String

Select Case dwEventID

Case SHCNE_RENAMEITEM: sEvent =

″重命名文件″ + strPath1 + ″为″ + strPath2

Case SHCNE_CREATE: sEvent = ″建立文件 文件名:″ + strPath1

Case SHCNE_DELETE: sEvent = ″删除文件 文件名:″ + strPath1

Case SHCNE_MKDIR: sEvent = ″新建目录 目录名:″ + strPath1

Case SHCNE_RMDIR: sEvent = ″删除目录 目录名:″ + strPath1

Case SHCNE_MEDIAINSERTED: sEvent = strPath1 + ″中插入可移动存储介质″

Case SHCNE_MEDIAREMOVED: sEvent = strPath1 + ″中移去可移动存储介质″

Case SHCNE_DRIVEREMOVED: sEvent = ″移去驱动器″ + strPath1

Case SHCNE_DRIVEADD: sEvent = ″添加驱动器″ + strPath1

Case SHCNE_NETSHARE: sEvent = ″改变目录″ + strPath1 + ″的共享属性″

Case SHCNE_UPDATEDIR: sEvent = ″更新目录″ + strPath1

Case SHCNE_UPDATEITEM: sEvent = ″更新文件 文件名:″ + strPath1

Case SHCNE_SERVERDISCONNECT: sEvent = ″断开与服务器的连″ + strPath1 + ″ ″ + strPath2

Case SHCNE_UPDATEIMAGE: sEvent = ″SHCNE_UPDATEIMAGE″

Case SHCNE_DRIVEADDGUI: sEvent = ″SHCNE_DRIVEADDGUI″

Case SHCNE_RENAMEFOLDER: sEvent = ″重命名文件夹″ + strPath1 + ″为″ + strPath2

Case SHCNE_FREESPACE: sEvent = ″磁盘空间大小改变″

Case SHCNE_ASSOCCHANGED: sEvent = ″改变文件关联″

End Select

SHNotify_GetEventStr = sEvent

End Function

在mSub.Bas中加入以下代码:

'mSub函数包括窗口的消息处理函数

Option Explicit

Private Const WM_NCDESTROY = &H82

Private Const GWL_WNDPROC = (-4)

Private Const OLDWNDPROC = ″OldWndProc″

Private Declare Function GetProp Lib″user32″ Alias″GetPropA″ (ByVal _

hWnd As Long, ByVal lpString As String) As Long

Private Declare Function SetProp Lib ″user32″ Alias ″SetPropA″ (ByVal _

hWnd As Long, ByVal lpString As String, ByVal hData As Long) As Long

Private Declare Function RemoveProp Lib ″user32″ Alias ″RemovePropA″ (ByVal _

hWnd As Long, ByVal lpString As String) As Long

Private Declare Function SetWindowLong Lib ″user32″ Alias ″SetWindowLongA″ _

(ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long

Private Declare Function CallWindowProc Lib ″user32″ Alias ″CallWindowProcA″ _

(ByVal lpPrevWndFunc As Long, ByVal hWnd As Long, ByVal uMsg As Long, _

ByVal wParam As Long, ByVal lParam As Long) As Long

Public Function SubClass(hWnd As Long) As Boolean

Dim lpfnOld As Long

Dim fSuccess As Boolean

If (GetProp(hWnd, OLDWNDPROC) = 0) Then

lpfnOld = Set Window Long(h Wnd, GWL-WNDPROC, Address Of Wnd Proc)

If lpfnOld Then

fSuccess = SetProp(hWnd, OLDWNDPROC, lpfnOld)

End If

End If

If fSuccess Then

SubClass = True

Else

If lpfnOld Then Call UnSubClass(hWnd)

MsgBox ″Unable to successfully subclass &H″ & Hex(hWnd), vbCritical

End If

End Function

Public Function UnSubClass(hWnd As Long) As Boolean

Dim lpfnOld As Long

lpfnOld = GetProp(hWnd, OLDWNDPROC)

If lpfnOld Then

If RemoveProp(hWnd, OLDWNDPROC) Then

UnSubClass = SetWindowLong(hWnd, GWL_WNDPROC, lpfnOld)

End If

End If

End Function

Public Function WndProc(ByVal hWnd As Long,pByVal uMsg Ap Long, ByVal wParam As _

Long, ByVal lParam As Long) As Long

Select Case uMsg

Case WM_SHNOTIFY '处理e统消息通告函数

Call Form1.NotificationReceipt(wParamN lParam)

Case WM_NCDESTROY

Call UnSubClass(hWnd)N D sgBox ″Unubclassed &H″ & Hex(hWnd), vbCritical, ″WndProc Error″

End Select

WndProc = CallWindowProc(GetProp(hWnd, OLDWNDPROC), hWnd, uMsg, wParam, lParam)

End Function

保存文件,然后运行程序,然后你可以在Explore中试着建立或者删除一个文件或者文件夹,在Form中可以看到你所做的ll已经被纪录l且显示到TextBox中了。

现在分析以下上面的程序,上面的程序首先调用SHChangeNotifyRegister函数将Form添加到系统消息通告链中,并利用SetWindowLong函数改变FormEd省的消息D理函数,当y受到系统通告消后,根据传递的参数获得系统通告的内容并且显示在文本窗口中。退出程序时调用SHChangeNotifyDeregister函数注销系统消息通告。

接下来我要向大家介绍如何使用Windows未公开函数实现调用Windows系统中的一些对话框的功能。其中包括如何调用系统的″运行程序″对话框、”查找文件″对话框、更改与文件相关联的图标对话框等等。

首先在VB中建立一个新的工程文件,然后在Form1中加入五个CommandButton控件,不要改变它们的属性,然后在Form1的代码窗口中加入以下代码:

Option Explicit

Private Type BrowseInfo

hwndOwner As Long

pIDLRoot As Long

pszDisplayName As Long

lpszTitle As Long

ulFlags As Long

lpfnCallback As Long

lParam As Long

iImage As Long

End Type

Const BIF_RETURNONLYFSDIRS = 1

Const MAX_PATH = 260

Private Declare Function SHObjectProperties Lib ″Shell32″ Alias ″#178″ _

(ByVal hwndOwner As Long, _

ByVal uFlags As Long, _

ByVal lpstrName As String, _

ByVal lpstrPar As String) As Long

Private Declare Sub CoTaskMemFree Lib ″ole32.dll″ (ByVal hMem As Long)

Private Declare Function SHBrowseForFolder Lib ″Shell32″ (lpbi _

As BrowseInfo) As Long

Private Declare Function SHFindFiles Lib ″Shell32″ Alias ″#90″ _

(ByVal pIDLRoot As Long, _

ByVal pidlSavedSearch As Long) As Long

Private Declare Function GetFileNameFromBrowse Lib ″Shell32″ Alias ″#63″ ( _

ByVal hwndOwner As Long, _

ByVal lpstrFile As String, _

ByVal nMaxFile As Long, _

ByVal lpstrInitDir As String, _

ByVal lpstrDefExt As String, _

ByVal lpstrFilter As String, _

ByVal lpstrTitle As String) As Long

Private Declare Sub PickIconDlg Lib ″Shell32″ Alias ″#62″ (ByVal hwndOwner As Long, _

ByVal lpstrFile As String, ByVal nMaxFile As Long, lpdwIconIndex As Long)

Private Declare Function SHRunFileDlg Lib ″Shell32″ Alias ″#61″ _

(ByVal hOwner As Long, _

ByVal hIcon As Long, _

ByVal lpstrDirectory As String, _

ByVal szTitle As String, _

ByVal szPrompt As String, _

ByVal uFlags As Long) As Long

Private Sub Command1_Click()

SHRunFileDlg Form1.hWnd, Form1.Icon.Handle, ″c:\windows″, ″运行程序演示″,

″在文本框中输入程序名或按浏览键查找程序″, 0

End Sub

Private Sub Command2_Click()

Dim a As Long

Dim astr As String

astr = ″c:\windows\notepad.exe″

PickIconDlg Form1.hWnd, astr, 1, a

End Sub

Private Sub Command3_Click()

Dim astr As String * 256

Dim bstr As String

bstr = ″c:\windows″

GetFileNameFromBrowse Form1.hWnd, astr, 256, bstr, ″*.txt″, _

″文本文件 *.txt″, ″Open Sample″

Debug.Print astr

End Sub

Private Sub Command4_Click()

Dim lpIDList As Long

Dim udtBI As BrowseInfo

'初试化udtBI结构

With udtBI

.hwndOwner = Form1.hWnd

.ulFlags = BIF_RETURNONLYFSDIRS

End With

'弹出文件夹查看窗口

lpIDList = SHBrowseForFolder(udtBI)

If lpIDList Then

'查找文件

SHFindFiles lpIDList, 0

Call CoTaskMemFree(lpIDList)

End If

End Sub

Private Sub Command5_Click()

SHObjectProperties Form1.hWnd, 2, ″c:\windows\notepad.exe″, ″Samples″

End Sub

Private Sub Form_Load()

Command1.Caption = ″运行程序″

Command2.Caption = ″更改图标″

Command3.Caption = ″打开文件″

Command4.Caption = ″查找文件″

Command5.Caption = ″显示文件属性″

End Sub

运行程序,分别点击不同的按钮,就可以看到不同的按钮实现了对不同的系统对话框的调用。以上程序在Windows98、VB6下运行通过。(完)

(长沙 陈锐)

 
 
 
免责声明:本文为网络用户发布,其观点仅代表作者个人观点,与本站无关,本站仅提供信息存储服务。文中陈述内容未经本站证实,其真实性、完整性、及时性本站不作任何保证或承诺,请读者仅作参考,并请自行核实相关内容。
2023年上半年GDP全球前十五强
 百态   2023-10-24
美众议院议长启动对拜登的弹劾调查
 百态   2023-09-13
上海、济南、武汉等多地出现不明坠落物
 探索   2023-09-06
印度或要将国名改为“巴拉特”
 百态   2023-09-06
男子为女友送行,买票不登机被捕
 百态   2023-08-20
手机地震预警功能怎么开?
 干货   2023-08-06
女子4年卖2套房花700多万做美容:不但没变美脸,面部还出现变形
 百态   2023-08-04
住户一楼被水淹 还冲来8头猪
 百态   2023-07-31
女子体内爬出大量瓜子状活虫
 百态   2023-07-25
地球连续35年收到神秘规律性信号,网友:不要回答!
 探索   2023-07-21
全球镓价格本周大涨27%
 探索   2023-07-09
钱都流向了那些不缺钱的人,苦都留给了能吃苦的人
 探索   2023-07-02
倩女手游刀客魅者强控制(强混乱强眩晕强睡眠)和对应控制抗性的关系
 百态   2020-08-20
美国5月9日最新疫情:美国确诊人数突破131万
 百态   2020-05-09
荷兰政府宣布将集体辞职
 干货   2020-04-30
倩女幽魂手游师徒任务情义春秋猜成语答案逍遥观:鹏程万里
 干货   2019-11-12
倩女幽魂手游师徒任务情义春秋猜成语答案神机营:射石饮羽
 干货   2019-11-12
倩女幽魂手游师徒任务情义春秋猜成语答案昆仑山:拔刀相助
 干货   2019-11-12
倩女幽魂手游师徒任务情义春秋猜成语答案天工阁:鬼斧神工
 干货   2019-11-12
倩女幽魂手游师徒任务情义春秋猜成语答案丝路古道:单枪匹马
 干货   2019-11-12
倩女幽魂手游师徒任务情义春秋猜成语答案镇郊荒野:与虎谋皮
 干货   2019-11-12
倩女幽魂手游师徒任务情义春秋猜成语答案镇郊荒野:李代桃僵
 干货   2019-11-12
倩女幽魂手游师徒任务情义春秋猜成语答案镇郊荒野:指鹿为马
 干货   2019-11-12
倩女幽魂手游师徒任务情义春秋猜成语答案金陵:小鸟依人
 干货   2019-11-12
倩女幽魂手游师徒任务情义春秋猜成语答案金陵:千金买邻
 干货   2019-11-12
 
推荐阅读
 
 
 
>>返回首頁<<
 
靜靜地坐在廢墟上,四周的荒凉一望無際,忽然覺得,淒涼也很美
© 2005- 王朝網路 版權所有