ShrinkText

Shrinks a text into smaller text controlling where is the majority will be displayed and adding ... in between
Two functions, ShrinkText and ShrinkText_Delimiter
1st one to shrink regardless of text, while second one will respect the delimiter character
ShrinkText will do shrinking like
D:\ANmar.Systems\Sites\Tigris.Tech\wwwroot\ANmaRedirect.asp
into
D:\ANm...\wwwroot\ANmaRedirect.asp

ShrinkText_Delimiter will do shrinking as
D:\ANmar.Systems\Sites\Tigris.Tech\wwwroot\ANmaRedirect.asp
into
D:\ANmar.Systems\...\ANmaRedirect.asp


Public

Tested

My Own Work
Function ShrinkText(OriginText, Optional Shrink2Chars = 100, _
Optional ShrinkReplace = "...", Optional Part1W = 0.5)
' Shrink2Chars, max length of desired output text
' Part1W is the weight of text to be used before the ..., as number between 0 and 1
' use 0.5 to devid weight in half between before ... and after it
Rett = OriginText
Part2W = 1 - Part1W
If Len(OriginText) > Shrink2Chars Then
Part1L = Int((Shrink2Chars - Len(ShrinkReplace)) * Part1W)
Part2L = Int((Shrink2Chars - Len(ShrinkReplace)) * Part2W)
Rett = Left(OriginText, Part1L) & ShrinkReplace & Right(OriginText, Part2L)
End If
ShrinkText = Rett
End Function
Function ShrinkText_Delimiter(OriginText, Optional Delimi = "\", _
Optional Shrink2Chars = 100, Optional ShrinkReplace = "...")
' Shrinks a string by removing middle part and replacing it with ...
' it makes sure that Delimi is found at start and end of string
' Like shrinking ...
' D:\ANmar.Systems\Sites\devexceloper.com\wwwroot\ANmaRedirect.asp
' to
' D:\ANmar.Systems\...\ANmaRedirect.asp
'Shrink2Chara = number of characters to shring to
'Delimi = the character to make sure it shows at start or end
'
' Needs MinofArray
Dim ArrMin()
Trr1 = InStr(1, OriginText, Delimi, vbTextCompare)
Trr9 = InStrRev(OriginText, Delimi, , vbTextCompare)
GoodText = OriginText
Attempt = 1
Do
Trr2 = InStr(Trr1 + 1, OriginText, Delimi, vbTextCompare)
Trr8 = InStrRev(OriginText, Delimi, Trr9 - 1, vbTextCompare)
New1Text = Left(OriginText, Trr1) & ShrinkReplace & Mid(OriginText, Trr9)
New2Text = Left(OriginText, Trr2) & ShrinkReplace & Mid(OriginText, Trr9)
New3Text = Left(OriginText, Trr1) & ShrinkReplace & Mid(OriginText, Trr8)
New4Text = Left(OriginText, Trr2) & ShrinkReplace & Mid(OriginText, Trr8)

ReDim ArrMin(3)
ArrMin(0) = Shrink2Chars - Len(New1Text)
ArrMin(1) = Shrink2Chars - Len(New2Text)
ArrMin(2) = Shrink2Chars - Len(New3Text)
ArrMin(3) = Shrink2Chars - Len(New4Text)
ScoMin = MinOfArray(ArrMin, 1)

' for now, do the loop once, to be enhanced in future to loop until the best text found
If ScoMin = 0 Then GoodText = New1Text
If ScoMin = 1 Then GoodText = New2Text
If ScoMin = 2 Then GoodText = New3Text
If ScoMin = 3 Then GoodText = New4Text
Exit Do

Trr1 = InStr(Trr1 + 1, OriginText, Delimi, vbTextCompare)
Trr9 = InStrRev(OriginText, Delimi, Trr9 - 1, vbTextCompare)
Attempt = Attempt + 1
If Attempt > 10 Then Exit Do
Loop
ShrinkText_Delimiter = GoodText
End Function

OriginText, Optional Shrink2Chars = 100, Optional ShrinkReplace = "...", Optional Part1W = 0.5
and
OriginText, Optional Delimi = "\", Optional Shrink2Chars = 100, Optional ShrinkReplace = "..."

Views 295 Downloads 38

VBA Texts + Strings
ANmarAmdeen
655
Attachments
Revisions

v1.0