ちょっと便利な自作関数集(VB6.0) - VBレスキュー(花ちゃん)

Option Explicit

Function LenA(mozi As String) As Integer
　　LenA = LenB(StrConv(mozi, vbFromUnicode))
End Function

Private Sub Command1_Click()
　　Dim intLen As Integer
　　intLen = LenA("VBレスキュー(花ちゃん)")
　　Debug.Print intLen　　　'結果 22 (全角 9個半角 4個)
End Sub

このような関数を標準モジュールに作っておけば全角と半角が混在しているような文字列の表示幅が
全角 = 2バイト半角 = 1バイトで計算でき便利ですよね。

２．データ交換する(スワップ Swap関数)

旧の Basic には、Swap関数があったのですが、Visual Basic にはないので作ってみました。

Sub Swap(Deta1, Deta2)
　　Dim Sw
　　If VarType(Deta1) <> VarType(Deta2) Then Exit Sub
　　Sw = Deta1: Deta1 = Deta2: Deta2 = Sw
End Sub

Private Sub Command1_Click()
　　Dim s1 As String
　　Dim s2 As String
　　s1 = "ABCDE"
　　s2 = "あいうえお"
　　Swap s1, s2

　　Debug.Print s1, s2　　　'結果　あいうえお　　ABCDE
End Sub

使い方はご覧のようにいたって簡単
これで変数 s1 , s2 の内容が入れ替わる。ただし、異なる変数型間の交換はできません。
又、大量のデータ(1万件以上位)をソートする場合は速度等の関係であまりお薦めできません。

３．Locate 関数を使う(表示及び印刷位置指定関数)

Locate 関数を使う
Sub Locate(X As Variant, Y As Variant)
　　ScaleMode = 4
　　CurrentX = X:　 CurrentY = Y
End Sub

少し改造すると色々な物に使用できます。
ScaleMode を自由に設定するように追加するとか。
Private Sub LocateEx(myObj As Object, X As Long, Y As Long, myStr As String)
　　With myObj
　　　　.ScaleMode = vbCharacters　 'キャラクターモード
　　　　.CurrentX = X
　　　　.CurrentY = Y
　　End With
　　myObj.Print myStr
End Sub

使い方
Private Sub Command1_Click()
　　Locate 10, 5: Print "10桁目の5行目に表示"
　　LocateEx Me, 1, 1, "VBレスキュー(花ちゃん)　(1行目の1桁目に表示)"
End Sub

これで、旧の Basic(と言っても今じゃ知らない人が殆どでしょうが) の Locate 関数が使えます。
尚、印刷位置指定にも使えます。
旧のBasicにあった印刷設定用の関数が、Visual Basic ではなくなっているので、(Print Using 等)重宝しています。

上記実行結果
　

４．半角・全角文字の判定をする(文字コードを扱う)　SampleNo.086　2002.05.17

Visual Basic で文字列を扱う上で、文字コードについて知っておくのは、必須ともいえます。
まず、下記コードを試して下さい。

Option Explicit　　 'SampleNo=086 WindowsXP VB6.0(SP5) 2002.05.17

Private Sub Text1_KeyPress(KeyAscii As Integer)
　　Debug.Print KeyAscii
　　If KeyAscii = vbKeyReturn Then
　　　　KeyAscii = 0
　　Else
　　　　If KeyAscii >= 0 And KeyAscii < 31 Then
　　　　　　MsgBox "制御文字です"
　　　　　　Exit Sub
　　　　End If
　　　　If KeyAscii > 0 And KeyAscii < 255 Then
　　　　　　MsgBox "Ascii コード 255 以内です"
　　　　　　'128 ～ 160 と 224 ～ 255 はキーボードから直接入力不可
　　　　End If
　　　　If KeyAscii > 160 And KeyAscii < 224 Then
　　　　　　MsgBox "半角カナ文字です"
　　　　End If
　　　　If LenB(StrConv(Chr$(KeyAscii), vbFromUnicode)) = 1 Then
　　　　　　MsgBox "シフトJISコード 1バイト文字です"
　　　　End If
　　End If
End Sub

イミディエイトウィンドウで　?chr(64)　と入力すると @　が表示します
イミディエイトウィンドウで　?asc("@")　と入力すると 64 が表示します
ヘルプで ASCII 文字セット (0 - 127)
　　　　 ASC 関数 32 ビット版での文字列操作の注意事項
等も調べて下さい

それを関数化すると

Private Function fHanOrZen(myString As String) As Integer
　　If Len(myString) = 1 Then 'エラー処理 0 を返す
　　　　If Asc(myString) >= 0 And Asc(myString) <= 255 Then
　　　　　　fHanOrZen = 1　　'半角=1
　　　　Else
　　　　　　fHanOrZen = 2　　'全角 = 2
　　　　End If
　　Else
　　　　fHanOrZen = 0　　　　'判定不能 = 0
　　End If
End Function

使用方法

Private Sub Command1_Click()
　　Dim Ret As Integer
　　Ret = fHanOrZen(Text2.Text)
　　Select Case Ret
　　　　Case 1
　　　　　　MsgBox "半角文字です"
　　　　Case 2
　　　　　　MsgBox "全角文字です"
　　　　Case 0
　　　　　　MsgBox "指定方法が間違ってます"
　　End Select
End Sub

参考までに(詳しくは、ヘルプで、[キーコード定数]をキーに検索して見て下さい。)　

定数	コード	キー名	定数	コード	キー名
vbKeyLButton	1	マウスの左ボタン	vbKeySpace	32	Space キー
vbKeyRButton	2	マウスの右ボタン	vbKeyPageUp	33	PageUp キー
vbKeyCancel	3	Cancel キー	vbKeyPageDown	34	PageDown キー
vbKeyMButton	4	マウスの右ボタン	vbKeyEnd	35	End キー
vbKeyBack	8	BackSpace キー	vbKeyHome	36	Home キー
vbKeyTab	9	Tab キー	vbKeyLeft	37	← キー
VbLf	10	ラインフィード文字	vbKeyUp	38	↑ キー
VbCrLf	改行して次の行の先頭に移動		vbKeyRight	39	→ キー
vbKeyClear	12	Clear キー	vbKeyDown	40	↓ キー
vbKeyReturn	13	Enter キー	vbKeySelect	41	Select キー
vbKeyShift	16	Shift キー	vbKeyPrint	42	PrintScreen キー
vbKeyControl	17	Ctrl キー	vbKeyExecute	43	Execute キー
vbKeyMenu	18	Alt キー	vbKeySnapshot	44	Snapshot キー
vbKeyPause	19	Pause キー	vbKeyInsert	45	Ins キー
vbKeyCapital	20	CapsLock キー	vbKeyDelete	46	Del キー
vbKeyEscape	27	Esc キー	vbKeyHelp	47	Help キー

５．テキストボックスで数字しか入力できないように制限する(簡易型)

普通は下記のように設定されているのを多く見かけますが!
Private Sub Text1_KeyPress(KeyAscii As Integer)
　　If KeyAscii >= 32 And KeyAscii < 48 Or KeyAscii > 57 Then
　　　　Beep　　　　　　　　　　'エラー音
　　　　KeyAscii = 0　　　　　　'入力キーを無効にする
　　End If
End Sub

上記の設定ですと、マイナスキーやコンマ等入、できず、貼り付けられたらアウトです。

Private Sub Text1_KeyPress(KeyAscii As Integer)
　　If KeyAscii >= 32 And KeyAscii < 45 Or KeyAscii > 57 Or KeyAscii = 47 Then
　　　　Beep　　　　　　　　　　'エラー音
　　　　KeyAscii = 0　　　　　　'入力キーを無効にする
　　End If
End Sub

これで、カンマとマイナスキーも入力できます。簡易的に使うならこれでもいいのですが、貼り付けられたらアウトです。
テキストボックスへの貼り付け防止対策については、[テキストボックスへの貼り付け防止]をご覧ください。

６．四捨五入の関数(四捨五入・切上・切り捨て・桁数を指定) SampleNo.064 2002.05.15

四捨五入だけでその都度書くなら
Private Sub Command2_Click()
　　Dim A As Single
　　Text1.Text = "5.555"
　　Text2.Text = Format$(Text1.Text, "###.#")
　　'結果　5.6
End Sub

WindowsXPの場合Format関数を使用すると五捨五入になるので注意(下記参照)

Windows XP に含まれているオートメーションライブラリ 3.50 環境では、
Format 関数は、丸めの対象となる数値が 5 の場合、最も一般的である
「丸めの対象となる一桁前の数値が偶数であれば繰り下げ、奇数であれば
繰り上げる」という方法で数値の丸めの処理を行います。
Windows XP 環境において Format 関数は以下のように動作します。

　　例:
　Format("0.5", "#,##0")　　 '0 が返ります
　Format("1.5", "#,##0")　　 '2 が返ります
　Format("2.5", "#,##0")　　 '2 が返ります
　Format("3.5", "#,##0")　　 '4 が返ります

自分で四捨五入の関数を作るなら

Option Explicit　

'=======================================================
'四捨五入・切り捨て・切り上げ処理関数
'=======================================================
'使用方法　 result=fRound(MyVal,Keta, UpDo)
'-----------------------------
'引数　 MyVal :対象となる数値(Currencyの範囲)(""不可)
'　　　 Keta　:処理をする桁数(省略時:0桁)
'　　　 UpDo　:処理方法(省略時=0:四捨五入)1=切上その他=切捨
'戻値　 result:処理結果(Currency型)
'-------------------------------------------------------
Private Function fRound(ByVal MyVal As Currency, Optional ByVal keta _
　　　　As Integer = 0, Optional ByVal UpDo As Integer = 0) As Currency
　　'指定桁数の制限
　　If keta < 0 Or keta > 3 Or Len(Str$(MyVal)) > 17 Then
　　　　MsgBox "正しい桁数の範囲で設定して下さい", vbOKOnly, "桁エラー"
　　　　Exit Function
　　End If
　　If keta Then　 '小数点第二位以上の場合の処理
　　　　MyVal = MyVal * (10 ^ keta)
　　End If
　　Select Case UpDo
　　　　Case 0　　 '四捨五入
　　　　　　If MyVal < 0 Then
　　　　　　　　MyVal = MyVal - 0.5
　　　　　　Else
　　　　　　　　MyVal = MyVal + 0.5
　　　　　　End If
　　　　Case 1　　 '切り上げ
　　　　　　If MyVal - CInt(MyVal) Then
　　　　　　　　If MyVal < 0 Then
　　　　　　　　　　MyVal = MyVal - 1
　　　　　　　　Else
　　　　　　　　　　MyVal = MyVal + 1
　　　　　　　　End If
　　　　　　End If
　　　　Case Else
　　End Select
　　'その他は切り捨て処理
　　MyVal = Fix(MyVal)
　　If keta Then
　　　　'元の桁に戻す
　　　　MyVal = MyVal / (10 ^ keta)
　　End If
　　fRound = MyVal
End Function

Private Sub Command1_Click()
　　Dim UpDo As Integer
　　If Option1(0).Value = True Then
　　　　UpDo = 0
　　ElseIf Option1(1).Value = True Then
　　　　UpDo = 1
　　Else
　　　　UpDo = 2
　　End If
　　Text2.Text = fRound(CCur(Text1.Text), CInt(Text3.Text), UpDo)
End Sub

顧客によって、消費税の算出方法が違う場合、こんな関数があれば便利ですよネ!。

注意
上記では、消費税計算用に Currency 型を使っておりますので小数部桁数を制限しております、。

小数点以下の数値が含む計算上の注意事項
パソコンは2進数で電卓は10進数で計算するために、どうしても小数点以下の計算で誤差が発生します。
　　電卓では100÷3×3=99.9999999
　　PCでは100÷3×3=100　になります

　　次の例では　Ans=18.45 のはずが　18.449 となる
Private Sub Command2_Click()
　　Dim dblValue1 As Double
　　Dim dblValue2 As Double
　　Dim dblValue3 As Double
　　Dim curValue1 As Currency
　　Dim curValue2 As Currency
　　Dim curValue3 As Currency

　　dblValue1 = 123
　　curValue1 = 123

　　dblValue2 = 0.15
　　curValue2 = 0.15

　　dblValue3 = Fix((dblValue1 * dblValue2) * 1000) / 1000
　　curValue3 = Fix((curValue1 * curValue2) * 1000) / 1000

　　Label2.Caption = Format$(dblValue3, "#,###.####")　　'18.449
　　Label3.Caption = Format$(curValue3, "#,###.####")　　'18.45
End Sub

こういった場合変数を Currency型 Variant型で計算して下さい

７．NullChar(Chr(0))　文字以降を消去する(ゆう(U)さん投稿分)　　SampleNo.080　　2002.05.17

NullChar(Chr(0))　文字以降を消去する(ゆう(U)さん投稿分)　　SampleNo.080　　2002.05.17

私の場合ランダムファイルで書き込みすると事前にフォーマットしていないと・・・のような文字が文字列の後ろに入り　RTrim()関数を使っても空白が除去できません。
MyDaTa = Trim(fNullCut(MyDaTa)) のようにしてファイルから読み込んだデータの空白及びNullChar(Chr(0))　を除去しています。
文字列の後ろに変な文字がくっついている場合試して下さい。

Option Explicit

Private Function fNullCut(ByRef myString As String) As String
　　Dim i As Long
　　i = InStr(myString, vbNullChar)
　　If i > 0& Then
　　　　fNullCut = Left$(myString, i - 1&)
　　Else
　　　　fNullCut = myString
　　End If
End Function

Private Sub Command1_Click()
　　Dim myString　As String
　　myString = "VBレスキュー(花ちゃん)" & String$(8, vbNullChar)
　　Text1.Text = myString & "ABCDEFG"
　　Label1.Caption = fNullCut(myString) & "ABCDEFG"
End Sub

８．プログラムを起動したフォルダーのPATH(カレントディレクトリ)を取得する

通常は、strMyPath = App.Path のようにして起動フォルダーを取得しますが、ファイルのPathを記入する場合、
strMyPath & "\" & "ファイル名"　と　"\"　を追加しなけばならない。　
但し、ルートディレクトリの時は最後が "\" になります。
又、起動中にディレクトリが変更されたりしたら変わってしまいます。

そこで下記のような関数を作っておくと、プログラムの終了まで起動ディレクトリを保持しているので安心です。

使用場所
プログラムを配布したりすると、人によりプログラムをインストールするフォルダーが違ってくる、そのような場合起動ディレクトリを取得し、プログラムとデータを同じフォルダーにさえ入れておけば稼動する。

基本的な使い方

次のように、標準モジュール内に関数を作っておけばどこからでも参照でき便利です。Loadイベント等で必ず起動直後に1度Call して下さい

Private Sub Form_Load()
　　'起動時一度取得しておけば、プログラム終了まで起動パスが保持される。
　　Debug.Print fMyPath　　 '結果　C:\Program Files\Microsoft Visual Studio\VB98\
End Sub

Public Function fMyPath() As String
　　'プログラム終了まで　MyPath　の内容を保持
　　Static MyPath As String
　　'途中でディレクトリ-が変更されても起動ディレクトリ-を確保
　　If Len(MyPath) = 0& Then
　　　　MyPath = App.Path　　　　 'ディレクトリ-を取得
　　　　'ルートディレクトリかの判断
　　　　If Right$(MyPath, 1&) <> "\" Then
　　　　　　MyPath = MyPath & "\"
　　　　End If
　　End If
　　fMyPath = MyPath
End Function

９．VB2005 以降のPadLeft関数を作成

Private Sub Command2_Click()
　　Debug.Print fPadLeft("5", 5, "0")　 '00005
　　Debug.Print fPadLeft("5", 5, " ")　 '　　5
End Sub

Private Function fPadLeft(ByVal myData As String, ByVal CutLen As Long, ByVal CutStr As String) As String
'文字を右寄せし、指定した文字列の文字数になるまで左側に指定した文字(0 や " " 等)を埋め込みます。
　　Dim tmp As String
　　tmp = Right$(String$(CutLen, CutStr) & myData, CutLen)
　　fPadLeft = tmp
End Function

検索キーワード及びサンプルコードの別名(機能名)

全角2バイト半角1バイトで文字列長を計算する　文字列長の計算方法　文字列幅を調べる　データを入れ替えるスワップ　2つのデータの交換　2つのデータの入れ替え　印刷位置指定方法　
表示位置指定方法　行桁位置　ScaleMode　全角　半角　文字コード　テキストボックスに数字しか入力できないように制限する　貼り付け防止　数字入力専用　四捨五入　まるめ処理　小数点
切り捨て　切り上げ　桁指定　小数点以下　第何位　NullChar の除去　API関数　文字化け　最後に変な文字が付く　起動パス　EXEのパス　起動フォルダー　起動ディレクトリ
フォルダーのPATH　フォルダーのパス