frmmain.frm

一个Excel的插件

VERSION 5.00
Object = "{F9043C88-F6F2-101A-A3C9-08002B2F49FB}#1.2#0"; "COMDLG32.OCX"
Begin VB.Form frmMain 
   Caption         =   "短信精灵配置"
   ClientHeight    =   2385
   ClientLeft      =   60
   ClientTop       =   345
   ClientWidth     =   3480
   Icon            =   "frmMain.frx":0000
   LinkTopic       =   "Form1"
   MaxButton       =   0   'False
   ScaleHeight     =   2385
   ScaleWidth      =   3480
   StartUpPosition =   2  'CenterScreen
   Begin MSComDlg.CommonDialog cdMain 
      Left            =   3120
      Top             =   1440
      _ExtentX        =   847
      _ExtentY        =   847
      _Version        =   393216
   End
   Begin VB.CommandButton cmdExit 
      Caption         =   "退出"
      Height          =   375
      Left            =   1320
      TabIndex        =   2
      Top             =   1800
      Width           =   615
   End
   Begin VB.CommandButton cmdDel 
      Caption         =   "将短信精灵从Excel界面中卸载"
      Height          =   375
      Left            =   240
      TabIndex        =   1
      Top             =   1200
      Width           =   3015
   End
   Begin VB.CommandButton cmdAdd 
      Caption         =   "加载短信精灵-Excel 短信插件"
      Height          =   375
      Left            =   240
      TabIndex        =   0
      Top             =   600
      Width           =   3015
   End
   Begin VB.Label Label1 
      BackStyle       =   0  'Transparent
      Caption         =   "请您先确保退出Excel"
      ForeColor       =   &H80000002&
      Height          =   255
      Left            =   720
      TabIndex        =   3
      Top             =   240
      Width           =   1935
   End
End
Attribute VB_Name = "frmMain"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Private Const HKEY_CLASSES_ROOT = &H80000000
Private Const HKEY_CURRENT_USER = &H80000001
Private Const STANDARD_RIGHTS_ALL = &H1F0000
Private Const KEY_ENUMERATE_SUB_KEYS = &H8
Private Const KEY_SET_VALUE = &H2
Private Const KEY_CREATE_SUB_KEY = &H4
Private Const KEY_QUERY_VALUE = &H1
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 REG_MULTI_SZ = 7
Private Const ERROR_SUCCESS = 0&
Private Const READ_CONTROL = &H20000
Private Const REG_SZ = 1
Private Const REG_DWORD = 4
Private Const REG_EXPAND_SZ = 2
Private Const REG_BINARY = 3
Private Const REG_DWORD_BIG_ENDIAN = 5
Private Const REG_DWORD_LITTLE_ENDIAN = 4
Private Const REG_NONE = 0

Dim FSO As New FileSystemObject

Private Declare Function RegDeleteKey Lib "advapi32.dll" Alias "RegDeleteKeyA" (ByVal hKey As Long, ByVal lpSubKey As String) As Long
Private Declare Function RegDeleteValue Lib "advapi32.dll" Alias "RegDeleteValueA" (ByVal hKey As Long, ByVal lpValueName As String) 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 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 String, ByVal cbData As Long) As Long
Private Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey 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 String, lpcbData As Long) As Long

Private Sub cmdAdd_Click()
Dim hKey As Long ' 主键的句柄
Dim Return_OpenKey As Long '函数调用的返回值
Dim PriKey1 As String, PriKey2 As String '主键

PriKey1 = "Software\Microsoft\Office\9.0\Excel\Options" '主键
PriKey2 = "Software\Microsoft\Office\10.0\Excel\Options" '主键

Return_OpenKey = RegOpenKeyEx(HKEY_CURRENT_USER, PriKey1, 0, KEY_ALL_ACCESS, hKey)
  
'下面的函数RegCreateKey建立一个主键，如此键已存在，则打开它
If hKey = 0 Then
   Return_OpenKey = RegOpenKeyEx(HKEY_CURRENT_USER, PriKey2, 0, KEY_ALL_ACCESS, hKey)
   If hKey = 0 Then
      MsgBox "没有发现MicroSoft公司的Excel2000以上版本，短信精灵无法加载！"
      Exit Sub
   End If
End If

If FSO.FileExists("C:\Program Files\短信精灵\短信精灵.xla") = True Then
   KeyData = Chr(34) & "C:\Program Files\短信精灵\短信精灵.xla" & Chr(34)
Else
   cdMain.Filter = "Excel宏文件 " & "(*.XLA)|*.XLA"
   cdMain.ShowSave
   If InStr(cdMain.FileName, "短信精灵.xla") = 0 Then
      MsgBox "没有发现短信精灵宏文件，加载失败！"
      Exit Sub
   Else
      KeyData = Chr(34) & cdMain.FileName & Chr(34)
   End If
End If

If RegQueryValueEx(hKey, "OPEN", 0, REG_SZ, ByVal KeyData, LenB(KeyData)) = ERROR_SUCCESS Then
   MsgBox "短信精灵已经加载，不需要再次加载。"
   Exit Sub
End If

If RegSetValueEx(hKey, "OPEN", 0, REG_SZ, ByVal KeyData, LenB(KeyData)) <> ERROR_SUCCESS Then
   RegCloseKey hKey
   MsgBox "短信精灵加载失败！您可以手工加载，方法是进入工具—加载宏-浏览。"
Else
   RegCloseKey hKey
   MsgBox "短信精灵加载成功，您启动Excel即可邂逅短信短信精灵！"
   SaveSetting "FFJL", "sendstat", "Spirit", KeyData
End If

'运行此程序后，打开注册表，我们会发现在主键 HKEY_CURRENT_USER（在此主键下记录本机当前用户的一些信息）下，增加了子键"北信BITI\People"，我们还可看到两个指定的键值名称都有正确的键值。从而完成了注册的任务。
'注：此程序在VB5.0中运行通过。
 
End Sub

Private Sub cmdDel_Click()

Dim hKey As Long ' 主键的句柄
Dim Return_OpenKey As Long '函数调用的返回值
Dim PriKey1 As String, PriKey2 As String '主键
Dim KeyData As String

PriKey1 = "Software\Microsoft\Office\9.0\Excel\Options" '主键
PriKey2 = "Software\Microsoft\Office\10.0\Excel\Options" '主键

Return_OpenKey = RegOpenKeyEx(HKEY_CURRENT_USER, PriKey1, 0, KEY_ALL_ACCESS, hKey)
  
'下面的函数RegCreateKey建立一个主键，如此键已存在，则打开它
If hKey = 0 Then
   Return_OpenKey = RegOpenKeyEx(HKEY_CURRENT_USER, PriKey2, 0, KEY_ALL_ACCESS, hKey)
   If hKey = 0 Then
      MsgBox "没有发现MicroSoft公司的Excel2000以上版本，短信精灵无必要卸载！"
      Exit Sub
   End If
End If

KeyData = GetSetting("FFJL", "sendstat", "Spirit", Chr(34) & "C:\Program Files\短信精灵\短信精灵.xla" & Chr(34))

If RegQueryValueEx(hKey, "OPEN", 0, REG_SZ, ByVal KeyData, LenB(KeyData)) = ERROR_SUCCESS Then
   
   If RegDeleteValue(hKey, "OPEN") = ERROR_SUCCESS Then
      
      RegCloseKey hKey
      
      RegOpenKeyEx HKEY_CURRENT_USER, "Software\VB and VBA Program Settings\FFJL\sendstat", 0, KEY_ALL_ACCESS, hKey
      RegDeleteKey hKey, ""
      RegCloseKey hKey
       
      RegOpenKeyEx HKEY_CURRENT_USER, "Software\VB and VBA Program Settings\FFJL\Service", 0, KEY_ALL_ACCESS, hKey
      RegDeleteKey hKey, ""
      RegCloseKey hKey
      
      RegOpenKeyEx HKEY_CURRENT_USER, "Software\VB and VBA Program Settings\FFJL", 0, KEY_ALL_ACCESS, hKey
      RegDeleteKey hKey, ""
      RegCloseKey hKey
           
      MsgBox "短信精灵已经成功卸载！"
      
   End If
   
Else

   RegCloseKey hKey
   MsgBox "短信精灵已经卸载！"
   
End If

End Sub

Public Function GetBetweenPart(Con As String, tag1 As String, tag2 As String)
On Error GoTo ErrorDeal

GetBetweenPart = GetLeftPart(GetRightPart(Con, tag1), tag2)
Exit Function

ErrorDeal:
GetBetweenPart = ""

End Function

Public Function GetLeftPart(Con As String, tag As String)
On Error GoTo ErrorDeal

GetLeftPart = Left(Con, InStr(Con, tag) - 1)
Exit Function

ErrorDeal:
GetLeftPart = ""

End Function

Public Function GetRightPart(Con As String, tag As String)
On Error GoTo ErrorDeal

GetRightPart = Right(Con, Len(Con) - InStr(Con, tag) - Len(tag) + 1)
Exit Function

ErrorDeal:
GetRightPart = ""

End Function

Private Sub cmdExit_Click()

Unload Me

End Sub