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