2013年01月13日

バイト数を用いる文字列関数(改造版)

バイト数を用いる文字列関数 に関し、全角途中の指定時に取得した文字列に文字化けが発生するという指摘があったので、全角途中を指定された場合に半角スペースを挿入するように改造してみました。


VB や VBA の文字列関数である Left、Len、Mid、Right は全角文字でも半角文字でも 1文字と計算されてしまいます。

昔のように(?)、半角は 1バイト、全角は 2バイトとなる関数が欲しいと思ったことはないでしょうか?

例えば、全半角混在の固定長テキストファイルからある一部分(mバイト目から長さ nバイト)を切り出すようなことってありませんか?

通常の Left、Len、Mid、Right のような感覚で使える関数が欲しいと思って作成しました。

ascii_string2.txt






' @(f)
'
' 機能 : ASCIIでのLeftB
'
' 返り値 : 文字列
'
' 引き数 : ARG1 - 文字列(Unicode)
' ARG2 - (ASCIIでの)文字列長
'
' 機能説明 : 文字列の左端からASCIIコードでのバイト数分の文字列を返す。
'
' 備考 :
'
Public Function pAsciiLeftB(ByVal strValue As String, _
ByVal intLength As Integer) As String
Dim intValueLength As Integer

intValueLength = pAsciiLenB(strValue)

If intLength <= 0 Then
pAsciiLeftB = ""
ElseIf intValueLength > intLength Then
pAsciiLeftB = pAsciiMidB(strValue, 1, intLength)
Else
pAsciiLeftB = strValue
End If
End Function

' @(f)
'
' 機能 : ASCIIバイト長取得
'
' 返り値 : バイト長
'
' 引き数 : ARG1 - 文字列(Unicode)
'
' 機能説明 : ASCIIコードでのバイト長を返す。
'
' 備考 :
'
Public Function pAsciiLenB(ByVal strValue As String) As Integer
pAsciiLenB = LenB(StrConv(strValue, vbFromUnicode))
End Function

' @(f)
'
' 機能 : ASCIIでのMidB
'
' 返り値 : 文字列
'
' 引き数 : ARG1 - 文字列(Unicode)
' ARG2 - (ASCIIでの)開始位置
' ARG3 - (ASCIIでの)文字列長(省略可)
'
' 機能説明 : 文字列のASCIIコードでの開始位置からバイト数分の文字列を返す。
'
' 備考 :
'
Public Function pAsciiMidB(ByVal strValue As String, _
ByVal intStart As Integer, _
Optional ByVal varLength As Variant) As String
Dim intValueLength As Integer
Dim intMaxLength As Integer
Dim strRet As String
Dim i As Integer
Dim intLeftlength As Integer
Dim strChar1 As String

intValueLength = pAsciiLenB(strValue)

If intValueLength >= intStart Then
intMaxLength = intValueLength - intStart + 1
If IsMissing(varLength) Then
varLength = intMaxLength
ElseIf varLength > intMaxLength Then
varLength = intMaxLength
ElseIf varLength <= 0 Then
pAsciiMidB = ""
Exit Function
End If
strRet = ""
For i = 1 To Len(strValue)
intLeftlength = pAsciiLenB(Left(strValue, i))
If intLeftlength >= intStart Then
strChar1 = Mid(strValue, i, 1)
If strRet = "" And _
intLeftlength = intStart And _
pAsciiLenB(strChar1) > 1 Then
' 開始位置の全角途中指定時の補正
strRet = " "
Else
strRet = strRet & strChar1
End If
If pAsciiLenB(strRet) > varLength Then
' 文字列長の全角途中指定時の補正
strRet = Left(strRet, Len(strRet) - 1) & " "
End If
If pAsciiLenB(strRet) >= varLength Then
Exit For
End If
End If
Next i
pAsciiMidB = strRet
Else
pAsciiMidB = ""
End If
End Function

' @(f)
'
' 機能 : ASCIIでのRightB
'
' 返り値 : 文字列
'
' 引き数 : ARG1 - 文字列(Unicode)
' ARG2 - (ASCIIでの)文字列長
'
' 機能説明 : 文字列の右端からASCIIコードでのバイト数分の文字列を返す。
'
' 備考 :
'
Public Function pAsciiRightB(ByVal strValue As String, _
ByVal intLength As Integer) As String
Dim intValueLength As Integer

intValueLength = pAsciiLenB(strValue)

If intLength <= 0 Then
pAsciiRightB = ""
ElseIf intValueLength > intLength Then
pAsciiRightB = pAsciiMidB(strValue, intValueLength - intLength + 1)
Else
pAsciiRightB = strValue
End If
End Function

2009年06月27日

文字列の固定長編集関数

全半角混在の文字列を固定長テキストファイルへ出力する時に、空白などを埋めるのが面倒だと感じたことありませんか?

昔のように(?)、半角は 1バイト、全角は 2バイトと計算し、編集するバイト長を与えて固定長文字列を編集する関数を作成しました。

下記ソース中の pAsciiLenB、pAsciiRightB、pAsciiLeftB「バイト数を用いる文字列関数」をごらん下さい。

また pNzも末尾に書いてありますが、このプロシージャは Microsoft AccessNz関数を VBで使用できるように作成したものです。

fix_string.txt




'' (文字列固定長編集用)文字詰方向
Public Enum Enum_EDITFIXSTRING_DIRECTION
EDITFIXSTRING_DIRECTION_LEFT ''' 左詰
EDITFIXSTRING_DIRECTION_RIGHT ''' 右詰
End Enum


' @(f)
'
' 機能 : 文字列固定長編集
'
' 返り値 : 編集後の文字列
'
' 引き数 : ARG1 - 文字列
' ARG2 - 編集後の文字長 ... ASCIIでのバイト長
' ARG3 - 文字詰方向 ... "R" - 右詰, 左記以外 - 左詰(規定値)
' ARG4 - 付加する文字 ... 規定値 " "
'
' 機能説明 : 文字列を与えられた文字長に左詰または右詰し、
' 残りの文字数を付加文字で埋める。
'
' 備考 :
'
Public Function pEditFixString(ByVal varValue As Variant, _
ByVal intLength As Integer, _
Optional ByVal enmDirection As Enum_EDITFIXSTRING_DIRECTION _
= EDITFIXSTRING_DIRECTION_LEFT, _
Optional ByVal strFillChar As String = " ") As String
Dim strWk As String
Dim intWkLen As Integer

strWk = pNz(varValue, ""): intWkLen = pAsciiLenB(strWk)
If intWkLen < intLength Then
If enmDirection = EDITFIXSTRING_DIRECTION_RIGHT Then
pEditFixString = _
pAsciiRightB(String(intLength, strFillChar) & strWk, _
intLength)
Else
pEditFixString = _
pAsciiLeftB(strWk & String(intLength, strFillChar), _
intLength)
End If
ElseIf intWkLen = intLength Then
pEditFixString = strWk
Else
If enmDirection = EDITFIXSTRING_DIRECTION_RIGHT Then
pEditFixString = pAsciiRightB(strWk, intLength)
Else
pEditFixString = pAsciiLeftB(strWk, intLength)
End If
End If
End Function

' @(f)
'
' 機能   : Nullの場合の値変更
'
' 返り値 : 元の値が Null の時は 初期値 を返し、
' Null以外の時は 元の値 を返す。
'
' 引き数  : ARG1 - 元の値
' ARG2 - 初期値(Nullの場合に返す値)
'
' 機能説明 : Null値の置き換え。
'
' 備考   :
'
Public Function pNz(ByVal varOriginalValue As Variant, _
ByVal varInitValue As Variant) As Variant
If IsNull(varOriginalValue) Then
pNz = varInitValue
Else
pNz = varOriginalValue
End If
End Function

バイト数を用いる文字列関数

VB や VBA の文字列関数である Left、Len、Mid、Right は全角文字でも半角文字でも 1文字と計算されてしまいます。

昔のように(?)、半角は 1バイト、全角は 2バイトとなる関数が欲しいと思ったことはないでしょうか?

例えば、全半角混在の固定長テキストファイルからある一部分(mバイト目から長さ nバイト)を切り出すようなことってありませんか?

StrConv関数を組み合わせているだけなんですが、通常の Left、Len、Mid、Right のような感覚で使える関数が欲しいと思って作成しました。

※全角途中指定時の補正を行う改造版を こちら に公開しています。

ascii_string.txt






' @(f)
'
' 機能 : ASCIIでのLeftB
'
' 返り値 : 文字列
'
' 引き数 : ARG1 - 文字列(Unicode)
' ARG2 - (ASCIIでの)文字列長
'
' 機能説明 : 文字列の左端からASCIIコードでのバイト数分の文字列を返す。
'
' 備考 :
'
Public Function pAsciiLeftB(ByVal strValue As String, _
ByVal intLength As Integer) As String
pAsciiLeftB = StrConv(LeftB(StrConv(strValue, vbFromUnicode), _
intLength), vbUnicode)
End Function

' @(f)
'
' 機能 : ASCIIバイト長取得
'
' 返り値 : バイト長
'
' 引き数 : ARG1 - 文字列(Unicode)
'
' 機能説明 : ASCIIコードでのバイト長を返す。
'
' 備考 :
'
Public Function pAsciiLenB(ByVal strValue As String) As Integer
pAsciiLenB = LenB(StrConv(strValue, vbFromUnicode))
End Function

' @(f)
'
' 機能 : ASCIIでのMidB
'
' 返り値 : 文字列
'
' 引き数 : ARG1 - 文字列(Unicode)
' ARG2 - (ASCIIでの)開始位置
' ARG3 - (ASCIIでの)文字列長(省略可)
'
' 機能説明 : 文字列のASCIIコードでの開始位置からバイト数分の文字列を返す。
'
' 備考 :
'
Public Function pAsciiMidB(ByVal strValue As String, _
ByVal intStart As Integer, _
Optional ByVal varLength As Variant) As String
If IsMissing(varLength) Then
pAsciiMidB = StrConv(MidB(StrConv(strValue, vbFromUnicode), _
intStart), vbUnicode)
Else
pAsciiMidB = StrConv(MidB(StrConv(strValue, vbFromUnicode), _
intStart, varLength), vbUnicode)
End If
End Function

' @(f)
'
' 機能 : ASCIIでのRightB
'
' 返り値 : 文字列
'
' 引き数 : ARG1 - 文字列(Unicode)
' ARG2 - (ASCIIでの)文字列長
'
' 機能説明 : 文字列の右端からASCIIコードでのバイト数分の文字列を返す。
'
' 備考 :
'
Public Function pAsciiRightB(ByVal strValue As String, _
ByVal intLength As Integer) As String
pAsciiRightB = StrConv(RightB(StrConv(strValue, vbFromUnicode), _
intLength), vbUnicode)
End Function

年齢計算関数

年齢を計算する関数を僕なりに作成したものです。

age.txt



' @(f)
'
' 機能 : 年齢 取得
'
' 返り値 : 年齢
'
' 引き数 : ARG1 - 生年月日
' ARG2 - 算出基準日
'
' 機能説明 : 年齢を計算・取得する。
'
' 備考 :
'
Public Function pGetAge(ByVal varBirthday As Variant, _
ByVal dtBaseYmd As Date) As Integer
If IsDate(varBirthday) Then
If Month(dtBaseYmd) * 100 + Day(dtBaseYmd) _
< Month(CDate(varBirthday)) * 100 + Day(CDate(varBirthday)) Then
pGetAge = DateDiff("yyyy", varBirthday, dtBaseYmd) - 1
Else
pGetAge = DateDiff("yyyy", varBirthday, dtBaseYmd)
End If
Else
pGetAge = 0
End If
End Function

月末日取得関数

月末日を取得する関数を僕なりに作成したものです(関数にするほどでもないか?)。

lastday.txt



' @(f)
'
' 機能   : 月末日取得
'
' 返り値  : 指定された年、月の月末日
'
' 引き数  : ARG1 - 年
'     ARG2 - 月
'
' 機能説明 : 月末日を算出する
'
' 備考   :
'
Public Function pGetLastDay(ByVal intY As Integer, _
ByVal intM As Integer) As Date
pGetLastDay = DateSerial(intY, intM + 1, 1) - 1
End Function

ドライブの列挙とドライブの種類

ドライブを列挙するプロシージャと、ドライブの種類を取得するプロシージャです。

drive.txt






'' ドライブ調査用
''' 判断不能
Public Const DRIVE_NODETERMINE_DRIVETYPE As Long = 0
''' ルートディレクトリなし
Public Const DRIVE_NOEXIST_ROOTDIRECTORY As Long = 1
''' 取り外し可能
Public Const DRIVE_REMOVABLE As Long = 2
''' 固定
Public Const DRIVE_FIXED As Long = 3
''' ネットワーク
Public Const DRIVE_REMOTE As Long = 4
''' CD-ROM
Public Const DRIVE_CDROM As Long = 5
''' RAMディスク
Public Const DRIVE_RAMDISK As Long = 6

Private Declare Function GetLogicalDriveStrings Lib "kernel32.dll" _
Alias "GetLogicalDriveStringsA" _
(ByVal nBufferLength As Long, _
ByVal lpBuffer As String) As Long
Private Declare Function GetDriveType Lib "kernel32" _
Alias "GetDriveTypeA" _
(ByVal nDrive As String) As Long

' @(f)
'
' 機能 : ドライブ 取得
'
' 返り値 : ドライブの文字の配列 (異常時は Null)
'
' 機能説明 : ドライブを取得しVariant配列にして返す。
'
' 備考 :
'
Public Function pGetDrives() As Variant
Dim strBuffer As String * 256
Dim strDrives As String

Call GetLogicalDriveStrings(Len(strBuffer), strBuffer)
strDrives = pGetStringFromAPI(strBuffer, String$(2, vbNullChar))
If strDrives = vbNullChar Or strDrives = "" Then
pGetDrives = Null
Else
pGetDrives = Split(strDrives, vbNullChar)
End If
End Function

' @(f)
'
' 機能 : ドライブ種類取得
'
' 返り値 : ドライブの種類 (上記 Public Const 参照)
'
' 機能説明 : ドライブの種類を返す。
'
' 備考 :
'
Public Function pGetDriveType(ByVal strDrive As String)
pGetDriveType = GetDriveType(strDrive)
End Function

' @(f)
'
' 機能   : APIの引数からの文字列取得
'
' 返り値  : 取得した文字列
'
' 引き数  : ARG1 - APIの引数の文字列
' ARG2 - 終端の文字 ... 既定値 vbNullChar
'
' 機能説明 : APIの引数で使用される文字列(Null文字が終端の固定長)から
' Accessで使用する文字列(可変長)を取得する
'
' 備考   :
'
Public Function pGetStringFromAPI(strApiString As String, _
Optional ByVal strEndChar As String = vbNullChar) As String
Dim intPos As Integer

intPos = InStr(1, strApiString, strEndChar)
If intPos > 0 Then
pGetStringFromAPI = Left(strApiString, intPos - 1)
Else
pGetStringFromAPI = strApiString
End If
End Function

設定(.ini)ファイルの読み書き

設定(.ini)ファイルの読み書きを行うプロシージャです。

使用するパソコンごとに異なる情報を保存しておきたい場合とか、データベースに持たせるほどではない程度のデータの定義とか、設定(.ini)ファイルの使い道って意外と多いと思います。

レジストリに情報を保存するほうが VB/VBA からは簡単にできますが、.iniというテキストファイルのほうが扱いやすいので、僕はほとんどレジストリを使用せずに設定(.ini)ファイルを使っています。

inifile.txt










'INIファイル用
Private Declare Function GetPrivateProfileInt Lib "kernel32" _
Alias "GetPrivateProfileIntA" _
(ByVal lpApplicationName As String, _
ByVal lpKeyName As String, _
ByVal nDefault As Long, _
ByVal lpFileName As String) As Long
Private Declare Function GetPrivateProfileString Lib "kernel32" _
Alias "GetPrivateProfileStringA" _
(ByVal lpApplicationName As String, _
ByVal lpKeyName As Any, _
ByVal lpDefault As String, _
ByVal lpReturnedString As String, _
ByVal nSize As Long, _
ByVal lpFileName As String) As Long
Private Declare Function GetPrivateProfileSection Lib "kernel32" _
Alias "GetPrivateProfileSectionA" _
(ByVal lpAppName As String, _
ByVal lpReturnedString As String, _
ByVal nSize As Long, _
ByVal lpFileName As String) As Long
Private Declare Function GetPrivateProfileSectionNames Lib "kernel32" _
Alias "GetPrivateProfileSectionNamesA" _
(ByVal lpReturnedString As String, _
ByVal nSize As Long, _
ByVal lpFileName As String) As Long
Private Declare Function WritePrivateProfileString Lib "kernel32" _
Alias "WritePrivateProfileStringA" _
(ByVal lpApplicationName As String, _
ByVal lpKeyName As Any, _
ByVal lpString As Any, _
ByVal lpFileName As String) As Long

' @(f)
'
' 機能   : APIの引数からの文字列取得
'
' 返り値  : 取得した文字列
'
' 引き数  : ARG1 - APIの引数の文字列
' ARG2 - 終端の文字 ... 既定値 vbNullChar
'
' 機能説明 : APIの引数で使用される文字列(Null文字が終端の固定長)から
' VBで使用する文字列(可変長)を取得する
'
' 備考   :
'
Public Function pGetStringFromAPI(strApiString As String, _
Optional ByVal strEndChar As String = vbNullChar) As String
Dim intPos As Integer

intPos = InStr(1, strApiString, strEndChar)
If intPos > 0 Then
pGetStringFromAPI = Left(strApiString, intPos - 1)
Else
pGetStringFromAPI = strApiString
End If
End Function

' @(f)
'
' 機能 : INIファイルの数値取得
'
' 返り値 : INIファイルの設定値(未設定時は ARG3 の値を返す)
'
' 引き数 : ARG1 - セクション名
' ARG2 - キー名
' ARG3 - 初期値
' ARG4 - INIファイル名
'
' 機能説明 : INIファイルから該当セクション、キーの数値を取得
'
' 備考 :
'
Public Function pGetIniNum(ByVal strSection As String, _
ByVal strKey As String, _
ByVal lngInit As Long, _
ByVal strIniFile As String) As Long
pGetIniNum = GetPrivateProfileInt( _
ByVal strSection & String$(128, vbNullChar), _
ByVal strKey & String$(128, vbNullChar), _
ByVal lngInit, _
ByVal strIniFile & String$(128, vbNullChar))
End Function

' @(f)
'
' 機能 : INIファイルの文字列値取得
'
' 返り値 : INIファイルの設定値(未設定時は ARG3 の値を返す)
'
' 引き数 : ARG1 - セクション名
' ARG2 - キー名
' ARG3 - 初期値
' ARG4 - INIファイル名
'
' 機能説明 : INIファイルから該当セクション、キーの文字列値を取得
'
' 備考 :
'
Public Function pGetIniString(ByVal strSection As String, _
ByVal strKey As String, _
ByVal strInit As String, _
ByVal strIniFile As String) As String
Dim strGetBuffer As String * 2048

Call GetPrivateProfileString( _
ByVal strSection & String$(128, vbNullChar), _
ByVal strKey & String$(128, vbNullChar), _
ByVal strInit & String$(128, vbNullChar), _
strGetBuffer, _
ByVal LenB(strGetBuffer) / 2, _
ByVal strIniFile & String$(128, vbNullChar))
pGetIniString = pGetStringFromAPI(strGetBuffer)
End Function

' @(f)
'
' 機能 : INIファイルのSection名全取得
'
' 返り値 : INIファイルのSection名の配列
'
' 引き数 : ARG1 - INIファイル名
'
' 機能説明 : INIファイルから該当セクションの全てのキーと値を取得
'
' 備考 : Section内に何もない時は Null を返す
'
Public Function pGetIniSectionNames(ByVal strIniFile As String) As Variant
Dim strGetBuffer As String * 32767
Dim strWkString As String

Call GetPrivateProfileSectionNames( _
strGetBuffer, _
ByVal LenB(strGetBuffer) / 2, _
ByVal strIniFile & String$(128, vbNullChar))
strWkString = pGetStringFromAPI(strGetBuffer, String$(2, vbNullChar))
If strWkString = vbNullChar Or strWkString = "" Then
pGetIniSectionNames = Null
Else
pGetIniSectionNames = Split(strWkString, vbNullChar)
End If
End Function

' @(f)
'
' 機能 : INIファイルのSection全取得
'
' 返り値 : INIファイルのSection内容
' ... キー、値、キー、値、・・・の配列
'
' 引き数 : ARG1 - セクション名
' ARG2 - INIファイル名
'
' 機能説明 : INIファイルから該当セクションの全てのキーと値を取得
'
' 備考 : Section内に何もない時は Null を返す
'
Public Function pGetIniSection(ByVal strSection As String, _
ByVal strIniFile As String) As Variant
Dim strGetBuffer As String * 32767
Dim strWkString As String
Dim varSectionItem As Variant
Dim varKeyAndValue As Variant
Dim lngIdx As Long
Dim lngPosEq As Long
Dim lngPosComment As Long
Dim lngKeyIdx As Long

Call GetPrivateProfileSection( _
ByVal strSection & String$(128, vbNullChar), _
strGetBuffer, _
ByVal LenB(strGetBuffer) / 2, _
ByVal strIniFile & String$(128, vbNullChar))
strWkString = pGetStringFromAPI(strGetBuffer, String$(2, vbNullChar))
If strWkString = vbNullChar Or strWkString = "" Then
pGetIniSection = Null
Else
varSectionItem = Split(strWkString, vbNullChar)
ReDim varKeyAndValue(0 To _
(UBound(varSectionItem) - LBound(varSectionItem)) * 2 + 1)
For lngIdx = LBound(varSectionItem) To UBound(varSectionItem)
lngKeyIdx = (lngIdx - LBound(varSectionItem)) * 2
lngPosEq = InStr(varSectionItem(lngIdx), "=")
If lngPosEq = 0 Then
varKeyAndValue(lngKeyIdx) = varSectionItem(lngIdx)
varKeyAndValue(lngKeyIdx + 1) = ""
Else
varKeyAndValue(lngKeyIdx) = _
Left(varSectionItem(lngIdx), lngPosEq - 1)
varKeyAndValue(lngKeyIdx + 1) = _
Mid(varSectionItem(lngIdx), lngPosEq + 1)
End If
lngPosComment = InStr(varKeyAndValue(lngKeyIdx), ";")
If lngPosComment > 0 Then
varKeyAndValue(lngKeyIdx) = _
RTrim(Left(varKeyAndValue(lngKeyIdx), _
lngPosComment - 1))
varKeyAndValue(lngKeyIdx + 1) = ""
End If
lngPosComment = InStr(varKeyAndValue(lngKeyIdx + 1), ";")
If lngPosComment > 0 Then
varKeyAndValue(lngKeyIdx + 1) = _
RTrim(Left(varKeyAndValue(lngKeyIdx + 1), _
lngPosComment - 1))
End If
Next lngIdx
pGetIniSection = varKeyAndValue
End If
End Function

' @(f)
'
' 機能 : INIファイルへの文字列値格納
'
' 返り値 : True - 成功, False - 失敗
'
' 引き数 : ARG1 - セクション名
' ARG2 - キー名
' ARG3 - 文字列値
' ARG4 - INIファイル名
'
' 機能説明 : INIファイルの該当セクション、キーに文字列値を格納
'
' 備考 :
'
Public Function pSetIniString(ByVal strSection As String, _
ByVal strKey As String, _
ByVal strValue As String, _
ByVal strIniFile As String) As Boolean
pSetIniString = CBool(WritePrivateProfileString( _
ByVal strSection & String$(128, vbNullChar), _
ByVal strKey & String$(128, vbNullChar), _
ByVal strValue & String$(128, vbNullChar), _
ByVal strIniFile & String$(128, vbNullChar)))
End Function

' @(f)
'
' 機能 : INIファイルのキー削除
'
' 返り値 : True - 成功, False - 失敗
'
' 引き数 : ARG1 - セクション名
' ARG2 - キー名
' ARG3 - INIファイル名
'
' 機能説明 : INIファイルの該当セクションの該当キーを削除
'
' 備考 :
'
Public Function pDeleteIniKey(ByVal strSection As String, _
ByVal strKey As String, _
ByVal strIniFile As String) As Boolean
pDeleteIniKey = CBool(WritePrivateProfileString( _
ByVal strSection & String$(128, vbNullChar), _
ByVal strKey & String$(128, vbNullChar), _
ByVal vbNullString, _
ByVal strIniFile & String$(128, vbNullChar)))
End Function

四捨五入、切り捨て、切り上げ

VB の Round関数、この関数はなぜか(?)四捨五入ではなく丸めを行うための関数です。ここでは丸めについての説明は省略しますが、例えば Round関数 に 1.5 と 2.5 を渡した場合の戻り値を見れば、四捨五入とは違うことはわかると思います。

そこで作成したのが以下の、四捨五入、切り捨て、切り上げを行うプロシージャです。

round.txt




'' 切り上げ・切り捨ての処理区分
Public Enum Enum_ROUND_SHORIKBN
ROUND_SHORIKBN_SISYAGONYU ''' 四捨五入
ROUND_SHORIKBN_KIRIAGE ''' 切り上げ
ROUND_SHORIKBN_KIRISUTE ''' 切り捨て
End Enum

' @(f)
'
' 機能 : 四捨五入、切り捨て、切り上げ
'
' 返り値 : 処理後の数値
'
' 引き数 : ARG1 - 数値
' ARG2 - 小数点以下桁数 ... 既定値 - 0
' ARG3 - 処理区分(列挙型 Enum_ROUND_SHORIKBN より選択)
' ... 既定値 - 四捨五入
'
' 機能説明 : 数値の四捨五入、切り捨て、切り上げを行う。
'
' 備考 :
'
Function pRound(ByVal varNum As Variant, _
Optional ByVal intDecimalPoint As Integer = 0, _
Optional ByVal enmUpDown As Enum_ROUND_SHORIKBN = _
ROUND_SHORIKBN_SISYAGONYU) As Variant
Dim varWkNum As Variant
Dim intPlusMinus As Integer

If varNum < 0 Then
intPlusMinus = -1
Else
intPlusMinus = 1
End If

varWkNum = CDec(varNum)
Select Case UCase(enmUpDown)
Case ROUND_SHORIKBN_KIRIAGE '' 切り上げ
varWkNum = Fix(varWkNum * (10 ^ intDecimalPoint)) _
/ (10 ^ intDecimalPoint)
If varWkNum <> varNum Then
varWkNum = varWkNum + (10 ^ (intDecimalPoint * -1)) _
* intPlusMinus
End If
Case ROUND_SHORIKBN_KIRISUTE '' 切り捨て
varWkNum = Fix(varWkNum * (10 ^ intDecimalPoint)) _
/ (10 ^ intDecimalPoint)
Case Else '' 四捨五入
varWkNum = varWkNum + (0.5 * 10 ^ (intDecimalPoint * -1)) _
* intPlusMinus
varWkNum = Fix(varWkNum * (10 ^ intDecimalPoint)) _
/ (10 ^ intDecimalPoint)
End Select

pRound = varWkNum
End Function