Wrox Programmer Forums

Need to download code?

View our list of code downloads.

Go Back   Wrox Programmer Forums > Visual Basic > VB 6 Visual Basic 6 > VB How-To
Password Reminder
Register
Register | FAQ | Members List | Calendar | Search | Today's Posts | Mark Forums Read
VB How-To Ask your "How do I do this with VB?" questions in this forum.
Welcome to the p2p.wrox.com Forums.

You are currently viewing the VB How-To section of the Wrox Programmer to Programmer discussions. This is a community of tens of thousands of software programmers and website developers including Wrox book authors and readers. As a guest, you can read any forum posting. By joining today you can post your own programming questions, respond to other developersí questions, and eliminate the ads that are displayed to guests. Registration is fast, simple and absolutely free .
DRM-free e-books 300x50
Reply
 
Thread Tools Display Modes
  #1 (permalink)  
Old March 13th, 2017, 03:12 PM
Registered User
Points: 5, Level: 1
Points: 5, Level: 1 Points: 5, Level: 1 Points: 5, Level: 1
Activity: 25%
Activity: 25% Activity: 25% Activity: 25%
 
Join Date: Mar 2017
Posts: 1
Thanks: 0
Thanked 0 Times in 0 Posts
Default convert vba code to vb -

Option Explicit

Sub DocumentUniverse()

Dim DesApp As Designer.Application
Dim Univ As Designer.Universe
Dim CurrentApp As String
On Error GoTo ErrorHandler

'some Excel housekeeping
CurrentApp = Application.Caption
Application.Cursor = xlWait
Application.DisplayAlerts = False

'start Designer and log in
Set DesApp = New Designer.Application
DesApp.Window.State = dsMinimized
DesApp.Visible = True
Application.StatusBar = "Logging in..."
Call DesApp.LogonDialog

'open a universe
Application.StatusBar = "Opening universe..."
Set Univ = DesApp.Universes.Open
DesApp.Visible = False

'restore Excel as active application
Call AppActivate(CurrentApp)
Application.ScreenUpdating = True

'call separate procedure for each part of the universe
Call ListTables(Univ.Tables)
Call ListColumns(Univ.Tables)
Call ListJoins(Univ.Joins)
Call ListContexts(Univ.Contexts)
Call ListClasses(Univ.Classes, 1)
Call ListObjects(Univ.Classes, 1)
Call ListConditions(Univ.Classes, 1)

CleanUp:
On Error Resume Next
Application.StatusBar = False
Application.Cursor = xlDefault
Univ.Close
Set Univ = Nothing
DesApp.Quit
Set DesApp = Nothing
Exit Sub

ErrorHandler:
Call AppActivate(CurrentApp)
MsgBox Err.Source & " - " & Err.Number & ": " & Err.Description, _
vbCritical, "Failure in DocumentUniverse()"
Resume CleanUp

End Sub

Sub ListTables(Tbls As Designer.Tables)

Dim Tbl As Designer.Table
Dim Rng As Excel.Range
Dim RowNum As Long
On Error GoTo ErrorHandler

Application.StatusBar = "Documenting database tables..."
Set Rng = Sheets("Database Tables").Cells
RowNum = 1
For Each Tbl In Tbls
RowNum = RowNum + 1
Rng(RowNum, 1) = Tbl.Name
If Tbl.IsAlias Then Rng(RowNum, 2) = Tbl.OriginalTable.Name
Next Tbl

CleanUp:
Set Tbl = Nothing
Exit Sub

ErrorHandler:
MsgBox Err.Source & " - " & Err.Number & ": " & Err.Description, _
vbCritical, "Failure in ListTables()"
Resume CleanUp

End Sub

Sub ListColumns(Tbls As Designer.Tables)

Dim Tbl As Designer.Table
Dim Col As Designer.Column
Dim Rng As Excel.Range
Dim RowNum As Long
On Error GoTo ErrorHandler

Application.StatusBar = "Documenting database table columns..."
Set Rng = Sheets("Database Columns").Cells
RowNum = 1
For Each Tbl In Tbls
If Not Tbl.IsAlias Then
For Each Col In Tbl.Columns
RowNum = RowNum + 1
Rng(RowNum, 1) = Tbl.Name
Rng(RowNum, 2) = Col.Name
Rng(RowNum, 3) = Col.Type
Next Col
End If
Next Tbl

CleanUp:
Set Col = Nothing
Set Tbl = Nothing
Exit Sub

ErrorHandler:
MsgBox Err.Source & " - " & Err.Number & ": " & Err.Description, _
vbCritical, "Failure in ListColumns()"
Resume CleanUp

End Sub

Sub ListJoins(Jns As Designer.Joins)

Dim Jn As Designer.Join
Dim Rng As Excel.Range
Dim RowNum As Long
On Error GoTo ErrorHandler

Application.StatusBar = "Documenting joins..."
Set Rng = Sheets("Joins").Cells
RowNum = 1
For Each Jn In Jns
RowNum = RowNum + 1
Rng(RowNum, 1) = Jn.Expression
Rng(RowNum, 2) = Jn.ShortCut
Rng(RowNum, 3) = Jn.Cardinality
Rng(RowNum, 4) = Jn.OuterJoin
Next Jn

CleanUp:
Set Jn = Nothing
Exit Sub

ErrorHandler:
MsgBox Err.Source & " - " & Err.Number & ": " & Err.Description, _
vbCritical, "Failure in ListJoins()"
Resume CleanUp

End Sub

Sub ListContexts(Conts As Designer.Contexts)

Dim Cont As Designer.Context
Dim Jn As Designer.Join
Dim Rng As Excel.Range
Dim RowNum As Long
On Error GoTo ErrorHandler

Application.StatusBar = "Documenting contexts..."
Set Rng = Sheets("Contexts").Cells
RowNum = 1
For Each Cont In Conts
For Each Jn In Cont.Joins
RowNum = RowNum + 1
Rng(RowNum, 1) = Cont.Name
Rng(RowNum, 2) = Jn.Expression
Rng(RowNum, 3) = Cont.Description
Next Jn
Next Cont

CleanUp:
Set Cont = Nothing
Set Jn = Nothing
Exit Sub

ErrorHandler:
MsgBox Err.Source & " - " & Err.Number & ": " & Err.Description, _
vbCritical, "Failure in ListContexts()"
Resume CleanUp

End Sub

Sub ListClasses(Clss As Designer.Classes, RowNum As Long)

Dim Cls As Designer.Class
Dim Rng As Excel.Range
On Error GoTo ErrorHandler

Application.StatusBar = "Documenting classes..."
Set Rng = Sheets("Classes").Cells
For Each Cls In Clss
RowNum = RowNum + 1
Rng(RowNum, 1) = Cls.Name
Rng(RowNum, 2) = Cls.RootClass.Name
Rng(RowNum, 3) = Cls.Description
'because classes can have classes, this procedure
'recursively calls itself as needed
If Cls.Classes.Count > 0 Then
Call ListClasses(Cls.Classes, RowNum)
End If
Next Cls

CleanUp:
Set Cls = Nothing
Exit Sub

ErrorHandler:
'Rootclass property for a first level class will
'cause this error. It's OK to continue.
If UCase(Err.Source) = "DESIGNER" And Err.Number = 91 Then
Resume Next
End If
MsgBox Err.Source & " - " & Err.Number & ": " & Err.Description, _
vbCritical, "Failure in ListClasses()"
Resume CleanUp

End Sub

Sub ListObjects(Clss As Designer.Classes, RowNum As Long)

Dim Cls As Designer.Class
Dim Obj As Designer.Object
Dim Tbl As Designer.Table
Dim Rng As Excel.Range
On Error GoTo ErrorHandler

Application.StatusBar = "Documenting objects..."
Set Rng = Sheets("Objects").Cells
For Each Cls In Clss
For Each Obj In Cls.Objects
RowNum = RowNum + 1
Rng(RowNum, 1) = Cls.Name
Rng(RowNum, 2) = Obj.Name
Rng(RowNum, 3) = Obj.Type
Rng(RowNum, 4) = Obj.Description
'Excel drops a leading apostrophe, so make sure it stays
If Left(Obj.Select, 1) = "'" Then
Rng(RowNum, 5) = "'" & Obj.Select
Else
Rng(RowNum, 5) = Obj.Select
End If
'Excel drops a leading apostrophe, so make sure it stays
If Left(Obj.Where, 1) = "'" Then
Rng(RowNum, 6) = "'" & Obj.Where
Else
Rng(RowNum, 6) = Obj.Where
End If
'list all of the tables separated by a comma ...
For Each Tbl In Obj.Tables
Rng(RowNum, 7) = Rng(RowNum, 7) & Tbl.Name & ", "
Next Tbl
'... but remove the trailing comma
If Obj.Tables.Count > 0 Then
Rng(RowNum, 7) = Left(Rng(RowNum, 7), Len(Rng(RowNum, 7)) - 2)
End If
Rng(RowNum, 8) = Obj.Qualification
Rng(RowNum, 9) = Obj.AggregateFunction
If Obj.Qualification = dsDetailObject Then
Rng(RowNum, 10) = Obj.AssociatedDimension.Name
End If
Rng(RowNum, 11) = Obj.HasListOfValues
Rng(RowNum, 12) = Obj.AllowUserToEditLov
Rng(RowNum, 13) = Obj.AutomaticLovRefreshBeforeUse
Rng(RowNum, 14) = Obj.ExportLovWithUniverse
Rng(RowNum, 15) = Obj.SecurityAccessLevel
Rng(RowNum, 16) = Obj.CanBeUsedResult
Rng(RowNum, 17) = Obj.CanBeUsedCondition
Rng(RowNum, 18) = Obj.CanBeUsedSort
Rng(RowNum, 19) = Obj.DataBaseFormat
Rng(RowNum, 20) = Obj.Show
Next Obj
'because classes can have classes, this procedure
'recursively calls itself as needed
If Cls.Classes.Count > 0 Then
Call ListObjects(Cls.Classes, RowNum)
End If
Next Cls

CleanUp:
Set Tbl = Nothing
Set Obj = Nothing
Set Cls = Nothing
Exit Sub

ErrorHandler:
MsgBox Err.Source & " - " & Err.Number & ": " & Err.Description, _
vbCritical, "Failure in ListObjects()"
Resume CleanUp

End Sub

Sub ListConditions(Clss As Designer.Classes, RowNum As Long)

Dim Cls As Designer.Class
Dim Cond As Designer.PredefinedCondition
Dim Tbl As Designer.Table
Dim Rng As Excel.Range
On Error GoTo ErrorHandler

Application.StatusBar = "Documenting conditions..."
Set Rng = Sheets("Conditions").Cells
For Each Cls In Clss
For Each Cond In Cls.PredefinedConditions
RowNum = RowNum + 1
Rng(RowNum, 1) = Cls.Name
Rng(RowNum, 2) = Cond.Name
Rng(RowNum, 3) = Cond.Description
Rng(RowNum, 4) = Cond.Where
'list all of the tables separated by a comma ...
For Each Tbl In Cond.Tables
Rng(RowNum, 5) = Rng(RowNum, 5) & Tbl.Name & ", "
Next Tbl
'... but remove the trailing comma
If Cond.Tables.Count > 0 Then
Rng(RowNum, 5) = Left(Rng(RowNum, 5), Len(Rng(RowNum, 5)) - 2)
End If
Rng(RowNum, 6) = Cond.Show
Next Cond
'because classes can have classes, this procedure
'recursively calls itself as needed
If Cls.Classes.Count > 0 Then
Call ListConditions(Cls.Classes, RowNum)
End If
Next Cls

CleanUp:
Set Tbl = Nothing
Set Cond = Nothing
Set Cls = Nothing
Exit Sub

ErrorHandler:
MsgBox Err.Source & " - " & Err.Number & ": " & Err.Description, _
vbCritical, "Failure in ListConditions()"
Resume CleanUp

End Sub
Reply With Quote
Reply


Thread Tools
Display Modes

Posting Rules
You may not post new threads
You may not post replies
You may not post attachments
You may not edit your posts

BB code is On
Smilies are On
[IMG] code is Off
HTML code is Off
Trackbacks are Off
Pingbacks are On
Refbacks are Off

Similar Threads
Thread Thread Starter Forum Replies Last Post
Convert VBA to vb.Net headworth Excel VBA 1 July 22nd, 2009 09:51 PM
Help me i must convert Code vb to C# pla_2 C# 3 October 14th, 2006 12:54 AM
convert vba code to vb tommy03 VB How-To 3 February 23rd, 2005 01:13 PM
VBA code convert to SQL omnicap1 Access VBA 2 August 23rd, 2004 03:03 AM
Convert VB to C# code skdp VS.NET 2002/2003 2 March 1st, 2004 10:45 PM



All times are GMT -4. The time now is 05:12 AM.


Powered by vBulletin®
Copyright ©2000 - 2017, Jelsoft Enterprises Ltd.
© 2013 John Wiley & Sons, Inc.