Tek-Tips is the largest IT community on the Internet today!
Members share and learn making Tek-Tips Forums the best source of peer-reviewed technical information on the Internet!
-
Congratulations Chris Miller on being selected by the Tek-Tips community for having the most helpful posts in the forums last week. Way to Go!
Using the StdText object 2
- Thread starter sdoughty
- Start date
-
1
- #2
Hi Steve
Here is some VBA code I use in MSAccess or MSExcel to handle extended text. You'll need to paste the code into a class module. Hope this helps.
Regards
Dallas
Code:
Option Compare Database
Option Explicit
'PURPOSE:
' This class creates extended text entries for any text code/text key on a remove and replace basis.
' Existing text for the code/key combination is removed and replaced with the text string provided.
' The class automatically breaks long text strings in memo type fields into suitable lengths for loading
' to MIMS.
'****************************** CLASS USAGE EXAMPLES ******************************************
'Public Sub UseExtTextClass_Set()
' Dim myText As clsExtText 'Create an instance of the class
' mims_go 'Log in to MIMS
' myText.TextType = "**" 'Two character Text Type Code
' myText.TextID = "000000023320020116ACCO" 'The Text Key
' myText.Text = "This is the text we want to load." 'The Text
' If Not myText.MIMS_SetText Then 'Load the text
' MsgBox "Error updating text" 'Handle any errors
' End If
' mims_stop 'Log out of MIMS
'End Sub
'Public Sub UseExtTextClass_Get()
' Dim myText As New clsExtText 'Create an instance of the class
' Dim someText As String
' mims_go 'Log in to MIMS
' myText.TextType = "DT" 'Two character Text Type Code
' myText.TextID = "0000100300068153BIPLEL01" 'The Text Key
' myText.MIMS_Fetch 'Get text from MIMS
' someText = myText.Text
' MsgBox someText
' mims_stop 'Log out of MIMS
'End Sub
'*********************************************************************************************
Private Const ClassName = "MIMS_StdText"
Private Const aLineLength = 60
Private MIMSlineCount As Long
Private MIMStotalCurrentLines As Long
Public TextType As String
Public TextID As String
Public HeadingLine As String
Private TextLines As Collection
Public errors As New Collection
Private Sub Class_Initialize()
Set TextLines = New Collection
End Sub
Public Property Get Text() As String
Dim Line As Variant
For Each Line In TextLines
Text = Text & Line & Chr(13) & Chr(10)
Next Line
End Property
Public Property Let Text(ByVal vNewValue As String)
Set TextLines = New Collection
If vNewValue = "" Then
Exit Property
End If
Dim newLine As String
Dim oldLine As String
Dim pos As Integer
Dim CRLF As String
Dim longLines As Collection
Dim longLine As Variant
CRLF = Chr(13) & Chr(10)
' Split the lines from the Memo into the array using CRLF.
Set longLines = New Collection
oldLine = vNewValue
newLine = ""
While Len(oldLine) > 0
pos = InStr(oldLine, CRLF)
If pos = 0 Then
longLines.Add oldLine
oldLine = ""
Else
longLines.Add Mid(oldLine, 1, pos - 1)
oldLine = Mid(oldLine, pos + 2, Len(oldLine))
End If
Wend
' Split each line now in the array using LineLength
For Each longLine In longLines
If Len(longLine) = 0 Then
TextLines.Add longLine
Else
oldLine = longLine
While Len(oldLine) > 0
If Len(oldLine) <= aLineLength Then
TextLines.Add oldLine
oldLine = ""
Else
pos = InStr(oldLine, " ")
newLine = ""
If pos > aLineLength Or pos = 0 Then
TextLines.Add Mid(oldLine, 1, aLineLength)
oldLine = Mid(oldLine, aLineLength + 1, Len(oldLine))
Else
While (Len(newLine) + pos - 1) <= aLineLength And pos <> 0
newLine = newLine & Mid(oldLine, 1, pos)
oldLine = Mid(oldLine, pos + 1, Len(oldLine))
pos = InStr(oldLine, " ")
Wend
TextLines.Add newLine
End If
End If
Wend
End If
Next longLine
End Property
Public Function appendText(aString As String)
Dim myText As String
myText = Me.Text
myText = myText & aString
Me.Text = myText
End Function
Public Function MIMS_SetText() As Boolean
On Error Resume Next
Dim Block As New MIMSBlock
Dim Reply As New MIMSReply
Dim Request As MIMSRequest
Dim Instance As MIMSInstance
Dim textLine As Variant
Dim startLineNo As Long
Dim lineCount As Long
Dim totalCurrentLines As Long
Dim lineIDX As Long
Dim instanceTextLine As String
Set Block = gobjMIMS.Blocks.New
Set Request = Block.Requests.New
Request.AddFieldNameValue MIMSX_FLAG_SERVICE, "STDTEXT.Delete"
Request.AddFieldNameValue "_BeginTxn", ""
Request.AddFieldNameValue "_Commit", ""
Request.AddFieldNameValue "_ErrorControl", 1
Request.Instances.New (1)
Request.Instances(1).AddFieldNameValue "StdTextId", TextType & TextID
Set Request = Block.Requests.New
Request.AddFieldNameValue "_Service", "STDTEXT.SetText"
Request.AddFieldNameValue "_ReplyList", "StdTextId"
lineIDX = 0
startLineNo = 1
totalCurrentLines = TextLines.Count
instanceTextLine = ""
lineCount = 0
For Each textLine In TextLines
lineIDX = lineIDX + 1
lineCount = lineCount + 1
instanceTextLine = instanceTextLine & textLine & Space(160 - Len(textLine))
If lineCount = 20 Then ' Create new instance for this batch of 20 lines
Set Instance = Request.Instances.New
Instance.AddFieldNameValue "StdTextId", TextType & TextID
Instance.AddFieldNameValue "StartLineNo", startLineNo ' Starting line of this instance
Instance.AddFieldNameValue "LineCount", lineCount ' Number of lines in this instance
Instance.AddFieldNameValue "TotalCurrentLines", totalCurrentLines ' Total number of lines in the Text
Instance.AddFieldNameValue "TotalRetrievedLines", 0 ' Number of Lines already there
Instance.AddFieldNameValue "TextLine", instanceTextLine ' Lines of text
Instance.AddFieldNameValue "HeadingLine", HeadingLine ' Dummy Heading Line
startLineNo = startLineNo + lineCount
instanceTextLine = ""
lineCount = 0
End If
Next textLine
If lineCount > 0 Then ' Create new instance for this batch of lines that is < 20 lines
Set Instance = Request.Instances.New
Instance.AddFieldNameValue "StdTextId", TextType & TextID
Instance.AddFieldNameValue "StartLineNo", startLineNo ' Starting line of this instance
Instance.AddFieldNameValue "LineCount", lineCount ' Number of lines in this instance
Instance.AddFieldNameValue "TotalCurrentLines", totalCurrentLines ' Total number of lines in the Text
Instance.AddFieldNameValue "TotalRetrievedLines", 0 ' Number of Lines already there
Instance.AddFieldNameValue "TextLine", instanceTextLine ' Lines of text
Instance.AddFieldNameValue "HeadingLine", HeadingLine ' Dummy Heading Line
End If
If Request.Instances.Count = 0 Then
MIMS_SetText = True
Exit Function
End If
Reply = Block.Send
Set Request = Block.Reply.Requests(2)
If Request.IsError Then
GoTo ErrorHandle
End If
For Each Instance In Request.Instances
Set Instance = Request.Instances(1)
If Instance.IsError Then
GoTo ErrorHandle
End If
Next Instance
MIMS_SetText = True
ExitHandle:
Exit Function
ErrorHandle:
'gstrErrMsg = "Error in MIMS_SetText Request"
MsgBox Err.Number & " " & Err.Description
MIMS_SetText = False
End Function
Public Function MIMS_Fetch() As Boolean
On Error GoTo ErrorHandle:
'Stop
Set TextLines = New Collection
Dim Block As New MIMSBlock
Dim Request As MIMSRequest
Dim Instance As MIMSInstance
Dim textLine As Variant
Dim startLineNo As Long
Dim lineCount As Long
Dim totalCurrentLines As Long
Dim lineIDX As Long
Dim instanceTextLine As String
Dim i As Integer
Set Block = gobjMIMS.Blocks.New
Set Request = Block.Requests.New
Request.AddFieldNameValue MIMSX_FLAG_SERVICE, "STDTEXT.GetText"
Request.AddFieldNameValue "_ReplyList", "LineCount,StartLineNo,TextLine"
Request.Instances.New (1)
Request.Instances(1).AddFieldNameValue "StdTextId", TextType & TextID
Do While True
' Send the Block to MIMS
On Error Resume Next
Block.Send
On Error GoTo 0
' Set the Request
Set Request = Block.Reply.Requests(1)
' Process the requests reply
If Request.IsError Then
GoTo ErrorHandle
Else
For Each Instance In Request.Instances
If Instance.IsError Then
GoTo ErrorHandle
Else
i = 1
textLine = Instance.Fields("TextLine")
While Len(textLine) > 0
TextLines.Add Trim(Mid(textLine, 1, 160))
textLine = Mid(textLine, 161, Len(textLine))
Wend
End If
Next Instance
End If
' Leave loop if no more data to fetch - The reply Request is not a restart when no more data is available
If Not Request.IsRestart Then
Exit Do
End If
' prepare to fetch next block of data
If Request.IsRestart Then
Request.Fields(MIMSX_FLAG_RESTART) = Request.Fields(MIMSX_FLAG_RESTART)
Else
Request.AddFieldNameValue MIMSX_FLAG_RESTART, Request.Fields(MIMSX_FLAG_RESTART)
End If
Loop
MIMS_Fetch = True
ExitHandle:
Exit Function
ErrorHandle:
MsgBox Err.Number & " " & Err.Description
MIMS_Fetch = False
End Function- Thread starter
- #3
-
1
- #4
JimBarrett
Programmer
Mark,
Congratulations on a pretty nifty piece of code!
Any chance you could post your fixed up version?
Congratulations on a pretty nifty piece of code!
Any chance you could post your fixed up version?
siddhamitra
Programmer
Mark,
I too am very interested in your corrected code. I am struggling with updating std text at the moment.
Many thanks in advance,
Carly
I too am very interested in your corrected code. I am struggling with updating std text at the moment.
Many thanks in advance,
Carly
- Status
Similar threads
- Locked
- Question
- Locked
- Question
- Locked
- Question