Code works in VB 6, but not in Excel 2002 or Word 2002
Excel 2002 or Word 2002.
Only 1 line of code needs to be changed to run in each of those three
environments, the assignment to strCurrentDir.
Code is intended to register a DLL and replace, if any, an extant DLL.
Either I've made an error that, at this time, I do not yet see. Or there's a
difference between VB and VBA in handling, perhaps, the unregistration of a
DLL.
There are two modules listed below, separated by
''''.
Option Explicit
Private Declare Function RegisterDLL Lib "ColorDLL.dll" _
Alias "DllRegisterServer" () As Long
Private Declare Function UnRegisterDLL Lib "ColorDLL.dll" _
Alias "DllUnregisterServer" () As Long
Public Sub main()
InstallDll
End Sub
Private Sub InstallDll()
Const strDLLName As String = "ColorDLL"
Const strDLLFile As String = strDLLName & ".dll"
Dim strCurrentDir As String
Dim strPurpleDir As String
' strCurrentDir = ThisWorkbook.Path & "\" ' For Excel
' strCurrentDir = App.Path & "\" ' For VB
strCurrentDir = ThisDocument.Path & "\" ' For Word
strPurpleDir = GetProgramFilesDir() & "\Purple\"
If vbYes = MsgBox(Prompt:="Do you wish to install " & strDLLName &
vbCrLf & _
"in the " & strPurpleDir & " directory?", Buttons:=vbYesNo,
Title:="DLL Install") Then
On Error Resume Next
ChDir strPurpleDir
If Err.Number = 0 Then
Debug.Print "Purple directory exists"
On Error Resume Next
If UnRegisterDLL = 0 Then
Debug.Print "Unregistered successfully"
End If
Select Case Err.Number
Case 0
Debug.Print "OK, 0"
Case 53
Debug.Print "OK, 53"
Case Else
With Err
Debug.Print "Unregister failed: " & .Number & " " &
..Description
End With
End Select
Else
MkDir strPurpleDir
Debug.Print "Purple directory created"
End If
On Error GoTo 0
ChDir strCurrentDir
Debug.Print "''''"
Debug.Print strPurpleDir & strDLLFile
Debug.Print Dir(strPurpleDir & strDLLFile)
Debug.Print strCurrentDir & strDLLFile
Debug.Print Dir(strCurrentDir & strDLLFile)
Debug.Print "xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx"
If Len(Dir(strPurpleDir & strDLLFile)) <> 0 Then
On Error Resume Next
Kill strPurpleDir & strDLLFile
With Err
Debug.Print "After Kill: " & .Number & " " & .Description
End With
End If
On Error Resume Next
FileCopy strCurrentDir & strDLLFile, strPurpleDir & strDLLFile
If Err.Number = 0 Then
Debug.Print "Install successful!"
On Error GoTo RegisterFailed
If RegisterDLL = 0 Then
Debug.Print "Registered successfully"
Else
Debug.Print "Not registered, error = 0"
End If
Else
With Err
Debug.Print "Could not install: " & .Number & " " &
..Description
End With
MsgBox Prompt:="Could not install " & strDLLName & "." _
& vbCrLf & vbCrLf & "You may install the add-in manually by
copying the file " & _
strDLLFile & " to:" _
& vbCrLf & vbCrLf & strPurpleDir & "\" _
& vbCrLf & vbCrLf & "And then use regsvr32.", _
Buttons:=vbOKOnly, Title:="DLL Install"
Exit Sub
End If
On Error GoTo 0
Else
MsgBox Prompt:="Install Cancelled", Buttons:=vbOKOnly, Title:="DLL
Install"
End If
ChDir strCurrentDir
On Error GoTo 0
Exit Sub
RegisterFailed:
With Err
Debug.Print "Register failed: " & .Number & " " & .Description
End With
End Sub
''''
Option Explicit
Private Const CSIDL_FLAG_CREATE = &H8000&
Private Const CSIDL_PROGRAM_FILES = &H26&
Private Const SHGFP_TYPE_CURRENT = 0
Private Const MAX_PATH = 260
Private Declare Function SHGetFolderPath Lib "shfolder" _
Alias "SHGetFolderPathA" _
(ByVal hwndOwner As Long, ByVal nFolder As Long, _
ByVal hToken As Long, ByVal dwFlags As Long, _
ByVal pszPath As String) As Long
Public Function GetProgramFilesDir() As String
Dim sPath As String
Dim RetVal As Long
sPath = String(MAX_PATH, 0)
RetVal = SHGetFolderPath(0, CSIDL_PROGRAM_FILES Or CSIDL_FLAG_CREATE, 0,
_
SHGFP_TYPE_CURRENT, sPath)
GetProgramFilesDir = Left(sPath, InStr(1, sPath, Chr(0)) - 1)
End Function
--
http://www.standards.com/; Programming and support for Word macros,
including converting from WordBasic to VBA; Technical reviewing; Standards;
Product functional/design/specifications
---------------

