Jump to content


This is a ready-only archive of the InstallSite Forum. You cannot post any new content here. / Dies ist ein Archiv des InstallSite Forums. Hier können keine neuen Beiträge veröffentlicht werden.
Photo

Creating COM+ Applications and COM Components


1 reply to this topic

bernadettefearon

bernadettefearon
  • Members
  • 94 posts

Posted 02 July 2002 - 11:47

Hi all,
I am creating an installation for a vb project which requires that I create firstly three COM+ Applications and for each of these add a number of COM components.
Is there a way to do this during install or does anyone know of some VB to run which would do this ?
Thanks
Berni
.................................[br]Bernadette Fearon[br]www.mineit.com

Leigh Ravenhall

Leigh Ravenhall
  • Members
  • 269 posts

Posted 03 July 2002 - 10:12

In theory, I guess it should be possible to do this through the ComPlus table, but I've never done it.  The following script will create a COM+/MTS server package on Win2K/NT.  It takes the following parameters:
strAppName:  The name of the application
strUsername:  The username for the application to run under
strPassword:  The password for the user
strDirectory:  The directory where the component files are
strFileSpec:  A file specification for files to add

The VBScript runs in a deferred custom action and writes messages to the UI to let the user know why it's taking so long (It's not too slow per file, but I run it with about 1500 files)

I also have scripts to delete the application, add files to an existing, etc, but I'll leave some of the fun to you.   :D

Let me know if you run into any issues and I'll try to help next time I'm on the boards.  You'll probably have to change/remove the calls to my logging routines.

Code Sample

Private Sub createCOMServer(strAppName, strUsername, strPassword, strDirectory, strFileSpec)

On Error Resume Next

Dim oMTS 'Catalog object for COM+/MTS
Dim oPackages 'Package collection of the catalog
Dim oPackage 'An individual package from the collection
Dim oComponents 'The components collection (required for NT)
Dim oUtil 'Component utility interface (required for NT)

Dim oFSO 'Scripting host file system object
Dim oFolder 'Folder from the file system object
Dim oFile 'An individual file from the folder.files collection

Dim oRecord 'Temporary MSI database record for updating the progress bar
Dim oProgressRec 'Temporary MSI database record for updating the progress bar

Dim strFile 'Filename of a file to be added to the app

Dim intPackages 'Count of the number of packages in the packages collection
Dim intReturn 'Used for trapping return values
Dim i 'Counter variabled

Dim bFound 'Flag if package is found to exist already

Dim bTerminate 'Flag to terminate a dllhost.exe process
Dim intCount 'Count of the number of dllhost.exe processes running
Dim oWMI 'Windows Management and Instrumentation object
Dim strQuery 'WMI query to retrieve dllhost.exe process objects.
Dim oProcessArray 'Array of dllhost.exe processes
Dim oProcess 'WMI process object
Dim intPIDs(20) 'Array of process IDs

Dim oRegExp 'Regular expression object for matching filenames
Dim bMatchFiles 'Flag to determine if files must match a specified criteria

Dim bNT 'Flag for operating system

bNT = checkNT()

If bNT Then
CreateLogEntry "Creating MTS server package:  " & strAppName
Else
CreateLogEntry "Creating COM+ server app:  " & strAppName
End If

'Write inital message to the progress bar
Set oRecord = Session.Installer.CreateRecord(3)

oRecord.StringData(1) = "CreateServer"
oRecord.StringData(2) = "Creating " & strAppName & " package"
oRecord.StringData(3) = ""
Session.message msiMessageTypeActionStart, oRecord

If Err.Number <> 0 Then
'Error with messaging.  Non-fatal, clear then continue
Err.Clear
End If

If bNT Then
bTerminate = False
Else
Set oWMI = GetObject("winmgmts:")

strQuery = "select * from win32_process " & _
"where Name=""DLLHOST.EXE"""

Set oProcessArray = oWMI.execquery(strQuery)

intCount = 0

For Each oProcess in oProcessArray
If intCount = UBound(intPIDs) Then
ReDim Preserve intPIDs(intCount + 5)
End If

intPIDs(intCount) = oProcess.ProcessId
intCount = intCount + 1
Next

bTerminate = True
If Err.Number <> 0 Then
'Error with process enumeration
'Clear error, then continue with installation
'Rollback/uninstall may now call for a reboot
CreateLogEntry "Error creating processID array" & vbCrLf & _
"Error number:  " & Err.Number & vbCrLf & _
"Error description:  " & Err.Description & vbCrLf & _
"Error source:  " & Err.source
Err.Clear
'Set flag so don't attempt to kill process at end
bTerminate = False
End If
End If

'Create catalog object, for use throughout action
If bNT Then
Set oMTS = CreateObject("MTSAdmin.Catalog.1")
Else
Set oMTS = CreateObject("COMAdmin.COMAdminCatalog")
End If

If Err.Number <> 0 Then
'Need to devise a suitable system for log messages.
'Currently, display message box
CreateLogEntry "Error creating catalog object." & vbCrLf & _
  "Error number:  " & Err.Number & vbCrLf & _
  "Error description:  " & Err.Description & vbCrLf & _
  "Error source:  " & Err.Source
Exit Sub
End If


'Get the list of COM+ packages on the system
If bNT Then
Set oPackages = oMTS.GetCollection("Packages")
Else
Set oPackages = oMTS.GetCollection("Applications")
End If

oPackages.Populate

If Err.Number <> 0 Then
CreateLogEntry "Error obtaining packages collection" & vbCrLf & _
"Error number:  " & Err.Number & vbCrLf & _
"Error description:  " & Err.Description & vbCrLf & _
"Error source:  " & Err.Source
Exit Sub
End If


'Initialise variables for search for existing package
intPackages = oPackages.Count
bFound = False

'For each COM+ package on the machine
For i=0 To intPackages-1
'If Not found
If bFound = False Then
'If name of old package matches name of new package
If (StrComp(oPackages.Item(i).Value("Name"), strAppName) = 0) Then
'Set flag, then remove package
'Need to log this sort of information
bFound = True
oPackages.Remove(i)
'Save the changes
oPackages.SaveChanges()
End If
End If
Next

If Err.Number <> 0 Then
'Log error removing package
CreateLogEntry "Error checking for existing package" & vbCrLf & _
"Error number:  " & Err.Number & vbCrLf & _
"Error description:  " & Err.Description & vbCrLf & _
"Error source:  " & Err.Source
Exit Sub
End If


'Add new package, then set the appropriate properties
Set oPackage = oPackages.Add()
oPackage.Value("Name") = strAppName

If bNT Then
oPackage.Value("Activation") = "Local"
Else
oPackage.Value("Activation") = 1
End If

oPackage.Value("Identity") = strUsername
oPackage.Value("Password") = strPassword
'Save the changes to the COM+ database
oPackages.SaveChanges()

If Err.Number <> 0 Then
CreateLogEntry "Error creating package" & vbCrLf & _
"Error number:  " & Err.Number & vbCrLf & _
"Error description:  " & Err.Description & vbCrLf & _
"Error source:  " & Err.Source
Exit Sub
End If

'Increment the progress bar by a few percent after creation of COM+ application.
'Application does not yet have components installed.  To make for smoother advancing
'of the progress bar, this should be broken up into smaller pieces, one piece after
'each segment of code that has gone before
Set oProgressRec = Session.Installer.CreateRecord(3)

oProgressRec.IntegerData(1) = 2
oProgressRec.IntegerData(2) = 500000
oProgressRec.IntegerData(3) = 0
Session.message msiMessageTypeProgress, oProgressRec

If Err.Number <> 0 Then
'Error with messaging.  Non-fatal, clear error and continue
Err.Clear
End If

If strDirectory = "" Then
'Not adding any files
CreateLogEntry "No directory specified, not adding any files to package"
Exit Sub
End If

If bNT Then
Set oComponents = oPackages.GetCollection("ComponentsInPackage", oPackage.Value("ID"))
Set oUtil = oComponents.GetUtilInterface
End If

If Err.Number <> 0 Then
CreateLogEntry "Error creating component utility interface" & vbCrLf & _
"Error number:  " & Err.Number & vbCrLf & _
"Error description:  " & Err.Description & _
"Error source:  " & Err.Source & _
"No components have been added to the MTS package:  " & strAppName
Exit Sub
End If

'Setup more stuff to control the progress bar.  Advance in smaller increments than previous,
'with one increment per file.  No ticks on the progress bar have been reserved for this
'custom action, therefore the possibility exists that the installation may try to increment
'the progress bar beyond 100%.  If ticks are reserved, the progress bar will jump from 76%
'to 100%
Set oProgressRec = Session.Installer.CreateRecord(3)
oProgressRec.IntegerData(1) = 2
oProgressRec.IntegerData(2) = 20000
oProgressRec.IntegerData(3) = 0

If Err.Number <> 0 Then
'Error with messaging, non-fatal.  Clear error and continue
Err.Clear
End If

Set oFSO = CreateObject("Scripting.FileSystemObject")
Set oFolder = oFSO.GetFolder(strDirectory)

'Loop through all files in the directory, add all type libraries to the package
Set oRecord = Session.Installer.CreateRecord(3)

If strFileSpec <> "" Then
'Pattern matching of filename
Set oRegExp = New RegExp
oRegExp.IgnoreCase = True
oRegExp.Pattern = FileSpecToRegExp(strFileSpec)
bMatchFiles = True
Else
bMatchFiles = False
End If

For Each oFile in oFolder.Files
strFile = oFile.Path

If (Not bMatchFiles Or oRegExp.Test(strFile)) Then
If UCase(Right(strFile,3)) = "TLB" Then
'Setup messaging to provide messages above the progress bar, explicitly listing
'what is being done.  In this case, what file is being added to the package
oRecord.StringData(1) = "CreateRDAC"
oRecord.StringData(2) = "Adding file " & strFile & " to " & strAppName & " package"
oRecord.StringData(3) = ""
Session.message msiMessageTypeActionStart, oRecord

'Update progress bar after each file
Session.message msiMessageTypeProgress, oProgressRec

If Err.Number <> 0 Then
'Error with messaging.  Non fatal, clear then continue
Err.Clear
End If

'Finally add the particular component
If bNT Then
oUtil.InstallComponent strFile, "", ""
Else
oMTS.InstallComponent strAppName, strFile, "", ""
End If

If Err.Number <> 0 Then
'Log
CreateLogEntry "Error adding item to package" & vbCrLf & _
  "Error number:  " & Err.Number & vbCrLf & _
  "Error description:  " & Err.Description & vbCrLf & _
  "Error source:  " & Err.Source & vbCrLf & vbCrLf & _
  "Item being added was:  " & strFile
Err.Clear
Else
CreateLogEntry strFile & " successfully added to package " & strAppName
End If
End If
End If
Next


'Loop through all files in the directory, add all dll files to the package
For Each oFile in oFolder.Files
strFile = oFile.Path

If (Not bMatchFiles Or oRegExp.Test(strFile)) Then
If UCase(Right(strFile,3)) = "DLL" Then

'See comments from previous loop
oRecord.StringData(1) = "CreateRDAC"
oRecord.StringData(2) = "Adding file " & strFile & " to " & strAppName & " package"
oRecord.StringData(3) = ""
Session.message msiMessageTypeActionStart, oRecord

Session.message msiMessageTypeProgress, oProgressRec

If Err.Number <> 0 Then
'Clear error thrown by installer messaging components, proceed with install
Err.Clear
End If

'Add the component
If bNT Then
oUtil.InstallComponent strFile, "", ""
Else
oMTS.InstallComponent strAppName, strFile, "", ""
End If

If Err.Number <> 0 Then
'Log
CreateLogEntry "Error adding item to package" & vbCrLf & _
  "Error number:  " & Err.Number & vbCrLf & _
  "Error description:  " & Err.Description & vbCrLf & _
  "Error source:  " & Err.Source & vbCrLf & vbCrLf & _
  "Item being added was:  " & strFile
Err.Clear
Else
CreateLogEntry strFile & " successfully added to package " & strAppName
End If
End If
End If
Next

If Err.Number <> 0 Then
CreateLogEntry "Error occurred" & vbCrLf & _
"Error number:  " & Err.Number & vbCrLf & _
"Error description:  " & Err.Description & vbCrLf & _
"Error source:  " & Err.Source
Err.Clear
End If

If bTerminate Then
Set oProcessArray = oWMI.execquery(strQuery)

For Each oProcess in oProcessArray
i = 0
bFound = False
While i <= intCount And Not bFound
If oProcess.ProcessId = intPIDs(i) Then
bFound = True
End If
i = i + 1
Wend

If bFound = False Then
oProcess.Terminate()
End If
Next

If Err.Number <> 0 Then
'Error terminating the process
'Clear error, then continue
'Rollback/uninstallation may now cause a reboot
CreateLogEntry "Error terminating process.  Uninstall may require reboot" & vbCrLf & _
"Error number:  " & Err.Number & vbCrLf & _
"Error description:  " & Err.Description & vbCrLf & _
"Error source:  " & Err.Source
Err.Clear
End If
End If

End Sub

Private Function checkNT()

On Error Resume Next

Dim oShell 'Scripting host object to read the registry

Set oShell = CreateObject("WScript.Shell")

If oShell.RegRead("HKLM\SOFTWARE\Microsoft\Windows NT\CurrentVersion\CurrentVersion") = "4.0" Then
checkNT = True
Else
checkNT = False
End If
End Function

Private Function FileSpecToRegExp(strFileSpec)

On Error Resume Next

strFileSpec = Replace(strFileSpec, ".", "\.")
strFileSpec = Replace(strFileSpec, "?", ".")
FileSpecToRegExp = Replace(strFileSpec, "*", ".*")

End Function

Leigh Ravenhall
Expert Information Services