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 879 Downloads 212

VBA Texts + Strings
ANmarAmdeen
755
Attachments
Revisions

v1.0