一個(gè)人的朝圣深度感悟

What Started It All

是什么開始了

I had an instance recently where I needed to take text from a textbox on a VBA form and split the text into separate lines to send to a zebra printer. ?The catch was that I needed the text to break at the same line points as the VBA textbox. ?The textbox was configured with multiline and wordwrap enabled. ?Searching all over the internet for a function or idea to accomplish this task, I found plenty of examples of wrapping text based on already included carriage returns or just of a space and character count, but not what I needed. ?A VBA textbox may or may not have carriage returns and it splits text on more than just spaces. ?

最近我有一個(gè)實(shí)例，我需要從VBA表單上的文本框中獲取文本并將文本拆分成單獨(dú)的行以發(fā)送到Zebra打印機(jī)。 問題是我需要文本在與VBA文本框相同的行點(diǎn)處中斷。 文本框已配置為啟用多行和自動(dòng)換行。 在Internet上搜索用于完成此任務(wù)的功能或構(gòu)想，我發(fā)現(xiàn)了很多基于已經(jīng)包含回車符或僅包含空格和字符數(shù)來包裝文本的示例，但不是我所需要的。 VBA文本框可能有回車符，也可能沒有回車符，它會(huì)在多個(gè)空格上分割文本。

This led me on a quest to build a word wrap function mimicking the wrapping of a textbox. ?Working through coding and testing, I ended up creating a few different versions. ?The earlier versions were better than what I had found, but not good enough for my needs. ?They are posted here in case they are good enough for you. ?The original function returned data in a string array, but it was easy to adjust it to return as single string with carriage returns to break apart each line. ?That code is also included.

這使我開始尋求構(gòu)建模仿文字框自動(dòng)換行的自動(dòng)換行功能。 通過編碼和測試，我最終創(chuàng)建了幾個(gè)不同的版本。 較早的版本比我發(fā)現(xiàn)的要好，但不足以滿足我的需求。 如果它們對您足夠好，則會(huì)在此處發(fā)布。 原始函數(shù)以字符串?dāng)?shù)組的形式返回?cái)?shù)據(jù)，但是很容易將其調(diào)整為帶有回車符的單個(gè)字符串以將每一行分開。 該代碼也包括在內(nèi)。

Breakdown of the basic code:

基本代碼明細(xì)：

A textbox has a variety of rules on how it separates text. ?The first step is to take the text and split it into an array based on already defined line feeds. ?Use the line feed (vbLf) as this will catch user entered returns from both Enter Key (If EnterKeyBehavior = True) and Cntrl-Enter (if EnterKey Behavior=False).

文本框?qū)τ谌绾畏指粑谋揪哂卸喾N規(guī)則。 第一步是獲取文本并將其根據(jù)已定義的換行符拆分為一個(gè)數(shù)組。 使用換行符（vbLf），因?yàn)樗鼘⒉东@用戶從Enter鍵（如果EnterKeyBehavior = True）和Cntrl-Enter（如果EnterKey Behavior = False）輸入的返回值。

strLineData = Split(TextToWrap, vbLf) ' This is the RegEx List for Characters that should be grouped with the text that follows them ' ${(<[\ - Have to use escape character "\" for ] and \ strStartGroup = "${(<\[\\" ' This is the RegEx List for Characters that should be grouped with the text the preceeds them ' !)}%>?-] - Have to use escape character "\" for - and ] strEndGroup = "!)}%>?\-\]" ' [] = Group. Find Anything listed in this group. ? = Find 0 to 1 instances strRegPattern = "[" & strStartGroup & "]?" ' Now grab all characters that are not part of special list and no spaces \s ' [] = Group. Find Anything listed in this group. + = Find 1 to many instances. ' Equates to finding whole words including some special characters (those not in list since negative comparison) strRegPattern = strRegPattern & "[^\s" & strStartGroup & strEndGroup & "]+" ' [] = Group. Find Anything listed in this group. ? = Find 0 to 1 instances strRegPattern = strRegPattern & "[" & strEndGroup & "]?" objRegExp.Pattern = strRegPattern Set objWordList = objRegExp.Execute(strLine)

The first function I created calculated the width of each line by the number of characters per line. ?These can work well for you if you are using a fixed width font. ?They are simplier and will run slightly faster. ?

我創(chuàng)建的第一個(gè)函數(shù)通過每行的字符數(shù)來計(jì)算每行的寬度。 如果您使用的是固定寬度的字體，則這些字體對您來說效果很好。 它們比較簡單，運(yùn)行速度會(huì)稍快。

I have included a VBScript version using late binding. ?

我已經(jīng)包括了使用后期綁定的VBScript版本。

WordWrapByCharacterToArray Function:

WordWrapByCharacterToArray 功能：

Here is the first function. ?To use this function, send it the text that you want word wrapped and the maximum number of characters per line. ?It will return a string array with each line as a separate element in the array.

這是第一個(gè)功能。 要使用此功能，請向其發(fā)送您要自動(dòng)換行的文本以及每行最大字符數(shù)。 它將返回一個(gè)字符串?dāng)?shù)組，其中每一行作為數(shù)組中的單獨(dú)元素。

Example Usage:

用法示例：

Dim strLines() As String strLines = WordWrapByCharacterToArray(TextToWrap:=TextBox1.Text, LengthOfLine:=20) For i = 0 To UBound(strLines)Debug.Print strLines(i) Next '--------------------------------------------------------------------------------------- ' Function : WordWrapByCharacterToArray ' Date : 03/21/2012 ' Purpose : Will Return a String array of line data wrapped at proper break points ' for a given line length as determined by the number of characters. ' It uses the same rules as a VBA text box ' ' Usage : Set a string array = to WordWrapByCharacterToArray sending WordWrapByCharacterToArray ' your text and maximum length for each line ' Example: ' Dim strLines() as string ' strLines = WordWrapByCharacterToArray("This is my text I want to wrap around something", 15) ' This will break the string into multiple lines with a maximum length of 15 characters per line '--------------------------------------------------------------------------------------- ' Public Function WordWrapByCharacterToArray(ByVal TextToWrap As String, _ByVal LengthOfLine As Long) As String()On Error GoTo WordWrapByCharacterToArray_Error:Dim objRegExp As VBScript_RegExp_55.RegExpDim objWordList As VBScript_RegExp_55.MatchCollectionDim objWord As VBScript_RegExp_55.MatchDim strStartGroup As StringDim strEndGroup As StringDim strRegPattern As StringDim intLineNum As Integer: intLineNum = 0Dim intLinePos As IntegerDim strReturn() As StringDim strLineData() As StringDim strLine As VariantDim intNumCharUsed As Integer' Instantiate RegExSet objRegExp = New VBScript_RegExp_55.RegExp' ------------------------------------' Set Set Font Settings' ------------------------------------' Make sure we were sent a good line widthIf LengthOfLine < 1 Then' Return an ErrorErr.Raise Number:=vbObjectError + 605, Description:="Requested Length of Line must be greater than 0"End If' ------------------------------------' Set RegEx Settings' ------------------------------------objRegExp.MultiLine = FalseobjRegExp.Global = True' ------------------------------------' Set the Search Pattern' ------------------------------------' This is the RegEx List for Characters that should be grouped with the text that follows them' ${(<[\ - Have to use escape character "\" for ] and \strStartGroup = "${(<\[\\"' This is the RegEx List for Characters that should be grouped with the text the preceeds them' !)}%>?-] - Have to use escape character "\" for - and ]strEndGroup = "!)}%>?\-\]"' [] = Group. Find Anything listed in this group. ? = Find 0 to 1 instancesstrRegPattern = "[" & strStartGroup & "]?"' Now grab all characters that are not part of special list and no spaces \s' [] = Group. Find Anything listed in this group. + = Find 1 to many instances.' Equates to finding whole words including some special characters (those not in list since negative comparison)strRegPattern = strRegPattern & "[^\s" & strStartGroup & strEndGroup & "]+"' [] = Group. Find Anything listed in this group. ? = Find 0 to 1 instancesstrRegPattern = strRegPattern & "[" & strEndGroup & "]?"objRegExp.Pattern = strRegPattern' ------------------------------------' Break up Original String into already defined lines' ------------------------------------strLineData = Split(TextToWrap, vbLf)' ------------------------------------' Set Original Size of Return Array to just one line. Can Expand Later' ------------------------------------ReDim Preserve strReturn(0)' ------------------------------------' Loop through each line to wrap text if needed' ------------------------------------For Each strLine In strLineData' Reset the Line Position for this set of textintLinePos = 0' Make sure the line is long enough to need to be wrappedIf Len(strLine) > LengthOfLine Then' ------------------------------------' Get the list of words defined by the Pattern' ------------------------------------Set objWordList = objRegExp.Execute(strLine)' ------------------------------------' Build the Return Array' ------------------------------------For Each objWord In objWordList' See if this word is too big to FitIf objWord.Length > LengthOfLine Then' Word is too big for the line, have to break it appart' Reset the Number of Characters used in this word to 1intNumCharUsed = 1' First see if we have any remaining words that should be added to the previous lineIf objWord.FirstIndex - intLinePos > 0 Then' See if we need to expand the arrayIf UBound(strReturn) < intLineNum Then' ReDim the ArrayReDim Preserve strReturn(intLineNum)End If' Save Previous LinestrReturn(intLineNum) = Mid(strLine, intLinePos + 1, objWord.FirstIndex - intLinePos)' Reset the Line PositionintLinePos = objWord.FirstIndex' Increment our line CounterintLineNum = intLineNum + 1End IfDo While intNumCharUsed < objWord.Length' See if we need to expand the arrayIf UBound(strReturn) < intLineNum Then' ReDim the ArrayReDim Preserve strReturn(intLineNum)End If' Get as many characters as will fit on the linestrReturn(intLineNum) = Mid(objWord.Value, intNumCharUsed, LengthOfLine)' Increase the Number used counterintNumCharUsed = intNumCharUsed + Len(strReturn(intLineNum))' Reset the Line PositionintLinePos = intLinePos + Len(strReturn(intLineNum))' Increment our line CounterintLineNum = intLineNum + 1LoopElseIf objWord.FirstIndex - intLinePos + objWord.Length > LengthOfLine Then' See if we need to expand the arrayIf UBound(strReturn) < intLineNum Then' ReDim the ArrayReDim Preserve strReturn(intLineNum)End If' This word will not fit on current Line. Save Current LinestrReturn(intLineNum) = Mid(strLine, intLinePos + 1, objWord.FirstIndex - intLinePos)' Reset the Line PositionintLinePos = objWord.FirstIndex' Increment our line CounterintLineNum = intLineNum + 1End IfEnd If 'objWord.Length > LengthOfLineNext' ------------------------------------' See if there is any text yet to add' ------------------------------------If (Len(strLine) - intLinePos) > 0 Then' See if we need to expand the arrayIf UBound(strReturn) < intLineNum Then' ReDim the ArrayReDim Preserve strReturn(intLineNum)End If' Save of the Last bits of DatastrReturn(intLineNum) = Right(strLine, Len(strLine) - intLinePos)' Increment our line CounterintLineNum = intLineNum + 1End IfElse' ------------------------------------' The entire line fits. Add it now' ------------------------------------' See if we need to expand the arrayIf UBound(strReturn) < intLineNum Then' ReDim the ArrayReDim Preserve strReturn(intLineNum)End IfstrReturn(intLineNum) = strLine' Increment our line CounterintLineNum = intLineNum + 1End IfNext' Return our ArrayWordWrapByCharacterToArray = strReturnRelease:On Error Resume NextErase strReturnSet objWordList = NothingSet objWord = NothingSet objRegExp = NothingExit FunctionWordWrapByCharacterToArray_Error:MsgBox "Procedure = WordWrapByCharacterToArray" & vbCrLf & _"Error Number = " & Err.Number & vbCrLf & _"Error Message = " & Err.Description & vbCrLf, _vbCritical Or vbSystemModal, "Word Wrap Error"Resume Release: End Function VBScript Version:'--------------------------------------------------------------------------------------- ' Function : WordWrapByCharacterToArray ' Date : 03/21/2012 ' Purpose : Will Return a String array of line data wrapped at proper break points ' for a given line length as determined by the number of characters. ' It uses the same rules as a VBA text box ' ' Usage : Set a string array = to WordWrapByCharacterToArray sending WordWrapByCharacterToArray ' your text and maximum length for each line ' Example: ' Dim strLines ' strLines = WordWrapByCharacterToArray("This is my text I want to wrap around something", 15) ' This will break the string into multiple lines with a maximum length of 15 characters per line '--------------------------------------------------------------------------------------- ' Public Function WordWrapByCharacterToArray(TextToWrap, LengthOfLine)Dim objRegExp, objWordList, objWordDim strStartGroup, strEndGroup, strRegPatternDim intLineNum, intLinePos, intNumCharUsedDim strReturn(), strLineData, strLine' Instantiate RegExSet objRegExp = CreateObject("VBScript.RegExp")intLineNum = 0' ------------------------------------' Set Set Font Settings' ------------------------------------' Make sure we were sent a good line widthIf LengthOfLine < 1 Then' Return an ErrorErr.Raise vbObjectError + 605, "Requested Length of Line must be greater than 0"End If' ------------------------------------' Set RegEx Settings' ------------------------------------objRegExp.MultiLine = FalseobjRegExp.Global = True' ------------------------------------' Set the Search Pattern' ------------------------------------' This is the RegEx List for Characters that should be grouped with the text that follows them' ${(<[\ - Have to use escape character "\" for ] and \strStartGroup = "${(<\[\\"' This is the RegEx List for Characters that should be grouped with the text the preceeds them' !)}%>?-] - Have to use escape character "\" for - and ]strEndGroup = "!)}%>?\-\]"' [] = Group. Find Anything listed in this group. ? = Find 0 to 1 instancesstrRegPattern = "[" & strStartGroup & "]?"' Now grab all characters that are not part of special list and no spaces \s' [] = Group. Find Anything listed in this group. + = Find 1 to many instances.' Equates to finding whole words including some special characters (those not in list since negative comparison)strRegPattern = strRegPattern & "[^\s" & strStartGroup & strEndGroup & "]+"' [] = Group. Find Anything listed in this group. ? = Find 0 to 1 instancesstrRegPattern = strRegPattern & "[" & strEndGroup & "]?"objRegExp.Pattern = strRegPattern' ------------------------------------' Break up Original String into already defined lines' ------------------------------------strLineData = Split(TextToWrap, vbLf)' ------------------------------------' Set Original Size of Return Array to just one line. Can Expand Later' ------------------------------------ReDim strReturn(0)' ------------------------------------' Loop through each line to wrap text if needed' ------------------------------------For Each strLine In strLineData' Reset the Line Position for this set of textintLinePos = 0' Make sure the line is long enough to need to be wrappedIf Len(strLine) > LengthOfLine Then' ------------------------------------' Get the list of words defined by the Pattern' ------------------------------------Set objWordList = objRegExp.Execute(strLine)' ------------------------------------' Build the Return Array' ------------------------------------For Each objWord In objWordList' See if this word is too big to FitIf objWord.Length > LengthOfLine Then' Word is too big for the line, have to break it appart' Reset the Number of Characters used in this word to 1intNumCharUsed = 1' First see if we have any remaining words that should be added to the previous lineIf objWord.FirstIndex - intLinePos > 0 Then' See if we need to expand the arrayIf UBound(strReturn) < intLineNum Then' ReDim the ArrayReDim Preserve strReturn(intLineNum)End If' Save Previous LinestrReturn(intLineNum) = Mid(strLine, intLinePos + 1, objWord.FirstIndex - intLinePos)' Reset the Line PositionintLinePos = objWord.FirstIndex' Increment our line CounterintLineNum = intLineNum + 1End IfDo While intNumCharUsed < objWord.Length' See if we need to expand the arrayIf UBound(strReturn) < intLineNum Then' ReDim the ArrayReDim Preserve strReturn(intLineNum)End If' Get as many characters as will fit on the linestrReturn(intLineNum) = Mid(objWord.Value, intNumCharUsed, LengthOfLine)' Increase the Number used counterintNumCharUsed = intNumCharUsed + Len(strReturn(intLineNum))' Reset the Line PositionintLinePos = intLinePos + Len(strReturn(intLineNum))' Increment our line CounterintLineNum = intLineNum + 1LoopElseIf objWord.FirstIndex - intLinePos + objWord.Length > LengthOfLine Then' See if we need to expand the arrayIf UBound(strReturn) < intLineNum Then' ReDim the ArrayReDim Preserve strReturn(intLineNum)End If' This word will not fit on current Line. Save Current LinestrReturn(intLineNum) = Mid(strLine, intLinePos + 1, objWord.FirstIndex - intLinePos)' Reset the Line PositionintLinePos = objWord.FirstIndex' Increment our line CounterintLineNum = intLineNum + 1End IfEnd If 'objWord.Length > LengthOfLineNext' ------------------------------------' See if there is any text yet to add' ------------------------------------If (Len(strLine) - intLinePos) > 0 Then' See if we need to expand the arrayIf UBound(strReturn) < intLineNum Then' ReDim the ArrayReDim Preserve strReturn(intLineNum)End If' Save of the Last bits of DatastrReturn(intLineNum) = Right(strLine, Len(strLine) - intLinePos)' Increment our line CounterintLineNum = intLineNum + 1End IfElse' ------------------------------------' The entire line fits. Add it now' ------------------------------------' See if we need to expand the arrayIf UBound(strReturn) < intLineNum Then' ReDim the ArrayReDim Preserve strReturn(intLineNum)End IfstrReturn(intLineNum) = strLine' Increment our line CounterintLineNum = intLineNum + 1End IfNext' Return our ArrayWordWrapByCharacterToArray = strReturn' Release the ObjectsOn Error Resume NextSet objWordList = NothingSet objWord = NothingSet objRegExp = Nothing End Function

WordWrapByCharacterToSstring Function:

WordWrapByCharacterToSstri ng功能：

Here is the Next function. ?To use this function, send it the text that you want word wrapped and the maximum number of characters per line. ?It will return a single string with each line in the string separated by a carriage return.

這是Next函數(shù)。 要使用此功能，請向其發(fā)送您要自動(dòng)換行的文本以及每行最大字符數(shù)。 它將返回單個(gè)字符串，字符串中的每一行都用回車符分隔。

Example Usage:

用法示例：

Dim strWrappedLines As String strWrappedLines = WordWrapByPointToString(TextToWrap:=TextBox1.Text, LengthOfLine:=20) Debug.Print strWrappedLines '--------------------------------------------------------------------------------------- ' Procedure : WordWrapByCharacterToString ' Date : 03/23/2012 ' Purpose : Will Return a String array of line data wrapped at proper break points ' for a given line length as determined by the number of characters. ' It uses the same rules as a VBA text box ' *** MUST have a REFERENCE set for MICROSOFT VBSCRIPT REGULAR EXPRESSION 5.5 ' ' Usage : Set a string array = to WordWrapByCharacterToString sending WordWrapByCharacterToString ' your text and maximum length for each line ' Example: ' Dim strWrappedLines as string ' strWrappedLines = WordWrapByCharacterToString("This is my text I want to wrap around something", 15) ' This will break the string into multiple lines with a maximum length of 15 characters per line '--------------------------------------------------------------------------------------- ' Public Function WordWrapByCharacterToString(ByVal TextToWrap As String, _ByVal LengthOfLine As Long) As StringOn Error GoTo WordWrapByCharacterToString_Error:Dim objRegExp As VBScript_RegExp_55.RegExpDim objWordList As VBScript_RegExp_55.MatchCollectionDim objWord As VBScript_RegExp_55.MatchDim strStartGroup As StringDim strEndGroup As StringDim strRegPattern As StringDim intLineNum As Integer: intLineNum = 0Dim intLinePos As IntegerDim strReturn As StringDim strLineData() As StringDim strLine As VariantDim intNumCharUsed As Integer' Instantiate RegExSet objRegExp = New VBScript_RegExp_55.RegExp' ------------------------------------' Set Set Font Settings' ------------------------------------' Make sure we were sent a good line widthIf LengthOfLine < 1 Then' Return an ErrorErr.Raise Number:=vbObjectError + 605, Description:="Requested Length of Line must be greater than 0"End If' ------------------------------------' Set RegEx Settings' ------------------------------------objRegExp.MultiLine = FalseobjRegExp.Global = True' ------------------------------------' Set the Search Pattern' ------------------------------------' This is the RegEx List for Characters that should be grouped with the text that follows them' ${(<[\ - Have to use escape character "\" for ] and \strStartGroup = "${(<\[\\"' This is the RegEx List for Characters that should be grouped with the text the preceeds them' !)}%>?-] - Have to use escape character "\" for - and ]strEndGroup = "!)}%>?\-\]"' [] = Group. Find Anything listed in this group. ? = Find 0 to 1 instancesstrRegPattern = "[" & strStartGroup & "]?"' Now grab all characters that are not part of special list and no spaces \s' [] = Group. Find Anything listed in this group. + = Find 1 to many instances.' Equates to finding whole words including some special characters (those not in list since negative comparison)strRegPattern = strRegPattern & "[^\s" & strStartGroup & strEndGroup & "]+"' [] = Group. Find Anything listed in this group. ? = Find 0 to 1 instancesstrRegPattern = strRegPattern & "[" & strEndGroup & "]?"objRegExp.Pattern = strRegPattern' ------------------------------------' Break up Original String into already defined lines' ------------------------------------strLineData = Split(TextToWrap, vbLf)' ------------------------------------' Loop through each line to wrap text if needed' ------------------------------------For Each strLine In strLineData' Reset the Line Position for this set of textintLinePos = 0' Make sure the line is long enough to need to be wrappedIf Len(strLine) > LengthOfLine Then' ------------------------------------' Get the list of words defined by the Pattern' ------------------------------------Set objWordList = objRegExp.Execute(strLine)' ------------------------------------' Build the Return Array' ------------------------------------For Each objWord In objWordList' See if this word is too big to FitIf objWord.Length > LengthOfLine Then' Word is too big for the line, have to break it appart' Reset the Number of Characters used in this word to 1intNumCharUsed = 1' First see if we have any remaining words that should be added to the previous lineIf objWord.FirstIndex - intLinePos > 0 Then' Save Previous LinestrReturn = strReturn & (Mid(strLine, intLinePos + 1, objWord.FirstIndex - intLinePos) & vbNewLine)' Reset the Line PositionintLinePos = objWord.FirstIndex' Increment our line CounterintLineNum = intLineNum + 1End IfDo While intNumCharUsed < objWord.Length' Get as many characters as will fit on the linestrReturn = strReturn & (Mid(objWord.Value, intNumCharUsed, LengthOfLine) & vbNewLine)' Reset the Line PositionintLinePos = intLinePos + Len(Mid(objWord.Value, intNumCharUsed, LengthOfLine))' Increase the Number used counterintNumCharUsed = intNumCharUsed + Len(Mid(objWord.Value, intNumCharUsed, LengthOfLine))' Increment our line CounterintLineNum = intLineNum + 1LoopElseIf objWord.FirstIndex - intLinePos + objWord.Length > LengthOfLine Then' This word will not fit on current Line. Save Current LinestrReturn = strReturn & (Mid(strLine, intLinePos + 1, objWord.FirstIndex - intLinePos) & vbNewLine)' Reset the Line PositionintLinePos = objWord.FirstIndex' Increment our line CounterintLineNum = intLineNum + 1End IfEnd If 'objWord.Length > LengthOfLineNext' ------------------------------------' See if there is any text yet to add' ------------------------------------If (Len(strLine) - intLinePos) > 0 Then' Save of the Last bits of DatastrReturn = strReturn & (Right(strLine, Len(strLine) - intLinePos) & vbNewLine)' Increment our line CounterintLineNum = intLineNum + 1End IfElse' ------------------------------------' The entire line fits. Add it now' ------------------------------------strReturn = strReturn & (strLine & vbNewLine)' Increment our line CounterintLineNum = intLineNum + 1End IfNext' Return our ArrayWordWrapByCharacterToString = strReturnRelease:On Error Resume NextSet objWordList = NothingSet objWord = NothingSet objRegExp = NothingExit FunctionWordWrapByCharacterToString_Error:MsgBox "Procedure = WordWrapByCharacterToString" & vbCrLf & _"Error Number = " & Err.Number & vbCrLf & _"Error Message = " & Err.Description & vbCrLf, _vbCritical Or vbSystemModal, "Word Wrap Error"Resume Release: End Function VBScript Version:'--------------------------------------------------------------------------------------- ' Procedure : WordWrapByCharacterToString ' Date : 03/23/2012 ' Purpose : Will Return a String array of line data wrapped at proper break points ' for a given line length as determined by the number of characters. ' It uses the same rules as a VBA text box ' ' Usage : Set a string array = to WordWrapByCharacterToString sending WordWrapByCharacterToString ' your text and maximum length for each line ' Example: ' Dim strWrappedLines ' strWrappedLines = WordWrapByCharacterToString("This is my text I want to wrap around something", 15) ' This will break the string into multiple lines with a maximum length of 15 characters per line '--------------------------------------------------------------------------------------- ' Public Function WordWrapByCharacterToString(TextToWrap, LengthOfLine)Dim objRegExp, objWordList, objWordDim strStartGroup, strEndGroup, strRegPatternDim intLineNum, intLinePos, intNumCharUsedDim strReturn, strLineData, strLine' Instantiate RegExSet objRegExp = CreateObject("VBScript.RegExp")intLineNum = 0' ------------------------------------' Set Set Font Settings' ------------------------------------' Make sure we were sent a good line widthIf LengthOfLine < 1 Then' Return an ErrorErr.Raise vbObjectError + 605, "Requested Length of Line must be greater than 0"End If' ------------------------------------' Set RegEx Settings' ------------------------------------objRegExp.MultiLine = FalseobjRegExp.Global = True' ------------------------------------' Set the Search Pattern' ------------------------------------' This is the RegEx List for Characters that should be grouped with the text that follows them' ${(<[\ - Have to use escape character "\" for ] and \strStartGroup = "${(<\[\\"' This is the RegEx List for Characters that should be grouped with the text the preceeds them' !)}%>?-] - Have to use escape character "\" for - and ]strEndGroup = "!)}%>?\-\]"' [] = Group. Find Anything listed in this group. ? = Find 0 to 1 instancesstrRegPattern = "[" & strStartGroup & "]?"' Now grab all characters that are not part of special list and no spaces \s' [] = Group. Find Anything listed in this group. + = Find 1 to many instances.' Equates to finding whole words including some special characters (those not in list since negative comparison)strRegPattern = strRegPattern & "[^\s" & strStartGroup & strEndGroup & "]+"' [] = Group. Find Anything listed in this group. ? = Find 0 to 1 instancesstrRegPattern = strRegPattern & "[" & strEndGroup & "]?"objRegExp.Pattern = strRegPattern' ------------------------------------' Break up Original String into already defined lines' ------------------------------------strLineData = Split(TextToWrap, vbLf)' ------------------------------------' Loop through each line to wrap text if needed' ------------------------------------For Each strLine In strLineData' Reset the Line Position for this set of textintLinePos = 0' Make sure the line is long enough to need to be wrappedIf Len(strLine) > LengthOfLine Then' ------------------------------------' Get the list of words defined by the Pattern' ------------------------------------Set objWordList = objRegExp.Execute(strLine)' ------------------------------------' Build the Return Array' ------------------------------------For Each objWord In objWordList' See if this word is too big to FitIf objWord.Length > LengthOfLine Then' Word is too big for the line, have to break it appart' Reset the Number of Characters used in this word to 1intNumCharUsed = 1' First see if we have any remaining words that should be added to the previous lineIf objWord.FirstIndex - intLinePos > 0 Then' Save Previous LinestrReturn = strReturn & (Mid(strLine, intLinePos + 1, objWord.FirstIndex - intLinePos) & vbNewLine)' Reset the Line PositionintLinePos = objWord.FirstIndex' Increment our line CounterintLineNum = intLineNum + 1End IfDo While intNumCharUsed < objWord.Length' Get as many characters as will fit on the linestrReturn = strReturn & (Mid(objWord.Value, intNumCharUsed, LengthOfLine) & vbNewLine)' Reset the Line PositionintLinePos = intLinePos + Len(Mid(objWord.Value, intNumCharUsed, LengthOfLine))' Increase the Number used counterintNumCharUsed = intNumCharUsed + Len(Mid(objWord.Value, intNumCharUsed, LengthOfLine))' Increment our line CounterintLineNum = intLineNum + 1LoopElseIf objWord.FirstIndex - intLinePos + objWord.Length > LengthOfLine Then' This word will not fit on current Line. Save Current LinestrReturn = strReturn & (Mid(strLine, intLinePos + 1, objWord.FirstIndex - intLinePos) & vbNewLine)' Reset the Line PositionintLinePos = objWord.FirstIndex' Increment our line CounterintLineNum = intLineNum + 1End IfEnd If 'objWord.Length > LengthOfLineNext' ------------------------------------' See if there is any text yet to add' ------------------------------------If (Len(strLine) - intLinePos) > 0 Then' Save of the Last bits of DatastrReturn = strReturn & (Right(strLine, Len(strLine) - intLinePos) & vbNewLine)' Increment our line CounterintLineNum = intLineNum + 1End IfElse' ------------------------------------' The entire line fits. Add it now' ------------------------------------strReturn = strReturn & (strLine & vbNewLine)' Increment our line CounterintLineNum = intLineNum + 1End IfNext' Return our ArrayWordWrapByCharacterToString = strReturn' Release the ObjectsOn Error Resume NextSet objWordList = NothingSet objWord = NothingSet objRegExp = Nothing End Function

Stage Two:

第二階段：

As I mentioned, the problem with both of the above functions is that they still break based on a character count. ?With propotionalized fonts, though, a line of "iiiiiiiiii" will break differently than a line of "WWWWWWWWWW" in a textbox. ?Since the width of a text box is based on points, the code needed to determine the size of the text in points before it could split the lines. ?There are examples on the internet of using Windows APIs to determine the pixel size of a section of text. ?If you know the DPI of a monitor, which can be had via the APIs, you can determine the point size. ?Adapting those ideas, a class to determine text size was created.

正如我提到的，上述兩個(gè)函數(shù)的問題在于它們?nèi)匀换谧址?jì)數(shù)而中斷。 但是，對于帶比例的字體，文本框中的“ iiiiiiiiii”行與“ WWWWWWWWWW”行的折斷方式不同。 由于文本框的寬度基于點(diǎn)，因此需要使用代碼來確定文本的大小（以點(diǎn)為單位），然后才能分割線。 互聯(lián)網(wǎng)上有使用Windows API確定一段文字的像素大小的示例。 如果您知道可以通過API獲得的顯示器的DPI，則可以確定點(diǎn)的大小。 為適應(yīng)這些想法，創(chuàng)建了一個(gè)確定文本大小的類。

This class is used to measure the point size of each word, to compare that with the targeted line width in points, and to see if the word fits that line. ?Pleaset note that the defined width of a text box is not exactly the size needed for your total line width. ?The textbox has margins built into the display. ?I could not find this documented anywhere, but it appears that the margin is 3 points per side (Selection Margin is another 3 if set to true and a displayed scroll bar appears to take up 14). ?Therefore when wrapping text, you need to take the width of the text box and subtract the correct amount (like 6 for just a basic box) to find the width in points that can display text. ?

此類用于測量每個(gè)單詞的點(diǎn)大小，將其與目標(biāo)行寬（以磅為單位）進(jìn)行比較，并查看單詞是否適合該行。 請注意，文本框的定義寬度與總線寬所需的大小不完全相同。 文本框在顯示屏中內(nèi)置了頁邊距。 我在任何地方都找不到此文檔，但是看來邊距是每邊3個(gè)點(diǎn)（如果設(shè)置為true，則“選擇邊距”是另外3個(gè)點(diǎn)，并且顯示的滾動(dòng)條似乎占用14個(gè)點(diǎn)）。 因此，在自動(dòng)換行時(shí)，需要采用文本框的寬度并減去正確的數(shù)量（例如對于基本框來說為6）以找到可以顯示文本的點(diǎn)的寬度。

Since this code requires access to Windows API, VBA must be used. ?Therefore, they have been coded using early binding for regular expressions. ?Please make sure to add a reference in your project to MICROSOFT VBSCRIPT REGULAR EXPRESSION 5.5 to use these functions.

由于此代碼需要訪問Windows API，因此必須使用VBA。 因此，已使用早期綁定對正則表達(dá)式進(jìn)行編碼。 請確保在項(xiàng)目中添加對MICROSOFT VBSCRIPT REGULAR EXPRESSION 5.5的引用，以使用這些功能。

WordWrapByPointToArray Function:

WordWrapByPointToArray函數(shù)：

Here is the third attempt at a function. ?To use this function, send it the text that you want word wrapped, the font used, and how wide the line should be in points. ?It will return a string array with each line as a separate element in the array.

這是函數(shù)的第三次嘗試。 要使用此功能，請向其發(fā)送要自動(dòng)換行的文本，使用的字體以及線的寬度（以磅為單位）。 它將返回一個(gè)字符串?dāng)?shù)組，其中每一行作為數(shù)組中的單獨(dú)元素。

Example:

例：

Dim strLines() As String strLines = WordWrapByPointToArray(TextToWrap:=TextBox1.Text, TextFont:=TextBox1.Font, LineWidthInPoints:=TextBox1.Width - 6) For i = 0 To UBound(strLines)Debug.Print strLines(i) Next '--------------------------------------------------------------------------------------- ' Function : WordWrapByPointToArray ' Date : 03/20/2012 ' Purpose : Will Return a String array of line data that has been sepearated into lines ' based on Width in Points and split according to textbox word wrap rules. ' *** MUST have a REFERENCE set for Microsoft VBScript Regular Expression 5.5 ' *** Must also have the DetermineTextSize Class added to the project*** ' ' Usage : Set a string array = to WordWrapByPointToArray sending WordWrapByPointToArray ' your text, Font and Line Width (Point Size) for each line ' Example: ' Dim strLines() as string ' strLines = WordWrapByPointToArray(TextToWrap:=TextBox1.Text, TextFont:=TextBox1.Font, LineWidthInPoints:=TextBox1.Width - 6) ' This will break the string into multiple lines at the same point as the text box ' ' Please note in the example I take 6 away form TextBox1.Width as this appears to be ' the margin size of a text box. I found this through trial and error and have not ' been able to verify that value. '--------------------------------------------------------------------------------------- ' Public Function WordWrapByPointToArray(ByVal TextToWrap As String, _ByVal TextFont As StdFont, ByVal LineWidthInPoints As Single) As String()On Error GoTo WordWrapByPointToArray_Error:Dim objRegExp As VBScript_RegExp_55.RegExpDim objWordList As VBScript_RegExp_55.MatchCollectionDim objWord As VBScript_RegExp_55.MatchDim udtTextSize As DetermineTextSizeDim strStartGroup As StringDim strEndGroup As StringDim strRegPattern As StringDim intLineNum As Integer: intLineNum = 0Dim intLinePos As IntegerDim intEndPosition As IntegerDim strReturn() As StringDim strLineData() As StringDim strLine As VariantDim lngPointSize As LongDim lngWordSize As LongDim intNumCharUsed As Integer' Instantiate RegExSet objRegExp = New VBScript_RegExp_55.RegExpSet udtTextSize = New DetermineTextSize' ------------------------------------' Set Set Font Settings' ------------------------------------' Make sure we were sent a good line widthIf LineWidthInPoints < 1 Then' Return an ErrorErr.Raise Number:=vbObjectError + 605, Description:="Requested Line Width in Points must be greater than 0"End If' ------------------------------------' Set Set Font Settings' ------------------------------------udtTextSize.Font = TextFont' ------------------------------------' Set RegEx Settings' ------------------------------------objRegExp.MultiLine = FalseobjRegExp.Global = True' ------------------------------------' Set the Search Pattern' ------------------------------------' This is the RegEx List for Characters that should be grouped with the text that follows them' ${(<[\ - Have to use escape character "\" for ] and \strStartGroup = "${(<\[\\"' This is the RegEx List for Characters that should be grouped with the text the preceeds them' !)}%>?-] - Have to use escape character "\" for - and ]strEndGroup = "!)}%>?\-\]"' [] = Group. Find Anything listed in this group. ? = Find 0 to 1 instancesstrRegPattern = "[" & strStartGroup & "]?"' Now grab all characters that are not part of special list and no spaces \s' [] = Group. Find Anything listed in this group. + = Find 1 to many instances.' Equates to finding whole words including some special characters (those not in list since negative comparison)strRegPattern = strRegPattern & "[^\s" & strStartGroup & strEndGroup & "]+"' [] = Group. Find Anything listed in this group. ? = Find 0 to 1 instancesstrRegPattern = strRegPattern & "[" & strEndGroup & "]?"objRegExp.Pattern = strRegPattern' ------------------------------------' Break up Original String into already defined lines' ------------------------------------strLineData = Split(TextToWrap, vbLf)' ------------------------------------' Set Original Size of Return Array to just one line. Can Expand Later' ------------------------------------ReDim Preserve strReturn(0)' ------------------------------------' Loop through each line to wrap text if needed' ------------------------------------For Each strLine In strLineData' Reset the Line Position for this set of textintLinePos = 0' Make sure the line is long enough to need to be wrappedIf udtTextSize.TextWidthinPoints(strLine) > LineWidthInPoints Then' ------------------------------------' Get the list of words defined by the Pattern' ------------------------------------Set objWordList = objRegExp.Execute(strLine)' ------------------------------------' Build the Return Array' ------------------------------------For Each objWord In objWordListlngWordSize = udtTextSize.TextWidthinPoints(objWord.Value)' See if this word is too big to FitIf lngWordSize > LineWidthInPoints Then' Word is too big for the line, have to break it appart' Reset the Number of Characters used in this word to 0intNumCharUsed = 0' First see if we have any remaining words that should be added to the previous lineIf objWord.FirstIndex - intLinePos > 0 Then' See if we need to expand the arrayIf UBound(strReturn) < intLineNum Then' ReDim the ArrayReDim Preserve strReturn(intLineNum)End If' Save Previous LinestrReturn(intLineNum) = Mid(strLine, intLinePos + 1, objWord.FirstIndex - intLinePos)' Reset the Line PositionintLinePos = objWord.FirstIndex' Increment our line CounterintLineNum = intLineNum + 1End IflngPointSize = lngWordSize' Keep Looping until remaining text will fit on a line by itselfDo While lngPointSize > LineWidthInPoints' Calculate the new end Length (Try to get close to needed end so it does not loop too long)If (objWord.Length - intNumCharUsed) > 10 Then' Set our attempted end position. Figure out how much of the word we have left' and then take the percentage of that. The precantage being how far over' the line width we areintEndPosition = intLinePos + ((objWord.Length - intNumCharUsed) / CInt(lngPointSize / LineWidthInPoints))Else' We don't have too many characters Left so just go at them one at a timeintEndPosition = intLinePos + (objWord.Length - intNumCharUsed)End If' Recalculate the lengthlngPointSize = udtTextSize.TextWidthinPoints(Mid(strLine, intLinePos + 1, intEndPosition - intLinePos))If lngPointSize <= LineWidthInPoints Then' Keep Looping until we are one past it fitting on the lineDo While lngPointSize <= LineWidthInPoints' This character would still fit, add one more characterintEndPosition = intEndPosition + 1' Recalculate the lengthlngPointSize = udtTextSize.TextWidthinPoints(Mid(strLine, intLinePos + 1, intEndPosition - intLinePos))Loop' Take away the one extra character to go back to the last one that fitintEndPosition = intEndPosition - 1Else' Still too big' Keep removing one character until it fitsDo While lngPointSize > LineWidthInPoints' Did not fit, go back one characterintEndPosition = intEndPosition - 1' Recalculate the lengthlngPointSize = udtTextSize.TextWidthinPoints(Mid(strLine, intLinePos + 1, intEndPosition - intLinePos))LoopEnd If' Calculate how many characters were addedintNumCharUsed = intNumCharUsed + (intEndPosition - intLinePos)' See if we need to expand the arrayIf UBound(strReturn) < intLineNum Then' ReDim the ArrayReDim Preserve strReturn(intLineNum)End If' Since we made it this far, we know this text fits. Add it nowstrReturn(intLineNum) = Mid(strLine, intLinePos + 1, intEndPosition - intLinePos)' Reset the Line PositionintLinePos = intEndPosition' Increment our line CounterintLineNum = intLineNum + 1' Now Calculate how big the next line is when we add the remaining text and try againlngPointSize = udtTextSize.TextWidthinPoints(Mid(strLine, intLinePos + 1, objWord.FirstIndex - intLinePos + objWord.Length))LoopElse' This word is smaller than the line width. Check the width if we add itlngPointSize = udtTextSize.TextWidthinPoints(Mid(strLine, intLinePos + 1, objWord.FirstIndex - intLinePos + objWord.Length))If lngPointSize > LineWidthInPoints Then' It did not fit. Add previous text to array' See if we need to expand the arrayIf UBound(strReturn) < intLineNum Then' ReDim the ArrayReDim Preserve strReturn(intLineNum)End If' This word will not fit on current Line. Save Current LinestrReturn(intLineNum) = Mid(strLine, intLinePos + 1, objWord.FirstIndex - intLinePos)' Reset the Line PositionintLinePos = objWord.FirstIndex' Increment our line CounterintLineNum = intLineNum + 1End IfEnd IfNext' ------------------------------------' See if there is any text yet to add' ------------------------------------If (Len(strLine) - intLinePos) > 0 Then' See if we need to expand the arrayIf UBound(strReturn) < intLineNum Then' ReDim the ArrayReDim Preserve strReturn(intLineNum)End If' Save of the Last bits of DatastrReturn(intLineNum) = Right(strLine, Len(strLine) - intLinePos)' Increment our line CounterintLineNum = intLineNum + 1End IfElse' ------------------------------------' The entire line fits. Add it now' ------------------------------------' See if we need to expand the arrayIf UBound(strReturn) < intLineNum Then' ReDim the ArrayReDim Preserve strReturn(intLineNum)End IfstrReturn(intLineNum) = strLine' Increment our line CounterintLineNum = intLineNum + 1End IfNext' Return our ArrayWordWrapByPointToArray = strReturnRelease:On Error Resume NextErase strReturnSet udtTextSize = NothingSet objWordList = NothingSet objWord = NothingSet objRegExp = NothingExit FunctionWordWrapByPointToArray_Error:MsgBox "Procedure = WordWrapByPointToArray" & vbCrLf & _"Error Number = " & Err.Number & vbCrLf & _"Error Message = " & Err.Description & vbCrLf, _vbCritical Or vbSystemModal, "Word Wrap Error"Resume Release: End Function

WordWrapByPointToString Function

WordWrapByPointToString函數(shù)

Here is the fourth attempt at a function. ?To use this function, send it the text that you want word wrapped, the font used, and how wide the line should be in points. ?It will return a single string with each line in the string separated by a carriage return.

這是功能的第四次嘗試。 要使用此功能，請向其發(fā)送要自動(dòng)換行的文本，使用的字體以及線的寬度（以磅為單位）。 它將返回單個(gè)字符串，字符串中的每一行都用回車符分隔。

Example:

例：

Dim strWrappedLines As String strWrappedLines = WordWrapByPointToString(TextToWrap:=TextBox1.Text, TextFont:=TextBox1.Font, LineWidthInPoints:=TextBox1.Width - 6) Debug.Print strWrappedLines '--------------------------------------------------------------------------------------- ' Function : WordWrapByPointToString ' Date : 03/20/2012 ' By : Barry Versaw ' Purpose : Will Return a String of data that has been sepearated into lines ' based on Width in Points and split according to textbox word wrap rules. ' Each line is separated by a carriage return & line feed ' *** MUST have a REFERENCE set for Microsoft VBScript Regular Expression 5.5 ' *** Must also have the DetermineTextSize Class added to the project*** ' ' Usage : Set a string array = to WordWrapByPointToString sending WordWrapByPointToString ' your text, Font and Line Width (Point Size) for each line ' Example: ' Dim strWrappedLines as string ' strWrappedLines = WordWrapByPointToString(TextToWrap:=TextBox1.Text, TextFont:=TextBox1.Font, LineWidthInPoints:=TextBox1.Width - 6) ' This will break the string into multiple lines at the same point as the text box ' ' Please note in the example I take 6 away form TextBox1.Width as this appears to be ' the margin size of a text box. I found this through trial and error and have not ' been able to verify that value. '--------------------------------------------------------------------------------------- ' Public Function WordWrapByPointToString(ByVal TextToWrap As String, _ByVal TextFont As StdFont, ByVal LineWidthInPoints As Single) As StringOn Error GoTo WordWrapByPointToString_Error:Dim objRegExp As VBScript_RegExp_55.RegExpDim objWordList As VBScript_RegExp_55.MatchCollectionDim objWord As VBScript_RegExp_55.MatchDim udtTextSize As DetermineTextSizeDim strStartGroup As StringDim strEndGroup As StringDim strRegPattern As StringDim intLineNum As Integer: intLineNum = 0Dim intLinePos As IntegerDim intEndPosition As IntegerDim strReturn As StringDim strLineData() As StringDim strLine As VariantDim lngPointSize As LongDim lngWordSize As LongDim intNumCharUsed As Integer' Instantiate RegExSet objRegExp = New VBScript_RegExp_55.RegExpSet udtTextSize = New DetermineTextSize' ------------------------------------' Set Set Font Settings' ------------------------------------' Make sure we were sent a good line widthIf LineWidthInPoints < 1 Then' Return an ErrorErr.Raise Number:=vbObjectError + 605, Description:="Requested Line Width in Points must be greater than 0"End If' ------------------------------------' Set Set Font Settings' ------------------------------------udtTextSize.Font = TextFont' ------------------------------------' Set RegEx Settings' ------------------------------------objRegExp.MultiLine = FalseobjRegExp.Global = True' ------------------------------------' Set the Search Pattern' ------------------------------------' This is the RegEx List for Characters that should be grouped with the text that follows them' ${(<[\ - Have to use escape character "\" for ] and \strStartGroup = "${(<\[\\"' This is the RegEx List for Characters that should be grouped with the text the preceeds them' !)}%>?-] - Have to use escape character "\" for - and ]strEndGroup = "!)}%>?\-\]"' [] = Group. Find Anything listed in this group. ? = Find 0 to 1 instancesstrRegPattern = "[" & strStartGroup & "]?"' Now grab all characters that are not part of special list and no spaces \s' [] = Group. Find Anything listed in this group. + = Find 1 to many instances.' Equates to finding whole words including some special characters (those not in list since negative comparison)strRegPattern = strRegPattern & "[^\s" & strStartGroup & strEndGroup & "]+"' [] = Group. Find Anything listed in this group. ? = Find 0 to 1 instancesstrRegPattern = strRegPattern & "[" & strEndGroup & "]?"objRegExp.Pattern = strRegPattern' ------------------------------------' Break up Original String into already defined lines' ------------------------------------strLineData = Split(TextToWrap, vbLf)' ------------------------------------' Loop through each line to wrap text if needed' ------------------------------------For Each strLine In strLineData' Reset the Line Position for this set of textintLinePos = 0' Make sure the line is long enough to need to be wrappedIf udtTextSize.TextWidthinPoints(strLine) > LineWidthInPoints Then' ------------------------------------' Get the list of words defined by the Pattern' ------------------------------------Set objWordList = objRegExp.Execute(strLine)' ------------------------------------' Build the Return Array' ------------------------------------For Each objWord In objWordListlngWordSize = udtTextSize.TextWidthinPoints(objWord.Value)' See if this word is too big to FitIf lngWordSize > LineWidthInPoints Then' Word is too big for the line, have to break it appart' Reset the Number of Characters used in this word to 0intNumCharUsed = 0' First see if we have any remaining words that should be added to the previous lineIf objWord.FirstIndex - intLinePos > 0 Then' Save Previous LinestrReturn = strReturn & (Mid(strLine, intLinePos + 1, objWord.FirstIndex - intLinePos) & vbNewLine)' Reset the Line PositionintLinePos = objWord.FirstIndex' Increment our line CounterintLineNum = intLineNum + 1End IflngPointSize = lngWordSize' Keep Looping until remaining text will fit on a line by itselfDo While lngPointSize > LineWidthInPoints' Calculate the new end Length (Try to get close to needed end so it does not loop too long)If (objWord.Length - intNumCharUsed) > 10 Then' Set our attempted end position. Figure out how much of the word we have left' and then take the percentage of that. The precantage being how far over' the line width we areintEndPosition = intLinePos + ((objWord.Length - intNumCharUsed) / CInt(lngPointSize / LineWidthInPoints))Else' We don't have too many characters Left so just go at them one at a timeintEndPosition = intLinePos + (objWord.Length - intNumCharUsed)End If' Recalculate the lengthlngPointSize = udtTextSize.TextWidthinPoints(Mid(strLine, intLinePos + 1, intEndPosition - intLinePos))If lngPointSize <= LineWidthInPoints Then' Keep Looping until we are one past it fitting on the lineDo While lngPointSize <= LineWidthInPoints' This character would still fit, add one more characterintEndPosition = intEndPosition + 1' Recalculate the lengthlngPointSize = udtTextSize.TextWidthinPoints(Mid(strLine, intLinePos + 1, intEndPosition - intLinePos))Loop' Take away the one extra character to go back to the last one that fitintEndPosition = intEndPosition - 1Else' Still too big' Keep removing one character until it fitsDo While lngPointSize > LineWidthInPoints' Did not fit, go back one characterintEndPosition = intEndPosition - 1' Recalculate the lengthlngPointSize = udtTextSize.TextWidthinPoints(Mid(strLine, intLinePos + 1, intEndPosition - intLinePos))LoopEnd If' Calculate how many characters were addedintNumCharUsed = intNumCharUsed + (intEndPosition - intLinePos)' Since we made it this far, we know this text fits. Add it nowstrReturn = strReturn & (Mid(strLine, intLinePos + 1, intEndPosition - intLinePos) & vbNewLine)' Reset the Line PositionintLinePos = intEndPosition' Increment our line CounterintLineNum = intLineNum + 1' Now Calculate how big the next line is when we add the remaining text and try againlngPointSize = udtTextSize.TextWidthinPoints(Mid(strLine, intLinePos + 1, objWord.FirstIndex - intLinePos + objWord.Length))LoopElse' This word is smaller than the line width. Check the width if we add itlngPointSize = udtTextSize.TextWidthinPoints(Mid(strLine, intLinePos + 1, objWord.FirstIndex - intLinePos + objWord.Length))If lngPointSize > LineWidthInPoints Then' It did not fit. Add previous text to array' This word will not fit on current Line. Save Current LinestrReturn = strReturn & (Mid(strLine, intLinePos + 1, objWord.FirstIndex - intLinePos) & vbNewLine)' Reset the Line PositionintLinePos = objWord.FirstIndex' Increment our line CounterintLineNum = intLineNum + 1End IfEnd IfNext' ------------------------------------' See if there is any text yet to add' ------------------------------------If (Len(strLine) - intLinePos) > 0 Then' Save of the Last bits of DatastrReturn = strReturn & (Right(strLine, Len(strLine) - intLinePos) & vbNewLine)' Increment our line CounterintLineNum = intLineNum + 1End IfElse' ------------------------------------' The entire line fits. Add it now' ------------------------------------strReturn = strReturn & (strLine & vbNewLine)' Increment our line CounterintLineNum = intLineNum + 1End IfNext' Return our StringWordWrapByPointToString = strReturnRelease:On Error Resume NextSet udtTextSize = NothingSet objWordList = NothingSet objWord = NothingSet objRegExp = NothingExit FunctionWordWrapByPointToString_Error:MsgBox "Procedure = WordWrapByPointToString" & vbCrLf & _"Error Number = " & Err.Number & vbCrLf & _"Error Message = " & Err.Description & vbCrLf, _vbCritical Or vbSystemModal, "Word Wrap Error"Resume Release: End Function

DetermineTextSize Class

確定文本大小類

Both of the above functions require the following code to be added as a class to your project. ?Please name the class DetermineTextSize. ?To add a class, on the menu click Insert >>?Class Module. ?Then in the properties change the name to DetermineTextSize. ?Then in the code window paste the following code:

以上兩個(gè)功能都需要將以下代碼作為類添加到您的項(xiàng)目中。 請將該類命名為DefineTextSize。 要添加類，請?jiān)诓藛紊蠁螕舨迦?gt;>類模塊。 然后在屬性中將名稱更改為確定文本大小。 然后在代碼窗口中粘貼以下代碼：

'--------------------------------------------------------------------------------------- ' Class : DetermineTextSize ' PURPOSE : This class accepts a font and the determines the size of the passed text. ' It can return the Text Height or Width in Pixels or ' The Text Height or Width in Points ' ' This code is adapted from several posts on the web '-----------------------Option Explicit' Declare all Needed Windows Constants Private Const LF_FACESIZE = 32 Private Const LOGPIXELSY = 90 Private Const LOGPIXELSX = 88 Private Const DT_CALCRECT = &H400' See - http://msdn.microsoft.com/en-us/library/dd145037%28v=vs.85%29.aspx Private Type udtLogFontlfHeight As LonglfWidth As LonglfEscapement As LonglfOrientation As LonglfWeight As LonglfItalic As BytelfUnderline As BytelfStrikeOut As BytelfCharSet As BytelfOutPrecision As BytelfClipPrecision As BytelfQuality As BytelfPitchAndFamily As BytelfFaceName(LF_FACESIZE) As Byte End TypePrivate Type udtTextSizeWidth As LongHeight As Long End TypePrivate Declare Function GetTextExtentPoint Lib "gdi32" _Alias "GetTextExtentPointA" (ByVal hDC As Long, _ByVal lpszString As String, ByVal cbString As Long, _lpSIZE32 As udtTextSize) As LongPrivate Declare Function CreateFontIndirect Lib "gdi32" Alias "CreateFontIndirectA" _(ByRef lpudtLogFont As udtLogFont) As LongPrivate Declare Function GetDC Lib "user32.dll" _(ByVal hWnd As Long) As LongPrivate Declare Function ReleaseDC Lib "user32.dll" _(ByVal hWnd As Long, ByVal hDC As Long) As LongPrivate Declare Function MulDiv Lib "kernel32" ( _ByVal nNumber As Long, ByVal nNumerator As Long, _ByVal nDenominator As Long) As LongPrivate Declare Function DeleteObject Lib "gdi32" _(ByVal hObject As Long) As LongPrivate Declare Function GetDeviceCaps Lib "gdi32" _(ByVal hDC As Long, ByVal nIndex As Long) As LongPrivate Declare Function SelectObject Lib "gdi32" _(ByVal hDC As Long, ByVal hObject As Long) As LongPrivate m_objFont As StdFont ' Store Font Settings to be used for calculations Private m_hDeviceContext As Long ' Store the handler for the Device Context Private m_intDPIWidth As Integer ' Store the DPI Width - just calculate once Private m_intDPIHeight As Integer ' Store the DPI Height - just calculate once'--------------------------------------------------------------------------------------- ' Procedure : Class_Initialize ' Purpose : Class has been Declared. Set Default Values '--------------------------------------------------------------------------------------- ' Private Sub Class_Initialize()' Instantiate the Font ObjectSet m_objFont = New StdFont' Get Access to A Device Context for the general screenm_hDeviceContext = GetDC(0)' Grab the Screen DPI Settingsm_intDPIWidth = GetDeviceCaps(m_hDeviceContext, LOGPIXELSX)m_intDPIHeight = GetDeviceCaps(m_hDeviceContext, LOGPIXELSY) End Sub'--------------------------------------------------------------------------------------- ' Procedure : Class_Terminate ' Purpose : Class is being Destroyed. Release objects '--------------------------------------------------------------------------------------- ' Private Sub Class_Terminate()Set m_objFont = NothingEnd Sub'--------------------------------------------------------------------------------------- ' Property : Font ' Purpose : Gets & Lets the Font to be used in sizing the text '--------------------------------------------------------------------------------------- ' Public Property Get Font() As StdFontFont = m_objFontReleaseDC 0, m_hDeviceContextEnd PropertyPublic Property Let Font(ByVal FontValue As StdFont)Set m_objFont = FontValueEnd Property'--------------------------------------------------------------------------------------- ' Procedure : TextHeightInPixels ' Purpose : Returns the Height of sent text in pixels '--------------------------------------------------------------------------------------- Public Function TextHeightInPixels(ByVal TextToEvaluate As String) As LongDim udtSize As udtTextSize' Get the Size of the Text in Height & WidthudtSize = GetSizeOfText(TextToEvaluate)' .Bottom Returns how high the rectangle is in pixelsTextHeightInPixels = udtSize.Height End Function'--------------------------------------------------------------------------------------- ' Procedure : TextHeightInPoints ' Purpose : Returns the Height of sent text in Points '--------------------------------------------------------------------------------------- Public Function TextHeightInPoints(ByVal TextToEvaluate As String) As LongDim udtSize As udtTextSize' Get the Size of the Text in Height & WidthudtSize = GetSizeOfText(TextToEvaluate)' .Bottom Returns how high the rectangle is in pixels' Pionts = Pixels * 72 / DPI : 72 Points Per Inch' Use MulDiv to avoid potential overflow errorTextHeightInPoints = MulDiv(udtSize.Height, 72, m_intDPIHeight)End Function'--------------------------------------------------------------------------------------- ' Procedure : TextWidthInPixels ' Purpose : Returns the width of sent text in pixels. If the text has ' multiple lines, it returns the width of the widest line. '--------------------------------------------------------------------------------------- Public Function TextWidthInPixels(ByVal TextToEvaluate As String) As LongDim udtSize As udtTextSize' Get the Size of the Text in Height & WidthudtSize = GetSizeOfText(TextToEvaluate)' Width is the Right Dimension of the RectangleTextWidthInPixels = udtSize.WidthEnd Function'--------------------------------------------------------------------------------------- ' Procedure : TextWidthInPoints ' Purpose : Returns the width of sent text in Points. If the text has ' multiple lines, it returns the width of the widest line. '--------------------------------------------------------------------------------------- Public Function TextWidthinPoints(ByVal TextToEvaluate As String) As LongDim udtSize As udtTextSize' Get the Size of the Text in Height & WidthudtSize = GetSizeOfText(TextToEvaluate)' Width is the Right Dimension of the Rectangle' Pionts = Pixels * 72 / DPI : 72 Points Per Inch' Use MulDiv to avoid potential overflow errorTextWidthinPoints = MulDiv(udtSize.Width, 72, m_intDPIWidth)End Function'--------------------------------------------------------------------------------------- ' Procedure : GetudtTextSize ' Purpose : Gets udtLogFont size of a string and returns it as ' Width ane Length Dimension '--------------------------------------------------------------------------------------- ' Private Function GetSizeOfText(ByVal TextToSize As String) As udtTextSizeDim udtFont As udtLogFontDim hFont As Long ' Handle to a Logical FontDim hOldFont As Long ' Handle to a Logcial FontDim udtReturnDims As udtTextSize' Convert the stdFont to a udtLogFont for use in drawing the RectangleudtFont = OLEFontToLogFont(m_objFont)' Create a temporary Font to draw the RectanglehFont = CreateFontIndirect(udtFont)' Store the Current Font to put back when donehOldFont = SelectObject(m_hDeviceContext, hFont)' Draw the RectangleGetTextExtentPoint m_hDeviceContext, TextToSize, Len(TextToSize), udtReturnDims' Put the Original Font Back in PlaceSelectObject m_hDeviceContext, hOldFont' Delete our Temporary FontDeleteObject hFont' Return the DimensionsGetSizeOfText = udtReturnDimsEnd Function'--------------------------------------------------------------------------------------- ' Procedure : OLEFontToLogFont ' Purpose : Converts an OLE stdFont to a udtLogFont '--------------------------------------------------------------------------------------- Private Function OLEFontToLogFont(ByVal FontToConvert As StdFont) As udtLogFontDim strFont As StringDim intChar As IntegerDim bytFont() As ByteWith OLEFontToLogFontstrFont = FontToConvert.NamebytFont = StrConv(strFont, vbFromUnicode)For intChar = 0 To Len(strFont) - 1.lfFaceName(intChar) = bytFont(intChar)Next intChar' Convert Height from Points to Pixels' Use MulDiv to avoid potential overflow error.lfHeight = -MulDiv(FontToConvert.Size, m_intDPIHeight, 72).lfItalic = FontToConvert.Italic.lfWeight = FontToConvert.Weight.lfUnderline = FontToConvert.Underline.lfStrikeOut = FontToConvert.Strikethrough.lfCharSet = FontToConvert.CharsetEnd WithEnd Function

翻譯自: https://www.experts-exchange.com/articles/10064/The-end-of-a-pilgrimage-to-find-a-more-robust-WordWrap-function.html

一個(gè)人的朝圣深度感悟

總結(jié)

以上是生活随笔為你收集整理的一个人的朝圣深度感悟_朝圣之末找到更强大的WordWrap函数的全部內(nèi)容，希望文章能夠幫你解決所遇到的問題。

如果覺得生活随笔網(wǎng)站內(nèi)容還不錯(cuò)，歡迎將生活随笔推薦給好友。