Move down row od text (1 Viewer)

pekajo

Registered User.
Local time
Today, 14:25
Joined
Jul 25, 2011
Messages
72
Hi,
How do you move down a text box on a form that looks like.
ASCjkhjkhc
ghgshjg
hjjkhkjkjkhh
jhhjhjhjkhkhj
ghghgkjhjk

and I need to move down each row and extract data.
Also how do you find the end of the row so I can use the mid() function.
Thanks
Peter
 
Last edited:

Ranman256

Registered User.
Local time
Yesterday, 22:25
Joined
Apr 9, 2015
Messages
3,644
you dont extract data by cycling thru form rows,
extract it in bulk, (to excel) via Transferspreadsheet....
(you didnt say how to extract it, and what to: excel, text...)

but, you can take if from the text box: msgbox txtBox
 

pekajo

Registered User.
Local time
Today, 14:25
Joined
Jul 25, 2011
Messages
72
Hi,
My issue is this. I get a long email from IT saying they have setup a new email user in the format:

Name: Peter Jones
UserName: pJones
Password: ytrrunnsdge
Emailaddress: Peter@jhsdfjkjkf.com.au

I need to exctract as variables"
Row 1 "Peter"
Row 2 "pJones"
Row 3 "ytrrunnsdge"
Row 4 "Peter@jhsdfjkjkf.com.au"

On each row I can find the ":" and use Mid() to extract the data I want.


Peter
 

Isaac

Lifelong Learner
Local time
Yesterday, 19:25
Joined
Mar 14, 2017
Messages
2,817
Forget about text boxes and forms. Research how to automate Outlook and read an email. You can save the email as text and then open the text file as a scripting file system object text stream.
 

arnelgp

error reading drive A:
Local time
Today, 11:25
Joined
May 7, 2009
Messages
10,871
sometime last 2015, i helped an OP who has similar problem.
don't recall if in UA or here.
i search on this forum and it was here:
only his e-mail has many field to extract:
Code:
Dim rs As DAO.recordSet

'----------------------------------------------------------------
' arnel g. puzon
' 18-Aug-2015
'
' in response to Mr. JohnLee's
'
' I Hoping someone can help me as I’m having problems understanding
' how to write VBA to extract data from ".msg" files and import that data into a table in my database.
' I have over 5000 .msg files of which I need to extract the following information:
'----------------------------------------------------------------
Public Sub UpdateTableFromMsgFiles()
'
'-----------------------------------------------------------------
' table structure to update from .msg (outlook)
'
' strFirstName
' strSurname
' strStreetNr
' strCity
' strPostcode
' strTel
' strMobile
' strEmail
' strVoucherCode
' strAddif
' strModel
' strSerialNo
' strName
' strStreet
' strNr
' strPostcode2
' strGasSafe
' strIsadv
' strTC
' strInstallationDate
'
'---------------------------------------------------------------
'
' location of .msg
' G:\Scan - Verify\eFlow\Dynamics\Vaillant\Old No DPA Printed
'
'----------------------------------------------------------------
' format of .msg
'
' First Name: Tim
' Surname: O 'Rourke
' Street & Nr: 399 Upper Eastern Green Lane
' City: Coventry
' Postcode: CV5 7DJ
' Tel: 02476 421140
' Mobile: 07854420697
' Email: timorourke@ fsmail.net
' Do you have a voucher code?:
' adddif:
' Select a model: ecoTEC plus 831
' serial numer (28 didgets): 21145000100116861300375260N1 DD-MM-YYYY Installation Date: 2015-03-27
' Name: Barry Allard,Premium Heating and Plumbing
' Street: Broad Lane
' Nr.: Coventry
' Postcode: CV5 7DJ
' Gas Safe Number (5/6 digits): 518169
' isadv:
' tc: 1
' DD-MM-YYYY Installation Date:
'
'----------------------------------------------------------------
' Make reference to the ff:
'
' Microsoft Outlook XX.X Object Library
' Microsoft Scripting Runtime
'
'----------------------------------------------------------------
  
    ' your table name here
    Const strTableName As String = "tblWebReg"
  
    Dim db As DAO.Database
  
    Dim fso As Scripting.FileSystemObject
  
    Dim strPath As String
    Dim strSaveTo As String
    Dim lngCounter As Long
  
  
    Dim ol As Outlook.Application
    Dim Msg As Outlook.MailItem
    Dim f As Scripting.File
  
    '*!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    '*!
    '*!
    '*! CHANGE THE PATH BELOW TO THE CORRECT LOCATION OF YOUR .msg FILES
    '*!
    '*!
    '*! strPath = "Z:\TEST"
    strPath = "G:\Scan - Verify\eFlow\Dynamics\Vaillant\Old No DPA Printed"
    '*!
    '*!
    '*! NOTE:
    '*!      it will create a temporary folder "Text" to your source
    '*!      folder.
    '*!
    '*!
    '*!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  
    strSaveTo = strPath & "\Text"
    Set fso = New Scripting.FileSystemObject
  
    If fso.FolderExists(strSaveTo) Then
        ' delete folder if already exists
        fso.DeleteFolder strSaveTo, True
    End If
    ' create new temporary foldr
    fso.CreateFolder strSaveTo
  
    SysCmd acSysCmdInitMeter, "Preparing", 3
    Set db = CurrentDb
    ' open our table
    Set rs = db.OpenRecordset(strTableName, dbOpenDynaset)
    SysCmd acSysCmdUpdateMeter, 1
  
    ' create outlook instance
    Set ol = CreateObject("Outlook.Application")
    SysCmd acSysCmdUpdateMeter, 2
    ' create scripting instance
    Set fso = CreateObject("Scripting.FileSystemObject")
    SysCmd acSysCmdUpdateMeter, 3
  
  
    SysCmd acSysCmdInitMeter, "Determining no of files to process", 3
    ' just how many .msg files do we need to process
    For Each f In fso.GetFolder(strPath).Files
        If LCase(fso.GetExtensionName(f)) = "msg" Then
            lngCounter = lngCounter + 1
            If lngCounter Mod 4 <> 0 Then
                SysCmd acSysCmdUpdateMeter, (lngCounter Mod 4)
            End If
        End If
    Next f
  
    ' recurse folder for .msg files
    SysCmd acSysCmdInitMeter, "Saving .msg file as text file", lngCounter
    lngCounter = 0
    For Each f In fso.GetFolder(strPath).Files
        If LCase(fso.GetExtensionName(f)) = "msg" Then
            Set Msg = ol.CreateItemFromTemplate(f.path)
            ' save .msg as text file, so we can read later
            lngCounter = lngCounter + 1
            SysCmd acSysCmdUpdateMeter, lngCounter
            Msg.SaveAs strSaveTo & "\" & left(f.NAME, Len(f.NAME) - 3) & "txt", olTXT 'olDoc
        End If
    Next
  
    If Not (ol Is Nothing) Then ol.Quit: Set ol = Nothing
  
    'process our text files
    SysCmd acSysCmdInitMeter, "extracting text and saving to table", lngCounter
    lngCounter = 0
    For Each f In fso.GetFolder(strSaveTo).Files
        If LCase(fso.GetExtensionName(f)) = "txt" Then
            lngCounter = lngCounter + 1
            SysCmd acSysCmdUpdateMeter, lngCounter
            Call addToTable(f)
        End If
    Next
  
    If Not (fso Is Nothing) Then Set fso = Nothing
    If Not (rs Is Nothing) Then rs.Close: Set rs = Nothing
    If Not (db Is Nothing) Then db.Close: Set db = Nothing
  
    SysCmd acSysCmdRemoveMeter
End Sub

Private Sub addToTable(ByVal strFilename As String)
  
    ' array to hold search strings
    Dim s(0 To 19) As String
    ' array to hold table field names
    Dim f(0 To 19) As String
  
    Dim bolAdd As Boolean
    Dim i As Long
    Dim lngPos As Long
    Dim bolPostalOneFinished As Boolean
  
    Dim strTextLine As String
    Dim iFile As Integer
  
    ' text to search in the text file
    s(0) = "First Name:"
    s(1) = "Surname:"
    s(2) = "Street & Nr:"
    s(3) = "City:"
    s(4) = "Postcode:"
    s(5) = "Tel:"
    s(6) = "Mobile:"
    s(7) = "Email:"
    s(8) = "Do you have a voucher code?:"
    s(9) = "adddif:"
    s(10) = "Select a model:"
    s(11) = "serial numer (28 didgets):"
    s(12) = "Name:"
    s(13) = "Street:"
    s(14) = "Nr.:"
    s(15) = "Postcode:"
    s(16) = "Gas Safe Number (5/6 digits):"
    s(17) = "isadv:"
    s(18) = "tc:"
    s(19) = "DD-MM-YYYY Installation Date:"
  
    'field name to update from our table
    f(0) = "strFirstName"
    f(1) = "strSurname"
    f(2) = "strStreetNr"
    f(3) = "strCity"
    f(4) = "strPostcode"
    f(5) = "strTel"
    f(6) = "strMobile"
    f(7) = "strEmail"
    f(8) = "strVoucherCode"
    f(9) = "strAddif"
    f(10) = "strModel"
    f(11) = "strSerialNo"
    f(12) = "strName"
    f(13) = "strStreet"
    f(14) = "strNr"
    f(15) = "strPostcode2"
    f(16) = "strGasSafe"
    f(17) = "strIsadv"
    f(18) = "strTC"
    f(19) = "strInstallationDate"
  
    iFile = FreeFile
    Open strFilename For Input As #iFile
  
    Line Input #iFile, strTextLine
  
    While Not EOF(iFile)
      
        'check for blank line and skip if blank
        If Not (Trim(strTextLine) = "") Then
            For i = LBound(s) To UBound(s)
              
                DoEvents
              
                lngPos = InStr(strTextLine, s(i))
                ' test if search string in our text variable
                If lngPos <> 0 Then
                    ' found, then create new recod to our table
                    If Not bolAdd Then
                        bolAdd = True
                        rs.AddNew
                    End If
                    ' check if postal code is being processed
                    If (i = 4) Then
                        ' did we already update first postal
                        If bolPostalOneFinished Then
                            ' update second postal field
                            Call rsUpdate(f(15), strTextLine, s(15))
                        Else
                            ' update first postal field
                            Call rsUpdate(f(i), strTextLine, s(i))
                            bolPostalOneFinished = True
                        End If
                    Else
                        If (i = 11) Then
                            'remove the DD-MM-YYYY
                            lngPos = InStr(strTextLine, "DD-MM-YYYY")
                            If lngPos > 0 Then strTextLine = left(strTextLine, lngPos - 1)  ' remove DD-MM-YYYY from our text line
                        End If
                        ' update rest of field
                        Call rsUpdate(f(i), strTextLine, s(i))
                    End If
                  
                    Exit For
                  
                End If
              
            Next
        End If
        Line Input #iFile, strTextLine

    Wend
  
    If bolAdd Then rs.Update
  
    ' close text file
    Close #iFile
  
    ' remove array from memory
    Erase s
    Erase f
End Sub


Private Sub rsUpdate(ByVal strFieldName As String, _
            ByVal strTextLine As String, ByVal strTextToBeReplaced As String)

    ' remove our search string from this text and
    ' remove all leading and trailing space from text
    strTextLine = RTrim(LTrim(Replace(strTextLine, strTextToBeReplaced, "")))
  
    ' update field with our text
    '
    ' note:
    '
    ' table's field size must be big enough (255 char) to hold variable
    ' length strings.
    ' i have access complaining when saving this record, saying
    ' that that the text i am saving cannot fit on the field!
    ' i don't want to truncate it as we may loose some text.
    '
    ' but if you really want to fit the text to the size of your field (losing some text)
    ' just uncomment the line below and comment out
    ' the second line in the code
    ' rs.Fields(strFieldName).Value = Left(strTextLine, rs.Fields(strFieldName).Size)   '1st line
    rs.fields(strFieldName).value = strTextLine                                         '2nd line
    DoEvents
End Sub
 
Last edited:

Users who are viewing this thread

Top Bottom