Categories: MSDN / DotNet / Java / Scripts / Linux / PHP Ask - La ask - La Answer

Code works in VB 6, but not in Excel 2002 or Word 2002

The code below runs correctly in VB 6, and does not run correctly in either
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
---------------
[4724 byte] By [Howard Kaikow] at [2007-11-10 12:22:41]