"Tom van Stiphout" <no*************@cox.net> wrote in message
news:an********************************@4ax.com...
On Wed, 21 Jun 2006 01:18:20 GMT, "Stephen Lebans"
<ForEmailGotoMy.WebSite.-WWWdotlebansdot...@linvalid.com> wrote:
Very cool. I have often thought what it would take to write such a
routine. Still pretty clueless. Perhaps you'll write an article for
some magazine?
Can we have multiple views as well?
-Tom.
I've got a tool that will automatically reorganize and add field/table
info
to the Relationship window. I have been trying to find the time to publish
it in the last month without success. I start my vacation in July and will
definately have time then.
Hi Tom
I already have a solution on my site to support mutliple Relationship views.
I'll have to see about integrating into this RelationShip view to PDF doc
solution.
I found it very difficult to develop the logic to automatically resize and
reposition the existing relationship windows. I'm not 100% satisfied with my
current solution but it does work quite well. I have tested it against
RelationShip views with hundreds of tables.
I've posted the main function's code below. Please remember this is very
raw. I have yet to clean the code, structure the comments properly, and
optimize the logic. But it does work as it stands now.
--
HTH
Stephen Lebans
http://www.lebans.com
Access Code, Tips and Tricks
Please respond only to the newsgroups so everyone can benefit.
Public Function RelationsToPDF(ctl As Access.Control) As Boolean
' The Font characteristics of the control passed to this function
' are used for the created PDF document.
Dim rlBlob() As RelWindow
' Copy of RelWindow but with minimal info and no fixed length strings
Dim rl() As RelWindowMin
Dim rlTemp() As RelWindowMin
' The RelationShip window BLOB from the System table
Dim rb As RelBlob
Dim db As DAO.Database 'This database.
Dim tdf As DAO.TableDef 'Each table referenced in the Relationships
window.
Dim tdfForeign As DAO.TableDef
Dim SRelTableName As String
Dim SRelFieldName As String
Dim sCodes As String
Dim s As String, sTable As String, sForeign As String
Dim blRet As Boolean
Dim lRet As Long
Dim lTemp As Long
' Current Screen Resolution
Dim Xdpi As Double
Dim Ydpi As Double
Dim lngIC As Long
Dim ConvX As Double
Dim ConvY As Double
Dim X1 As Long, X2 As Long, Y1 As Long, Y2 As Long
Dim X2Max As Long, Y2Max As Long
Dim X1Prev As Long, Y1Prev As Long
X2Max = 0
Y2Max = 0
Dim ctr As Long
' Current Column window width
Dim Width As Long
' Vars to create Font and Measure Text Width and Height
' Structure for DrawText calc
Dim sRect As RECT
' Reports Device Context
Dim hDC As Long
Dim newfont As Long
' Handle to our Font Object we created.
' We must destroy it before exiting main function
Dim oldfont As Long
' Device COntext's Font we must Select back into the DC
' before we exit this function.
' Logfont struct
Dim myfont As LOGFONT
' TextMetric struct
Dim tm As TEXTMETRIC
' LineSpacing Amount
Dim lngLineSpacing As Long
' Ttemp var
Dim numLines As Long
' Temp string var for current printer name
Dim strName As String
' Temp vars
Dim sngTemp1 As Single
Dim sngTemp2 As Single
Dim sText As String
' RelationShip OrdinalPosition Primary table->Field
Dim ReOPp As Integer
' RelationShip OrdinalPosition Foreign table->Field
Dim ReOPf As Integer
Dim fld As DAO.Field
' inner loop counter
Dim i As Integer
Dim rel As Relation
' Let's see if the DynaPDF.DLL is available.
blRet = LoadLib()
If blRet = False Then
' Cannot find DynaPDF.dll or StrStorage.dll file
Exit Function
End If
On Error GoTo ERR_RelationsToPDF
'Initialize: Open the Relationships report in design view.
Set db = CurrentDb()
sCodes = ""
' Field Types:
' ===========
' A AutoNumber field (size Long Integer)
' B Byte (Number)
' C Currency
' Dbl Double (Number)
' Dec Decimal (Number)
' Dt Date/Time
' Guid Replication ID (Globally Unique IDentifier)
' Hyp Hyperlink
' Int Integer (Number)
' L Long Integer (Number)
' M Memo field
' Ole OLE Object
' Sng Single (Number)
' T Text, with number of characters (size)
' Yn Yes/No
' ? Unknown field type
' Indexes:
' =======
' P Primary Key
' U Unique Index ('No Duplicates')
' I Indexed ('Duplicates Ok')
' Note: Lower case p, u, or i indicates a secondary field in a multi-field
index.
' Properties:
' ==========
' D Default Value set.
' R Required property is Yes
' V Validation Rule set.
' Z Allow Zero-Length is Yes (Text, Memo and Hyperlink only.)
' Get current Screen DPI
lngIC = apiCreateIC("DISPLAY", vbNullString, vbNullString, vbNullString)
'If the call to CreateIC didn't fail, then get the Screen X resolution.
If lngIC <> 0 Then
Xdpi = apiGetDeviceCaps(lngIC, LOGPIXELSX)
Ydpi = apiGetDeviceCaps(lngIC, LOGPIXELSY)
'Release the information context.
apiDeleteDC (lngIC)
Else
' Something has gone wrong. Assume an average value.
Xdpi = 120
Ydpi = 120
End If
' Create a temp Device Context
' Create our Font and select into the DC
' Get handle to screen Device Context
hDC = apiGetDC(0&)
With ctl
myfont.lfClipPrecision = CLIP_LH_ANGLES
myfont.lfOutPrecision = OUT_TT_ONLY_PRECIS
myfont.lfEscapement = 0
myfont.lfFaceName = .FontName & Chr$(0)
myfont.lfWeight = .FontWeight
myfont.lfItalic = .FontItalic
myfont.lfUnderline = .FontUnderline
'Must be a negative figure for height or system will return
'closest match on character cell not glyph
myfont.lfHeight = (.FontSize / 72) * -Ydpi
' Create our temp font
newfont = apiCreateFontIndirect(myfont)
End With
If newfont = 0 Then
Err.Raise vbObjectError + 256, "fTextWidthOrHeight", "Cannot Create
Font"
End If
' Select the new font into our DC.
oldfont = apiSelectObject(hDC, newfont)
' Get TextMetrics. This is required to determine
' Text height and the amount of extra spacing between lines.
lRet = GetTextMetrics(hDC, tm)
' Our DC is now ready for our calls to:
' Calculate our bounding box based on the controls current width
' lngRet = apiDrawText(hDC, sText, -1, sRect, DT_CALCRECT Or DT_TOP Or _
' DT_LEFT Or DT_WORDBREAK Or DT_EXTERNALLEADING Or DT_EDITCONTROL Or
DT_NOCLIP)
' Decode the RelationShip window BLOB
GetBlob rb, rlBlob
' Copy of array of RelWindow structures over to our minimal RelWindow struct
' so we can get rid of unused junk and the fixed length Unicode strings.
ReDim Preserve rl(0 To UBound(rlBlob))
For ctr = 0 To rb.NumWindows - 1
With rl(ctr)
' rb.ScrollBarXoffset + rb.ScrollBarYoffset will always be either:
' 0 - Both Vertical and Horiz ScrollBars are at the Home(0,0)
position
' a value signifying the offset of the pertinent ScrollBar to be
added
' to the negative X1,Y1,X2,Y2 coordinates.
' We can safely add
.RelWinX1 = (rlBlob(ctr).RelWinX1) + rb.ScrollBarXoffset
.RelWinX2 = (rlBlob(ctr).RelWinX2) + rb.ScrollBarXoffset
.RelWinY1 = (rlBlob(ctr).RelWinY1) + rb.ScrollBarYoffset
.RelWinY2 = (rlBlob(ctr).RelWinY2) + rb.ScrollBarYoffset
' ' Add a user defined Left Margin
' Dim LeftMargin As Long
' LeftMargin = 20
' .RelWinX1 = .RelWinX1 + LeftMargin
' .RelWinX2 = .RelWinX2 + LeftMargin
s = StrConv(rlBlob(ctr).WinName, vbFromUnicode)
s = Left$(s, InStr(1, s, Chr(0)) - 1)
.WinName = s
End With
Next ctr
' We need to perform several modifications to the BLOB data:
'1) Resize the height of each window so that all of the table's fields will
be visible.
' We will have to calculate a new Y1 position after we increate the height
of the window.
'
'2) Resize the width of each window so that the Table name and all of the
' field names will fit. Use a smaller font if the calculated width is
larger
' than our desired max width. Remember, I want to use a fixed width for
the
' columns of our output.
'3)
'
'
' The most difficult issue is to move every window to a column. Basically we
want
' to implement a Snap to Grid effect.
' Here is the logic:
' Loop through all windows
' Find the smallest X1 with the smallest Y1
' This becomes our first window
' Start looping again, this time finding the smallest X1 with the smallest
Y1
' that is larger than the previous Y1. This logic will ensure we are always
working
' down the grid. When we can no longer find any Y1 coords that are larger
than previous
' Y1 we are done this column of the grid. We then start over from the top
again.
' The logic is further constrained each time in the X direction for each
column of
' the grid we are building. X1 must be less than the width of the table at
the
' very top of the column we are currently working on. In other words, the
starting X1
' position of the next table window below the first one in this column must
have a
' starting X1 position less than the X1 + width of the first window in this
column.
' If there are two smaller windows under a wide window, and the second
window's Y1 meets
' the criteria of being larger than the first small window, we will move
this second
' small window directly underneath the first small window. It's the only
exception I
' can think of at this pointin developing this logic.
' Ok, we'll need an array and/or a collection to process implement our
logic.
' We really only need to store each Table name in final desired column
row/order.
' At this point we will not modify the original rl() array.
' Let's try a Collection for now. The key will be the Table Name. We do not
need
' to actually store any data as the order of the Key is what is important.
' Basically using the Collection as an odered list.
' First we find the smallest Y1 with the smallest X1.
' This gives us the topmost window in this column
' Next we search for the smallest X1 with a Y1 that is >= to the previous
Y1.
' We'll copy our rl() array over to a temp Collection
' so that we can remove entries as we process to
' speed up processing.
' Final Output order of windows
Dim cOut As New Collection
' Temp working Collection
Dim cTmp As New Collection
' Current Column Counter
Dim CurCol As Long
' Need to use/store the array index instead of a single instance of Rel
Window structure as VB
' will not accept a structure for the Item param of the Add method of the
Collection object.
'Dim r As RelWindowMin
' Copy to temp Collection
For ctr = 0 To rb.NumWindows - 1
With rl(ctr)
cTmp.Add Item:=ctr, Key:=.WinName
End With
Next ctr
' Non existent seed values
X1Prev = 100000
Y1Prev = 100000
' Find Top and left most window. Smallet X1 and Y1
Dim obj As Variant
Dim sNamePrev As String
' Need to flag when we are at the bottom of a column
'so we can reset seed values.
' No I think we can just keep finding the left most and top most window
' continually until all windows are processed/found.
' SNAP TO GRID
'for i =8 to 80 step 8
'
************************************************** **************************************
Dim SpacingInterval As Long
' Add a user defined Left Margin
Dim LeftMargin As Long
LeftMargin = 20
' Force window to multiple of SpacingInterval value.
' if less than halfway then go backwards to previous multiple.
' if more than or equal to halfway then go ahead to next multiple.
SpacingInterval = 100 ' was 200 sat march 11 at 5:57pm200
'For i = 100 To 200 Step 100
' SpacingInterval = i '* 25
For ctr = 0 To rb.NumWindows - 1
' Move to multiple of SpacingInterval
' Move to 0 if X1 is less than SpacingInterval
If rl(ctr).RelWinX1 <= SpacingInterval Then
rl(ctr).RelWinX1 = LeftMargin '0
Else
' Calculate which column X1 is in.
lRet = Int(rl(ctr).RelWinX1 / SpacingInterval)
lTemp = rl(ctr).RelWinX1 - (SpacingInterval * lRet)
' Less than half way to next multiple of SpacingInterval
If lTemp <= SpacingInterval / 2 Then
' Move back
lTemp = -lTemp 'SpacingInterval - lTemp
Else
' More than halfway to next multiple of SpacingInterval
' Move forward
lTemp = SpacingInterval - lTemp
End If
' Update coords
rl(ctr).RelWinX1 = rl(ctr).RelWinX1 + lTemp
rl(ctr).RelWinX2 = rl(ctr).RelWinX1 + lTemp
rl(ctr).Column = Int(rl(ctr).RelWinX1 / SpacingInterval)
End If
Next ctr
'Next i
' ****************
' March 11 9:15pm commented out belwo.
' Its' redundand and alreay done just above.
'' Increase space between SpaceInterval columns
'For ctr = 0 To rb.NumWindows - 1
' ' Add 300 to each SpacingInterval
' ' Determine Column #
' If rl(ctr).RelWinX1 < SpacingInterval Then
' ' Column = 0
' lRet = 0
' Else
' lRet = Int(rl(ctr).RelWinX1 / SpacingInterval)
'
' End If
'
' ' Update Column member
' rl(ctr).Column = lRet
' ' Update coords - add min 20 pixels between windows
' ' ****************************************
' 'comment out below March 11-2006
'
'************************************************* **********************
'' lTemp = rl(ctr).RelWinX2 - rl(ctr).RelWinX1
'' rl(ctr).RelWinX1 = rl(ctr).RelWinX1 + (lRet * 20) 'SpacingInterval)
'100) 'lTemp
'' rl(ctr).RelWinX2 = rl(ctr).RelWinX1 + lTemp '(lRet * 400)
''
'Next ctr
' Mon - March 6 10:10pm
' commented out
For ctr = 0 To rb.NumWindows - 1
For Each obj In cTmp
If rl(obj).RelWinX1 = X1Prev Then
' Still in same column
If rl(obj).RelWinY1 < Y1Prev Then
Y1Prev = rl(obj).RelWinY1
X1Prev = rl(obj).RelWinX1
sNamePrev = rl(obj).WinName
lRet = obj
End If
Else
If rl(obj).RelWinX1 < X1Prev Then
'If rl(obj).RelWinY1 = Y1Prev Then
Y1Prev = rl(obj).RelWinY1
X1Prev = rl(obj).RelWinX1
sNamePrev = rl(obj).WinName
lRet = obj
'ElseIf rl(obj).RelWinY1 <= Y1Prev Then
End If
End If
Next obj
' Error checking. Processed all windows
If Len(sNamePrev & vbNullString) = 0 Then Exit For
' Update Column member
' Save off this window in our ordered list
cOut.Add Item:=lRet, Key:=sNamePrev
' Remove this item from the temp work collection
cTmp.Remove sNamePrev
' Reset to non existent seed values
X1Prev = 100000
Y1Prev = 100000
sNamePrev = 0
Next ctr
' When we get to here all windows should have been processed
' and our temp work collection should have been emptied.
'
' Mon - March 6 10:10pm
' commented out
'X1 = 0
'Y1 = 0
'
'
' Make a working copy
ReDim rlTemp(0 To UBound(rl))
rlTemp = rl
' What we want to do is copy, in order, to the rl() array, via the
Collection Item prop
' from the rlTemp() array. This will put the windows in order from the
' top leftmost to the bottom right most. We need to do this so we can
adjust/increase
' the height of each Table windows so that all of the fields will be
visible.
ctr = 0
For Each obj In cOut
With rl(ctr)
.RelWinX1 = rlTemp(obj).RelWinX1
.RelWinY1 = rlTemp(obj).RelWinY1
.RelWinX2 = rlTemp(obj).RelWinX2
.RelWinY2 = rlTemp(obj).RelWinY2
.WinName = rlTemp(obj).WinName
.Column = rlTemp(obj).Column
ctr = ctr + 1
End With
Next
Dim MaxDocCharWidth As Long
Dim MaxDocCharHeight As Long
' Width of max documnentation characters
' Since we are using a 10 point font to calc width but really
' outputting 8 point with a 10 point leading then we do not
' need any extra char spacing.
sText = "XXXXg"
With sRect
.Left = 0
.Top = 0
.Bottom = 0
' Single line TextWidth
.Right = 32000
End With
lRet = apiDrawText(hDC, sText, -1, sRect, DT_CALCRECT Or DT_TOP Or _
DT_LEFT Or DT_WORDBREAK Or DT_EXTERNALLEADING Or DT_EDITCONTROL
Or DT_NOCLIP)
MaxDocCharWidth = sRect.Right
' Allow for 14 pt header and 10 point leading
MaxDocCharHeight = sRect.Bottom ' * 2
' Since the DyanPDF library will automatically wrap text to the next line
' we have to make sure that the Table name, the field names and the extra
' field documenting characters fit one single lines. Otherwise our logic
' to calculate the beginning and ending points of the Join lines will not be
accurate.
' There is an issue of overlap though in the X dimension when I increase the
width
' of the table window. This is easy to solve in the Y dimension but tougher
in the X direction.
' I may have to set a fixed width for all windows to solve this issue.
' X2Max holds widest Table or Field name.
' Loop through all of the table widths and adjust
' Add extra space in width to allow for documenting chars.
' Let's increase the Width of each Table window so that all fields are
visible.
' Perhaps we should modify the rl structure to hold max width required to
' ensure the table and field names are visible. No let's use a collection
object instead.
' No we will modify as we go - no need to store this value.
X2Max = 0
Y2Max = 0
Dim bHeader As Boolean
For ctr = 0 To rb.NumWindows - 1
With rl(ctr)
' Call our function to calc height
SRelTableName = .WinName '(.WinName) 'StrConv(.WinName,
vbFromUnicode)
s = Right$(SRelTableName, 3)
lRet = InStr(s, "_")
If lRet = 1 Or lRet = 2 Then
SRelTableName = Mid$(SRelTableName, 1, Len(SRelTableName) - (4 -
lRet))
End If
' DO NOT need to process this clone/copy - just process main table.
' No we cannot store the original Table window's Max width as it may
not have been
' processed at this point.
'If lRet = 0 Then
Set tdf = db.TableDefs(SRelTableName) '.WinName)
If Not tdf Is Nothing Then
'Calc width of Table name and all Field Names
' Set width of Table window to max width
sText = tdf.Name
With sRect
.Left = 0
.Top = 0
.Bottom = 0
' Single line TextWidth
.Right = 32000
End With
lRet = apiDrawText(hDC, sText, -1, sRect, DT_CALCRECT Or
DT_TOP Or _
DT_LEFT Or DT_WORDBREAK Or DT_EXTERNALLEADING Or
DT_EDITCONTROL Or DT_NOCLIP)
X2Max = sRect.Right
bHeader = True
For Each fld In tdf.Fields
sText = fld.Name
With sRect
.Left = 0
.Top = 0
.Bottom = 0
' Single line TextWidth
.Right = 32000
End With
lRet = apiDrawText(hDC, sText, -1, sRect, DT_CALCRECT Or
DT_TOP Or _
DT_LEFT Or DT_WORDBREAK Or DT_EXTERNALLEADING Or
DT_EDITCONTROL Or DT_NOCLIP)
If sRect.Right > X2Max Then
X2Max = sRect.Right
bHeader = False
End If
Next
'
************************************************** *********
' Make this a user optional param
' Resize to width ALL WINDOWS
' Get current width of this window. If it is less than X2Max
then adjust.
'If .RelWinX2 - .RelWinX1 < X2Max + MaxDocCharWidth Then
If bHeader = True Then
.RelWinX2 = .RelWinX1 + X2Max + MaxDocCharWidth
Else
.RelWinX2 = .RelWinX1 + X2Max + MaxDocCharWidth
End If
Set fld = Nothing
X2Max = 0
End If
'End If
End With
Next ctr
Set tdf = Nothing
' *****
' Adjust Height of all Relationship Table windows.
' *****
' Let's increase the Width of each Table window so that all fields are
visible.
' Perhaps we should modify the rl structure to hold max width required to
' ensure the table and field names are visible. No let's use a collection
object instead.
' No we will modify as we go - no need to store this value.
X2Max = 0
Y2Max = 0
For ctr = 0 To rb.NumWindows - 1
With rl(ctr)
' Call our function to calc height
SRelTableName = .WinName '(.WinName) 'StrConv(.WinName,
vbFromUnicode)
s = Right$(SRelTableName, 3)
lRet = InStr(s, "_")
If lRet = 1 Or lRet = 2 Then
SRelTableName = Mid$(SRelTableName, 1, Len(SRelTableName) - (4 -
lRet))
End If
' DO NOT need to process this clone/copy - just process main table.
' No we cannot store the original Table window's Max width as it may
not have been
' processed at this point.
'If lRet = 0 Then
' Build our string starting with Relationship Table window name
sText = SRelTableName & vbCrLf
Set tdf = db.TableDefs(SRelTableName) '.WinName)
If Not tdf Is Nothing Then
' Add individual Field names
For Each fld In tdf.Fields
sText = sText & fld.Name & vbCrLf
Next
With sRect
.Left = 0
.Top = 0
.Bottom = 0
' Single line TextWidth
.Right = 30000 'rl(ctr).RelWinX2 - rl(ctr).RelWinX1
End With
lRet = apiDrawText(hDC, sText, -1, sRect, DT_CALCRECT Or
DT_TOP Or _
DT_LEFT Or DT_WORDBREAK Or DT_EXTERNALLEADING Or
DT_EDITCONTROL Or DT_NOCLIP)
Y2Max = sRect.Bottom
' Get current height of this window. If it is less than calc
Height then adjust.
' We also need to leave room for an extra row to allow for
the
' Total Recs: line we output
If .RelWinY2 - .RelWinY1 < Y2Max + MaxDocCharHeight Then
.RelWinY2 = .RelWinY1 + Y2Max + MaxDocCharHeight
End If
Set fld = Nothing
End If
'End If
' ***
'***********************************************
' March 11/2006
' Add code here to set each window to the start of the column.
' Allow user to specify MinColumnSpacing
Dim MinColumnSpacing As Long
MinColumnSpacing = 40
' SpacingInterval contains relative offset
End With
Next ctr
Set tdf = Nothing
Set fld = Nothing
' March 6 -2006 10:18pm
' COMMENTED out below
' *****
' Adjust Starting X1 ANd Y1 of all Relationship Table windows.
' *****
' Let's increase the X1 starting X position of each Table window in order to
' increase the spacing between each table. We do this because overlapping
conditions
' are created when we previously increased the width of each Table window.
' To keep this simple, we allow the user to specify a fixed amount for the
' spacing value.
' Since our array of Rel() structures is ordered from top leftmost to
' bottom right most we can basically process the windows in a column by
column order.
'
' Because the spacing has to be cumulative per increasing column position,
we multiply
' the user's desired spacing value by the current column count(zero
indexed).
' Let's increase the Y1 starting Y position of each Table window in order to
' ensure that Table Windows do not overlape. We do this because overlapping
conditions
' are created when we previously increased the Height of each Table window
in order to
' ensure that all fields in the table window are visible.
Dim ctrCol As Long
'Dim Y1Prev As Long,
Dim Y2Prev As Long
Dim Y2PrevOrig As Long, Y1PrevOrig As Long
Dim VerticalWindowSpacing As Long
VerticalWindowSpacing = 14
Y1Prev = 0
Y2Prev = 0
X2Max = 0
Y2Max = 0
ctrCol = 0
Y2PrevOrig = 0
Y1PrevOrig = 99999999
For ctr = 0 To rb.NumWindows - 1
With rl(ctr)
' Modify Y1 first
' First window in the array is the topmost - leftmost window
' Determine if we are still in the current column.
' If the Y1 of this window is Greater than the Y1 of the
' previous window then we are still in the same column.
' Do need to code exception to handle when this current window
' is in the next column because even though the this Y1 is greater
' than previous Y1, X1 actually places this window in the next
column.(I think):-)
If .RelWinY1 > Y1PrevOrig Then
' We're still in the same column
' Store Y1
Y1PrevOrig = .RelWinY1
' Are we overlapping the previous window in this column.
If (.RelWinY1 < Y2Prev + VerticalWindowSpacing) And Y2Prev <> 0
Then
' Reposition to avoid overlap - calc resize first
.RelWinY2 = (.RelWinY2 - .RelWinY1) + Y2Prev +
VerticalWindowSpacing
.RelWinY1 = Y2Prev + VerticalWindowSpacing
' Y2Prev = .RelWinY2
' Y1Prev = .RelWinY1
'Else
End If
Y2Prev = .RelWinY2
Y1Prev = .RelWinY1
Else
' We're in the next column. Do not resize as it is the top most
' window in this column. Reset seeds to non existent values.
' Next Column
ctrCol = ctrCol + 1
Y2Prev = .RelWinY2
Y1Prev = .RelWinY1
Y1PrevOrig = .RelWinY1 '0
' Since we are at top of column no need to reposition
End If
End With
Next ctr
' Set absolute position for start of each column.
' Find Max Width of all windows in each column to calc ColumnWidth
' Storage for column Widths
Dim aColWidths() As Long
Dim lNumColumns As Long
' Get Total number of columns
For ctr = 0 To rb.NumWindows - 1
With rl(ctr)
If lNumColumns < .Column Then lNumColumns = .Column
End With
Next ctr
ReDim aColWidths(0 To lNumColumns)
Dim Gutter As Long
Gutter = 20
' Find largest window width in each column and
' store this value in our column width array.
For ctr = 0 To rb.NumWindows - 1
With rl(ctr)
If (.RelWinX2 - .RelWinX1) > aColWidths(.Column) Then
aColWidths(.Column) = (.RelWinX2 - .RelWinX1)
End If
End With
Next ctr
' Set X1 for every table window to the calc start of the column.
' *****************************
' Here we can set the Left Margin
For ctr = 0 To rb.NumWindows - 1
With rl(ctr)
' Column starting position =
' column widths for all previous columns plus
' column spacing value
lTemp = 0
For i = 0 To .Column - 1
lTemp = lTemp + aColWidths(i)
lTemp = lTemp + Gutter
Next i
.RelWinX2 = (.RelWinX2 - .RelWinX1) + lTemp
.RelWinX1 = IIf(lTemp = 0, LeftMargin, lTemp)
End With
Next ctr
' Loop through all Relationship Table windows to get
' the largest X2 and Y2 coordinates.
' Modify the starting Y1 coordinate for all Table Windows
' to allow for 1 inch Header section.
' Finally convert Window coords to 72 PPI used by the DynaPDF library
'
X2Max = 0
Y2Max = 0
For ctr = 0 To rb.NumWindows - 1
With rl(ctr)
.RelWinX1 = (.RelWinX1 / Xdpi) * 72
.RelWinX2 = ((.RelWinX2 / Xdpi) * 72) ' + 16
.RelWinY1 = ((.RelWinY1 / Ydpi) * 72) '+ 16 ' Space for header
section
.RelWinY2 = ((.RelWinY2 / Ydpi) * 72) '+ 6 ' Space for header
section
End With
X2 = rl(ctr).RelWinX2
Y2 = rl(ctr).RelWinY2
If X2Max < X2 Then X2Max = X2
If Y2Max < Y2 Then Y2Max = Y2
Next ctr
ctr = 0
' 1) We will have to widen each window to accomodate Allen Browne's
' documentation character symbols.
'
' 2) To make it simpler to create the windows in the PDF document
' I want to make each window the same width.
' In the next release I'll add a param to this function to allow
' the user to specify the desired width.
' So I'll need a function or functions in the StrStorage DLL
Dim sFields As String
Dim sPDF As String
sPDF = "C:\sourcecode\ReportToPDF\Relations.pdf"
' Should calc string width of Allen's Documentation Characters
' instead of using the fixed value of 16 Points.
' We also need to allow space for a Header or Footer
lRet = BeginPDF(sPDF, X2Max + 32, Y2Max + 32)
'GoTo HHH
' The first time through we will just gather the necessary info
' to allow us to draw the Relationship Join lines.
' We will need to store
' Table Name(to index into the Relation object)
' Table Ypos
' Field Name(to index into Relation object)
' Field Pos - 1 to num fields
For ctr = 0 To rb.NumWindows - 1
With rl(ctr)
On Error Resume Next
SRelTableName = .WinName
Set tdf = Nothing
' We don't have to remove _1(_x) from end of WinName because the
Relation object
' only stores relations under the original table name - Customers
not Customers_1.
' We know it is a Clone/Copy of the Table when the Table and
ForeightTable props
' are the same. We can then examine the Name prop, specifically the
last char
' to tell what instance of the clone/copy we are working with.
' First instance is Customers_1 then Customers_2 etc. But this logic
does not
' carry over to the Name prop of the Relation object.
' Customers_1 = CustomersCustomers
' Customers_2 = CustomersCustomers_1
'etc
' s = Right$(SRelTableName, 3)
' lRet = InStr(s, "_")
' If lRet = 1 Or lRet = 2 Then SRelTableName = Mid$(SRelTableName, 1,
Len(SRelTableName) - (4 - lRet))
'
Set tdf = db.TableDefs(SRelTableName)
If Not tdf Is Nothing Then
'Get Field Name + Documenting info
'sFields = DescribeFields(tdf)
'lngKt = lngKt + 1& 'Count the tables processed successfully.
' See if there are any matching Relation entries.
' If there are then store the required information
' to allow us to draw the Relationship table/field Lines
For Each rel In db.Relations
If rel.Table = .WinName Then ' Then
' There is a matching relation for this Relationship
Window Table.
' We need to find the rel field for this entry and
' store the absolute position of this field in the
table->fields collection.
' We cannot draw the line now as the matching rel table
may not
' have been drawn yet. Remember, we must draw all of the
Relationship lines
' BEFORE we draw the Table windows as the Rel Lines must
appear
' behind the Table windows.
' We can use the OrdinalPosition property of the field
but it must be in
' the Table object not the Relationship object.
OrdinalPosition is a
' zero based prop.
' We then will use the same logic as above to determine
the absolute
' position of the matching ForeignName Field for the
ForeignTable
' component of this Relationship.
' Do we need to store this information at all? I mean
since the
' OrdinalPosition prop is available for Relationship
fields we do not
' need to store it. Also since the absolute position of
each
' Relationship Table window is known/calculated why
can't I simply
' loop through the Relations collection and render the
Lines when the
' Table prop of the Relation object has a matching entry
in the
' Relationship window BLOB data?
' Draw the Line for this Relationship
' Get the Ordinal Position of the Primary and
ForeignTable fields
Set fld = rel.Fields(0)
ReOPp = tdf.Fields(fld.Name).OrdinalPosition
' Check if ForeignTable prop is a Clone/Copy
lRet = 0
If rel.Table = rel.ForeignTable Then
' Determine which copy(_x) this one is
If Len(rel.Table) * 2 = Len(rel.Name) Then
s = rel.ForeignTable & "_" & 1
lRet = 1
Else
' Grab last character of Name prop. This logic
will
' only support to a max of 9 clones/copies
s = Right$(rel.Name, 1)
s = rel.ForeignTable & "_" & Val(s) + 1
lRet = 1
End If
End If
Set tdfForeign = db.TableDefs(rel.ForeignTable)
ReOPf =
tdfForeign.Fields(fld.ForeignName).OrdinalPosition + 1
' Calc the start and ending X,Y cordinates for the
' Relationship Line we are going to draw.
X1 = .RelWinX1 '(.RelWinX1 / Xdpi) * 72
Y1 = .RelWinY1 '(.RelWinY1 / Ydpi) * 72
' Now we need to add an offset to Y1 to bring us down to
' the row containing the relationship field. Since the
' OrdinalPosition index is zero based we don't have to
add 1
' to cover the fact that we output a row first
containing
' the Table name. 10 pts is the row spacing.
Y1 = Y1 + (IIf(ReOPp = 0, 1, ReOPp) * 10)
' Now we need to find X1 and Y1 for the Foreign Table
' Find it in the Rel BLOB data.
' Need to allow logic to determine on which side(left or
right)
' we want the Relationship Line to start from.
' If the left edge of the Foreign table window is <= to
the
' center of the Primary Table then the Joining line will
originate from
' the left side of the Primary table. Otherwise, it will
originate
' from the right side of the Primary table
If lRet = 0 Then
s = rel.ForeignTable
End If
For i = 0 To rb.NumWindows - 1
If rl(i).WinName = s Then 'rel.ForeignTable Then
'If Trim(rl(i).WinName) = rel.ForeignTable Then
X2 = (rl(i).RelWinX1)
Y2 = (rl(i).RelWinY1)
Y2 = Y2 + (IIf(ReOPf = 0, 1, ReOPf) * 10)
' Which side of Primary table does the Join line
' originate from left/right.
' Handled in StrStorage DLL by DrawLine function
lRet = DrawLine(.RelWinX2 - .RelWinX1,
rl(i).RelWinX2 - rl(i).RelWinX1, _
X1, Y1, X2, Y2, lRet)
End If
Next i
Set fld = Nothing
Set tdfForeign = Nothing
End If
Next
End If
End With
Set tdf = Nothing
Next ctr
HHH:
' Output Header before Table Windows
' Pass 0 in NumFields param to signal this is Header info.
' Pass desired Header info in TableNames param.
' Coordinate params will be used to position Header
' We have modified the starting Y1 coordinate for all Table Windows
' to allow for 1 inch Header section.
'SRelTableName = "RelationShip Report:" & Date & Chr(0) 'vbCrLf
's = CurrentDb().Name & Chr(0)
'lRet = DrawTableWindow(SRelTableName, s, 0, _
' 10, 10, 400, -1)
' Main loop to actually draw each Relationship Table window
' and the Tables component fields.
For ctr = 0 To rb.NumWindows - 1
With rl(ctr)
On Error Resume Next
SRelTableName = .WinName '(.WinName) 'StrConv(.WinName,
vbFromUnicode)
s = Right$(SRelTableName, 3)
lRet = InStr(s, "_")
If lRet = 1 Or lRet = 2 Then SRelTableName = Mid$(SRelTableName, 1,
Len(SRelTableName) - (4 - lRet))
Set tdf = db.TableDefs(SRelTableName)
If Not tdf Is Nothing Then
'Get Field Name + Documenting info
sFields = DescribeFields(tdf)
'lngKt = lngKt + 1& 'Count the tables processed successfully.
End If
' lRet = DrawTableWindow(SRelTableName, sFields, rb.NumWindows, _
' (.RelWinX1 / Xdpi) * 72, (.RelWinY1 / Ydpi) * 72, (((.RelWinX2 -
..RelWinX1) / Xdpi) * 72) + 12, ((.RelWinY2 - .RelWinY1) / Ydpi) * 72)
lRet = DrawTableWindow(.WinName, sFields, rb.NumWindows, _
.RelWinX1, .RelWinY1, (.RelWinX2 - .RelWinX1), (.RelWinY2 -
..RelWinY1))
End With
Set tdf = Nothing
Next ctr
' Do we open new PDF in registered PDF viewer on this system?
'If StartPDFViewer = True Then
ShellExecuteA Application.hWndAccessApp, "open", sPDF, vbNullString,
vbNullString, 1
'End If
On Error GoTo 0
lRet = EndPDF
RelationsToPDF = True
EXIT_RelationsToPDF:
Set db = Nothing
Set tdf = Nothing
Set fld = Nothing
Set rel = Nothing
' If we aready loaded then free the library
If hLibStrStorage <> 0 Then
hLibStrStorage = FreeLibrary(hLibStrStorage)
End If
If hLibDynaPDF <> 0 Then
hLibDynaPDF = FreeLibrary(hLibDynaPDF)
End If
' Cleanup
lRet = apiSelectObject(hDC, oldfont)
' Delete the Font we created
apiDeleteObject (newfont)
' Release the handle to the Screen's DC
lRet = apiReleaseDC(0&, hDC)
Exit Function
ERR_RelationsToPDF:
MsgBox Err.Description, vbOKOnly, Err.Source & ":" & Err.Number
RelationsToPDF = False
Resume EXIT_RelationsToPDF
End Function
