ActiveX Documenter Source (349K)
VB5 ActiveX Documenter (148K)
VB6 ActiveX Documenter (138K)
Bugs: 2 / 2
Issues: 0 / 0
Questions: 0 / 0
23 Feb 2003
Fixed hacks to determine default interface and events; you can now generate documentation for any TLB
Types exposed by Type Libraries are now documented correctly; previously types appeared as Classes with constant members.
Documentation associated with Types or enumerated members in Type Libraries now included.
Documentation generation now 100x quicker for large type libraries.
Subclassing Without The Crashes
Two code only solutions for displaying Common/Dialogs
vbAccelerator Status Bar Control
Ole Guid and interface definitions (OleGuids.Tlb)
PopupMenu DLL - Create Unlimited Popup Menus
vbAccelerator Toolbar and CoolMenu Control v3.5
vbAccelerator TabStrip Control
vbAccelerator - Contents of code file: fDev.frm
VERSION 5.00
Begin VB.Form frmDocHelp
Caption = "ActiveX Documenter"
ClientHeight = 6750
ClientLeft = 4890
ClientTop = 1935
ClientWidth = 7635
BeginProperty Font
Name = "Tahoma"
Size = 8.25
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Icon = "fDev.frx":0000
LinkTopic = "Form1"
ScaleHeight = 6750
ScaleWidth = 7635
Begin TLibHelp.vbalStatusBar sbrMain
Align = 2 'Align Bottom
Height = 360
Left = 0
TabIndex = 20
Top = 6390
Width = 7635
_ExtentX = 13467
_ExtentY = 635
BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851}
Name = "Tahoma"
Size = 8.25
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
BackColor = -2147483633
SimpleStyle = 0
End
Begin VB.PictureBox picTab
BeginProperty Font
Name = "MS Sans Serif"
Size = 8.25
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 4155
Index = 2
Left = 300
ScaleHeight = 4095
ScaleWidth = 7215
TabIndex = 3
Top = 1740
Width = 7275
Begin TLibHelp.vbalRichEdit rtfDocument
Height = 1935
Left = 180
TabIndex = 19
Top = 120
Width = 3135
_ExtentX = 5530
_ExtentY = 3413
Version = 1
BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851}
Name = "Tahoma"
Size = 8.25
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
ForeColor = -2147483630
ViewMode = 0
End
End
Begin VB.PictureBox picTab
BeginProperty Font
Name = "MS Sans Serif"
Size = 8.25
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 4155
Index = 0
Left = 180
ScaleHeight = 4095
ScaleWidth = 7215
TabIndex = 1
Top = 1080
Width = 7275
Begin VB.ListBox lstMembers
Height = 2595
Left = 0
MultiSelect = 2 'Extended
TabIndex = 6
Top = 1320
Width = 7155
End
Begin VB.ListBox lstGeneral
Height = 840
Left = 0
MultiSelect = 2 'Extended
TabIndex = 5
Top = 240
Width = 7155
End
Begin VB.Label lblGeneral
Caption = "General:"
Height = 195
Left = 60
TabIndex = 8
Top = 0
Width = 2595
End
Begin VB.Label lblMembers
Caption = "Members:"
Height = 195
Left = 60
TabIndex = 7
Top = 1080
Width = 2595
End
End
Begin VB.ComboBox cboClass
Appearance = 0 'Flat
Height = 315
Left = 5040
Sorted = -1 'True
Style = 2 'Dropdown List
TabIndex = 4
Top = 780
Width = 2535
End
Begin TLibHelp.cToolbar tbrMain
Left = 1740
Top = 60
_ExtentX = 9234
_ExtentY = 873
End
Begin TLibHelp.TabControl tabMain
Height = 4275
Left = 0
TabIndex = 0
Top = 1320
Width = 7335
_ExtentX = 12938
_ExtentY = 7541
BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851}
Name = "Tahoma"
Size = 8.25
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
End
Begin TLibHelp.cReBar rbrMain
Left = 60
Top = 60
_ExtentX = 10398
_ExtentY = 767
End
Begin VB.PictureBox picTab
BeginProperty Font
Name = "MS Sans Serif"
Size = 8.25
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 4155
Index = 1
Left = 60
ScaleHeight = 4095
ScaleWidth = 7215
TabIndex = 2
Top = 840
Width = 7275
Begin VB.CommandButton cmdRemoveSuperClass
Caption = "<"
Height = 315
Left = 3660
TabIndex = 18
Top = 3060
Visible = 0 'False
Width = 315
End
Begin VB.CommandButton cmdAddSuperClass
Caption = ">"
Height = 315
Left = 3660
TabIndex = 17
Top = 2700
Visible = 0 'False
Width = 315
End
Begin VB.CommandButton cmdRemoveInterface
Caption = "<"
Height = 315
Left = 3660
TabIndex = 16
Top = 1020
Visible = 0 'False
Width = 315
End
Begin VB.CommandButton cmdAddInterface
Caption = ">"
Height = 315
Left = 3660
TabIndex = 15
Top = 660
Visible = 0 'False
Width = 315
End
Begin VB.ListBox lstSuperClass
BackColor = &H8000000F&
Enabled = 0 'False
Height = 1815
IntegralHeight = 0 'False
Left = 4020
TabIndex = 14
Top = 2280
Visible = 0 'False
Width = 3135
End
Begin VB.ListBox lstInterface
BackColor = &H8000000F&
Enabled = 0 'False
Height = 1815
IntegralHeight = 0 'False
Left = 4020
TabIndex = 12
Top = 240
Visible = 0 'False
Width = 3135
End
Begin VB.ListBox lstAvailable
BackColor = &H8000000F&
Enabled = 0 'False
Height = 3765
IntegralHeight = 0 'False
Left = 0
TabIndex = 9
Top = 240
Visible = 0 'False
Width = 3555
End
Begin VB.Label lblSuper
Caption = "Create Super Classed Member:"
Height = 255
Left = 4020
TabIndex = 13
Top = 2040
Visible = 0 'False
Width = 3135
End
Begin VB.Label lblCreate
Caption = "Create Empty, Equivalent Member:"
Height = 255
Left = 4020
TabIndex = 11
Top = 0
Visible = 0 'False
Width = 3135
End
Begin VB.Label lblAvail
Caption = "Available:"
Height = 255
Left = 0
TabIndex = 10
Top = 0
Width = 3495
End
End
Begin TLibHelp.cToolbar tbrMenu
Left = 3720
Top = 60
_ExtentX = 3413
_ExtentY = 873
End
End
Attribute VB_Name = "frmDocHelp"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Private Declare Function SetWindowTheme Lib "uxtheme.dll" _
(ByVal hwnd As Long, ByVal pszSubAppName As Long, ByVal pszSubIdList As
Long) As Long
Private WithEvents m_cMenu As cPopupMenu
Attribute m_cMenu.VB_VarHelpID = -1
Private m_cIcons As cVBALImageList
Private Enum EDocumentationTypes
eDocumentText
eDocumentRtf
eDocumentHTML
End Enum
Private Enum EDocumentSectionTypes
eHeader
eGeneralInformation
eBody
eFooter
End Enum
Private Type tTypeInfoDefault
iDefaultInterface As Long
iDefaultEvents As Long
End Type
Private m_cTLI As TypeLibInfo
Private m_sInterfaces() As String
Private m_iTypeInfoIndex() As Long
Private m_tDefaults() As tTypeInfoDefault
Private m_bHidden() As Boolean
Private m_iCount As Long
Private m_bShowHelp As Boolean
Private m_sCmdLine As String
Private m_cMRU As cMRUFileList
Private m_sInitSaveDir As String
Private m_sInitOpenDir As String
Private m_lMax As Long
Private m_lValue As Long
Private m_cRTF As cStringBuilder
Private m_cHtml As cStringBuilder
Private Function HtmlParse(ByVal sToParse As String) As String
ReplaceSection sToParse, "&", "&"
ReplaceSection sToParse, "<", "<"
ReplaceSection sToParse, ">", ">"
ReplaceSection sToParse, """", """
HtmlParse = sToParse
End Function
Private Sub pCreateMenu()
Dim lI(0 To 6) As Long
lI(0) = m_cMenu.AddItem("MENU", , , , , , , "MENU")
lI(1) = m_cMenu.AddItem("&File", , , lI(0), , , , "FILE:TOP")
lI(2) = m_cMenu.AddItem("&Open..." & vbTab & "Ctrl+O", "Open", , lI(1), 1, ,
, "FILE:OPEN")
lI(2) = m_cMenu.AddItem("&Save..." & vbTab & "Ctrl+S", "Save", , lI(1), 2, ,
, "FILE:SAVE")
lI(2) = m_cMenu.AddItem("-", , , lI(1))
lI(2) = m_cMenu.AddItem("&Print" & vbTab & "Ctrl+P", "Print", , lI(1), 6, ,
, "FILE:PRINT")
lI(2) = m_cMenu.AddItem("Print Pre&view", "Print Preview", , lI(1), 10, ,
False, "FILE:PRINTPREVIEW")
lI(2) = m_cMenu.AddItem("-", , , lI(1))
Dim i As Long
For i = 1 To 8
lI(2) = m_cMenu.AddItem("", , , lI(1), , , False, "FILE:MRU:" & i)
m_cMenu.Visible(lI(2)) = False
Next i
lI(2) = m_cMenu.AddItem("-", , , lI(1), , , , "FILE:MRU:SEP")
m_cMenu.Visible(lI(2)) = False
lI(2) = m_cMenu.AddItem("E&xit", "Exit the application", , lI(1), , , ,
"FILE:EXIT")
lI(1) = m_cMenu.AddItem("&Edit", , , lI(0), , , , "EDIT:TOP")
lI(2) = m_cMenu.AddItem("&Copy" & vbTab & "Ctrl+C", "Copy Selected Content",
, lI(1), 4, , , "EDIT:COPY")
lI(2) = m_cMenu.AddItem("-", , , lI(1))
lI(2) = m_cMenu.AddItem("Select &All" & vbTab & "Ctrl+A", "Select All", ,
lI(1), , , , "EDIT:SELECTALL")
lI(2) = m_cMenu.AddItem("&Invert Selection", "Invert Selection", , lI(1), ,
, , "EDIT:INVERTSELECTION")
lI(2) = m_cMenu.AddItem("Select &None", "Select None", , lI(1), , , ,
"EDIT:SELECTNONE")
lI(1) = m_cMenu.AddItem("&Help", , , lI(0), , , , "HELP:TOP")
lI(2) = m_cMenu.AddItem("&Contents" & vbTab & "F1", "Help Contents", ,
lI(1), , , False, "HELP:CONTENTS")
lI(2) = m_cMenu.AddItem("&vbAccelerator on the Web", "vbAccelerator on the
Web", , lI(1), 7, , , "HELP:VBA")
lI(2) = m_cMenu.AddItem("-", , , lI(1))
lI(2) = m_cMenu.AddItem("&About...", "About this application", , lI(1), , ,
, "HELP:ABOUT")
lI(0) = m_cMenu.AddItem("TOOLBAR", , , , , , , "TOOLBAR")
m_cMenu.AddItem "&Open" & vbTab & "Ctrl+O", "Open", , lI(0), 1, , ,
"TOOLBAR:OPEN"
m_cMenu.AddItem "&Save" & vbTab & "Ctrl+S", "Save", , lI(0), 2, , ,
"TOOLBAR:SAVE"
m_cMenu.AddItem "-", , , lI(0)
m_cMenu.AddItem "&Copy" & vbTab & "Ctrl+C", "Copy", , lI(0), 4, , ,
"TOOLBAR:COPY"
m_cMenu.AddItem "-", , , lI(0)
m_cMenu.AddItem "&Print" & vbTab & "Ctrl+P", "Print", , lI(0), 6, , ,
"TOOLBAR:PRINT"
m_cMenu.AddItem "-", , , lI(0)
m_cMenu.AddItem "&vbAccelerator on the Web", "vbAccelerator on the Web", ,
lI(0), 7, , , "TOOLBAR:VBA"
End Sub
Private Sub Status(ByVal sStatus As String)
sbrMain.PanelText(1) = " " & sStatus
Me.Refresh
End Sub
Private Property Let ProgressMax(ByVal lMax As Long)
m_lMax = lMax
End Property
Private Property Let ProgressValue(ByVal lValue As Long)
m_lValue = lValue
sbrMain.RedrawPanel 2
End Property
Private Sub pParseCommand()
Dim sRem As String
Dim iPos As Long
Dim bPrint As Boolean
' do we have a print?
iPos = InStr(m_sCmdLine, "/p/index.html")
If (iPos <> 0) Then
bPrint = True
If (iPos > 1) Then
sRem = Left$(m_sCmdLine, (iPos - 1))
End If
If (iPos < Len(m_sCmdLine) - 2) Then
sRem = sRem & Mid$(m_sCmdLine, (iPos + 3))
End If
m_sCmdLine = sRem
End If
' The remainder should be interpreted as a file:
End Sub
Public Property Let CommandLine(ByVal sCmd As String)
m_sCmdLine = sCmd
End Property
Private Function pbGetTypeLibInfo( _
ByVal sFIle As String _
) As Boolean
On Error GoTo pGetTypeLibInfoError
' Clear up info we're holding about previous TypeLib, if any:
m_iCount = 0
Erase m_sInterfaces
Erase m_iTypeInfoIndex
Erase m_tDefaults
cboClass.Clear
cboClass.AddItem "<No Interfaces>"
cboClass.ListIndex = 0
cboClass.Enabled = False
lstGeneral.Clear
lstMembers.Clear
' Generate a TypeLibInfo object for the specified file.
Status "Linking to Type Library..."
Set m_cTLI = TLI.TypeLibInfoFromFile(sFIle)
Me.Caption = App.Title & " (" & sFIle & ")"
' If we succeed, then organize the TypeInfo members.
' VB classes have a number of components which are normally hidden from you:
' -the CoClass, which has the correct name but is empty because all its
functions
' are performed by the members with _ before the name,
' -one or two DispInterface items, which underscores first. The first
has one underscore
' and contains the non-event interfaces. The second has two and
contains the events.
Dim iTypeInfo As Long
Dim sName As String
Dim sBelongsTo As String
Dim iCheckOwner As Long
Dim iDefaultInterface As Long
Dim iDefaultEvents As Long
Dim iDefault As Long
Dim bDefault As Long
' Populate general information:
With m_cTLI
lstGeneral.AddItem "Library:" & vbTab & .Name & " (" & .HelpString & ")"
lstGeneral.itemData(lstGeneral.NewIndex) = &HFFFFFFF
lstGeneral.AddItem "File:" & vbTab & sFIle
lstGeneral.itemData(lstGeneral.NewIndex) = &HFFFFFFF
lstGeneral.AddItem "GUID:" & vbTab & .GUID
lstGeneral.itemData(lstGeneral.NewIndex) = &HFFFFFFF
lstGeneral.AddItem "Version:" & vbTab & .MajorVersion & "." &
.MinorVersion
lstGeneral.itemData(lstGeneral.NewIndex) = &HFFFFFFF
End With
Status "Counting Type Library Members..."
With m_cTLI
' Items with an attribute mask = 16 are old interfaces:
m_iCount = .TypeInfoCount
ReDim Preserve m_sInterfaces(1 To m_iCount) As String
ReDim Preserve m_iTypeInfoIndex(1 To m_iCount) As Long
ReDim Preserve m_tDefaults(1 To m_iCount) As tTypeInfoDefault
ReDim Preserve m_bHidden(1 To m_iCount) As Boolean
For iTypeInfo = 1 To m_iCount
m_sInterfaces(iTypeInfo) = .TypeInfos(iTypeInfo).Name
m_iTypeInfoIndex(iTypeInfo) = iTypeInfo
m_bHidden(iTypeInfo) = (.TypeInfos(iTypeInfo).AttributeMask = 16)
On Error Resume Next
iDefaultInterface =
.TypeInfos(iTypeInfo).DefaultInterface.TypeInfoNumber
If (Err.Number = 0) Then
m_tDefaults(iTypeInfo).iDefaultInterface = iDefaultInterface + 1
Else
m_tDefaults(iTypeInfo).iDefaultInterface = -1
End If
Err.Clear
iDefaultEvents =
.TypeInfos(iTypeInfo).DefaultEventInterface.TypeInfoNumber
If (Err.Number = 0) Then
m_tDefaults(iTypeInfo).iDefaultEvents = iDefaultEvents + 1
Else
m_tDefaults(iTypeInfo).iDefaultEvents = -1
End If
On Error GoTo pGetTypeLibInfoError
Next iTypeInfo
End With
' Add to the combo box:
If (iTypeInfo > 0) Then
Status "Adding Type Library Members..."
cboClass.Clear
cboClass.AddItem "<All Interfaces>"
cboClass.itemData(cboClass.NewIndex) = &HFFFFFFF
For iTypeInfo = 1 To m_iCount
If Not (m_bHidden(iTypeInfo)) Then
' Is this a default interface or event for some other item?
bDefault = False
For iDefault = 1 To m_iCount
If Not (iDefault = iTypeInfo) Then
If (m_tDefaults(iDefault).iDefaultEvents = iTypeInfo) Or
(m_tDefaults(iDefault).iDefaultInterface = iTypeInfo) Then
bDefault = True
Exit For
End If
End If
Next iDefault
If Not (bDefault) Then
If (m_cTLI.TypeInfos(iTypeInfo).TypeKindString = "enum")
Then
cboClass.AddItem "Enum " & m_sInterfaces(iTypeInfo)
Else
cboClass.AddItem m_sInterfaces(iTypeInfo)
End If
cboClass.itemData(cboClass.NewIndex) = iTypeInfo
End If
End If
Next iTypeInfo
cboClass.Enabled = True
cboClass.ListIndex = 0
End If
Status "Ready."
pbGetTypeLibInfo = True
Exit Function
pGetTypeLibInfoError:
MsgBox "Failed to get type lib info for file: '" & sFIle & "'" & vbCrLf &
vbCrLf & Err.Description, vbExclamation
Set m_cTLI = Nothing
Exit Function
End Function
Private Function psGetGeneralInfoRtf(ByVal lIndex As Long) As String
Dim sPre As String
sPre = lstGeneral.List(lIndex)
' parse backslashes into Rtf version:
ReplaceSection sPre, "\", "\\"
' parse tabs into Rtf version:
ReplaceSection sPre, Chr$(9), "\tab "
' parse { brackets:
pParseGUID sPre
psGetGeneralInfoRtf = sPre
End Function
Private Function pParseGUID(ByVal sThis As String) As String
ReplaceSection sThis, "{", "\{"
ReplaceSection sThis, "}", "\}"
End Function
Private Sub ReplaceSection( _
ByRef sToModify As String, _
ByVal sToReplace As String, _
ByVal sReplaceWith As String _
)
' ==================================================================
' Replaces all occurrences of sToReplace with
' sReplaceWidth in sToModify.
' ==================================================================
' ==================================================================
' Replaces all occurrences of sToReplace with
' sReplaceWidth in sToModify.
' ==================================================================
Dim iLastPos As Long
Dim iNextPos As Long
Dim iReplaceLen As Long
Dim sOut As String
iReplaceLen = Len(sToReplace)
iLastPos = 1
iNextPos = InStr(iLastPos, sToModify, sToReplace)
sOut = ""
Do While (iNextPos > 0)
If (iNextPos > 1) Then
sOut = sOut & Mid$(sToModify, iLastPos, (iNextPos - iLastPos))
End If
sOut = sOut & sReplaceWith
iLastPos = iNextPos + iReplaceLen
iNextPos = InStr(iLastPos, sToModify, sToReplace)
Loop
If (iLastPos <= Len(sToModify)) Then
sOut = sOut & Mid$(sToModify, (iLastPos))
End If
sToModify = sOut
End Sub
Private Sub pEvaluateEnum( _
ByRef ti As TypeInfo, _
ByRef sMembers() As String, _
ByRef sHelp() As String, _
ByRef iMemberCount As Long _
)
Dim iMember As Long
iMemberCount = 0
Erase sMembers
With ti
On Error Resume Next
iMemberCount = .Members.Count
If (Err.Number <> 0) Then
iMemberCount = 0
End If
Err.Clear
On Error GoTo 0
If (iMemberCount > 0) Then
ReDim sMembers(1 To iMemberCount) As String
ReDim sHelp(1 To iMemberCount) As String
For iMember = 1 To iMemberCount
With .Members(iMember)
sMembers(iMember) = .Name & "=" & .Value
sHelp(iMember) = .HelpString
End With
Next iMember
End If
End With
End Sub
Private Sub pEvaluateClass( _
ByRef ti As TypeInfo, _
ByRef sMembers() As String, _
ByRef sHelp() As String, _
ByRef iMemberCount As Long _
)
Dim iMember As Long
Dim iMemCount As Long
' Initialise:
iMemberCount = 0
Erase sMembers
Erase sHelp
' Find out the contents of the TypeInfo:
With ti
Debug.Print .Name, .TypeKind
' Get number of members in this class:
On Error Resume Next
iMemCount = .Members.Count
If (Err.Number <> 0) Then
iMemCount = 0
End If
Err.Clear
On Error GoTo 0
If (iMemCount > 0) Then
For iMember = 1 To iMemCount
If (.Members(iMember).AttributeMask = 0) Then ' Not hidden
iMemberCount = iMemberCount + 1
ReDim Preserve sMembers(1 To iMemberCount) As String
ReDim Preserve sHelp(1 To iMemberCount) As String
pEvaluateClassMember .Members(iMember),
sMembers(iMemberCount), sHelp(iMemberCount), iMemberCount
End If
If (iMember Mod 10) = 0 Then
Status "Getting information for " & ti.Name & " (" & iMember
& " of " & iMemCount & ")"
End If
Next iMember
End If
End With
End Sub
Private Function psGetMemberType( _
ByRef tM As MemberInfo, _
ByRef bIsLet As Boolean _
) As String
bIsLet = False
Select Case tM.InvokeKind
Case INVOKE_EVENTFUNC
psGetMemberType = "Event"
Case INVOKE_FUNC
If (tM.ReturnType.VarType = VT_VOID) Or (tM.ReturnType.VarType =
VT_HRESULT) Then
psGetMemberType = "Sub"
Else
psGetMemberType = "Function"
End If
Case INVOKE_PROPERTYGET
psGetMemberType = "Property Get"
Case INVOKE_PROPERTYPUT
psGetMemberType = "Property Let"
bIsLet = True
Case INVOKE_PROPERTYPUTREF
psGetMemberType = "Property Set"
Case INVOKE_UNKNOWN
psGetMemberType = "Const"
Case Else
Debug.Assert 1 = 0
End Select
End Function
Private Sub pEvaluateClassMember( _
ByRef tM As MemberInfo, _
ByRef sMember As String, _
ByRef sHelp As String, _
ByRef iMember As Long _
)
Dim iParam As Long
Dim iParamCount As Long
Dim lType As TliVarType
Dim bOptional As Boolean
Dim bIsLet As Boolean
Dim sDefault As String
Dim sName As String
Dim sPrefix As String
'On Error Resume Next
With tM
' Type of member (sub, function, property..):
sMember = psGetMemberType(tM, bIsLet)
sName = .Name
If (Left$(sName, 1) = "_") Then
' check for standard prefixes:
sPrefix = Left$(sName, 7)
If (sPrefix = "_B_var_") Then
sName = Mid$(sName, 8)
ElseIf (sPrefix = "_B_str_") Then
sName = Mid$(sName, 8) & "$"
End If
End If
sMember = sMember & " " & sName
' Any parameters?
iParamCount = .Parameters.Count
If (Err.Number <> 0) Then
iParamCount = 0
End If
Err.Clear
' If we have parameters then add the function description:
For iParam = 1 To iParamCount
bOptional = False
With .Parameters(iParam)
' Add open bracket first time:
If (iParam = 1) Then
sMember = sMember & "("
End If
' .HasCustomData or .Optional implies the parameter is optional:
If (.HasCustomData() = True) Then
sMember = sMember & "Optional "
bOptional = True
Else
If .Optional Then
sMember = sMember & "Optional "
End If
End If
' Check Byref/Byval status of member:
If ((lType And VT_BYREF) = VT_BYREF) Then
Else
sMember = sMember & "ByVal "
End If
' Name of parameter:
sMember = sMember & .Name
' Evaluate the parameter type:
If (.VarTypeInfo.VarType = 0) Then
' Custom type:
sMember = sMember & " As " & .VarTypeInfo.TypeInfo.Name
Else
lType = .VarTypeInfo.VarType
sMember = sMember & psTranslateType(lType)
End If
' Add default value if there is one:
If (bOptional) Then
If (.Default) Then
On Error Resume Next
sDefault = CStr(.DefaultValue)
If (Err.Number = 0) Then
sMember = sMember & "=" & sDefault
Else
sMember = sMember & "=Nothing"
End If
Err.Clear
On Error GoTo 0
End If
End If
' If this is the last parameter then close the declaration,
' otherwise put a comma in front of the next one:
If (iParam < iParamCount) Then
sMember = sMember & ", "
Else
If Not (bIsLet) Then
sMember = sMember & ")"
End If
End If
End With
Next iParam
' Now add the return type and fix up Property Lets as required:
If (.ReturnType.VarType <> 0) Then
' Returns a Standard type:
If (.ReturnType.VarType = VT_VOID) Or (.ReturnType.VarType =
VT_HRESULT) Then
' sub
Else
' If a constant, we want to get the constant value:
If (Left$(sMember, 5) = "Const") Then
'Debug.Print sMember, .ReturnType.VarType
If (.ReturnType.VarType = VT_BSTR) Or (.ReturnType.VarType
= VT_LPSTR) Then
On Error Resume Next
sMember = sMember & " = " &
psParseForNonPrintable(.Value) & ""
Err.Clear
Else
On Error Resume Next
sMember = sMember & " = " & .Value
If Not (Err.Number = 0) Then
' This is a member of a type, we should fill in the
type:
ReplaceSection sMember, "Const", ""
sMember = sMember &
psTranslateType(.ReturnType.VarType)
End If
On Error GoTo 0
End If
Else
' If property let, must put in the RHS argument:
If (bIsLet) Then
If (iParamCount = 0) Then
' property let has only one var:
sMember = sMember & "(RHS "
Else
' more than on property let var:
sMember = sMember & ", RHS"
End If
End If
' No paramters, put the open close in:
If (iParamCount = 0) Then
If Not (bIsLet) Then
sMember = sMember & "()"
End If
End If
' Add the return type:
sMember = sMember & psTranslateType(.ReturnType.VarType)
' Close the property let statement:
If (bIsLet) Then
sMember = sMember & ")"
End If
End If
End If
Else
' If property let, must put in the RHS argument:
If (bIsLet) Then
If (iParamCount = 0) Then
' property let has only one var:
sMember = sMember & "(RHS "
Else
' more than on property let var:
sMember = sMember & ", RHS"
End If
End If
' No paramters, put the open close in:
If (iParamCount = 0) Then
If Not (bIsLet) Then
If InStr(sMember, "Const") > 0 Then
ReplaceSection sMember, "Const", ""
Else
sMember = sMember & "()"
End If
End If
End If
' Returns a custom type:
sMember = sMember & " As " & .ReturnType.TypeInfo.Name
' Close the property let statement:
If (bIsLet) Then
sMember = sMember & ")"
End If
End If
sHelp = .HelpString
End With
End Sub
Private Function psParseForNonPrintable(ByVal vThis As Variant) As String
Dim iPos As Long
Dim sRet As String
Dim iLen As Long
Dim iChar As Integer
Dim sChar As String
Dim bLastNonPrintable As Boolean
iLen = Len(vThis)
For iPos = 1 To iLen
sChar = Mid$(vThis, iPos, 1)
iChar = Asc(sChar)
If (iChar < 32) Then
If (iPos <> 1) Then
sRet = sRet & "& "
End If
If (bLastNonPrintable) Then
sChar = "Chr$(" & iChar & ") "
Else
If (iPos = 1) Then
sChar = "Chr$(" & iChar & ") "
Else
sChar = """ & Chr$(" & iChar & ") "
End If
End If
bLastNonPrintable = True
Else
If (bLastNonPrintable) Or (iPos = 1) Then
If (iPos <> 1) Then
sRet = sRet & "& "
End If
sChar = """" & sChar
End If
bLastNonPrintable = False
End If
sRet = sRet & sChar
Next iPos
If Not (bLastNonPrintable) Then
sRet = sRet & """"
End If
psParseForNonPrintable = sRet
End Function
Private Sub pEvaluateMember( _
ByRef ti As TypeInfo, _
ByRef sName As String, _
ByRef sGuid As String, _
ByRef sHelpString As String, _
ByRef sType As String, _
ByRef sMembers() As String, _
ByRef sHelp() As String, _
ByRef iMemberCount As Long _
)
Dim iTypeInfo As Long
With ti
sName = .Name
sGuid = .GUID
sHelpString = .HelpString
sType = .TypeKindString
If (.TypeKind = TKIND_ENUM) Then
' do enum:
pEvaluateEnum ti, sMembers(), sHelp(), iMemberCount
Else
' do class:
pEvaluateClass ti, sMembers(), sHelp(), iMemberCount
End If
End With
End Sub
Private Function psTranslateType(ByVal lType As Long)
Dim sType As String
Select Case (lType And &HFF&)
Case VT_BOOL
sType = "Boolean"
Case VT_BSTR, VT_LPSTR, VT_LPWSTR
sType = "String"
Case VT_DATE
sType = "Date"
Case VT_INT
sType = "Integer"
Case VT_VARIANT
sType = "Variant"
Case VT_DECIMAL
sType = "Decimal"
Case VT_I4
sType = "Long"
Case VT_I2
sType = "Integer"
Case VT_I8
sType = "Unknown"
Case VT_SAFEARRAY
sType = "SafeArray"
Case VT_CLSID
sType = "CLSID"
Case VT_UINT
sType = "UInt"
Case VT_UI4
sType = "ULong"
Case VT_UNKNOWN
sType = "Unknown"
Case VT_VECTOR
sType = "Vector"
Case VT_R4
sType = "Single"
Case VT_R8
sType = "Double"
Case VT_DISPATCH
sType = "Object"
Case VT_UI1
sType = "Byte"
Case VT_CY
sType = "Currency"
Case VT_HRESULT
sType = "HRESULT" ' note if this was a function it should be a sub
Case VT_VOID
sType = "Any"
Case VT_ERROR
sType = "Long"
Case VT_VECTOR
' hmmm
sType = "Vector"
Case Else
sType = "<Unsupported Variant Type"
Select Case (lType And &HFF&)
Case VT_UI1
sType = sType & "(VT_UI1)"
Case VT_UI2
sType = sType & "(VT_UI2)"
Case VT_UI4
sType = sType & "(VT_UI4)"
Case VT_UI8
sType = sType & "(VT_UI8)"
Case VT_USERDEFINED
sType = sType & "(VT_USERDEFINED)"
End Select
sType = sType & ">"
Debug.Print "Unknown Type", lType
'Debug.Assert 1 = 0
End Select
If (lType And VT_ARRAY) = VT_ARRAY Then
sType = "() As " & sType
Else
sType = " As " & sType
End If
psTranslateType = sType
End Function
Private Sub cboClass_Click()
Dim iTypeInfo As Long
Dim i As Long
Dim sTypeLibName As String
Dim sDateString As String
Dim sTypeLibString As String
' Clear list
Status "Getting Type Library Information..."
lstMembers.Clear
Set m_cRTF = New cStringBuilder
Set m_cHtml = New cStringBuilder
If (cboClass.ListIndex > -1) Then
' Evaluate the contents:
iTypeInfo = cboClass.itemData(cboClass.ListIndex)
If (iTypeInfo > 0) Then
Screen.MousePointer = vbHourglass
' Prepare the RTF header:
sDateString = "yr" & Year(Now) & "\mo" & Month(Now) & "\dy" &
Day(Now) & "\hr" & Hour(Now) & "\min" & Minute(Now)
sTypeLibString = m_cTLI.Name
m_cRTF.Append "{\rtf1\ansi\ansicpg1252\uc1
\deff0\deflang1033\deflangfe1033{\fonttbl{\f0\froman\fcharset0\fprq
2{\*\panose 02020603050405020304}Times New
Roman;}{\f1\fswiss\fcharset0\fprq2{\*\panose
020b0604020202020204}Arial;}"
m_cRTF.Append vbCrLf
m_cRTF.Append "{\f2\fmodern\fcharset0\fprq1{\*\panose
02070309020205020404}Courier
New;}{\f15\fswiss\fcharset0\fprq2{\*\panose
020b0604030504040204}Verdana;}}{\colortbl;\red0\green0\blue0;\red0\
green0\blue255;\red0\green255\blue255;\red0\green255\blue0;" &
vbCrLf
m_cRTF.Append
"\red255\green0\blue255;\red255\green0\blue0;\red255\green255\blue0
;\red255\green255\blue255;\red0\green0\blue128;\red0\green128\blue12
8;\red0\green128\blue0;\red128\green0\blue128;\red128\green0\blue0;\
red128\green128\blue0;\red128\green128\blue128;" & vbCrLf
m_cRTF.Append
"\red192\green192\blue192;}{\stylesheet{\widctlpar\adjustright
\fs20\lang2057\cgrid \snext0
Normal;}{\s1\sb240\sa60\keepn\widctlpar\adjustright
\b\f15\fs28\lang2057\kerning28\cgrid \sbasedon0 \snext0 heading
1;}{\s3\sb240\sa60\keepn\widctlpar\adjustright" & vbCrLf
m_cRTF.Append "\b\f15\lang2057\cgrid \sbasedon0 \snext0 heading
3;}{\*\cs10 \additive Default Paragraph
Font;}{\s15\qc\widctlpar\adjustright \b\f15\fs16\lang2057\cgrid
\sbasedon0 \snext0 caption;}{\s16\li720\widctlpar\adjustright
\f2\fs16\lang2057\cgrid" & vbCrLf
m_cRTF.Append "\sbasedon0 \snext16 Code;}{\*\cs17 \additive
\ul\cf12 \sbasedon10 FollowedHyperlink;}{\*\cs18 \additive \ul\cf2
\sbasedon10 Hyperlink;}{\s19\widctlpar\adjustright
\f15\fs20\lang2057\cgrid \sbasedon0 \snext19 Paragraph;}}{\info" &
vbCrLf
m_cRTF.Append "{\title " & sTypeLibName & "Interface
Definition}{\author ActiveX Documenter}{\operator ActiveX
Documenter}{\creatim\" & sDateString & "}{\revtim\" & sDateString
& "}{\printim\" & sDateString & "}{\version1}{\edmins8}" & vbCrLf
m_cRTF.Append "{\nofchars1789}{\*\company
vbaccelerator}{\nofcharsws2197}{\vern89}}\paperw11906\paperh16838
\widowctrl\ftnbj\aenddoc\formshade\viewkind1\viewscale100\pgbrdrhea
d\pgbrdrfoot \fet0\sectd
\linex0\headery709\footery709\colsx709\endnhere\sectdefaultcl
{\*\pnseclvl1" & vbCrLf
m_cRTF.Append "\pnucrm\pnstart1\pnindent720\pnhang{\pntxta
.}}{\*\pnseclvl2\pnucltr\pnstart1\pnindent720\pnhang{\pntxta
.}}{\*\pnseclvl3\pndec\pnstart1\pnindent720\pnhang{\pntxta
.}}{\*\pnseclvl4\pnlcltr\pnstart1\pnindent720\pnhang{\pntxta
)}}{\*\pnseclvl5" & vbCrLf
m_cRTF.Append "\pndec\pnstart1\pnindent720\pnhang{\pntxtb
(}{\pntxta
)}}{\*\pnseclvl6\pnlcltr\pnstart1\pnindent720\pnhang{\pntxtb
(}{\pntxta
)}}{\*\pnseclvl7\pnlcrm\pnstart1\pnindent720\pnhang{\pntxtb
(}{\pntxta )}}{\*\pnseclvl8\pnlcltr\pnstart1\pnindent720\pnhang" &
vbCrLf
m_cRTF.Append "{\pntxtb (}{\pntxta
)}}{\*\pnseclvl9\pnlcrm\pnstart1\pnindent720\pnhang{\pntxtb
(}{\pntxta )}}\pard\plain \widctlpar\adjustright
\fs20\lang2057\cgrid {\b\f1\fs24" & vbCrLf
m_cRTF.Append sTypeLibString & " Interface Definition \par " &
vbCrLf & "\par }"
m_cRTF.Append "{\b\f1 General Information" & vbCrLf & "\par }"
m_cRTF.Append "\pard \widctlpar\tx993\adjustright {\f1 " &
psGetGeneralInfoRtf(0) & vbCrLf
m_cRTF.Append "\par " & psGetGeneralInfoRtf(1) & vbCrLf
m_cRTF.Append "\par " & psGetGeneralInfoRtf(2) & vbCrLf
m_cRTF.Append "\par " & psGetGeneralInfoRtf(3) & vbCrLf
m_cRTF.Append "\par }\pard \widctlpar\adjustright {" & vbCrLf
m_cRTF.Append "\par }"
' Prepare the Html header:
m_cHtml.Append "<html><head>"
m_cHtml.Append vbCrLf
m_cHtml.Append "<title>" & sTypeLibString & " Interface
Definition</title>" & vbCrLf
m_cHtml.Append "<meta http-equiv=""Content Type""
content=""text/html;charset=iso=8859-1"" />" & vbCrLf
m_cHtml.Append "<meta name=""AUTHOR"" content=""vbAccelerator
ActiveX Documenter"" />" & vbCrLf
m_cHtml.Append "<meta name=""KEYWORDS"" content=""Visual Basic, VB,
ActiveX, COM,"
m_cHtml.Append sTypeLibString
If (iTypeInfo < &HFFFFFFF) Then
m_cHtml.Append "," & cboClass.List(cboClass.ListIndex)
End If
m_cHtml.Append """ />" & vbCrLf
m_cHtml.Append "<meta name=""DESCRIPTION"" content=""ActiveX
Documentation for Object " & sTypeLibString & """ />" & vbCrLf
m_cHtml.Append "</head><body>" & vbCrLf
m_cHtml.Append "<h1>" & sTypeLibString & " Interface
Definition</h1>" & vbCrLf
m_cHtml.Append "<div id=""general"">" & vbCrLf
m_cHtml.Append "<h2>General Information</h2>" & vbCrLf
m_cHtml.Append "<p id=""library"">" & HtmlParse(lstGeneral.List(0))
& "</p>" & vbCrLf
m_cHtml.Append "<p id=""filename"">" &
HtmlParse(lstGeneral.List(1)) & "</p>" & vbCrLf
m_cHtml.Append "<p id=""guid"">" & HtmlParse(lstGeneral.List(2)) &
"</p>" & vbCrLf
m_cHtml.Append "<p id=""version"">" & HtmlParse(lstGeneral.List(3))
& "</p>" & vbCrLf
m_cHtml.Append "</div>" & vbCrLf
m_cHtml.Append "<div id=""toc"">" & vbCrLf
m_cHtml.Append "<h2 class=""toc"">Contents</h2>" & vbCrLf
Dim bFirst As Boolean
bFirst = True
For i = 1 To cboClass.ListCount - 1
iTypeInfo = cboClass.itemData(i)
If (Not (iTypeInfo And &HFFFF0000) = 0) Then
Debug.Print "Incorrect Type Info"
Else
If (m_cTLI.TypeInfos(iTypeInfo).TypeKindString = "enum") Then
If (bFirst) Then
m_cHtml.Append "<ul>" & vbCrLf
m_cHtml.Append "<li class=""toc1""><a
href=""#enums"">Enums</a>" & vbCrLf
m_cHtml.Append "<ul>" & vbCrLf
bFirst = False
End If
m_cHtml.Append "<li class=""toc2""><a href=""#enum" &
iTypeInfo & """>" & cboClass.List(i) & "</a></li>" &
vbCrLf
End If
End If
Next i
If Not bFirst Then
m_cHtml.Append "</ul></li></ul>" & vbCrLf
End If
bFirst = True
For i = 1 To cboClass.ListCount - 1
iTypeInfo = cboClass.itemData(i)
If (Not (iTypeInfo And &HFFFF0000) = 0) Then
Debug.Print "Incorrect Type Info"
Else
If (m_cTLI.TypeInfos(iTypeInfo).TypeKindString <> "enum") Then
If (bFirst) Then
m_cHtml.Append "<ul>" & vbCrLf
m_cHtml.Append "<li class=""toc1""><a
href=""#classes"">Classes</a>" & vbCrLf
m_cHtml.Append "<ul>" & vbCrLf
bFirst = False
End If
m_cHtml.Append "<li class=""toc2""><a href=""#class" &
iTypeInfo & """>" & cboClass.List(i) & "</a>" & vbCrLf
m_cHtml.Append "<ul>" & vbCrLf
m_cHtml.Append "<li class=""toc3""><a href=""#methods" &
iTypeInfo & """>Methods</a></li>" & vbCrLf
m_cHtml.Append "<li class=""toc3""><a href=""#events" &
iTypeInfo & """>Events</a></li>" & vbCrLf
m_cHtml.Append "</ul></li>" & vbCrLf
End If
End If
Next i
If Not bFirst Then
m_cHtml.Append "</ul></li></ul>" & vbCrLf
End If
m_cHtml.Append "</div>"
iTypeInfo = cboClass.itemData(cboClass.ListIndex)
If (iTypeInfo = &HFFFFFFF) Then
' Do all the enums:
m_cRTF.Append "{\b\f1 Enumerations" & vbCrLf
m_cRTF.Append "\par }{\f1 This section lists enumerations
exposed by " & sTypeLibString & "." & vbCrLf
m_cRTF.Append "\par }{\f1" & vbCrLf
m_cHtml.Append "<div id=""enums"">" & vbCrLf
m_cHtml.Append "<h2>Enumerations</h2>" & vbCrLf
m_cHtml.Append "<p>This section lists enumerations exposed by "
& sTypeLibString & ".</p>" & vbCrLf
Status "Reading enums..."
ProgressMax = (cboClass.ListCount - 1) * 2
For i = 0 To cboClass.ListCount - 1
If (i <> cboClass.ListIndex) Then
ProgressValue = i
iTypeInfo = cboClass.itemData(i)
If (m_cTLI.TypeInfos(iTypeInfo).TypeKindString =
"enum") Then
Status "Getting Information for " &
m_cTLI.TypeInfos(iTypeInfo).Name & " ..."
pDisplayInterfaces iTypeInfo
End If
End If
Next i
m_cRTF.Append "}{" & vbCrLf
m_cRTF.Append "\par" & vbCrLf
m_cRTF.Append "\par }{\b\f1 Interfaces}{\b\f1" & vbCrLf
m_cRTF.Append "\par }{\f1 This section lists }{\f1 the Classes
exposed by " & sTypeLibString & ". For each class, the
methods and events are listed.}{\f1" & vbCrLf
m_cRTF.Append "\par }{" & vbCrLf
m_cRTF.Append "\par }" & vbCrLf
m_cHtml.Append "</div>" & vbCrLf
m_cHtml.Append "<div id=""interfaces"">" & vbCrLf
m_cHtml.Append "<h2>Interfaces</h2>" & vbCrLf
m_cHtml.Append "<p>This section lists the classes exposed by "
& sTypeLibString & ". For each class, the methods and events
are listed.</p>"
' Do all the interfaces:
For i = 0 To cboClass.ListCount - 1
If (i <> cboClass.ListIndex) Then
iTypeInfo = cboClass.itemData(i)
ProgressValue = i + cboClass.ListCount - 1
If (m_cTLI.TypeInfos(iTypeInfo).TypeKindString <>
"enum") Then
Status "Getting Information for " &
m_cTLI.TypeInfos(iTypeInfo).Name & " ..."
pDisplayInterfaces iTypeInfo
m_cRTF.Append "{\par}" & vbCrLf
End If
End If
Next i
m_cHtml.Append "</div>"
Else
Status "Getting Information for " &
m_cTLI.TypeInfos(iTypeInfo).Name & " ..."
m_cRTF.Append " {\f1 "
If (m_cTLI.TypeInfos(iTypeInfo).TypeKindString = "enum") Then
m_cHtml.Append "<div id=""enums"">" & vbCrLf
Else
m_cHtml.Append "<div id=""interfaces"">" & vbCrLf
End If
pDisplayInterfaces iTypeInfo
m_cRTF.Append "\par }" & vbCrLf
m_cHtml.Append "</div>"
End If
' Complete the RTF:
m_cRTF.Append "\par }}"
' Complete the Html:
m_cHtml.Append "</body></html>"
Status "Displaying the TypeLibrary Document..."
' Display the Rtf:
rtfDocument.Contents(SF_RTF) = m_cRTF.ToString
Screen.MousePointer = vbDefault
Status "Ready."
ProgressValue = 0
Else
Status "No Type Library Information."
End If
Else
Status "No Type Library Information."
End If
End Sub
Private Sub pDisplayInterfaces(iTypeInfo As Long)
Dim sJunk As String
Dim sType As String
Dim sGuid As String
Dim sMembers() As String
Dim sHelp() As String
Dim iMemberCount As Long
Dim sEvents() As String
Dim sEventHelp() As String
Dim iEventCount As Long
Dim iBelongsTo As Long
Dim sParseItem As String
Dim iMember As Long
pEvaluateMember m_cTLI.TypeInfos(iTypeInfo), sJunk, sGuid, sJunk, sType,
sMembers(), sHelp(), iMemberCount
If Not (m_tDefaults(iTypeInfo).iDefaultEvents = -1) Then
pEvaluateMember m_cTLI.TypeInfos(m_tDefaults(iTypeInfo).iDefaultEvents),
sJunk, sJunk, sJunk, sJunk, sEvents(), sEventHelp(), iEventCount
End If
If Not (m_tDefaults(iTypeInfo).iDefaultInterface = -1) Then
pEvaluateMember
m_cTLI.TypeInfos(m_tDefaults(iTypeInfo).iDefaultInterface), sJunk,
sJunk, sJunk, sJunk, sMembers(), sHelp(), iMemberCount
End If
' Add the information to the class list:
If (sType = "enum") Then
m_cHtml.Append "<a name=""enum" & iTypeInfo & """ />"
lstMembers.AddItem "Public Enum " & m_sInterfaces(iTypeInfo)
lstMembers.itemData(lstMembers.NewIndex) = &HFFFFFFF
m_cRTF.Append "\par " & "Public Enum " & m_sInterfaces(iTypeInfo) &
vbCrLf
m_cHtml.Append "<p class=""enum"">Public Enum " &
HtmlParse(m_sInterfaces(iTypeInfo)) & "</p>" & vbCrLf
For iMember = 1 To iMemberCount
If Len(sHelp(iMember)) > 0 Then
lstMembers.AddItem vbTab & sMembers(iMember) & vbTab & "' " &
sHelp(iMember)
Else
lstMembers.AddItem vbTab & sMembers(iMember)
End If
lstMembers.itemData(lstMembers.NewIndex) = iMember
m_cRTF.Append "\par \tab " & sMembers(iMember)
If Len(sHelp(iMember)) > 0 Then
m_cRTF.Append " \tab ' " & sHelp(iMember)
End If
m_cRTF.Append vbCrLf
m_cHtml.Append "<p class=""enumMember"">   " &
HtmlParse(sMembers(iMember))
If Len(sHelp(iMember)) > 0 Then
m_cHtml.Append "    ' " &
HtmlParse(sHelp(iMember))
End If
m_cHtml.Append "</p>" & vbCrLf
Next iMember
lstMembers.AddItem "End Enum"
lstMembers.itemData(lstMembers.NewIndex) = &HFFFFFFF
m_cRTF.Append "\par End Enum" & vbCrLf
m_cHtml.Append "<p class=""enum"">End Enum</p>" & vbCrLf
ElseIf (sType = "record") Then
lstMembers.AddItem "Public Type " & m_sInterfaces(iTypeInfo)
lstMembers.itemData(lstMembers.NewIndex) = -1
m_cRTF.Append "{\b\f1 " & m_sInterfaces(iTypeInfo) & vbCrLf
m_cRTF.Append "\par }"
m_cHtml.Append "<a name=""class" & iTypeInfo & """ />"
m_cHtml.Append "<h3>" & HtmlParse(m_sInterfaces(iTypeInfo)) & "</h3>" &
vbCrLf
m_cRTF.Append "{\par\f1 " & "Public Type " & m_sInterfaces(iTypeInfo) &
vbCrLf
m_cHtml.Append "<a name=""methods" & iTypeInfo & """ />"
m_cHtml.Append "<p class=""type"">Public Type " &
HtmlParse(m_sInterfaces(iTypeInfo)) & "</p>" & vbCrLf
For iMember = 1 To iMemberCount
If Len(sHelp(iMember)) > 0 Then
lstMembers.AddItem vbTab & sMembers(iMember) & vbTab & "' " &
sHelp(iMember)
Else
lstMembers.AddItem vbTab & sMembers(iMember)
End If
lstMembers.itemData(lstMembers.NewIndex) = iMember
m_cRTF.Append "\par \tab " & sMembers(iMember)
If Len(sHelp(iMember)) > 0 Then
m_cRTF.Append " \tab ' " & sHelp(iMember)
End If
m_cRTF.Append vbCrLf
m_cHtml.Append "<p class=""enumMember"">   " &
HtmlParse(sMembers(iMember))
If Len(sHelp(iMember)) > 0 Then
m_cHtml.Append "    ' " &
HtmlParse(sHelp(iMember))
End If
m_cHtml.Append "</p>" & vbCrLf
Next iMember
lstMembers.AddItem "End Type"
lstMembers.itemData(lstMembers.NewIndex) = &HFFFFFFF
m_cRTF.Append "\par End Type \par }" & vbCrLf
m_cHtml.Append "<p class=""type"">End Type</p>" & vbCrLf
Else
lstMembers.AddItem "Class:" & vbTab & m_sInterfaces(iTypeInfo) & " " &
sGuid
lstMembers.itemData(lstMembers.NewIndex) = -1
m_cRTF.Append "{\b\f1 " & m_sInterfaces(iTypeInfo) & " " &
pParseGUID(sGuid) & vbCrLf
m_cRTF.Append "\par }{" & vbCrLf
m_cHtml.Append "<a name=""class" & iTypeInfo & """ />"
m_cHtml.Append "<h3>" & HtmlParse(m_sInterfaces(iTypeInfo)) & " " &
HtmlParse(sGuid) & "</h3>" & vbCrLf
m_cRTF.Append "\par }{\f1\ul Methods" & vbCrLf & "}"
m_cHtml.Append "<a name=""methods" & iTypeInfo & """ />"
m_cHtml.Append "<h4>Methods</h4>" & vbCrLf
If (iMemberCount > 0) Then
lstMembers.AddItem "Methods:"
lstMembers.itemData(lstMembers.NewIndex) = -1
For iMember = 1 To iMemberCount
sParseItem = "Public " & sMembers(iMember)
m_cRTF.Append "{\b\f1 " & vbCrLf & "\par " & sMembers(iMember)
& vbCrLf & "\par }"
m_cHtml.Append "<p class=""member""><strong>" &
HtmlParse(sMembers(iMember)) & "</strong></p>" & vbCrLf
If Trim$(Len(sHelp(iMember))) > 0 Then
sParseItem = sParseItem & " '" & sHelp(iMember)
m_cRTF.Append "{\f1 " & sHelp(iMember) & "}"
m_cHtml.Append "<p class=""description"">" &
HtmlParse(sHelp(iMember)) & "</p>" & vbCrLf
End If
lstMembers.AddItem sParseItem
lstMembers.itemData(lstMembers.NewIndex) = iMember
If (iMember Mod 10) = 0 Then
Status "Getting Information for " & m_sInterfaces(iTypeInfo)
& " (" & iMember & " of " & iMemberCount & ")"
End If
Next iMember
Else
lstMembers.AddItem "No Methods."
lstMembers.itemData(lstMembers.NewIndex) = -1
m_cRTF.Append "{\f1\par " & "None " & vbCrLf & "\par}"
m_cHtml.Append "<p>None</p>" & vbCrLf
End If
m_cRTF.Append "{\f1" & vbCrLf & "\par}{\f1\ul Events" & vbCrLf & "\par}"
m_cHtml.Append "<a name=""events" & iTypeInfo & """ />"
m_cHtml.Append "<h4>Events</h4>" & vbCrLf
If (iEventCount > 0) Then
lstMembers.AddItem "Events:"
lstMembers.itemData(lstMembers.NewIndex) = -1
For iMember = 1 To iEventCount
sParseItem = "Public Event " & Mid$(sEvents(iMember), 5)
m_cRTF.Append "{\b\f1 " & vbCrLf & "\par " & sParseItem &
vbCrLf & "\par }"
m_cHtml.Append "<p class=""event""><strong>" &
HtmlParse(sParseItem) & "</strong></p>" & vbCrLf
If Trim$(Len(sEventHelp(iMember))) > 0 Then
sParseItem = sParseItem & " '" & sEventHelp(iMember)
m_cRTF.Append "{\f1 " & sEventHelp(iMember) & "}"
m_cHtml.Append "<p class=""description"">" &
HtmlParse(sEventHelp(iMember)) & "</p> " & vbCrLf
End If
lstMembers.AddItem sParseItem
lstMembers.itemData(lstMembers.NewIndex) = iMember
Next iMember
Else
lstMembers.AddItem "No Events."
lstMembers.itemData(lstMembers.NewIndex) = -1
m_cRTF.Append "{\f1 " & "None " & vbCrLf & "\par}"
m_cHtml.Append "<p>No Events.</p>" & vbCrLf
End If
End If
End Sub
Private Sub pShowTab(ByVal lTab As Long)
Dim i As Long
picTab(lTab - 1).Visible = True
picTab(lTab - 1).ZOrder
For i = 0 To 2
If (i <> lTab - 1) Then
picTab(i).Visible = False
End If
Next i
If Not m_cMenu Is Nothing Then
m_cMenu.Enabled(m_cMenu.IndexForKey("EDIT:INVERTSELECTION")) = (lTab = 1)
End If
End Sub
Private Sub pResizeTabs()
Dim i As Long
Dim lH As Long
Dim lMinH As Long
Dim lW As Long
Dim lCentreH As Long
Dim lbT As Long
If (tabMain.ClientWidth > 0) And (tabMain.ClientHeight > 0) Then
For i = 0 To 2
With tabMain
picTab(i).BorderStyle = 0
picTab(i).Move .ClientLeft, .ClientTop, .ClientWidth,
.ClientHeight
End With
Next i
' resize tab 1 contents:
lstGeneral.Width = picTab(0).ScaleWidth
lH = picTab(0).ScaleHeight - lstMembers.Top
If (lH > 0) Then
lstMembers.Move 0, lstMembers.Top, picTab(0).ScaleWidth, lH
End If
' resize tab 2 contents:
If Not (lstAvailable.Visible) Then
lblAvail.Width = Me.ScaleWidth
Else
lH = picTab(1).ScaleHeight - lstAvailable.Top
lW = (picTab(1).ScaleWidth - cmdAddInterface - 4 *
Screen.TwipsPerPixelX) \ 2
If (lH > 0) And (lW > 0) Then
' Reposition available list:
lstAvailable.Move 0, lstAvailable.Top, lW, lH
' Attempt to reposition the two add lists within bounds:
lMinH = cmdAddInterface.Height * 2 + 2 * Screen.TwipsPerPixelY
lCentreH = lH \ 2
If (lCentreH - lblCreate.Height < lMinH) Then lCentreH = lMinH
+ lblCreate.Height
lH = lCentreH - lblCreate.Height
lblCreate.Left = lW + cmdAddInterface.Width + 4 *
Screen.TwipsPerPixelX
lstInterface.Move lblCreate.Left, lstInterface.Top, lW, lH
lbT = lstInterface.Top + (lstInterface.Height) \ 2
cmdAddInterface.Move lW + Screen.TwipsPerPixelX, lbT -
cmdAddInterface.Height - Screen.TwipsPerPixelY
cmdRemoveInterface.Move cmdAddInterface.Left,
cmdAddInterface.Top + cmdAddInterface.Height +
Screen.TwipsPerPixelY
lbT = lstInterface.Top + lstInterface.Height + 2 *
Screen.TwipsPerPixelY
lblSuper.Move lstInterface.Left, lbT
lH = picTab(2).ScaleHeight - lblSuper.Top - lblSuper.Height
If (lH < lMinH) Then lH = lMinH
lstSuperClass.Move lstInterface.Left, lblSuper.Top +
lblSuper.Height, lW, lH
lbT = lstSuperClass.Top + (lstSuperClass.Height) \ 2
cmdAddSuperClass.Move cmdAddInterface.Left, lbT -
cmdAddSuperClass.Height - Screen.TwipsPerPixelY
cmdRemoveSuperClass.Move cmdAddInterface.Left,
cmdAddSuperClass.Top + cmdAddSuperClass.Height +
Screen.TwipsPerPixelY
End If
End If
' resize tab 3 contents:
rtfDocument.Move 0, 0, picTab(2).ScaleWidth, picTab(2).ScaleHeight
End If
End Sub
Private Sub Form_Load()
' set up status bar:
sbrMain.AddPanel estbrStandard, App.Title & " (No Open TypeLib)", , , ,
True, False
sbrMain.AddPanel estbrOwnerDraw, , , , 96
' set up class combo:
cboClass.Clear
cboClass.AddItem "<No Interfaces>"
cboClass.ListIndex = 0
cboClass.Enabled = False
Me.Caption = App.Title & " (No Open TypeLib)"
' icons:
Set m_cIcons = New cVBALImageList
m_cIcons.IconSizeX = 16
m_cIcons.IconSizeY = 16
m_cIcons.ColourDepth = ILC_COLOR4
m_cIcons.Create
'm_cIcons.AddFromFile App.Path & "\SmallAll.bmp", IMAGE_BITMAP
m_cIcons.AddFromResourceID 24, App.hInstance, IMAGE_BITMAP
' set up menu bar:
Set m_cMenu = New cPopupMenu
m_cMenu.hWndOwner = Me.hwnd
m_cMenu.ImageList = m_cIcons.hIml
m_cMenu.OfficeXpStyle = True
pCreateMenu
With tbrMenu
.CreateFromMenu2 m_cMenu, CTBMenuStyle, "MENU"
.ChevronButton(CTBChevronAdditionalAddorRemove) = True
.ChevronButton(CTBChevronAdditionalCustomise) = True
.ChevronButton(CTBChevronAdditionalReset) = True
On Error Resume Next
SetWindowTheme tbrMenu.hwnd, StrPtr(""), StrPtr("")
On Error GoTo 0
End With
With tbrMain
.ImageSource = CTBExternalImageList
.SetImageList m_cIcons.hIml
.CreateFromMenu2 m_cMenu, CTBToolbarStyle, "TOOLBAR"
.ChevronButton(CTBChevronAdditionalAddorRemove) = True
.ChevronButton(CTBChevronAdditionalCustomise) = True
.ChevronButton(CTBChevronAdditionalReset) = True
.ListStyle = True
End With
' set up rebar:
Dim lBar As Long
rbrMain.CreateRebar Me.hwnd
lBar = rbrMain.AddBandByHwnd(tbrMenu.hwnd, , , , "MenuBand")
lBar = rbrMain.AddBandByHwnd(tbrMain.hwnd, , True, , "ToolbarBand")
lBar = rbrMain.AddBandByHwnd(cboClass.hwnd, "Class", False, , "ClassBand")
rbrMain.BandChildMinWidth(0) = 24
rbrMain.BandChildIdealWidth(0) = Screen.Width
rbrMain.BandChevron(0) = True
rbrMain.BandChildMinWidth(1) = 24
rbrMain.BandChildIdealWidth(1) = Screen.Width
rbrMain.BandMaximise 1
rbrMain.BandChevron(1) = True
' set up tabs:
tabMain.AddTab "Browse", , , "Browse"
tabMain.AddTab "SuperClass", , , "SuperClass"
tabMain.AddTab "Document", , , "Document"
pResizeTabs
pShowTab 1
' Load options
Set m_cMRU = New cMRUFileList
pLoadOptions
' parse command line if any:
' options are /p /pt "filename"
pParseCommand
' The superclasser isn't ready yet:
lblAvail.Caption = "Sorry, super-class functionality is not available in
this release."
' RichEdit document might be > 32k
rtfDocument.MaxLength = &H100000 ' 1Mb
End Sub
Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
' Save options:
pSaveOptions
' Clear up objects
Set m_cTLI = Nothing
End Sub
Private Sub Form_Resize()
Dim lT As Long
Dim lST As Long
Dim lSW As Long, lSH As Long
Dim lTH As Long, lTW As Long
' Do Rebar:
rbrMain.RebarSize
lT = rbrMain.RebarHeight * Screen.TwipsPerPixelY
' Resize Tabs:
lTH = Me.ScaleHeight - lT - 8 * Screen.TwipsPerPixelY - sbrMain.Height
lTW = Me.ScaleWidth - 2 * Screen.TwipsPerPixelX
If (lTH > 0) And (lTW > 0) Then
tabMain.Move Screen.TwipsPerPixelX, lT + 4 * Screen.TwipsPerPixelY,
lTW, lTH
pResizeTabs
End If
End Sub
Private Sub pLoadOptions()
Dim cR As New cRegistry
If Not (pbLoadOptionsFromKey(HKEY_CURRENT_USER)) Then
pbLoadOptionsFromKey (HKEY_LOCAL_MACHINE)
End If
m_cMRU.MaxFileCount = 4
pDisplayMRU
End Sub
Private Function pbLoadOptionsFromKey(ByVal hKey As ERegistryClassConstants) As
Boolean
Dim cR As New cRegistry
cR.ClassKey = hKey
cR.SectionKey = "Software\vbaccelerator\TLibHelp\MRUFiles"
If (cR.KeyExists) Then
m_cMRU.Load cR
cR.SectionKey = "Software\vbaccelerator\TLibHelp"
cR.ValueKey = "InitOpenDir"
cR.ValueType = REG_SZ
m_sInitOpenDir = cR.Value
cR.ValueKey = "InitSaveDir"
cR.ValueType = REG_SZ
m_sInitSaveDir = cR.Value
If (Trim$(m_sInitSaveDir) = "") Then
' Get MyDocuments directory:
On Error Resume Next
m_sInitSaveDir = ShellFolder(CSIDL_PERSONAL)
End If
pbLoadOptionsFromKey = True
End If
End Function
Private Sub pSaveOptionsToKey(ByVal hKey As ERegistryClassConstants)
Dim cR As New cRegistry
cR.ClassKey = hKey
cR.SectionKey = "Software\vbaccelerator\TLibHelp\MRUFiles"
m_cMRU.Save cR
cR.SectionKey = "Software\vbaccelerator\TLibHelp"
cR.ValueKey = "InitOpenDir"
cR.ValueType = REG_SZ
cR.Value = m_sInitOpenDir
cR.ValueKey = "InitSaveDir"
cR.ValueType = REG_SZ
cR.Value = m_sInitSaveDir
End Sub
Private Sub pSaveOptions()
pSaveOptionsToKey HKEY_CURRENT_USER
pSaveOptionsToKey HKEY_LOCAL_MACHINE
End Sub
Private Sub pDisplayMRU()
Dim iFile As Long
Dim lIndex As Long
For iFile = 1 To m_cMRU.FileCount
lIndex = m_cMenu.IndexForKey("FILE:MRU:" & iFile)
If (m_cMRU.FileExists(iFile)) Then
If (iFile = 1) And cboClass.Enabled Then
m_cMenu.Checked(m_cMenu.IndexForKey("FILE:MRU:1")) = True
End If
m_cMenu.Caption(lIndex) = m_cMRU.MenuCaption(iFile)
m_cMenu.itemData(lIndex) = iFile
m_cMenu.Enabled(lIndex) = True
m_cMenu.Visible(lIndex) = True
Else
m_cMenu.Visible(lIndex) = False
m_cMenu.Enabled(lIndex) = False
End If
Next iFile
m_cMenu.Visible(m_cMenu.IndexForKey("FILE:MRU:SEP")) = (m_cMRU.FileCount > 0)
End Sub
Private Sub pSelect(ByRef lstThis As ListBox, Optional bSelectState As Variant,
Optional bInvert As Variant, Optional bEverything As Boolean = False)
Dim lI As Long
If Not (IsMissing(bSelectState)) Then
For lI = 0 To lstThis.ListCount - 1
If (lstThis.itemData(lI) > 0) Or (bEverything) Then
lstThis.Selected(lI) = bSelectState
End If
Next lI
Else
If (IsMissing(bInvert)) Then
bInvert = True
End If
For lI = 0 To lstThis.ListCount - 1
If (lstThis.itemData(lI) > 0) Or (bEverything) Then
lstThis.Selected(lI) = Not (lstThis.Selected(lI))
End If
Next lI
End If
End Sub
Private Sub m_cMenu_Click(ItemNumber As Long)
Dim sKey As String
Dim sFrom As String
Dim iPos As Long
Dim sCommand As String
sKey = m_cMenu.ItemKey(ItemNumber)
iPos = InStr(sKey, ":")
If (iPos > 0) Then
sFrom = Left(sKey, iPos - 1)
sCommand = Mid(sKey, iPos + 1)
Select Case sCommand
Case "OPEN"
pPerformOpen
Case "SAVE"
pPerformSave
Case "PRINT"
pPerformPrint
Case "PRINTPREVIEW"
Case "EXIT"
PostMessage Me.hwnd, WM_SYSCOMMAND, SC_CLOSE, 0
Case "COPY"
pCopy
Case "SELECTALL"
Select Case tabMain.SelectedTab
Case 1
pSelect lstMembers, True
Case 2
Case 3
rtfDocument.SelectAll
End Select
Case "SELECTNONE"
' clear selection:
Select Case tabMain.SelectedTab
Case 1
pSelect lstGeneral, False, , True
pSelect lstMembers, False, , True
Case 2
Case 3
rtfDocument.SelectNone
End Select
Case "INVERTSELECTION"
' invert selection (tab 1 only)
pSelect lstMembers, , True
Case "CONTENTS"
' help
MsgBox "Sorry, help contents are not available yet.", vbInformation
Case "VBA"
' Shell vbAccelerator:
On Error Resume Next
ShellEx "/index.html", , , , , Me.hwnd
If (Err.Number <> 0) Then
MsgBox "Sorry, I failed to open the web site: www.vbaccelerator.com
due to an error." & vbCrLf & vbCrLf & "[" & Err.Description & "]",
vbExclamation
End If
Case "ABOUT"
frmAbout.Show vbModal, Me
Case Else
Dim sFIle As String
If InStr(sCommand, "MRU") > 0 Then
sFIle = m_cMRU.file(m_cMenu.itemData(ItemNumber))
If (pbGetTypeLibInfo(sFIle)) Then
' success:
m_cMRU.AddFile sFIle
pDisplayMRU
End If
End If
End Select
End If
End Sub
Private Sub rbrMain_ChevronPushed(ByVal wID As Long, ByVal lLeft As Long, ByVal
lTop As Long, ByVal lRight As Long, ByVal lBottom As Long)
Dim v As Variant
v = rbrMain.BandData(wID)
If Not IsMissing(v) Then
Select Case v
Case "MenuBand"
tbrMenu.chevronPress lRight \ Screen.TwipsPerPixelX + 1, lTop \
Screen.TwipsPerPixelY
Case "ToolbarBand"
tbrMain.chevronPress lRight \ Screen.TwipsPerPixelX + 1, lTop \
Screen.TwipsPerPixelY
End Select
End If
End Sub
Private Sub rbrMain_HeightChanged(lNewHeight As Long)
Form_Resize
End Sub
Private Sub sbrMain_DrawItem(ByVal lHDC As Long, ByVal iPanel As Long, ByVal
lLeftPixels As Long, ByVal lTopPixels As Long, ByVal lRightPixels As Long,
ByVal lBottomPixels As Long)
Dim hBrush As Long
Dim lColor As Long
Dim tR As RECT
Dim lRight As Long
' Clear progress bar:
tR.Left = lLeftPixels
tR.Right = lRightPixels
tR.Top = lTopPixels
tR.Bottom = lBottomPixels
OleTranslateColor vbButtonFace, 0, lColor
hBrush = CreateSolidBrush(lColor)
FillRect lHDC, tR, hBrush
DeleteObject hBrush
If (m_lValue > 0) Then
Dim tBarR As RECT
LSet tBarR = tR
tBarR.Right = tR.Left + ((tR.Right - tR.Left) * m_lValue) \ m_lMax
OleTranslateColor vbHighlight, 0, lColor
hBrush = CreateSolidBrush(lColor)
FillRect lHDC, tBarR, hBrush
DeleteObject hBrush
SetBkMode lHDC, Transparent
DrawText lHDC, m_lValue & " of " & m_lMax, -1, tR, DT_SINGLELINE Or
DT_VCENTER
End If
End Sub
Private Sub tabMain_TabClick(ByVal lTab As Long)
pShowTab lTab
End Sub
Private Sub pPerformOpen()
Dim sFIle As String
' open
If (VBGetOpenFileName( _
sFIle, , True, , , , _
"ActiveX Files
(*.OCX;*.DLL;*.TLB;*.OLB;*.EXE)|*.OCX;*.DLL;*.TLB;*.OLB;*.EXE|ActiveX
Controls (*.OCX)|*.OCX|ActiveX DLLs (*.DLL)|*.DLL|Type Libraries
(*.TLB;*.OLB)|*.TLB;*.OLB|ActiveX Executables (*.EXE)|*.EXE|All Files
(*.*)|*.", _
1, m_sInitOpenDir, "Choose Type Library", "*.OCX", Me.hwnd)) Then
If (pbGetTypeLibInfo(sFIle)) Then
' success
m_cMRU.AddFile sFIle
pDisplayMRU
End If
End If
End Sub
Private Sub pPerformSave()
If Not (m_cTLI Is Nothing) And cboClass.Enabled Then
If (cboClass.itemData(cboClass.ListIndex) = &HFFFFFFF) Then
pSave m_cTLI.Name & " Interface Definition"
Else
pSave cboClass.List(cboClass.ListIndex)
End If
Else
MsgBox "No Type Library is Loaded to Save a Document for.", vbInformation
End If
End Sub
Private Sub pPerformPrint()
If Not (m_cTLI Is Nothing) And cboClass.Enabled Then
' print:
rtfDocument.PrintDoc m_cTLI.Name & " Interface Definition"
Else
MsgBox "No Type Library is Loaded to Save a Document for.", vbInformation
End If
End Sub
Private Sub pSave(ByVal sName As String)
Dim sTitle As String
Dim eType As ERECFileTypes
Dim iPos As Integer
Dim iFilterIndex As Long
Dim sExt As String
Dim bHtml As Boolean
sName = m_sInitSaveDir & sName
iFilterIndex = 1
VBGetSaveFileName sName, _
sTitle, True, _
"HTML Document (*.HTML)|*.HTML|Rich Text Document (*.RTF)|*.RTF|Text
Document (*.TXT)|*.TXT|All Files (*.*)|*.*", _
iFilterIndex, _
m_sInitSaveDir, _
"Choose Location to Save Document to", _
"HTML", _
Me.hwnd, _
OFN_PATHMUSTEXIST Or OFN_NOREADONLYRETURN
If (sName <> "") Then
iPos = InStr(sName, sTitle)
If (iPos <> 0) Then
m_sInitSaveDir = Left$(sName, (iPos - 1))
End If
If iFilterIndex = 1 Then
bHtml = True
ElseIf iFilterIndex = 2 Then
eType = SF_RTF
ElseIf iFilterIndex = 3 Then
eType = SF_TEXT
Else
' check extension:
For iPos = Len(sTitle) To 1 Step -1
If (Mid$(sTitle, iPos, 1) = ".") Then
sExt = UCase$(Mid$(sTitle, iPos + 1))
End If
Next iPos
Select Case sExt
Case "HTM", "HTML"
bHtml = True
Case "TXT"
eType = SF_TEXT
Case Else
eType = SF_RTF
End Select
End If
Dim iFile As Integer
Dim sContents As String
On Error Resume Next
If (bHtml) Then
iFile = FreeFile
Open sName For Binary Access Write Lock Read As #iFile
If (Err.Number <> 0) Then
MsgBox "Failed to open the file '" & sName & "' for writing:" &
vbCrLf & vbCrLf & Err.Description, vbExclamation
Close #iFile
Exit Sub
End If
Put #iFile, , m_cHtml.ToString
Close #iFile
Else
'sContents = rtfDocument.Contents(eType)
rtfDocument.SaveToFile sName, SF_RTF
End If
If (Err.Number <> 0) Then
MsgBox "Failed to get the document to save to disk:" & vbCrLf & vbCrLf
& Err.Description, vbExclamation
Kill sName
Err.Clear
Exit Sub
End If
On Error GoTo 0
End If
End Sub
Private Sub pCopy()
Dim sOut As String
Dim bIsGeneralSel As Boolean
Dim lI As Long
' depends on what tab we are on:
Select Case tabMain.SelectedTab
Case 1
' copy the selected items in the general list:
For lI = 0 To lstGeneral.ListCount - 1
If (lstGeneral.Selected(lI)) Then
sOut = sOut & lstGeneral.List(lI) & vbCrLf
bIsGeneralSel = True
End If
Next lI
If (bIsGeneralSel) Then
sOut = sOut & vbCrLf
End If
' copy the selected members:
For lI = 0 To lstMembers.ListCount - 1
If (lstMembers.Selected(lI)) Then
sOut = sOut & lstMembers.List(lI) & vbCrLf
End If
Next lI
Clipboard.Clear
Clipboard.SetText sOut
Case 2
' todo..
Case 3
' Call the copy method on the richedit box:
rtfDocument.Copy
End Select
End Sub