7451
社区成员
- 主页
windows右键菜单问题[300-500分]
怎么将自己的程序加入到右键菜单中，就像winzip 一样
并且知道你点击的是哪个文件或文件夹
我看过注册表，是添加到：
HKEY_CLASSES_ROOT/*/SHELLEX/contextmenuHandlers
下，然后指向的是一个dll,好象每个有此功能的软件都用了dll,我看过这些dll,应该是activeX的dll,请问谁有这些dll的源代码？提供思路的也可以
还有就是这些dll都是在系统启动后就添加到explorer的模块里，启动后就加载乐，请问如何加载？
在线等待，1天后回复的400分，2天以后回复的300分
并且知道你点击的是哪个文件或文件夹
我看过注册表，是添加到：
HKEY_CLASSES_ROOT/*/SHELLEX/contextmenuHandlers
下，然后指向的是一个dll,好象每个有此功能的软件都用了dll,我看过这些dll,应该是activeX的dll,请问谁有这些dll的源代码？提供思路的也可以
还有就是这些dll都是在系统启动后就添加到explorer的模块里，启动后就加载乐，请问如何加载？
在线等待，1天后回复的400分，2天以后回复的300分
...全文
请发表友善的回复…
发表回复
Rozre 2003-06-05
up
yefm 2003-06-05
up
rainstormmaster 2003-06-05
blacklevin(黑闪电)的就可以了，至于 zhou_huanxi(阿周) 说的：不能象WINZIP可处理相应文件，很容易解决。先在注册表中写入文件的打开方式。然后在程序中处理command传回的字串就可以了。
fontz 2003-06-05
感谢，收藏，有用
gilbe 2003-02-27
有没有不用控件的例子呢?
不用控件可不可以呢?
不用控件可不可以呢?
Girl1983 2003-02-26
http://www.freevbgood.com有个例子，http://www.sijiqing.com/vbgood/taishan/index.html
有个控件
有个控件
xiaole18 2003-02-26
又学了不少东西呀！
stove 2003-02-26
up
chanet 2003-02-26
挺复杂的...
来学习的...
来学习的...
SamHuang1 2003-02-26
up
来学习东西的!
来学习东西的!
我是杨威利 2003-02-26
gz
gilbe 2003-02-26
我已经成功做出，不过是用delphi做出的windows外壳，谁有vb的例子牙？
minajo21 2003-01-30
up
situation 2003-01-30
gz
along 2003-01-14
楼上这种方法只是执行相应的命令而不能象WINZIP可处理相应文件；其实WINZIP等软件是通过WINDOWS外壳扩展中的Context menu handles（向特定类型的文件对象增添上下文菜单）类实现的，WINDOWS外壳扩展都是基于COM组件型；外壳扩展都通过接口来访问对象。它一般都被设计成32位的进程服务器中，且都以动态链接库的形式为操作系统服务。因此要有一定的COM功底。
编写Context menu handles必须实现IShellExtInit(实现初始化）、IContextMenu(实现上下文相关菜单）与TComObjectFactory(实现对象的创建）三个接口。真正要做至象WINZIP等一样用VB实现有相当的困难；我有DELPHI的原代码，若要请留下EMAIL；但声明一点我也是参考了一些资料及代码后做出来的不过封装为DLL后在VB做的软件中应该也可以用。
另若嫌麻烦，也可用楼上的方法只不过稍作要改造即可处理相应文件。我以前用这种方法做过一个收集资料的小软件，若在文本类文件上单击右键即出添加菜单条目，单击此菜单条目即可把此文件导入我的资料库中，具体实现代码如下：
此处只给出TXT类文件添加右键菜单并通过单击右键菜把文件内容读入窗体的文本框中的代码（以下代码在VB6WINDOWSME下调试通过）：
其余类同。代码没有优化见笑了各位大侠。
以下在BAS中
Private Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long
Private Declare Function RegCreateKeyEx Lib "advapi32.dll" Alias "RegCreateKeyExA" (ByVal hKey As Long, ByVal lpSubKey As String, ByVal Reserved As Long, ByVal lpClass As String, ByVal dwOptions As Long, ByVal samDesired As Long, lpSecurityAttributes As SECURITY_ATTRIBUTES, phkResult As Long, lpdwDisposition As Long) As Long
Private Declare Function RegSetValueExString Lib "advapi32.dll" Alias "RegSetValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal Reserved As Long, ByVal dwType As Long, ByVal lpData As String, ByVal cbData As Long) As Long '
Private Declare Function RegOpenKeyEx Lib "advapi32.dll" Alias "RegOpenKeyExA" (ByVal hKey As Long, ByVal lpSubKey As String, ByVal ulOptions As Long, ByVal samDesired As Long, phkResult As Long) As Long
Private Declare Function RegQueryValueEx Lib "advapi32.dll" Alias "RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, lpType As Long, lpData As Any, lpcbData As Long) As Long
Private Declare Function RegDeleteKey Lib "advapi32.dll" Alias "RegDeleteKeyA" (ByVal hKey As Long, ByVal lpSubKey As String) As Long
Private Type SECURITY_ATTRIBUTES
NLONGTH As Long
bInheritHandle As Boolean
End Type
Private NotiFy1 As SECURITY_ATTRIBUTES
Public Const HKEY_LOCAL_MACHINE = &H80000002
Public Const REG_SZ = 1
Private Const STANDARD_RIGHTS_ALL = &H1F0000
Private Const KEY_CREATE_SUB_KEY = &H4
Private Const KEY_ENUMERATE_SUB_KEYS = &H8
Private Const KEY_QUERY_VALUE = &H1
Private Const KEY_SET_VALUE = &H2
Private Const KEY_NOTIFY = &H10
Private Const KEY_CREATE_LINK = &H20
Private Const SYNCHRONIZE = &H100000
Private Const KEY_ALL_ACCESS = ((STANDARD_RIGHTS_ALL Or KEY_QUERY_VALUE Or KEY_SET_VALUE Or KEY_CREATE_SUB_KEY Or KEY_ENUMERATE_SUB_KEYS Or KEY_NOTIFY Or KEY_CREATE_LINK) And (Not SYNCHRONIZE))
Private Const ERROR_SUCCESS = 0&
Private Const REG_OPTION_NON_VOLATILE = 0
Private Const STANDARD_RIGHTS_READ = &H20000
Private Const KEY_READ = ((STANDARD_RIGHTS_READ Or _
KEY_QUERY_VALUE Or _
KEY_ENUMERATE_SUB_KEYS Or _
KEY_NOTIFY) And _
(Not SYNCHRONIZE))
Dim Rc As Long
Dim hKey As Long
Dim lpData As String
Dim lpDataW As Long
Dim lpcbData As Long
Public Declare Function SHFileExists Lib "shell32.dll" Alias "#45" (ByVal szPath As String) As Long
Public Fapath As String '存放本程序所在路径名
Public MyTxtFile$ '菜单关联的文件的路径与文件名
Dim MyExeName$
'读取一个键值
Public Function GetRegValue(ByVal hKeyRoot As Long, ByVal SubKey As String, ByVal KeyValueName As String, ByVal ValueType As Long) As Variant
Rc = RegOpenKeyEx(hKeyRoot, SubKey, 0, KEY_READ, hKey)
If Rc <> ERROR_SUCCESS Then
Exit Function
End If
Rc = RegQueryValueEx(hKey, KeyValueName, 0, ValueType, ByVal 0, lpcbData)
If Rc <> ERROR_SUCCESS Then Exit Function
lpcbData = 260
lpData = String(lpcbData, Chr(0))
Rc = RegQueryValueEx(hKey, KeyValueName, 0, REG_SZ, ByVal lpData, lpcbData)
If Rc = ERROR_SUCCESS Then
Dim Regs As String, Lop As Integer
Regs = Left(lpData, lpcbData - 1)
Lop = InStr(Regs, Chr(0))
If Lop <> 0 Then Regs = Mid$(Regs, 1, Lop - 1)
GetRegValue = Regs
Else
GetRegValue = ""
End If
RegCloseKey hKey
End Function
'在注册表中创建一个键值
Public Function CreaSub(ByVal LngKey As Long, ByVal SubKey1 As String, ByVal KeyName As String, KeyValue As Variant, ByVal KeyValueType As Long)
Dim KeyHandle As Long
Dim ReturnValue As Long
Dim R1, R2, R3, R4 As Long
Dim Tt1 As String
R1 = RegCreateKeyEx(LngKey, SubKey1, 0&, Tt1, REG_OPTION_NON_VOLATILE, KEY_ALL_ACCESS, NotiFy1, KeyHandle, ReturnValue) ' RegOpenKeyEx(LngKey, SubKey1, 0, KEY_SET_VALUE, KeyHandle)
If R1 = ERROR_SUCCESS Then
R1 = SetValueEx(KeyHandle, KeyName, KeyValueType, KeyValue)
R4 = RegCloseKey(KeyHandle)
Else
Beep
MsgBox "访问注册表出错！！", 16, "注意"
Exit Function
End If
End Function
'设置REG_SZ值
Private Function SetValueEx(ByVal hKey As Long, sValueName As String, _
lType As Long, vValue As Variant) As Long
Dim sValue As String
sValue = vValue & Chr$(0)
SetValueEx = RegSetValueExString(hKey, sValueName, 0&, lType, sValue, Len(sValue))
End Function
'在注册表中删除一个键
Public Function DeleKeyN(ByVal LngKey As Long, ByVal SubKey1 As String) As Long
Dim KeyHandle As Long
Dim R1 As Long
R1 = RegOpenKeyEx(LngKey, SubKey1, 0&, KEY_ALL_ACCESS, KeyHandle)
If R1 = 0 Then
R1 = RegDeleteKey(LngKey, SubKey1)
If R1 = ERROR_SUCCESS Then
DeleKeyN = 1
RegCloseKey KeyHandle
Exit Function
Else
DeleKeyN = 0
End If
RegCloseKey KeyHandle
End If
End Function
'启动加载过程
Sub Main()
Dim CmdStr As String
Dim Regv$
CmdStr = Command '取命令行参数
Fapath = App.Path '程序所在路径
MyExeName = App.EXEName 'EXE文件名
'此处处理磁盘根目录与子目录
If Right(Fapath, 1) <> "\" Then Fapath = Fapath & "\"
'此处取得TXT文件类型名
Regv = GetRegValue(HKEY_LOCAL_MACHINE, "Software\classes\.txt", "", REG_SZ)
'此处在TXT文件下的Shell子键下建立与此类文件关联的右键菜注意键值中的%1
'此即为返加点击右键菜时所对应的文件名与路径
'此处添加的菜单名为——"发送到" & MyExeName
If Regv <> "" Then _
CreaSub HKEY_LOCAL_MACHINE, "Software\classes\" & Regv & "\shell\" & _
"发送到" & MyExeName & "\command", "", Fapath & MyExeName & ".exe %1", REG_SZ
'此处利用命令行形式获取此文件的路径与名字
If CmdStr <> "" Then
MyTxtFile = Mid$(CmdStr, 3, Len(CmdStr) - 2)
End If
Load MainFrm
End Sub
以下在FORM中
'在窗体中添加一文本框
'在窗体的调用事件中输入如代码
'文件内是否已在文本框中了呢？
'调试完后请自行调用删除一个键值代码删除刚建立的键值
'另请注意正常情况下文本框只能处理32KB内容，超过可能……haha!!
'在读某些文件可能出错请自行完整。
Private Sub Form_Load()
Dim FileHa&
If SHFileExists(MyTxtFile) Then
FileHa = FreeFile
Open MyTxtFile For Input As #FileHa
Text1.Text = StrConv(InputB$(LOF(FileHa), #FileHa), vbUnicode)
Close #FileHa
Else
Text1.Text = "程序出错," & MyTxtFile & "不存在！！"
End If
Me.Show
DoEvents
End Sub
编写Context menu handles必须实现IShellExtInit(实现初始化）、IContextMenu(实现上下文相关菜单）与TComObjectFactory(实现对象的创建）三个接口。真正要做至象WINZIP等一样用VB实现有相当的困难；我有DELPHI的原代码，若要请留下EMAIL；但声明一点我也是参考了一些资料及代码后做出来的不过封装为DLL后在VB做的软件中应该也可以用。
另若嫌麻烦，也可用楼上的方法只不过稍作要改造即可处理相应文件。我以前用这种方法做过一个收集资料的小软件，若在文本类文件上单击右键即出添加菜单条目，单击此菜单条目即可把此文件导入我的资料库中，具体实现代码如下：
此处只给出TXT类文件添加右键菜单并通过单击右键菜把文件内容读入窗体的文本框中的代码（以下代码在VB6WINDOWSME下调试通过）：
其余类同。代码没有优化见笑了各位大侠。
以下在BAS中
Private Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long
Private Declare Function RegCreateKeyEx Lib "advapi32.dll" Alias "RegCreateKeyExA" (ByVal hKey As Long, ByVal lpSubKey As String, ByVal Reserved As Long, ByVal lpClass As String, ByVal dwOptions As Long, ByVal samDesired As Long, lpSecurityAttributes As SECURITY_ATTRIBUTES, phkResult As Long, lpdwDisposition As Long) As Long
Private Declare Function RegSetValueExString Lib "advapi32.dll" Alias "RegSetValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal Reserved As Long, ByVal dwType As Long, ByVal lpData As String, ByVal cbData As Long) As Long '
Private Declare Function RegOpenKeyEx Lib "advapi32.dll" Alias "RegOpenKeyExA" (ByVal hKey As Long, ByVal lpSubKey As String, ByVal ulOptions As Long, ByVal samDesired As Long, phkResult As Long) As Long
Private Declare Function RegQueryValueEx Lib "advapi32.dll" Alias "RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, lpType As Long, lpData As Any, lpcbData As Long) As Long
Private Declare Function RegDeleteKey Lib "advapi32.dll" Alias "RegDeleteKeyA" (ByVal hKey As Long, ByVal lpSubKey As String) As Long
Private Type SECURITY_ATTRIBUTES
NLONGTH As Long
bInheritHandle As Boolean
End Type
Private NotiFy1 As SECURITY_ATTRIBUTES
Public Const HKEY_LOCAL_MACHINE = &H80000002
Public Const REG_SZ = 1
Private Const STANDARD_RIGHTS_ALL = &H1F0000
Private Const KEY_CREATE_SUB_KEY = &H4
Private Const KEY_ENUMERATE_SUB_KEYS = &H8
Private Const KEY_QUERY_VALUE = &H1
Private Const KEY_SET_VALUE = &H2
Private Const KEY_NOTIFY = &H10
Private Const KEY_CREATE_LINK = &H20
Private Const SYNCHRONIZE = &H100000
Private Const KEY_ALL_ACCESS = ((STANDARD_RIGHTS_ALL Or KEY_QUERY_VALUE Or KEY_SET_VALUE Or KEY_CREATE_SUB_KEY Or KEY_ENUMERATE_SUB_KEYS Or KEY_NOTIFY Or KEY_CREATE_LINK) And (Not SYNCHRONIZE))
Private Const ERROR_SUCCESS = 0&
Private Const REG_OPTION_NON_VOLATILE = 0
Private Const STANDARD_RIGHTS_READ = &H20000
Private Const KEY_READ = ((STANDARD_RIGHTS_READ Or _
KEY_QUERY_VALUE Or _
KEY_ENUMERATE_SUB_KEYS Or _
KEY_NOTIFY) And _
(Not SYNCHRONIZE))
Dim Rc As Long
Dim hKey As Long
Dim lpData As String
Dim lpDataW As Long
Dim lpcbData As Long
Public Declare Function SHFileExists Lib "shell32.dll" Alias "#45" (ByVal szPath As String) As Long
Public Fapath As String '存放本程序所在路径名
Public MyTxtFile$ '菜单关联的文件的路径与文件名
Dim MyExeName$
'读取一个键值
Public Function GetRegValue(ByVal hKeyRoot As Long, ByVal SubKey As String, ByVal KeyValueName As String, ByVal ValueType As Long) As Variant
Rc = RegOpenKeyEx(hKeyRoot, SubKey, 0, KEY_READ, hKey)
If Rc <> ERROR_SUCCESS Then
Exit Function
End If
Rc = RegQueryValueEx(hKey, KeyValueName, 0, ValueType, ByVal 0, lpcbData)
If Rc <> ERROR_SUCCESS Then Exit Function
lpcbData = 260
lpData = String(lpcbData, Chr(0))
Rc = RegQueryValueEx(hKey, KeyValueName, 0, REG_SZ, ByVal lpData, lpcbData)
If Rc = ERROR_SUCCESS Then
Dim Regs As String, Lop As Integer
Regs = Left(lpData, lpcbData - 1)
Lop = InStr(Regs, Chr(0))
If Lop <> 0 Then Regs = Mid$(Regs, 1, Lop - 1)
GetRegValue = Regs
Else
GetRegValue = ""
End If
RegCloseKey hKey
End Function
'在注册表中创建一个键值
Public Function CreaSub(ByVal LngKey As Long, ByVal SubKey1 As String, ByVal KeyName As String, KeyValue As Variant, ByVal KeyValueType As Long)
Dim KeyHandle As Long
Dim ReturnValue As Long
Dim R1, R2, R3, R4 As Long
Dim Tt1 As String
R1 = RegCreateKeyEx(LngKey, SubKey1, 0&, Tt1, REG_OPTION_NON_VOLATILE, KEY_ALL_ACCESS, NotiFy1, KeyHandle, ReturnValue) ' RegOpenKeyEx(LngKey, SubKey1, 0, KEY_SET_VALUE, KeyHandle)
If R1 = ERROR_SUCCESS Then
R1 = SetValueEx(KeyHandle, KeyName, KeyValueType, KeyValue)
R4 = RegCloseKey(KeyHandle)
Else
Beep
MsgBox "访问注册表出错！！", 16, "注意"
Exit Function
End If
End Function
'设置REG_SZ值
Private Function SetValueEx(ByVal hKey As Long, sValueName As String, _
lType As Long, vValue As Variant) As Long
Dim sValue As String
sValue = vValue & Chr$(0)
SetValueEx = RegSetValueExString(hKey, sValueName, 0&, lType, sValue, Len(sValue))
End Function
'在注册表中删除一个键
Public Function DeleKeyN(ByVal LngKey As Long, ByVal SubKey1 As String) As Long
Dim KeyHandle As Long
Dim R1 As Long
R1 = RegOpenKeyEx(LngKey, SubKey1, 0&, KEY_ALL_ACCESS, KeyHandle)
If R1 = 0 Then
R1 = RegDeleteKey(LngKey, SubKey1)
If R1 = ERROR_SUCCESS Then
DeleKeyN = 1
RegCloseKey KeyHandle
Exit Function
Else
DeleKeyN = 0
End If
RegCloseKey KeyHandle
End If
End Function
'启动加载过程
Sub Main()
Dim CmdStr As String
Dim Regv$
CmdStr = Command '取命令行参数
Fapath = App.Path '程序所在路径
MyExeName = App.EXEName 'EXE文件名
'此处处理磁盘根目录与子目录
If Right(Fapath, 1) <> "\" Then Fapath = Fapath & "\"
'此处取得TXT文件类型名
Regv = GetRegValue(HKEY_LOCAL_MACHINE, "Software\classes\.txt", "", REG_SZ)
'此处在TXT文件下的Shell子键下建立与此类文件关联的右键菜注意键值中的%1
'此即为返加点击右键菜时所对应的文件名与路径
'此处添加的菜单名为——"发送到" & MyExeName
If Regv <> "" Then _
CreaSub HKEY_LOCAL_MACHINE, "Software\classes\" & Regv & "\shell\" & _
"发送到" & MyExeName & "\command", "", Fapath & MyExeName & ".exe %1", REG_SZ
'此处利用命令行形式获取此文件的路径与名字
If CmdStr <> "" Then
MyTxtFile = Mid$(CmdStr, 3, Len(CmdStr) - 2)
End If
Load MainFrm
End Sub
以下在FORM中
'在窗体中添加一文本框
'在窗体的调用事件中输入如代码
'文件内是否已在文本框中了呢？
'调试完后请自行调用删除一个键值代码删除刚建立的键值
'另请注意正常情况下文本框只能处理32KB内容，超过可能……haha!!
'在读某些文件可能出错请自行完整。
Private Sub Form_Load()
Dim FileHa&
If SHFileExists(MyTxtFile) Then
FileHa = FreeFile
Open MyTxtFile For Input As #FileHa
Text1.Text = StrConv(InputB$(LOF(FileHa), #FileHa), vbUnicode)
Close #FileHa
Else
Text1.Text = "程序出错," & MyTxtFile & "不存在！！"
End If
Me.Show
DoEvents
End Sub
blacklevin 2003-01-13
我把上面的的代码重新写了一下
这样可以很直观的看到
现在无论反键点任何地方都可以在右键菜单执行ms-dos
Const HKEY_CLASSES_ROOT = &H80000000
Private Declare Function RegCloseKey Lib "advapi32.dll" (ByVal Hkey As Long) As Long
Private Declare Function RegCreateKey Lib "advapi32.dll" Alias "RegCreateKeyA" (ByVal Hkey As Long, ByVal lpSubKey As String, phkResult As Long) As Long
Private Declare Function RegSetValueEx Lib "advapi32.dll" Alias "RegSetValueExA" (ByVal Hkey As Long, ByVal lpValueName As String, ByVal Reserved As Long, ByVal dwType As Long, lpData As Any, ByVal cbData As Long) As Long
Const REG_SZ = 1
Private Sub savestring(Hkey As Long, strPath As String, strValue As String, strdata As String)
Dim keyhand As Long
Dim r As Long
r = RegCreateKey(Hkey, strPath, keyhand)
r = RegSetValueEx(keyhand, strValue, 0, REG_SZ, ByVal strdata, Len(strdata))
r = RegCloseKey(keyhand)
End Sub
Private Sub asscociateFileInPopup(sFileType As String)
Dim sReg As String
savestring HKEY_CLASSES_ROOT, sFileType & "\shell\ms-dos\", "", "执行ms-dos"
sReg = "c:\windows\system32\cmd.exe"
savestring HKEY_CLASSES_ROOT, sFileType & "\shell\ms-dos\command\", "", sReg
End Sub
Private Sub Form_Load()
asscociateFileInPopup "*"
asscociateFileInPopup "Directory"
asscociateFileInPopup "Drive"
asscociateFileInPopup "Folder"
End Sub
这样可以很直观的看到
现在无论反键点任何地方都可以在右键菜单执行ms-dos
Const HKEY_CLASSES_ROOT = &H80000000
Private Declare Function RegCloseKey Lib "advapi32.dll" (ByVal Hkey As Long) As Long
Private Declare Function RegCreateKey Lib "advapi32.dll" Alias "RegCreateKeyA" (ByVal Hkey As Long, ByVal lpSubKey As String, phkResult As Long) As Long
Private Declare Function RegSetValueEx Lib "advapi32.dll" Alias "RegSetValueExA" (ByVal Hkey As Long, ByVal lpValueName As String, ByVal Reserved As Long, ByVal dwType As Long, lpData As Any, ByVal cbData As Long) As Long
Const REG_SZ = 1
Private Sub savestring(Hkey As Long, strPath As String, strValue As String, strdata As String)
Dim keyhand As Long
Dim r As Long
r = RegCreateKey(Hkey, strPath, keyhand)
r = RegSetValueEx(keyhand, strValue, 0, REG_SZ, ByVal strdata, Len(strdata))
r = RegCloseKey(keyhand)
End Sub
Private Sub asscociateFileInPopup(sFileType As String)
Dim sReg As String
savestring HKEY_CLASSES_ROOT, sFileType & "\shell\ms-dos\", "", "执行ms-dos"
sReg = "c:\windows\system32\cmd.exe"
savestring HKEY_CLASSES_ROOT, sFileType & "\shell\ms-dos\command\", "", sReg
End Sub
Private Sub Form_Load()
asscociateFileInPopup "*"
asscociateFileInPopup "Directory"
asscociateFileInPopup "Drive"
asscociateFileInPopup "Folder"
End Sub
pdy11 2003-01-13
up
blacklevin 2003-01-13
Public Const HKEY_CLASSES_ROOT = &H80000000
Public Const HKEY_CURRENT_USER = &H80000001
Public Const HKEY_LOCAL_MACHINE = &H80000002
Public Const HKEY_USERS = &H80000003
Public Const HKEY_PERFORMANCE_DATA = &H80000004
Public Const ERROR_SUCCESS = 0&
Declare Function RegCloseKey Lib "advapi32.dll" (ByVal Hkey As Long) As Long
Declare Function RegCreateKey Lib "advapi32.dll" Alias "RegCreateKeyA" (ByVal Hkey As Long, ByVal lpSubKey As String, phkResult As Long) As Long
Declare Function RegDeleteKey Lib "advapi32.dll" Alias "RegDeleteKeyA" (ByVal Hkey As Long, ByVal lpSubKey As String) As Long
Declare Function RegDeleteValue Lib "advapi32.dll" Alias "RegDeleteValueA" (ByVal Hkey As Long, ByVal lpValueName As String) As Long
Declare Function RegOpenKey Lib "advapi32.dll" Alias "RegOpenKeyA" (ByVal Hkey As Long, ByVal lpSubKey As String, phkResult As Long) As Long
Declare Function RegQueryValueEx Lib "advapi32.dll" Alias "RegQueryValueExA" (ByVal Hkey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, lpType As Long, lpData As Any, lpcbData As Long) As Long
Declare Function RegSetValueEx Lib "advapi32.dll" Alias "RegSetValueExA" (ByVal Hkey As Long, ByVal lpValueName As String, ByVal Reserved As Long, ByVal dwType As Long, lpData As Any, ByVal cbData As Long) As Long
Public Const REG_SZ = 1 ' Unicode nul terminated string
Public Const REG_DWORD = 4 ' 32-bit number
Public Sub savekey(Hkey As Long, strPath As String)
Dim keyhand&
r = RegCreateKey(Hkey, strPath, keyhand&)
r = RegCloseKey(keyhand&)
End Sub
Public Function getstring(Hkey As Long, strPath As String, strValue As String)
Dim keyhand As Long
Dim datatype As Long
Dim lResult As Long
Dim strBuf As String
Dim lDataBufSize As Long
Dim intZeroPos As Integer
r = RegOpenKey(Hkey, strPath, keyhand)
lResult = RegQueryValueEx(keyhand, strValue, 0&, lValueType, ByVal 0&, lDataBufSize)
If lValueType = REG_SZ Then
strBuf = String(lDataBufSize, " ")
lResult = RegQueryValueEx(keyhand, strValue, 0&, 0&, ByVal strBuf, lDataBufSize)
If lResult = ERROR_SUCCESS Then
intZeroPos = InStr(strBuf, Chr$(0))
If intZeroPos > 0 Then
getstring = Left$(strBuf, intZeroPos - 1)
Else
getstring = strBuf
End If
End If
End If
End Function
Public Sub savestring(Hkey As Long, strPath As String, strValue As String, strdata As String)
Dim keyhand As Long
Dim r As Long
r = RegCreateKey(Hkey, strPath, keyhand)
r = RegSetValueEx(keyhand, strValue, 0, REG_SZ, ByVal strdata, Len(strdata))
r = RegCloseKey(keyhand)
End Sub
Function getdword(ByVal Hkey As Long, ByVal strPath As String, ByVal strValueName As String) As Long
Dim lResult As Long
Dim lValueType As Long
Dim lBuf As Long
Dim lDataBufSize As Long
Dim r As Long
Dim keyhand As Long
r = RegOpenKey(Hkey, strPath, keyhand)
' Get length/data type
lDataBufSize = 4
lResult = RegQueryValueEx(keyhand, strValueName, 0&, lValueType, lBuf, lDataBufSize)
If lResult = ERROR_SUCCESS Then
If lValueType = REG_DWORD Then
getdword = lBuf
End If
'Else
' Call errlog("GetDWORD-" & strPath, False)
End If
r = RegCloseKey(keyhand)
End Function
Function SaveDword(ByVal Hkey As Long, ByVal strPath As String, ByVal strValueName As String, ByVal lData As Long)
Dim lResult As Long
Dim keyhand As Long
Dim r As Long
r = RegCreateKey(Hkey, strPath, keyhand)
lResult = RegSetValueEx(keyhand, strValueName, 0&, REG_DWORD, lData, 4)
'If lResult <> error_success Then Call errlog("SetDWORD", False)
r = RegCloseKey(keyhand)
End Function
Public Function DeleteKey(ByVal Hkey As Long, ByVal strKey As String)
Dim r As Long
r = RegDeleteKey(Hkey, strKey)
End Function
Public Function DeleteValue(ByVal Hkey As Long, ByVal strPath As String, ByVal strValue As String)
Dim keyhand As Long
r = RegOpenKey(Hkey, strPath, keyhand)
r = RegDeleteValue(keyhand, strValue)
r = RegCloseKey(keyhand)
End Function
Public Sub asscociateFileInPopup(sFileType As String)
Dim sReg As String
sReg = Chr(34) & App.Path & "\" & App.EXEName & ".exe" & Chr(34) & " " & Chr(34) & "%1" & Chr(34)
savestring HKEY_CLASSES_ROOT, sFileType & "\shell\Edit With &Ultra HTML Designer\command", "", sReg
End Sub
asscociateFileInPopup "htmlfile"
Public Const HKEY_CURRENT_USER = &H80000001
Public Const HKEY_LOCAL_MACHINE = &H80000002
Public Const HKEY_USERS = &H80000003
Public Const HKEY_PERFORMANCE_DATA = &H80000004
Public Const ERROR_SUCCESS = 0&
Declare Function RegCloseKey Lib "advapi32.dll" (ByVal Hkey As Long) As Long
Declare Function RegCreateKey Lib "advapi32.dll" Alias "RegCreateKeyA" (ByVal Hkey As Long, ByVal lpSubKey As String, phkResult As Long) As Long
Declare Function RegDeleteKey Lib "advapi32.dll" Alias "RegDeleteKeyA" (ByVal Hkey As Long, ByVal lpSubKey As String) As Long
Declare Function RegDeleteValue Lib "advapi32.dll" Alias "RegDeleteValueA" (ByVal Hkey As Long, ByVal lpValueName As String) As Long
Declare Function RegOpenKey Lib "advapi32.dll" Alias "RegOpenKeyA" (ByVal Hkey As Long, ByVal lpSubKey As String, phkResult As Long) As Long
Declare Function RegQueryValueEx Lib "advapi32.dll" Alias "RegQueryValueExA" (ByVal Hkey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, lpType As Long, lpData As Any, lpcbData As Long) As Long
Declare Function RegSetValueEx Lib "advapi32.dll" Alias "RegSetValueExA" (ByVal Hkey As Long, ByVal lpValueName As String, ByVal Reserved As Long, ByVal dwType As Long, lpData As Any, ByVal cbData As Long) As Long
Public Const REG_SZ = 1 ' Unicode nul terminated string
Public Const REG_DWORD = 4 ' 32-bit number
Public Sub savekey(Hkey As Long, strPath As String)
Dim keyhand&
r = RegCreateKey(Hkey, strPath, keyhand&)
r = RegCloseKey(keyhand&)
End Sub
Public Function getstring(Hkey As Long, strPath As String, strValue As String)
Dim keyhand As Long
Dim datatype As Long
Dim lResult As Long
Dim strBuf As String
Dim lDataBufSize As Long
Dim intZeroPos As Integer
r = RegOpenKey(Hkey, strPath, keyhand)
lResult = RegQueryValueEx(keyhand, strValue, 0&, lValueType, ByVal 0&, lDataBufSize)
If lValueType = REG_SZ Then
strBuf = String(lDataBufSize, " ")
lResult = RegQueryValueEx(keyhand, strValue, 0&, 0&, ByVal strBuf, lDataBufSize)
If lResult = ERROR_SUCCESS Then
intZeroPos = InStr(strBuf, Chr$(0))
If intZeroPos > 0 Then
getstring = Left$(strBuf, intZeroPos - 1)
Else
getstring = strBuf
End If
End If
End If
End Function
Public Sub savestring(Hkey As Long, strPath As String, strValue As String, strdata As String)
Dim keyhand As Long
Dim r As Long
r = RegCreateKey(Hkey, strPath, keyhand)
r = RegSetValueEx(keyhand, strValue, 0, REG_SZ, ByVal strdata, Len(strdata))
r = RegCloseKey(keyhand)
End Sub
Function getdword(ByVal Hkey As Long, ByVal strPath As String, ByVal strValueName As String) As Long
Dim lResult As Long
Dim lValueType As Long
Dim lBuf As Long
Dim lDataBufSize As Long
Dim r As Long
Dim keyhand As Long
r = RegOpenKey(Hkey, strPath, keyhand)
' Get length/data type
lDataBufSize = 4
lResult = RegQueryValueEx(keyhand, strValueName, 0&, lValueType, lBuf, lDataBufSize)
If lResult = ERROR_SUCCESS Then
If lValueType = REG_DWORD Then
getdword = lBuf
End If
'Else
' Call errlog("GetDWORD-" & strPath, False)
End If
r = RegCloseKey(keyhand)
End Function
Function SaveDword(ByVal Hkey As Long, ByVal strPath As String, ByVal strValueName As String, ByVal lData As Long)
Dim lResult As Long
Dim keyhand As Long
Dim r As Long
r = RegCreateKey(Hkey, strPath, keyhand)
lResult = RegSetValueEx(keyhand, strValueName, 0&, REG_DWORD, lData, 4)
'If lResult <> error_success Then Call errlog("SetDWORD", False)
r = RegCloseKey(keyhand)
End Function
Public Function DeleteKey(ByVal Hkey As Long, ByVal strKey As String)
Dim r As Long
r = RegDeleteKey(Hkey, strKey)
End Function
Public Function DeleteValue(ByVal Hkey As Long, ByVal strPath As String, ByVal strValue As String)
Dim keyhand As Long
r = RegOpenKey(Hkey, strPath, keyhand)
r = RegDeleteValue(keyhand, strValue)
r = RegCloseKey(keyhand)
End Function
Public Sub asscociateFileInPopup(sFileType As String)
Dim sReg As String
sReg = Chr(34) & App.Path & "\" & App.EXEName & ".exe" & Chr(34) & " " & Chr(34) & "%1" & Chr(34)
savestring HKEY_CLASSES_ROOT, sFileType & "\shell\Edit With &Ultra HTML Designer\command", "", sReg
End Sub
asscociateFileInPopup "htmlfile"