erstudio 生成word宏

转自

http://blog.sina.com.cn/s/blog_4a40fa550100aixu.html

 

贴到宏编辑器中执行即可。

 

'MACRO TITLE: Report Logical or Physical Model TO Microsoft Word
'This macro generates a mini report for the selected entities in the active model.
' REQUIREMENT: You must have Word 97 or later installed.

Sub Main
 'Dim MS Word variables
 Dim Word As Object
 Dim Docs As Object
 Dim ActiveDoc As Object
 
 'Dim ER/Studio variables.
 Dim diag As Diagram
 Dim mdl As Model
 Dim subMdl As SubModel
 Dim ent As Entity
 Dim attr As AttributeObj
 Dim tableConstraints As TableCheckConstraints
 Dim tableConstraint As TableCheckConstraint

 Dim entNames As Variant
 Dim entCount As Variant
 Dim entLoop As Integer

 'Start MS Word and make it visible.
 Set Word = CreateObject("Word.Application")
 Wait 1 'Wait 1 second to allow application to be instantiated
 Word.Visible = True
 Word.Documents.Add
 Set ActiveDoc = Word.Documents(1)
 ActiveDoc.Activate
 With ActiveDoc
  .ShowSpellingErrors = False
  .ShowGrammaticalErrors  = False
  With .pageSetup
   .LeftMargin = 0.5*72 'Points
   .RightMargin = 0.5*72
   .TopMargin = 0.5*72
   .BottomMargin = 0.5*72
  End With
 End With

 'Init the ER/Studio variables.
 Set diag = DiagramManager.ActiveDiagram
 Set mdl = diag.ActiveModel

 'Process the current submodel, if one exists
 Set subMdl=mdl.ActiveSubModel
 subMdl.EntityNames(entNames, entCount)
 'Sort the entity names
 Call dhQuickSort(entNames)

 'Iterate through all entities in the current sub-model
    For entLoop = 0 To entCount - 1 'For Each ent In subMdl.Entities()
     Set ent = mdl.Entities.Item(entNames(entLoop))

  With Word.Selection
   'First the entity name
   .Font.Bold = True
   .Font.Underline = True
   .Font.Size = 18
   .TypeText Text:=ent.TableName

   'Keep the paragraph together, and with the next paragraph
   .Paragraphs(1).KeepTogether = True
   .Paragraphs(1).KeepWithNext = True

   'Now the entity definition
   .Font.Underline = False
   .Font.Bold = False
   .Font.Size = 12
   .TypeText Text:="  " & ent.Definition & vbCrLf

   'Is there a check constraint?
   Set tableConstraints = ent.TableCheckConstraints
   For Each tableConstraint In tableConstraints
    .TypeText Text:="Constraint " _
     & tableConstraint.ConstraintName _
     & ": " & tableConstraint.ConstraintText & vbCrLf
   Next
  End With
  
  'Iterate through all the attributes in the current entity
  For Each attr In ent.Attributes
   With Word.Selection
    'First the attribute name
    .Font.Bold = True
    'Check for a rolename
    If attr.AttributeName<>attr.ColumnName Then
     .TypeText Text:=attr.ColumnName & "." & attr.AttributeName & ": "
    Else
     .TypeText Text:=attr.ColumnName & ": "
    End If
    .Font.Bold = False

    'Then the datatype
    '.TypeText Text:= attr.Datatype
    .typetext Text:= attr.PhysicalDatatype
    If attr.DataLength > 0 Then
     .TypeText Text:= "(" & attr.DataLength & ")"
    End If
    .TypeText Text:= ": "

    'Now the Null option and Definition
    .TypeText Text:= IIf(attr.Identity, "IDENTITY", attr.NullOption) & ": " & attr.Definition & vbCrLf

    'Is there a default value?
    If Len(attr.DeclaredDefault) > 0 Then
     .TypeText Text:= "   Default Value: " & attr.DeclaredDefault & vbCrLf
    End If

    'Is there a validation rule?
    If Len(attr.CheckConstraint) > 0 Then
     .TypeText Text:= "   Constraint " & attr.CheckConstraintName  _
      & ": " & attr.CheckConstraint & vbCrLf
    End If
   End With
  Next
  
  With Word.Selection
   .Paragraphs(1).KeepWithNext = False
   .TypeText Text:= vbCrLf
  End With
    Next
End Sub

' **The following code is taken from the specified book.  It has been modified
' **to perform a case insensitive sort.

' From "VBA Developer's Handbook"
' by Ken Getz and Mike Gilbert
' Copyright 1997; Sybex, Inc. All rights reserved.

' Quicksort for simple data types.

' Indicate that a parameter is missing.
Const dhcMissing = -2

Sub dhQuickSort(varArray As Variant, _
 Optional intLeft As Integer = dhcMissing, _
 Optional intRight As Integer = dhcMissing)

    ' From "VBA Developer's Handbook"
    ' by Ken Getz and Mike Gilbert
    ' Copyright 1997; Sybex, Inc. All rights reserved.
   
    ' Entry point for sorting the array.
   
    ' This technique uses the recursive Quicksort
    ' algorithm to perform its sort.
   
    ' In:
    '   varArray:
    '       A variant pointing to an array to be sorted.
    '       This had better actually be an array, or the
    '       code will fail, miserably. You could add
    '       a test for this:
    '       If Not IsArray(varArray) Then Exit Sub
    '       but hey, that would slow this down, and it's
    '       only YOU calling this procedure.
    '       Make sure it's an array. It's your problem.
    '   intLeft:
    '   intRight:
    '       Lower and upper bounds of the array to be sorted.
    '       If you don't supply these values (and normally, you won't)
    '       the code uses the LBound and UBound functions
    '       to get the information. In recursive calls
    '       to the sort, the caller will pass this information in.
    '       To allow for passing integers around (instead of
    '       larger, slower variants), the code uses -2 to indicate
    '       that you've not passed a value. This means that you won't
    '       be able to use this mechanism to sort arrays with negative
    '       indexes, unless you modify this code.
    ' Out:
    '       The data in varArray will be sorted.
   
    Dim i As Integer
    Dim j As Integer
    Dim varTestVal As Variant
    Dim intMid As Integer

    If intLeft = dhcMissing Then intLeft = LBound(varArray)
    If intRight = dhcMissing Then intRight = UBound(varArray)
  
    If intLeft < intRight Then
        intMid = (intLeft + intRight) \ 2
        varTestVal = UCase(varArray(intMid))
        i = intLeft
        j = intRight
        Do
            Do While UCase(varArray(i)) < varTestVal
                i = i + 1
            Loop
            Do While UCase(varArray(j)) > varTestVal
                j = j - 1
            Loop
            If i <= j Then
                SwapElements varArray, i, j
                i = i + 1
                j = j - 1
            End If
        Loop Until i > j
        ' To optimize the sort, always sort the
        ' smallest segment first.
        If j <= intMid Then
            Call dhQuickSort(varArray, intLeft, j)
            Call dhQuickSort(varArray, i, intRight)
        Else
            Call dhQuickSort(varArray, i, intRight)
            Call dhQuickSort(varArray, intLeft, j)
        End If
    End If
End Sub

Private Sub SwapElements(varItems As Variant, intItem1 As Integer, intItem2 As Integer)
    Dim varTemp As Variant

    varTemp = varItems(intItem2)
    varItems(intItem2) = varItems(intItem1)
    varItems(intItem1) = varTemp
End Sub