1 Attachment(s)
Coding shows "Type mismatch" error
One of my friend has created a below coding for me.
Code:
Sub Demo()
Dim i As Long, j As Long, k As Long, t As Single, SngFnt As Single, ArrWdth() As Single
Dim ArrChr As String, StrTmp As String, StrTxt As String, StrFnd As String, StrRep As String
'String Array. As coded, holds character widths for 10pt Arial.
ArrChr = " 2.50 ! 3.35 " & Chr(34) & "4.10 # 5.00 $ 5.00 % 8.25 & 7.75 ' 1.75 ( 3.35 ) 3.35 " & _
"* 5.00 + 5.60 , 2.55 - 3.35 . 2.55 / 2.80 0 5.00 1 5.00 2 5.00 3 5.00 4 5.00 5 5.00 " & _
"6 5.00 7 5.00 8 5.00 9 5.00 : 2.80 ; 2.80 < 5.60 = 5.60 > 5.60 ? 4.45 @ 9.15 A 7.20 " & _
"B 6.65 C 6.65 D 7.20 E 6.10 F 5.55 G 7.20 H 7.20 I 3.35 J 3.90 K 7.20 L 6.10 M 8.85 " & _
"N 7.20 O 7.20 P 5.55 Q 7.20 R 6.65 S 5.55 T 6.10 U 7.20 V 7.20 W 9.45 X 7.20 Y 7.20 " & _
"Z 6.10 [ 3.35 \ 2.75 ] 3.35 ^ 4.70 _ 5.00 ` 3.35 a 4.45 b 5.00 c 4.45 d 5.00 e 4.45 " & _
"f 3.35 g 5.00 h 5.00 i 2.80 j 2.80 k 5.00 l 2.80 m 7.75 n 5.00 o 5.00 p 5.00 q 5.00 " & _
"r 3.35 s 3.90 t 2.80 u 5.00 v 5.00 w 7.20 x 5.00 y 5.00 z 4.45 { 4.80 | 1.95 } 4.80 ~ 5.45 "
'Input the font size & divide by 10 for scaling the output
SngFnt = 12 / 10
'Initialize the output String-width array
ReDim Preserve ArrWdth(1)
'Initialize the Find String
StrFnd = "(^13*)"
With ActiveDocument.Range
' Loop through all paragraphs
For i = 1 To .Paragraphs.Count
'Get the paragraph text, minus the paragraph marker
StrTmp = .Paragraphs(i).Range.Text
StrTmp = Left(StrTmp, Len(StrTmp) - 1)
'Redim the output String-width array, as necessary
If UBound(Split(StrTmp, vbTab)) > UBound(ArrWdth) Then
ReDim Preserve ArrWdth(UBound(Split(StrTmp, vbTab)))
End If
'Process each tab-separated block, ignoring the first one
For j = 1 To UBound(Split(StrTmp, vbTab))
StrTxt = Split(StrTmp, vbTab)(j)
'If there's a decimal number, trim to the last digit
'If InStr(StrTxt, ".") > 0 Then
If StrTxt Like "*.[0-9]*" Then
While Not IsNumeric(Right(StrTxt, 1))
StrTxt = Left(StrTxt, Len(StrTxt) - 1)
Wend
End If
'Calculate the string width, based on a 10pt font
t = 0
For k = 1 To Len(StrTxt)
t = t + Split(Split(ArrChr, " " & Mid(StrTxt, k, 1) & " ")(1), " ")(0)
Next
'Re-scale the calculation for the required point size
t = t * SngFnt
'Update the output String-width array
If t > ArrWdth(j) Then ArrWdth(j) = t
Next
Next
'Parse the string to be updated
'StrTmp = Split(.Paragraphs.First.Range.Text, vbTab)(0)
For i = 1 To .Paragraphs.Count
If UBound(Split(.Paragraphs(i).Range.Text, vbTab)) = UBound(ArrWdth) Then
'Parse the string to be updated
StrTmp = Split(.Paragraphs(i).Range.Text, vbTab)(0)
Exit For
End If
Next
'Split at ',")'
j = UBound(Split(StrTmp, Chr(44) & Chr(148) & ")")) - 1
For i = 0 To j
StrTxt = Split(StrTmp, Chr(44) & Chr(148) & ")")(i)
If i = 0 Then
'For the first item, re-split at '('
StrTxt = Right(StrTxt, Len(StrTxt) - InStrRev(StrTxt, "("))
Else
'For the remaining items, re-split at '"'
StrTxt = Right(StrTxt, Len(StrTxt) - InStrRev(StrTxt, Chr(147)))
End If
'Update the Find expression
StrFnd = StrFnd & StrTxt & "(*)"
Next
'Finalize the Find string
StrFnd = Left(StrFnd, Len(StrFnd) - 3) & "([!^13]{1,})"
'Add the 'master' width to the output String-width array
ReDim Preserve ArrWdth(j + 2)
ArrWdth(j + 2) = StrTxt
'Re-calculate the output String-width array elements
For i = UBound(ArrWdth) - 1 To 0 Step -1
ArrWdth(i) = ArrWdth(i + 1) - ArrWdth(i) - 10
Next
'Generate the Replace string
For i = 1 To UBound(ArrWdth) - 1
StrRep = StrRep & "\" & i & Round(ArrWdth(i + 1), 0)
Next
'Finalize the Replace string
StrRep = StrRep & "\" & i
'Add a temporary paragraph at the start of the document
.InsertBefore vbCr
'Update the document
With .Find
.ClearFormatting
.Replacement.ClearFormatting
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchWildcards = True
.Text = StrFnd
.Replacement.Text = StrRep
.execute replace:=wdReplaceAll
End With
'Delete the temporary paragraph at the start of the document
.Characters.First = vbNullString
End With
End Sub
The macro do the following.
1. Find out each and every character width from the Tab Delimited Text from the given Array. Character width is calculated (From Tab upto the numeric value except the hanging characters i.e., “)”, “*”, “%” etc.,)
2. Find out the maximum width of the each column.
3. Minus it with the values which is available on the Starting of the Paragraph and
4. Replace the Value
Coding Runs from the last column to the first column.
But the macro throws “Type mismatch” error (Highlighted in the Coding). At present I am unable to contact my friend.
I doesn’t know Visual Basic.
So if any one fix this Error. It will be greatly appreciated.
Sample data attached for your reference
Thanks in advance,
Joe
Re: Coding shows "Type mismatch" error
Well, I am not a guru in VB, but it doesn't prevent me to look for this type of error in MSDN. For instance here:
Quote:
Type mismatch (Visual Basic)
...
You attempted to convert a value to another type in a way that is not valid.
So why do you attempt to convert String to single (which is a 32-bit float)? :confused: