Solved

?place longstring from file in listbox

Posted on 2002-04-27
21
174 Views
Last Modified: 2010-05-02
I have a long string sent to me. I need
to put it in a list box but cant see the
chr(13) to seperate the items. I can
pass it to textbox with multiline set to true
but i need it in a list box.

0
Comment
Question by:josmic
  • 11
  • 5
  • 3
  • +2
21 Comments
 
LVL 3

Expert Comment

by:Gunsen
Comment Utility
Dim X()
X = Split("a" & Chr$(13) & "B", Chr$(13))
For i=0 To UBound(X)
  List1.AddItem X(i)
Next i
0
 

Author Comment

by:josmic
Comment Utility
here what i got does not work return  the whole string.
        Dim X() As String
       
        'X = Split("a" & Chr$(13) & "B", Chr$(13))
        X() = Split(sFileContent, Chr$(13), 300, 2)
               
        Dim i As Integer
        For i = 0 To UBound(X)
           frmU.lsIncomingFile.AddItem X(i)
        Next i
             
0
 

Author Comment

by:josmic
Comment Utility
returns
0
 

Author Comment

by:josmic
Comment Utility
returns
0
 
LVL 3

Expert Comment

by:Gunsen
Comment Utility
Why use 300 in parameter ?
0
 
LVL 3

Expert Comment

by:Gunsen
Comment Utility
Use -1
0
 

Author Comment

by:josmic
Comment Utility

Does not work!
X = Split(sFileContent, Chr(13), -1, 2)
X = Split(sFileContent, Chr$(13), -1, 2)
0
 
LVL 3

Expert Comment

by:Gunsen
Comment Utility
Then why use 2 as second parameter when (i guess) its a string
0
 

Author Comment

by:josmic
Comment Utility
its the vbcompare parameter type split( to see it.

0
 

Author Comment

by:josmic
Comment Utility
Somebody help
0
6 Surprising Benefits of Threat Intelligence

All sorts of threat intelligence is available on the web. Intelligence you can learn from, and use to anticipate and prepare for future attacks.

 

Author Comment

by:josmic
Comment Utility
Somebody help
0
 

Author Comment

by:josmic
Comment Utility
Does not work!
X = Split(sFileContent, Chr(13), -1, 1)
X = Split(sFileContent, Chr$(13), -1, 1)
 
1 for text
0
 
LVL 3

Expert Comment

by:Gunsen
Comment Utility
Then  what is the problem??
0
 

Author Comment

by:josmic
Comment Utility
Does not work!
X = Split(sFileContent, Chr(13), -1, 1)
X = Split(sFileContent, Chr$(13), -1, 1)
 
1 for text
0
 

Author Comment

by:josmic
Comment Utility
ive used split 1000 times. I dont know the problem.
must have to do with chr(13). try it .
"a" & Chr$(13) & "B"&"c" & Chr$(13) & "DD"
Once I string it together I cannot seperate it
0
 
LVL 22

Accepted Solution

by:
CJ_S earned 300 total points
Comment Utility
X = split(sFileContent, vbCrLf)
For i=LBound(X) to UBOund(X)
   .. do whatever you want with X(i)
Next
0
 
LVL 75

Expert Comment

by:Anthony Perkins
Comment Utility
josmic

As CJ_S has pointed out, evidently the problem has to do with the fact that you assumed incorrectly that the lines were delimitted by Chr(13) when in fact they are separated by Chr(13) + Chr(10), otherwise the code as posted by Gunsen would "have worked".

Anthony
0
 
LVL 17

Expert Comment

by:inthedark
Comment Utility
As ACPerkins points out chr(13)+chr(10) would solve the problem but there is a shortcut:

redim Lines(0) as String

Lines=Split(YourLongText, vbcrlf)

But this will only do half of the job, because the vbcrlf may only exist at the end of a paragraph some of the text way not be visible, so you need a further function to see how big each word is.

0
 
LVL 17

Expert Comment

by:inthedark
Comment Utility
Here is some code which shows how to find our hown many words fit in a window:

Th example loads and displays a large file 5800% faster than MS Word.

It loads a file of 1MB in just 0.060 seconds. But screen resize needs a little more thought.

Create a text file, paste the following into the file, then rename the file as "frmTextLoad.Frm", now just double click on the new file. In the next post I will show what needs changing.


VERSION 5.00
Begin VB.Form frmWP2
  AutoRedraw      =   -1  'True
  Caption         =   "Form1"
  ClientHeight    =   7545
  ClientLeft      =   60
  ClientTop       =   345
  ClientWidth     =   9660
  LinkTopic       =   "Form1"
  ScaleHeight     =   503
  ScaleMode       =   3  'Pixel
  ScaleWidth      =   644
  StartUpPosition =   3  'Windows Default
  Begin VB.Timer Timer1
     Left            =   7740
     Top             =   30
  End
  Begin VB.CommandButton Command1
     Caption         =   "Command1"
     Height          =   465
     Left            =   360
     TabIndex        =   2
     Top             =   0
     Width           =   1455
  End
  Begin VB.VScrollBar VScroll1
     Height          =   5025
     Left            =   7440
     TabIndex        =   1
     Top             =   480
     Width           =   345
  End
  Begin VB.PictureBox Picture1
     AutoRedraw      =   -1  'True
     Height          =   5025
     Left            =   360
     ScaleHeight     =   4965
     ScaleWidth      =   7005
     TabIndex        =   0
     Top             =   480
     Width           =   7065
  End
  Begin VB.Label Label1
     AutoSize        =   -1  'True
     Caption         =   "Label1"
     Height          =   195
     Left            =   4890
     TabIndex        =   4
     Top             =   60
     Width           =   480
  End
  Begin VB.Label lblTLOS
     AutoSize        =   -1  'True
     Caption         =   "lblTLOS"
     Height          =   195
     Left            =   2160
     TabIndex        =   3
     Top             =   90
     Width           =   570
  End
End
Attribute VB_Name = "frmWP2"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Dim GF As New zGF

Dim Loaded As Boolean
Private Type LineDef
   startword As Long
   lastword As Long
End Type
Private Type Pointerdef
   Para As Long    ' Pointer to Para
   LIP As Long     ' Line in Para
End Type

Private Type FontDef
   Font As Font
   SpaceWidth As Long
   LineHeight As Long
End Type

Dim MyFonts() As FontDef

Private Type ParaDef
 RepaginateRequired As Boolean
 Text As String
 WordCount As Long
 Words() As String
 Fonts() As Long
 PosX() As Long
 WLen() As Long     ' Length of each word
 Lines() As LineDef ' words in each line
 PointerToALP As Long
 Loaded As Boolean
End Type

Private Type DocDef
   Name As String
   Paras() As ParaDef
   ALP() As Pointerdef      ' Absolute line pointer to para ans line within para
   ALPCount As Long
   LastParaLoaded As Long         ' -1 = none loaded
   Loaded As Boolean
End Type


Dim PB As PictureBox ' or picturebox

Dim Doc As DocDef

Dim CP As Long ' Current Para
Dim CW As Long ' Current Word
Dim CC As Long ' Current Character In Word
Dim TLOS As Long ' topline on screen
Dim SpaceWidth As Long

Dim ML As Long
Dim MR As Long
Dim MT As Long
Dim MB As Long
Dim w As Long
Dim h As Long

Dim LineHeight

Sub DisplayData()

' Get Size of window
w = PB.ScaleWidth - ML - MR
h = PB.ScaleHeight - MT - MB

Dim PosX As Long
Dim posY As Long
Dim lc As Long
Dim abslc As Long ' absolute linecount

PB.Cls ' clear window

Dim wc As Long ' word count


lc = 0
Dim startword As Long
Dim lastword As Long
Dim MaxHeight As Long
Dim cf As Long      ' current font
Dim lf As Long      ' last font
Dim P As Long

posY = MT

'Dim st As Single
'st = Timer
lblTLOS.Caption = "Top Line: " + CStr(TLOS)
Do
   
   PosX = ML
   PB.CurrentY = posY ' if using multi fonts needs to be set for each word
       
   abslc = TLOS + lc
   Do
       If abslc > Doc.ALPCount - 1 Then
       
           If Doc.Loaded Then Exit Do
           LoadNextPara
           
           If Doc.LastParaLoaded < UBound(Doc.Paras) Then
               
               Doc.LastParaLoaded = Doc.LastParaLoaded + 1
               LoadPara Doc.LastParaLoaded
           Else
               Doc.Loaded = True
               VScroll1.Max = Doc.ALPCount - 1
               
               Exit Do
           End If
       
       End If
       If abslc <= Doc.ALPCount - 1 Then Exit Do
   Loop
   
   If abslc > Doc.ALPCount - 1 Then Exit Do
   
   P = Doc.ALP(abslc).Para ' para for this line
   
   MaxHeight = 0
   
   startword = Doc.Paras(P).Lines(Doc.ALP(abslc).LIP).startword
   lastword = Doc.Paras(P).Lines(Doc.ALP(abslc).LIP).lastword
   If startword >= 0 Then
   
       For wc = startword To lastword
           cf = Doc.Paras(P).Fonts(wc)
           If cf <> lf Then
              ' set new font here
              'set pb.font = myfonts.font
              lf = cf
           End If
           
           PB.CurrentX = Doc.Paras(P).PosX(wc)
           PB.Print Doc.Paras(P).Words(wc);
           If MyFonts(cf).LineHeight > MaxHeight Then
               MaxHeight = MyFonts(cf).LineHeight
           End If
           
       Next wc
   Else
       MaxHeight = MyFonts(0).LineHeight
   End If
   
   lc = lc + 1
   
   posY = posY + MaxHeight
   
   If posY + MyFonts(cf).LineHeight > h Then Exit Do
   
Loop

'MsgBox Format(Timer - st, "0.000") + " seconds to display page"
End Sub



Sub LoadNextPara()
If Doc.LastParaLoaded < UBound(Doc.Paras) Then
   Doc.LastParaLoaded = Doc.LastParaLoaded + 1
   LoadPara Doc.LastParaLoaded
Else
   Doc.Loaded = True
   VScroll1.Max = Doc.ALPCount - 1
End If
End Sub

Sub LoadPara(pc As Long)

Dim lc As Long      ' lines in the para
Dim xpos As Long
Dim wc As Long
Dim cf As Long
Dim tlc As Long
Dim pos As Long
lc = 0
pos = 0
Dim startword As Long
Dim lastword As Long


Doc.Paras(pc).WordCount = 0
Doc.Paras(pc).PointerToALP = Doc.ALPCount

If Len(Doc.Paras(pc).Text) > 0 Then
   
   If Not Doc.Paras(pc).Loaded Then
   
       Doc.Paras(pc).Words = Split(Doc.Paras(pc).Text, Space$(1))
       wc = UBound(Doc.Paras(pc).Words)
       Doc.Paras(pc).WordCount = wc + 1
       ReDim Doc.Paras(pc).WLen(wc)
       ReDim Doc.Paras(pc).PosX(wc)
       ReDim Doc.Paras(pc).Fonts(wc)
   End If
   
   ReDim Doc.Paras(pc).Lines(10)
   
   'Doc.Paras(lc)
   ' How big is each word?
   startword = 0
   pos = 0
   For wc = 0 To Doc.Paras(pc).WordCount - 1
       cf = 0
       Doc.Paras(pc).Fonts(wc) = cf
       If Not Doc.Paras(pc).Loaded Then
           Doc.Paras(pc).WLen(wc) = PB.TextWidth(Doc.Paras(pc).Words(wc))
       End If
       If pos + Doc.Paras(pc).WLen(wc) + MyFonts(cf).SpaceWidth > w Then
           pos = 0
           Doc.Paras(pc).PosX(wc) = pos
           GoSub CreateNewLine
           startword = wc
           lc = lc + 1     ' and line within para count
           If lc > UBound(Doc.Paras(pc).Lines) Then
               ReDim Preserve Doc.Paras(pc).Lines(lc + 10)
           End If
       Else
           Doc.Paras(pc).PosX(wc) = pos
       End If
       pos = pos + Doc.Paras(pc).WLen(wc) + MyFonts(cf).SpaceWidth
   
   Next wc
   
   ReDim Preserve Doc.Paras(pc).Lines(lc)
   wc = Doc.Paras(pc).WordCount
   GoSub CreateNewLine
Else
   ' blank para just drop one line
   ReDim Doc.Paras(pc).Lines(0)
   GoSub CreateNewLine
   Doc.Paras(pc).Lines(0).startword = -1
   Doc.Paras(pc).Lines(0).lastword = 0
End If

Doc.Paras(pc).Loaded = True
If Not Doc.Loaded Then
   If Doc.ALPCount - 1 > VScroll1.Max Then
       VScroll1.Max = Doc.ALPCount + 100
   End If
End If
GoTo Exiter:

CreateNewLine:

   Doc.Paras(pc).Lines(lc).startword = startword
   Doc.Paras(pc).Lines(lc).lastword = wc - 1
   
   Doc.ALPCount = Doc.ALPCount + 1
   tlc = Doc.ALPCount - 1
   
   If tlc > UBound(Doc.ALP) Then
       ReDim Preserve Doc.ALP(tlc + tlc * 0.25 + 100)
   End If
   Doc.ALP(tlc).LIP = lc
   Doc.ALP(tlc).Para = pc
Return

Exiter:

End Sub

Sub RepaginatePara(CP As Long)

Dim pc As Long
Dim wc As Long
Dim lc As Long
Dim pos As Long
Dim tlc As Long     ' total line count
Dim startword As Long
Dim lastword As Long
Dim cf As Long
Dim vs

tlc = 0

For pc = 0 To UBound(Doc.Paras)
   lc = 0
   pos = 0
   
   startword = 0
   pos = 0
   For wc = 0 To Doc.Paras(pc).WordCount - 1
       cf = Doc.Paras(pc).Fonts(wc)
       If pos + Doc.Paras(pc).WLen(wc) + MyFonts(cf).SpaceWidth > w Then
           pos = 0
           Doc.Paras(pc).PosX(wc) = pos

           Doc.Paras(pc).Lines(lc).startword = startword
           Doc.Paras(pc).Lines(lc).lastword = wc - 1
           startword = wc
           If tlc > UBound(Doc.ALP) Then
               ReDim Preserve Doc.ALP(tlc)
           End If
           Doc.ALP(tlc).LIP = lc
           Doc.ALP(tlc).Para = pc
           tlc = tlc + 1   ' increase the absolute line count

           lc = lc + 1     ' and line within para count
           If lc > UBound(Doc.Paras(pc).Lines) Then
               ReDim Preserve Doc.Paras(pc).Lines(lc + 10)
           End If
       Else
           Doc.Paras(pc).PosX(wc) = pos
       End If
       pos = pos + Doc.Paras(pc).WLen(wc) + MyFonts(cf).SpaceWidth
   Next wc
   ReDim Preserve Doc.Paras(pc).Lines(lc)
   If tlc > UBound(Doc.ALP) Then
       ReDim Preserve Doc.ALP(tlc + 100 + tlc * 0.25)
   End If
   Doc.ALP(tlc).LIP = lc
   Doc.ALP(tlc).Para = pc
   tlc = tlc + 1   ' increase the absolute line count
   
   Doc.Paras(pc).Lines(lc).startword = startword
   Doc.Paras(pc).Lines(lc).lastword = Doc.Paras(pc).WordCount - 1

Next pc
End Sub

Private Sub Command1_Click()

Dim YourText As String
ReDim Lines(0) As String
ReDim Doc.Paras(UBound(Lines))
Dim pc As Long
Dim wc As Long
Dim cf As Long
ReDim MyFonts(0)
Dim ddone As Boolean
Dim estlos As Long
Dim vs As VB.VScrollBar



' Create some test data
Dim ok
Dim k As Long


For wc = 1 To 4
   YourText = YourText + "Here is an example of some test data. "
Next wc

k = Val(InputBox("How many KB in your test data"))
If k < 1 Then
   k = 1
End If
k = k * 1024


YourText = Trim(YourText) + vbCrLf
Do
   YourText = YourText + YourText
   If Len(YourText) > k Then Exit Do
Loop
YourText = Left(YourText, k)


'YourText = GF.ReadFile("d:\tmp.txt")

' Start the data loading

' set margins
ML = 10 ' left
MR = 10 ' right
MT = 10 ' top
MB = 10 ' bottom



Set PB = Picture1 ' pb can be a form or a picture box
PB.Font.Name = "Arial"

' Get Size of window
w = PB.ScaleWidth - ML - MR
h = PB.ScaleHeight - MT - MB
   
Set MyFonts(0).Font = PB.Font
MyFonts(0).SpaceWidth = PB.TextWidth(Space$(1))
MyFonts(0).LineHeight = PB.TextHeight("Z") + 1 ' 1 pixel gap between lines
estlos = h / MyFonts(0).LineHeight

'First get paragraphs:

Lines = Split(YourText, vbCrLf)
YourText = ""

ReDim Doc.Paras(UBound(Lines))

ReDim Doc.ALP(100)

Dim lc As Long ' current line

Dim pos As Long
Dim startword As Long
Dim tlc As Long ' total line count

Dim st As Single
st = Timer

Doc.LastParaLoaded = -1
Doc.Loaded = False
Doc.ALPCount = 0

For pc = 0 To UBound(Lines)
   lc = 0
   pos = 0
   Doc.Paras(pc).Text = Lines(pc)
   Doc.Paras(pc).Loaded = False
   Doc.Paras(pc).PointerToALP = -1
   Lines(pc) = ""
Next pc


Erase Lines

CP = 0 ' Current Para
CW = 0 ' Currnt Word
CC = 0 ' Currnt Character In Word

VScroll1.Max = UBound(Doc.Paras) * 4 ' guess at size of file
DisplayData
VScroll1.LargeChange = h / MyFonts(0).LineHeight
MsgBox "Data loaded in: " + Format(Timer - st, "0.000") + "seconds total bytes=" + CStr(k)

Loaded = True

Timer1.Interval = 1


End Sub

Private Sub Form_Load()

Command1.Caption = "Load Data"
Set PB = Picture1

End Sub

Private Sub Form_Resize()
Command1.Move 0, 0
Picture1.Move 0, Command1.Height, Me.ScaleWidth - VScroll1.Width, _
   Me.ScaleHeight - Command1.Height
VScroll1.Top = Picture1.Top
VScroll1.Height = Picture1.Height
VScroll1.Left = Picture1.Width


If Loaded Then
   w = PB.ScaleWidth - ML - MR
   h = PB.ScaleHeight - MT - MB
   
 '  RepaginateDocument Doc, w, h
   DisplayData
   VScroll1.LargeChange = h / MyFonts(0).LineHeight
End If

End Sub

Private Sub Timer1_Timer()
Static Done As Boolean
Dim pc As Long

Dim st As Single
If Doc.Loaded Then
   Timer1.Interval = 0
   Label1.Caption = "Backgroud calcs: 100%"
Else
   If Done Then
       
       Do While Not Doc.Loaded
           LoadNextPara
           pc = pc + 1
           If pc > 100 Then Exit Do
       Loop
       Label1.Caption = "Backgroud calcs: " + CStr(Int(100 * Doc.LastParaLoaded / UBound(Doc.Paras())))
+ "%"
   Else
   
       st = Timer
       Do While Not Doc.Loaded
           LoadNextPara
           pc = pc + 1
           If pc > 100 Then Exit Do
       Loop
       Label1.Caption = "Backgroud calcs: " + CStr(Int(100 * Doc.LastParaLoaded / UBound(Doc.Paras())))
+ "%"
       st = Int((Timer - st) * 2000)
       If st < 2 Then st = 2
       Timer1.Interval = st
       Done = True
   End If
   
End If
End Sub

Private Sub VScroll1_Change()

VScroll1_Scroll
End Sub


Private Sub VScroll1_Scroll()
TLOS = VScroll1.Value
If Not Doc.Loaded Then
   If TLOS > Doc.ALPCount + 400 Then
       TLOS = Doc.ALPCount + 400
       VScroll1.Value = TLOS
   End If
End If
DisplayData

End Sub

Private Sub RepaginateDoc(ByRef Doc As DocDef, w As Long, h As Long)

Dim pc As Long

Dim wc As Long
Dim lc As Long
Dim pos As Long
Dim tlc As Long     ' total line count
Dim startword As Long
Dim lastword As Long
Dim cf As Long
Dim vs

tlc = 0

For pc = 0 To UBound(Doc.Paras)
   lc = 0
   pos = 0
   
   startword = 0
   pos = 0
   For wc = 0 To Doc.Paras(pc).WordCount - 1
       cf = Doc.Paras(pc).Fonts(wc)
       If pos + Doc.Paras(pc).WLen(wc) + MyFonts(cf).SpaceWidth > w Then
           pos = 0
           Doc.Paras(pc).PosX(wc) = pos

           Doc.Paras(pc).Lines(lc).startword = startword
           Doc.Paras(pc).Lines(lc).lastword = wc - 1
           startword = wc
           If tlc > UBound(Doc.ALP) Then
               ReDim Preserve Doc.ALP(tlc)
           End If
           Doc.ALP(tlc).LIP = lc
           Doc.ALP(tlc).Para = pc
           tlc = tlc + 1   ' increase the absolute line count

           lc = lc + 1     ' and line within para count
           If lc > UBound(Doc.Paras(pc).Lines) Then
               ReDim Preserve Doc.Paras(pc).Lines(lc + 10)
           End If
       Else
           Doc.Paras(pc).PosX(wc) = pos
       End If
       pos = pos + Doc.Paras(pc).WLen(wc) + MyFonts(cf).SpaceWidth
   Next wc
   ReDim Preserve Doc.Paras(pc).Lines(lc)
   If tlc > UBound(Doc.ALP) Then
       ReDim Preserve Doc.ALP(tlc + 100 + tlc * 0.25)
   End If
   Doc.ALP(tlc).LIP = lc
   Doc.ALP(tlc).Para = pc
   tlc = tlc + 1   ' increase the absolute line count
   
   Doc.Paras(pc).Lines(lc).startword = startword
   Doc.Paras(pc).Lines(lc).lastword = Doc.Paras(pc).WordCount - 1

Next pc

Set vs = VScroll1

vs.Value = 0
vs.Max = tlc

ReDim Preserve Doc.ALP(tlc - 1)

End Sub


0
 
LVL 17

Expert Comment

by:inthedark
Comment Utility
I had a better routine which was written way back in 95, althou not coded so well.

Paste the following code into a form declaration.  Add list1 onto the form.


Option Explicit


Private Sub Form_Load()

'make a long string for testing
' Create some test data

Dim ok
Dim k As Long
Dim YourText As String
Dim pc As Long
Dim wc As Long
For pc = 0 To 4
    For wc = 1 To 4
       YourText = YourText + "Here is an example of some test data. "
    Next wc
    YourText = YourText + vbCrLf
Next pc


k = Val(InputBox("How many KB in your test data"))
If k < 1 Then
   k = 1
End If
k = k * 1024


YourText = Trim(YourText) + vbCrLf
Do
   YourText = YourText + YourText
   If Len(YourText) > k Then Exit Do
Loop
YourText = "First Line" + vbCrLf + Left(YourText, k) + vbCrLf + "Last Line" + vbCrLf



' now split the text into lines that can be seen
ReDim lines(0) As String
Dim lc As Integer ' line count
Dim Lcc As Long

Set Me.Font = List1.Font

' make sure each line will fit in a window
pr_MakeLines Me, YourText, List1.Width - 255, lines(), lc

For Lcc = 1 To lc
    List1.AddItem lines(Lcc)
Next Lcc

MsgBox "Job Done"

End Sub


Sub pr_MakeLines(DisplayObject As Object, dtr As Variant, pprw As Single, stk$(), lc As Integer, Optional FirstLineWidth As Single = -1)

' redim stk$(5),stkc as integer
' DisplayObject is a form/printer with the same font as required
' dtr =source string
' prw =width  (but set prwidthscale to 1 if text width is being used)
' stk$() = the return string
' stkc = the line count returned stk$(1),stk$(2) etc. stk$(0) is unused
' NOTE: PRWIDTHSCALE MUST BE TRUE IF IN TEXT MODE
'Call pr_makelines(dtr, prw, stk$(), stkc)

Dim prw As Single
prw = FirstLineWidth
If prw < 0 Then
    prw = pprw
End If

If prw < 0 Then MsgBox "Programming Error no width has been specified"

Dim last_ok_spaced_length As Integer    ' last space chart ok length
Dim last_ok_nonspaced_length As Integer ' last ok length
Dim last_ok_punc_length As Integer
Dim c As Integer            ' work int
Dim current_block$          ' data to be stored
Dim l$                      ' current line
Dim current_char As Integer ' Current working charaters
Dim w$                  ' work area
ReDim datain(0) As String        ' Data lines
ReDim stk$(20)
Dim datainc As Integer  ' Number of lines to be formatted
Dim maxwidth As Single
Dim cline As Integer
Dim skipout As Integer
maxwidth = prw ' twips if not in text mode or charatcers in textmode
lc = 0

'usage:
' dim l$
' redim seps$(10)
' dim sepc as integer
' l$="Fred;jim;bert"
l$ = dtr
datain = Split(dtr, vbCrLf)
datainc = UBound(datain)


cline = -1

Do
    cline = cline + 1
    If cline > datainc Then Exit Do
   
    l$ = datain$(cline)
    If DisplayObject.TextWidth(l$) <= maxwidth Then
        current_block$ = l$: GoSub storeit
    Else
        GoSub checkwidth
    End If
Loop

ReDim Preserve stk$(lc)

Exit Sub

storeit:
    lc = lc + 1
    If lc > UBound(stk$) Then
        ReDim Preserve stk$(lc + 20)
    End If
    stk$(lc) = current_block$
    maxwidth = pprw
Return

checkwidth:

current_char = 0
last_ok_spaced_length = 0
last_ok_punc_length = 0
Do
    current_char = current_char + 1
 
    If current_char > Len(l$) Then
        GoSub processlastchunk
        If skipout Then Return
    End If
   
    If DisplayObject.TextWidth(Left$(l$, current_char)) > maxwidth Then
        GoSub processlastchunk
        If skipout Then Return
    End If
   
    If current_char > 1 Then
        last_ok_nonspaced_length = current_char - 1
   
        w$ = Mid$(l$, current_char, 1)
        If w$ = " " Then
            last_ok_spaced_length = current_char - 1
        Else
            If InStr("/~-=,.?)>]}", w$) Then
                last_ok_punc_length = current_char
            End If
        End If
    End If
       
Loop

Return


processlastchunk:

skipout = False
       
       
If last_ok_spaced_length = 0 Then
    If last_ok_punc_length > 0 Then
        last_ok_spaced_length = last_ok_punc_length
    Else
        last_ok_spaced_length = last_ok_nonspaced_length
    End If
End If

current_block$ = RTrim$(Left$(l$, last_ok_spaced_length))

GoSub storeit

Do
    If Len(l$) < last_ok_spaced_length + 1 Then
        skipout = True
        Return
    End If

    c = Asc(Mid$(l$, last_ok_spaced_length + 1, 1))
    If c = 32 Then
        last_ok_spaced_length = last_ok_spaced_length + 1
    Else
        l$ = Trim$(Mid$(l$, last_ok_spaced_length + 1))
        Exit Do
    End If

Loop

last_ok_spaced_length = 0
last_ok_nonspaced_length = 0
last_ok_punc_length = 0
current_char = 1
 
If DisplayObject.TextWidth(l$) <= maxwidth Then
    current_block$ = l$
    GoSub storeit
    skipout = True
    Return
End If

Return

End Sub

0
 

Author Comment

by:josmic
Comment Utility
cj s was first to solve my proble
thanks to all
0

Featured Post

Highfive + Dolby Voice = No More Audio Complaints!

Poor audio quality is one of the top reasons people don’t use video conferencing. Get the crispest, clearest audio powered by Dolby Voice in every meeting. Highfive and Dolby Voice deliver the best video conferencing and audio experience for every meeting and every room.

Join & Write a Comment

Introduction In a recent article (http://www.experts-exchange.com/A_7811-A-Better-Concatenate-Function.html) for the Excel community, I showed an improved version of the Excel Concatenate() function.  While writing that article I realized that no o…
This article describes some techniques which will make your VBA or Visual Basic Classic code easier to understand and maintain, whether by you, your replacement, or another Experts-Exchange expert.
Get people started with the utilization of class modules. Class modules can be a powerful tool in Microsoft Access. They allow you to create self-contained objects that encapsulate functionality. They can easily hide the complexity of a process from…
This lesson covers basic error handling code in Microsoft Excel using VBA. This is the first lesson in a 3-part series that uses code to loop through an Excel spreadsheet in VBA and then fix errors, taking advantage of error handling code. This l…

744 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question

Need Help in Real-Time?

Connect with top rated Experts

15 Experts available now in Live!

Get 1:1 Help Now