GFBlockSmooth/GFBlockSmooth.frm
VERSION 5.00
Begin VB.Form Form1
Caption = "Form1"
ClientHeight = 3195
ClientLeft = 60
ClientTop = 345
ClientWidth = 4695
LinkTopic = "Form1"
ScaleHeight = 3195
ScaleWidth = 4695
StartUpPosition = 3 'Windows‑Standard
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
'(c)2001, 2004 by Louis. Code to move blocks in x direction in 2D space so that they finally require as few space as possible.
'
'Downloaded from www.louis‑coder.com.
'This code sets the x position (starting at 0) of blocks with a special y position,
'width and height so that they'll require as little space space as possible.
'There are several possible usages:
'‑arranging signatures in front of notes
'‑arranging y text blocks (including line breaks) in x (< y) lines, etc.
'
'GFBlockSmooth
Private Type GFBlockSmoothStruct
BlockNumber As Integer
BlockXPosArray() As Long
BlockYPosArray() As Long
BlockWidthArray() As Long
BlockHeightArray() As Long
End Type
Private Sub Form_Load()
'on error resume next
Dim B As GFBlockSmoothStruct
'create squares
Call GFBlockSmoothStructVar_Resize(B, 7)
Call GFBlockSmoothStructVar_AddItem(B, 10, 100, 22, 1)
Call GFBlockSmoothStructVar_AddItem(B, 30, 30, 30, 2)
Call GFBlockSmoothStructVar_AddItem(B, 50, 55, 10, 3)
Call GFBlockSmoothStructVar_AddItem(B, 40, 20, 5, 4)
Call GFBlockSmoothStructVar_AddItem(B, 60, 54, 30, 5)
Call GFBlockSmoothStructVar_AddItem(B, 80, 65, 10, 6)
Call GFBlockSmoothStructVar_AddItem(B, 100, 70, 35, 7)
Call GFBlockSmooth(B)
'draw squares
Form1.ScaleMode = vbPixels
Form1.Show
Dim Temp As Long
For Temp = 1 To B.BlockNumber
Form1.Line (B.BlockXPosArray(Temp), B.BlockYPosArray(Temp))‑(B.BlockXPosArray(Temp) + B.BlockWidthArray(Temp) ‑ 1, B.BlockYPosArray(Temp) + B.BlockHeightArray(Temp) ‑ 1), 0, B
Form1.CurrentX = B.BlockXPosArray(Temp)
Form1.CurrentY = B.BlockYPosArray(Temp)
Form1.Print LTrim$(Str$(Temp))
Next Temp
End Sub
'*************************************GFBLOCKSMOOTH*************************************
'NOTE: use GFBlockSmooth() whenever rectangular areas are to be arranged
'so that they need as little space as possible.
Private Sub GFBlockSmoothStructVar_Resize(ByRef GFBlockSmoothStructVar As GFBlockSmoothStruct, ByVal BlockNumberNew As Integer)
'on error resume next
GFBlockSmoothStructVar.BlockNumber = BlockNumberNew
ReDim Preserve GFBlockSmoothStructVar.BlockXPosArray(1 To BlockNumberNew) As Long
ReDim Preserve GFBlockSmoothStructVar.BlockYPosArray(1 To BlockNumberNew) As Long
ReDim Preserve GFBlockSmoothStructVar.BlockWidthArray(1 To BlockNumberNew) As Long
ReDim Preserve GFBlockSmoothStructVar.BlockHeightArray(1 To BlockNumberNew) As Long
End Sub
Private Sub GFBlockSmoothStructVar_AddItem(ByRef GFBlockSmoothStructVar As GFBlockSmoothStruct, ByVal BlockYPos As Long, ByVal BlockWidth As Long, ByVal BlockHeight As Long, ByVal BlockNumber As Integer)
'on error resume next
If Not ((BlockNumber < 1) Or (BlockNumber > GFBlockSmoothStructVar.BlockNumber)) Then 'verify
GFBlockSmoothStructVar.BlockXPosArray(BlockNumber) = 0 'reset (to be calculated)
GFBlockSmoothStructVar.BlockYPosArray(BlockNumber) = BlockYPos
GFBlockSmoothStructVar.BlockWidthArray(BlockNumber) = BlockWidth
GFBlockSmoothStructVar.BlockHeightArray(BlockNumber) = BlockHeight
Else
MsgBox "internal error in GFBlockSmoothStructVar_AddItem(): passed value invalid !", vbOKOnly + vbExclamation
End If
End Sub
Private Sub GFBlockSmooth(ByRef B As GFBlockSmoothStruct)
'on error resume next 'version 1.0; use B as otherwise code is not readable anymore
Dim CurrentBlockLoop As Long
Dim CompareBlockLoop As Long
'
'NOTE: use this sub to smooth any blocks described by the four values x, y,
'width and height. This could be useful for e.g. arranging annotations that are
'to be displayed in front of an object and would be overlapping when having
'all the same x position. Note that y pos, width and height of the passed blocks
'must be set and this sub will calculate the x pos.
'
For CurrentBlockLoop = 1 To B.BlockNumber
B.BlockXPosArray(CurrentBlockLoop) = 0 'preset
For CompareBlockLoop = 1 To (CurrentBlockLoop ‑ 1) 'blocks 'after' CurrentBlockLoop are still to be moved, final x pos unknown
'check for block overlapping (x direction)
If IsLineOnLine2D(B.BlockXPosArray(CurrentBlockLoop), B.BlockXPosArray(CurrentBlockLoop) + B.BlockWidthArray(CurrentBlockLoop) ‑ 1, _
B.BlockXPosArray(CompareBlockLoop), B.BlockXPosArray(CompareBlockLoop) + B.BlockWidthArray(CompareBlockLoop) ‑ 1) = True Then
'check for block overlapping (y direction)
If IsLineOnLine2D(B.BlockYPosArray(CurrentBlockLoop), B.BlockYPosArray(CurrentBlockLoop) + B.BlockHeightArray(CurrentBlockLoop) ‑ 1, _
B.BlockYPosArray(CompareBlockLoop), B.BlockYPosArray(CompareBlockLoop) + B.BlockHeightArray(CompareBlockLoop) ‑ 1) = True Then
'NOTE: current block overlaps with compare block.
If (B.BlockXPosArray(CompareBlockLoop) + B.BlockWidthArray(CompareBlockLoop) + 1) > B.BlockXPosArray(CurrentBlockLoop) Then
'NOTE: current block can only be moved 'rightwards'.
B.BlockXPosArray(CurrentBlockLoop) = (B.BlockXPosArray(CompareBlockLoop) + B.BlockWidthArray(CompareBlockLoop) ‑ 1) + 1
CompareBlockLoop = 0 'compare current block with all blocks again
End If
End If
End If
Next CompareBlockLoop
Next CurrentBlockLoop
End Sub
Private Function IsLineOnLine2D(ByVal Line1XStartPos As Long, ByVal Line1XEndPos As Long, ByVal Line2XStartPos As Long, ByVal Line2XEndPos As Long) As Boolean 'belongs to GFBlockSmooth()
'on error resume next 'returns True if passed two lines 'touch' each other, False if not
If ((Not (Line1XStartPos < Line2XStartPos)) And (Not (Line1XStartPos > Line2XEndPos))) Or _
((Not (Line1XEndPos < Line2XStartPos)) And (Not (Line1XEndPos > Line2XEndPos))) Then
IsLineOnLine2D = True
Exit Function
End If
If ((Not (Line2XStartPos < Line1XStartPos)) And (Not (Line2XStartPos > Line1XEndPos))) Or _
((Not (Line2XEndPos < Line1XStartPos)) And (Not (Line2XEndPos > Line1XEndPos))) Then
IsLineOnLine2D = True
Exit Function
End If
IsLineOnLine2D = False
Exit Function
End Function
'*********************************END OF GFBLOCKSMOOTH**********************************
[END OF FILE]