|
半角に成る文字が1つも無い場合、エラーに成るので修正しました
Public Function GetPurpose(ByVal strMark As String) As String
Dim i As Long
Dim lngIndex As Long
Dim bytResult() As Byte
Dim strLetter As String
Dim bytLetter() As Byte
Dim blnWide As Boolean
Dim strReplace As String
Dim bytReplace() As Byte
If strMark = "" Then
Exit Function
End If
strMark = StrConv(strMark, vbNarrow)
strReplace = StrConv("-", vbFromUnicode)
bytReplace = strReplace
For i = 1 To Len(strMark)
strLetter = StrConv(Mid(strMark, i, 1), vbFromUnicode)
If LenB(strLetter) <> 2 And strLetter <> strReplace Then
blnWide = False
bytLetter = strLetter
ReDim Preserve bytResult(lngIndex)
bytResult(lngIndex) = bytLetter(0)
lngIndex = lngIndex + 1
Else
If Not blnWide Then
blnWide = True
ReDim Preserve bytResult(lngIndex)
bytResult(lngIndex) = bytReplace(0)
lngIndex = lngIndex + 1
End If
End If
Next i
If blnWide Then
lngIndex = lngIndex - 2
Else
lngIndex = lngIndex - 1
End If
If lngIndex > -1 Then
ReDim Preserve bytResult(lngIndex)
GetPurpose = StrConv(bytResult, vbUnicode)
End If
End Function
|
|