hira's AB Sample Codes [Page 1]

ActiveBasicのあったら便利なサンプルコードを置いておきます。
ここに置いているコードは、ご自由にお使い下さい。
ここで使用している関数などの詳しい説明はしませんのであらかじめご了承下さい。
※このコーナーのサンプルコードは、常に増加・変更・修正する可能性があります。
※AB3系で動作させることを前提としており、AB2系では動かないコードもあります。
※AB4.xにも対応していると思いますが、対応しないサンプルがある場合、お知らせ下さい。(2004.09.29)

[01]指数を数値に変換
[02]文字列を指定バイト数で改行
[03]文字列の置換
[04]文字列の検索(InStrの不具合を解消) 1 2 3
[05]サブクラス化(メッセージの横取り)
[06]カラー値をRGBに分解
[07]リストビューを扱う
[08]中身のあるフォルダを削除

[前ページ] [次ページ]

[01]指数を数値に変換

Function ShisuuVal(Number As String) As Double
Dim E As DWord
Dim Buf1 As String,Buf2 As String

    CharLower(Number)
    E=InStr(1,Number,"e")
    If E Then
        Buf1=Left$(Number,E-1)
        Buf2=Mid$(Number,E+1)
        ShisuuVal=Val2(Buf1)*10^Val2(Buf2)
    Else
        ShisuuVal=Val2(Number)
    End If
End Function
      
'Val関数が符号を認識していないようなので手を加えた
Function Val2(Data As String)As Double
    If Left$(Data,1)="-" Then
        Data=Mid$(Data,2)
        Val2=-Val(Data)
    ElseIf Left$(Data,1)="+" Then
        Data=Mid$(Data,2)
        Val2=Val(Data)
    Else
        Val2=Val(Data)
    End If
End Function

ShisuuVal("6e-5") → 0.00006
ShisuuVal("6e+5") → 600000 と変換されます。

[02]文字列を指定バイト数で改行

Function StrReturn(buf As String,Bytes As DWord) As String
Dim Active As String
Dim Char As Byte
    If buf="" Then Exit Function

    Do
        If InStr(1,buf,Ex"\r\n") Then
            Active=Left$(buf,InStr(1,buf,Ex"\r\n")+1)
            buf=Mid$(buf,InStr(1,buf,Ex"\r\n")+2)
        Else
            Active=buf
            buf=""
        End If
        Do
            '指定バイト数を超える場合は改行
            If Len(Active)>Bytes Then
                Char=Active(Bytes-1)
                '全角文字をまたぐ場合は1バイト減らす
                If ((((Char<=159) Or (Char>=224)) And (Char>=129)) And (Char<=252)) Then
                    '無限ループ防止
                    If Bytes=1 Then Exit Function
                    StrReturn=StrReturn & Left$(Active,Bytes-1) & Ex"\r\n"
                    Active=Mid$(Active,Bytes)
                Else
                    StrReturn=StrReturn & Left$(Active,Bytes) & Ex"\r\n"
                    Active=Mid$(Active,Bytes+1)
                End If
            Else
                StrReturn=StrReturn & Active & Ex"\r\n"
                Exit Do
            End If
        Loop
    Loop While Len(buf)
    StrReturn=Left$(StrReturn,Len(StrReturn)-2)
End Function

第1引数は元の文字列、第2引数は改行するバイト数を指定します。
StrReturn("これはabcでもあれはdefg",8) の戻り値は、

これはab
cでもあ
れはdefg

となります。長い文字列を描画するときに使えるかもしれません。

[03]文字列の置換

Declare Function MultiByteToWideChar Lib "kernel32" (CodePage As Long,dwFlags As Long,lpMultiByteStr As String, _
  cchMultiByte As Long,lpWideCharStr As String,cchWideChar As Long)As Long
Declare Function WideCharToMultiByte Lib "kernel32" (CodePage As Long,dwFlags As Long,lpWideByteStr As VoidPtr, _
  cchWideByte As Long,lpMultiCharStr As String,cchMultiChar As Long,pDefaultChar As Long,pUsedDefaultChar As Long)As Long

Function Replace(buf1 As String,buf2 As String,buf3 As String) As String
Dim uni1 As WordPtr,uni2 As WordPtr,uni3 As WordPtr,uni4 As WordPtr
Dim len1 As DWord,len2 As DWord,len3 As DWord,len4 As DWord
Dim i As DWord,j As DWord
Dim buf As String,buflen As DWord
    'Unicodeに変換
    len1=MultiByteToWideChar(0,0,buf1,Len(buf1),0,0)*2
    uni1=HeapAlloc(GetProcessHeap(),0,len1)
    MultiByteToWideChar(0,0,buf1,Len(buf1),uni1,len1)

    len2=MultiByteToWideChar(0,0,buf2,Len(buf2),0,0)*2
    uni2=HeapAlloc(GetProcessHeap(),0,len2)
    MultiByteToWideChar(0,0,buf2,Len(buf2),uni2,len2)

    len3=MultiByteToWideChar(0,0,buf3,Len(buf3),0,0)*2
    uni3=HeapAlloc(GetProcessHeap(),0,len3)
    MultiByteToWideChar(0,0,buf3,Len(buf3),uni3,len3)

    For i=0 To (len1\2)-(len2\2)
        For j=0 To (len2\2)-1
            If uni1(i+j)<>uni2(j) Then Exit For
        Next j
        If j=len2\2 Then
            'ヒットした
            If uni4=0 Then
                uni4=HeapAlloc(GetProcessHeap(),0,len3)
            Else
                uni4=HeapReAlloc(GetProcessHeap(),0,uni4,len4+len3)
            End If
            memcpy(uni4+len4,uni3,len3)
            len4=len4+len3
            i=i+(len2\2)-1
            'Shift-JIS換算の長さを足す
            buflen=buflen+Len(buf3)
        Else
            'ヒットしない
            If uni4=0 Then
                uni4=HeapAlloc(GetProcessHeap(),0,2)
            Else
                uni4=HeapReAlloc(GetProcessHeap(),0,uni4,len4+2)
            End If
            memcpy(uni4+len4,uni1+i*2,2)
            len4=len4+2
            'Shift-JIS換算の長さを足す
            If GetByte(uni4+len4-1) Then buflen=buflen+2 Else buflen=buflen+1
        End If
    Next i
    If i<>len1\2 Then
        '検索の対象にならなかった文字列
        If uni4=0 Then
            uni4=HeapAlloc(GetProcessHeap(),0,((len1\2)-i)*2)
        Else
            uni4=HeapReAlloc(GetProcessHeap(),0,uni4,len4+((len1\2)-i)*2)
        End If
        memcpy(uni4+len4,uni1+i*2,((len1\2)-i)*2)
        len4=len4+((len1\2)-i)*2
        'Shift-JIS換算の長さを足す
        buflen=buflen+(len1\2)-i
        For j=1 To ((len1\2)-i)*2-1
            If GetByte(uni4+i*2+j) Then buflen=buflen+1
        Next j
    End If
    'Shift-JISに戻す
    buf=ZeroString(buflen)
    WideCharToMultiByte(0,0,uni4,len4,buf,buflen,0,0)
    HeapFree(GetProcessHeap(),0,uni1)
    HeapFree(GetProcessHeap(),0,uni2)
    HeapFree(GetProcessHeap(),0,uni3)
    HeapFree(GetProcessHeap(),0,uni4)
    Replace=buf
End Function

第1引数は元の文字列、第2引数は検索文字列、第3引数は検索文字列を置き換える文字列を指定します。
Replace("暴力反対","反対","NG!") → "暴力NG!" となります。

[04]文字列の検索(InStrの不具合を解消)

Declare Function MultiByteToWideChar Lib "kernel32" (CodePage As Long,dwFlags As Long,lpMultiByteStr As String, _
  cchMultiByte As Long,lpWideCharStr As String,cchWideChar As Long)As Long

Function InStr2(Start As DWord,buf1 As String,buf2 As String) As DWord
Dim buf3 As String,uniStart As DWord
Dim uni1 As String,uni2 As String,uni3 As String
Dim uni_ptr As BytePtr
Dim i As DWord,j As DWord
    'Unicodeに変換
    uni1=ZeroString(MultiByteToWideChar(0,0,buf1,Len(buf1),0,0)*2)
    MultiByteToWideChar(0,0,buf1,Len(buf1),uni1,Len(uni1))
    uni2=ZeroString(MultiByteToWideChar(0,0,buf2,Len(buf2),0,0)*2)
    MultiByteToWideChar(0,0,buf2,Len(buf2),uni2,Len(uni2))
    buf3=Left$(buf1,Start-1)
    uniStart=MultiByteToWideChar(0,0,buf3,Len(buf3),0,0)*2+1
    '文字列検索
    For i=uniStart To Len(uni1)+1-Len(uni2) Step 2
        If Mid$(uni1,i,Len(uni2))=uni2 Then
            'Shift-JISの長さを求める
            uni_ptr=StrPtr(uni1)
            InStr2=1
            For j=0 To i-3 Step 2
                If uni1[j+1] Then InStr2=InStr2+2 Else InStr2=InStr2+1
            Next j
            Exit Function
        End If
    Next i
End Function

InStr関数と使い方は同じです。ではInStr関数とどう違うのかというと、
"表" "貼" "暴" などの文字は、2バイトで表されるうちの下位バイト(2バイト目)が "\" と同じコードになってしまい、これを "\" と誤認識してしまうために、
InStr(1,"表","\") → 2 という不本意な結果になってしまいます。
この誤認識を防ぐのがこの関数です。
もちろん、InStr2(1,"表","\") → 0 となります。

また、SinryowさんがInStr3関数として、上の関数より速い動作をするものを作成されました。同時にご紹介しておきます。

Function InStr3(StartPos As Long, buf1 As String, buf2 As String) As Long
Dim len1 As Long, len2 As Long, i As Long, i2 As Long, i3 As Long, j As Long

    len1=Len(buf1)
    len2=Len(buf2)

    If len2=0 Then
        InStr3=StartPos
        Exit Function
    End If

    StartPos=StartPos-1
    If StartPos<0 Then
        'error
        InStr3=0
        Exit Function
    End If

    i=StartPos:InStr3=0
    While i<=len1-len2
        i2=i:i3=0
        Do
            If i3=len2 Then
                InStr3=i+1
                Exit Do
            End If
            If buf1[i2]<>buf2[i3] Then Exit Do

            i2=i2+1
            i3=i3+1
        Loop
        If InStr3>=1 Then
            If Upper2Byte(buf2[0]) Or InStr3=1 Then
                Exit While
            Else
                For j=i-1 To 0 Step -1
                    If Not(Upper2Byte(buf1[j])) Then Exit For
                Next
                If (i-j) Mod 2=1 Then Exit While
            End If
            InStr3=0
        End If
        i=i+1
    Wend
End Function

'文字コードの範囲が &H80〜&H9F または &HE0〜&HFF の範囲にあるなら TRUE そうでないなら FALSE を返す
Function Upper2Byte(char As Byte) As Long
    Upper2Byte=((char And &H80)=&H80 And (char And &H40)=((char And &H20)<<1))
End Function

こちらも使い方は全く同じで、
InStr3(1,"表","\") → 0 となり、不本意な結果を防ぐことが可能になります。

そして、ABのInStr関数を基にして自作したInStr4関数も置いておきます。
長いですね、どうもすみません。
※処理速度はInStr3に比べて劣ります(原爆)

Declare Function MultiByteToWideChar Lib "kernel32" (CodePage As Long,dwFlags As Long,lpMultiByteStr As String, _
  cchMultiByte As Long,lpWideCharStr As String,cchWideChar As Long)As Long

Function InStr4(StartPos As Long, buf1 As String, buf2 As String) As Long
Dim len1 As Long,len2 As Long
Dim uni1 As WordPtr,uni2 As WordPtr
Dim Ret As Long
Dim i As Long,i2 As Long,i3 As Long
Dim StartPos2 As Long

    'データのチェック
    If StartPos<0 Or StartPos>Len(buf1) Then Exit Function
    If Len(buf2)=0 Then Exit Function
    len1=MultiByteToWideChar(0,0,buf1,Len(buf1),0,0)
    uni1=HeapAlloc(GetProcessHeap(),0,len1*2)
    MultiByteToWideChar(0,0,buf1,Len(buf1),uni1,len1*2)
    len2=MultiByteToWideChar(0,0,buf2,Len(buf2),0,0)
    uni2=HeapAlloc(GetProcessHeap(),0,len2*2)
    MultiByteToWideChar(0,0,buf2,Len(buf2),uni2,len2*2)

    i=MultiByteToWideChar(0,0,buf1,StartPos-1,0,0)
    Ret=0

    While i<=len1-len2
        i2=i:i3=0
        Do
            If i3=len2 Then
                Ret=i*2+1
                Exit Do
            End If
            If uni1[i2]<>uni2[i3] Then Exit Do

            i2=i2+1
            i3=i3+1
        Loop
        If Ret Then Exit While
        i=i+1
    Wend

    'Shift-JISに換算した長さを返す
    If Ret Then
        InStr4=(Ret-1)\2+1
        For i=0 To (Ret-1)\2
            If GetByte(uni1+i*2+1) Then InStr4=InStr4+1
        Next i
    End If

    HeapFree(GetProcessHeap(),0,uni1)
    HeapFree(GetProcessHeap(),0,uni2)
End Function

[05]サブクラス化

Windowsが裏で送っている「メッセージ」を横取りして処理を行います。

'グローバル変数
Dim CallBackhWnd As Long

Function WndProc(hWnd As Long,uMsg As Long,wParam As Long,lParam As Long) As Long
    WndProc=CallWindowProc(CallBackhWnd,hWnd,uMsg,wParam,lParam)
    'ここに示すメッセージは例です。実際にはここを変更します。
    If uMsg=WM_SYSCOMMAND Then
        '処理
    End If
End Function

Sub SubClassSetUp(hWnd As Long)
    CallBackhWnd = SetWindowLong(hWnd,GWL_WNDPROC,AddressOf(WndProc))
End Sub

Sub SubClassClose(hWnd As Long)
    SetWindowLong(hWnd,GWL_WNDPROC,CallBackhWnd)
End Sub

サブクラス化の開始時は SubClassSetUp(ウィンドウハンドル)
サブクラス化の終了時は SubClassClose(ウィンドウハンドル) を呼び出します。
なお、サブクラス化を開始したウィンドウに対しては、破棄されるまでにSubClassCloseを呼び出す必要があります。

また、7行目「If uMsg=…」の部分を変更し、欲しいメッセージについて処理を行ってください。複数のメッセージが欲しければElseIf・Select Caseなども活用してください。
ウィンドウメッセージについては各自でお調べ下さい。

[06]カラー値をRGBに分解

例えば、紫色を示すカラー値[&HFF00FF]から赤の要素[&HFF]や緑の要素[&H00]、青の要素[&HFF]を取り出す関数です。
もちろん、24ビットカラーであればどんな色でも3つの要素に分解できます。

Function GetRed(Color As Long) As Byte
     GetRed=Color And &HFF
End Function

Function GetGreen(Color As Long) As Byte
     GetGreen=Color>>8 And &HFF
End Function

Function GetBlue(Color As Long) As Byte
     GetBlue=Color>>16 And &HFF
End Function

赤の要素を取り出すには GetRed(カラー値)
緑の要素を取り出すには GetGreen(カラー値)
青の要素を取り出すには GetBlue(カラー値)

関数の戻り値がそれぞれの要素[&H00〜&HFF]になります。

[07]リストビューを扱う

'カラムを追加。
'Caption=カラムの文字列、hWnd=ListViewコントロールのハンドル、Index=カラムの番号(通常は左から0,1,2…と通し番号にすればOK)
'Alm=表示状態(0=左揃え、1=右揃え、2は中央揃え)、Width=カラムの幅(ピクセル)
Sub AddListColumn(Caption As String,hWnd As Long,Index As Long,Alm As Long,Width As Long)
Dim lvcolumn(5) As Long
Dim lvcaption As String
    lvcolumn(0)=&HF
    lvcolumn(1)=Alm'0=Left 1=Right 2=Middle
    lvcolumn(2)=Width'Pixel
    lvcaption=Caption:lvcolumn(3)=StrPtr(lvcaption)
    lvcolumn(4)=0
    lvcolumn(5)=Index'Index
    SendMessage(hWnd,&H101B,Index,VarPtr(lvcolumn(0)))
End Sub

'アイテムを追加。
'Text=一番左の列に表示する文字列、hWnd=ListViewコントロールのハンドル、
'Index=アイテムの番号(通常は上から0,1,2…と通し番号にすればOK)
Sub AddListItem(Text As String,hWnd As Long,Index As Long)
Dim lvitem(5)As Long
Dim lvcaption As String
    lvitem(0)=1
    lvitem(1)=Index
    lvitem(2)=0
    lvitem(3)=0
    lvitem(4)=0
    lvcaption=Text:lvitem(5)=StrPtr(lvcaption)
    SendMessage(hWnd,&H1007,0,VarPtr(lvitem(0)))
End Sub

'サブアイテムを設定。
'Text=設定する文字列、hWnd=ListViewコントロールのハンドル、Index=アイテムの番号、IndexSub=列番号(一番左の列が0、2列目が1…)
Sub SetListItem(Text As String,hWnd As Long,Index As Long,IndexSub As Long)
Dim lvitem(5)As Long
Dim lvcaption As String
    '同じ内容の時は書き込まない(余分な負荷がかかるため)
    If GetListItem(hWnd,Index,IndexSub)=Text Then Exit Sub
    lvitem(0)=1
    lvitem(1)=Index
    lvitem(2)=IndexSub
    lvitem(3)=0
    lvitem(4)=0
    lvcaption=Text:lvitem(5)=StrPtr(lvcaption)
    SendMessage(hWnd,&H1006,0,VarPtr(lvitem(0)))
End Sub

'サブアイテムを取得。
'hWnd=ListViewコントロールのハンドル、Index=アイテムの番号、IndexSub=列番号(一番左の列が0、2列目が1…)
Function GetListItem(hWnd As Long,Index As Long,IndexSub As Long)As String
Dim buf As String
Dim lvitem(6)As Long
    buf=ZeroString(1024)
    lvitem(0)=1
    lvitem(1)=Index
    lvitem(2)=IndexSub
    lvitem(3)=0
    lvitem(4)=0
    lvitem(5)=StrPtr(buf)
    lvitem(6)=1024
    SendMessage(hWnd,&H1005,0,VarPtr(lvitem(0)))
    GetListItem=Left$(buf,InStr(1,buf,Chr$(0))-1)
End Function

'アイテムを削除。
'hWnd=ListViewコントロールのハンドル、Index=アイテムの番号
Sub DelListItem(hWnd As Long,Index As Long)
    SendMessage(hWnd,&H1008,Index,0)
End Sub

'全アイテムを削除。
'hWnd=ListViewコントロールのハンドル
Sub DelAllListItem(hWnd As Long)
    SendMessage(hWnd,&H1009,0,0)
End Sub

'カラムを削除。
'hWnd=ListViewコントロールのハンドル、Index=カラムの番号。但し0(一番左のカラム)を指定することはできない。
Sub DelColumn(hWnd As Long,Index As Long)
    SendMessage(hWnd,&H101C,Index,0)
End Sub

'選択されているアイテムの番号を取得。
'hWnd=ListViewコントロールのハンドル
Function FindSelListItem(hWnd As Long)As Long
    FindSelListItem=SendMessage(hWnd,&H100C,-1,2)
End Function

'アイテムを選択させる。
'hWnd=ListViewコントロールのハンドル、Index=アイテムの番号
Sub SelectListItem(hWnd As Long,Index As Long)
Dim lvitem(9)As Long
    lvitem(0)=8
    lvitem(1)=Index
    lvitem(2)=0
    lvitem(3)=2
    lvitem(4)=2
    lvitem(5)=0
    lvitem(6)=0
    lvitem(7)=0
    lvitem(8)=0
    lvitem(9)=0
    SendMessage(hWnd,&H1006,0,VarPtr(lvitem(0)))
End Sub

説明は関数の上にコメントとして載せてありますので参考にしてください。

[08]中身のあるフォルダを削除

APIのRemoveDirectoryでは中身のあるフォルダは削除できません。そこでそんなフォルダも削除できる関数を作成してみました。

Type SHFILEOPSTRUCT
    hwnd As Long
    wFunc As Long
    pFrom As BytePtr
    pTo As BytePtr
    fFlags As Long
    fAnyOperationsAborted As Long
    hNameMappings As Long
    lpszProgressTitle As BytePtr
End Type
Declare Function SHFileOperation Lib "shell32" Alias "SHFileOperationA" (ByRef pFileOp As SHFILEOPSTRUCT) As Long

Function RemoveDir(Path As String) As Long
    Dim udtFileOp As SHFILEOPSTRUCT
    'フォルダでないものをはじく
    If (GetFileAttributes(Path) And FILE_ATTRIBUTE_DIRECTORY)<>FILE_ATTRIBUTE_DIRECTORY Then Exit Function
    If Right$(Path,1)="\" Then Path=Left$(Path,Len(Path)-1)
    ZeroMemory(VarPtr(udtFileOp),Len(udtFileOp))
    '削除処理
    With udtFileOp
        .hwnd=GetDesktopWindow()
        .wFunc=3
        Path=Path & ZeroString(2)
        .pFrom=StrPtr(Path)
        .fFlags=&H414 'FOF_SILENT Or FOF_NOCONFIRMATION Or FOF_NOERRORUI
        RemoveDir=SHFileOperation(udtFileOp)
        If RemoveDir=0 Then RemoveDir=1 Else RemoveDir=0
        If .fAnyOperationsAborted Then RemoveDir=0
    End With
End Function

RemoveDir(削除するフォルダ) で削除できます。
中にファイルやフォルダが入っていても、それごと削除することができます。
なお、フォルダ名はフルパスで指定しなければなりません。フルパスでない場合の動作は保証しません(^^;;
戻り値は、成功すれば1、失敗したときは0となります。

トップに戻る