よく見かけるVBサンプル集 MENU　20～29

'[ビットブロック転送](論理単位で指定)
Private Declare Function BitBlt Lib "gdi32" (ByVal hDCDest As Long, _
ByVal nXDest As Long, ByVal nYDest As Long, _
ByVal nWidth As Long, ByVal nHeight As Long, _
ByVal hDCSrc As Long, _
ByVal nXSrc As Long, ByVal nYSrc As Long, _
ByVal dwRop As Long ) As Long

hDCDest : コピー先のデバイスコンテキストハンドルを指定
nXDest ,
nYDest   : コピー先の長方形の左上隅の x , y座標を指定
nWidth ,
nHeight : コピー先の長方形の幅と高さを指定します。(コピー元も同じ)
hDCSrc : コピー元のデバイスコンテキストハンドルを指定
nXSrc ,
nYSrc    : コピー元の長方形の左上隅の x , y 座標を指定
dwRop    : ラスタオペレーションコードを指定します。

関数が成功すると、0 以外の値が返ります。

'[ビットマップを拡大/縮小コピー](論理単位で指定)
Private Declare Function StretchBlt Lib "gdi32" (ByVal hDCDest As Long, _
ByVal nXOriginDest As Long, ByVal nYOriginDest As Long, _
ByVal nWidthDest As Long, ByVal nHeightDest As Long, _
ByVal hDCSrc As Long, _
ByVal nXOriginSrc As Long, ByVal nYOriginSrc As Long, _
ByVal nWidthSrc As Long, ByVal nHeightSrc As Long, _
ByVal dwRop As Long ) As Long

hDCDest　    : コピー先のデバイスコンテキストハンドルを指定
nXOriginDest ,
nYOriginDest : コピー先の長方形の左上隅の x , y座標を指定
nWidthDest ,
nHeightDest : コピー先の長方形の幅と高さを指定
hDCSrc        : コピー元のデバイスコンテキストハンドルを指定
nXOriginSrc ,
nYOriginSrc   : コピー元の長方形の左上隅の x ,y座標を指定
nWidthSrc ,
nHeightSrc    : コピー元の長方形の幅と高さを指定
dwRop          : ラスタオペレーションコードを指定

関数が成功すると、0 以外の値が返ります。

'[デバイスコンテキストを解放します。]
Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, _
ByVal hDC As Long) As Long

hwnd : 解放するデバイスコンテキストに対応するウィンドウハンドルを指定
hDC : 解放するデバイスコンテキストのハンドルを指定

デバイスコンテキストが解放されたときは、1 が返ります。
デバイスコンテキストが解放されなかったときは、0 が返ります。

ScreenCapture（描画するオブジェクトのデバイスコンテキスト, _
キャプチャするサイズ幅，高さ，描画元ウィンドウハンドル，描画元デバイスコンテキスト）

使用例

call ShowMousePointerCursor（me.hdc,me.ScaleWidth,me.ScaleHeight,0,0,true）

'
'[画面キャプチャー(オブジェクトのサイズに合わせる機能付き)]
'
'■ 引数
'Objhdc:コピー先のデバイスコンテキストハンドルを指定
'ScaleWidth:コピー先の長方形の幅を指定
'ScaleHeight:コピー先の長方形の高さを指定
'hWndSrc:コピー元のウィンドウハンドルを指定
'hDCSrc:コピー元のデバイスコンテキストハンドルを指定
'AutoSize:オブジェクトのサイズに合わせるか？
'             (True=合わせる、False=変更しないでそのまま)
'□ 戻り値(なし)
Public Sub ScreenCapture(ByRef Objhdc As Long, _
                 ByVal ScaleWidth As Long, ByVal ScaleHeight As Long, _
                 ByVal hWndSrc As Long, ByVal hDCSrc As Long, _
                 ByVal AutoSize As Boolean)
   Dim ret As Long
   Dim Sh As Long, Sw As Long, Sx As Long, Sy As Long
   Dim flg As Boolean

   'hDCSrcが指定されていない場合には、ディスクトップ全体をキャプチャする
   If hDCSrc = 0 Then
      With Screen
         Sh = .Height
         Sw = .Width
         Sx = .TwipsPerPixelX
         Sy = .TwipsPerPixelY
      End With
      hDCSrc = GetDC(GetDesktopWindow())
      hWndSrc = GetDesktopWindow()
      flg = True
   End If
   'オブジェクトのサイズに合わせるか？
   If AutoSize Then
      ret = StretchBlt(Objhdc, 0, 0, _
         ScaleWidth, ScaleHeight, _
         hDCSrc, 0, 0, _
         Sw \ Sx, Sh \ Sy, _
         vbSrcCopy)
   Else
      ret = BitBlt(Objhdc, 0, 0, _
         ScaleWidth, ScaleHeight, _
         hDCSrc, 0, 0, _
         vbSrcCopy)
   End If

   If flg Then '必要に応じてデバイスコンテキストの解放
      ret = ReleaseDC(hWndSrc, hDCSrc)
   End If
End Sub

TOP

指定ウィンドウは表示/非表示になっているかを取得

使用API

'[ウィンドウの表示状態を取得する]
Private Declare Function IsWindowVisible Lib "user32" Alias "IsWindowVisible" ( _
ByVal hwnd As Long) As Long

hwnd
ウィンドウハンドルを指定

指定したウィンドウとその親ウィンドウが表示状態のときは
(WS_VISIBLE スタイルを持つときは)、0 以外の値が返ります。
指定したウィンドウとその親ウィンドウが非表示状態のときは
(WS_VISIBLE スタイルを持たないときは)、0 が返ります。

結果 = GetIswindowvisible（調べるウィンドウハンドル）

使用例

X = GetIswindowvisible（ME.hWnd）

'
'[ウィンドウの表示状態を取得する]
'
'■ 引数
'SethWnd:ウィンドウハンドルを指定
'□ 戻り値(True=表示, False=非表示)
Public Function GetIswindowvisible(ByVal SethWnd As Long) As Boolean
'見えているか
GetIswindowvisible = Not IsWindowVisible(SethWnd) = 0
End Function

TOP

通常移動できないコントロールのドラッグ移動

使用API

Public Const WM_NCLBUTTONDOWN = &HA1
Public Const HTCAPTION = 2

'[通常のマウス入力処理に戻します]
Private Declare Function ReleaseCapture Lib "user32" () As Long

関数が成功すると、0 以外の値が返ります。
関数が失敗すると、0 が返ります。

'[一つまたは複数のウィンドウに、メッセージを送ります]メッセージ送信先と同期します
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" ( _
ByVal hWnd As Long, _
ByVal wMsg As Long, _
ByVal wParam As Long, _
lParam As Any) As Long

hWnd
メッセージを受け取るウィンドウハンドルを指定。HWND_BROADCAST を指定すると、全トップレベルウィンドウにメッセージを送ります(子ウィンドウには送りません)
wMsg
送信するメッセージを指定
wParam
メッセージの追加情報を指定します。意味は wMsg パラメータの値により異なります。
lParam
メッセージの追加情報を指定します。意味は wMsg パラメータの値により異なります。

メッセージ処理の結果が返ります。意味は、メッセージにより異なります。
HWND_BROADCASTを使用する場合は、RegisterWindowMessage 関数を呼び出して、独自のメッセージを取得してください。

FMouseDown（対象ウィンドウハンドル）

使用例

CALL FMouseDown（ME.hWnd）

'
'通常移動できないコントロールのドラッグ移動
'■ 引数
' KeyAscii: KeyAscii
'□ 戻り値(なし)
' Visual BasicはMouseDownごとにSetCapture APIを呼び出すが、それを取り消す
' Windowsがドラッグを開始するように、メッセージを送る
Public Sub FMouseDown(ByVal objhWnd As Long)
   Dim nRet As Long
   Call ReleaseCapture
   nRet = SendMessage(objhWnd, WM_NCLBUTTONDOWN, HTCAPTION, 0&)
End Sub

TOP

数値以外の入力を無効にする

使用API

APIなし

KeyChkPress（KeyAscii）

使用例
Private Sub Text1_KeyPress(KeyAscii As Integer)
call KeyChkPress (KeyAscii)
End Sub

'
'[数値以外の入力を無効にする]
'■ 引数
'KeyAscii:KeyAscii
'□ 戻り値(なし)
Public Sub KeyChkPress(ByRef KeyAscii As Integer)
   If (KeyAscii < 48 Or KeyAscii > 57) Then
      If KeyAscii = 8 Then Exit Sub
      KeyAscii = 0
   End If
End Sub

TOP

二つの文字を比較する

WinNT/2000: Windows 2000以降 (インターネットエクスプローラ4.0以降が入っているNT4.0)
Windows95/98: Windows 98以降

使用API

'［２つの文字の比較を行う。比較は大文字小文字の違いを識別しない］
Private Declare Function ChrCmpI Lib "shlwapi" Alias "ChrCmpIA" _
(ByVal w1 As Byte, _
ByVal w2 As Byte) As Long

w1
比較される最初の文字
w2
比較される2番目の文字

二つの文字が一致するのなら、0を返す

結果 = chkChrCmp（比較される最初の文字，比較される2番目の文字）

使用例
X = chkChrCmp("A","a")

'
'[２つの文字の比較を行う。比較は大文字小文字の違いを識別しない]
'■ 引数
'C1:比較する文字1
'C1:比較する文字2
'□ 戻り値（Treu=一致、False=違う）
Public Function chkChrCmp(ByVal C1 As String,ByVal C2 As String) As Boolean
chkChrCmp = ChrCmpI(AscB(C1), AscB(C2)) = 0
End Function

TOP

フォルダーの新規作成

動きませんでした！間違い指摘歓迎！

ファイルシステムがファイルとディレクトリのセキュリティをサポートしている場合は、
指定されたセキュリティ記述子を新しいディレクトリに適用します。

使用API

'［ディレクトリを作成します］
>>セキュリティ属性に参照を指定する場合
    WinNT/2000: Windows NT 3.1以降

Public Type SECURITY_ATTRIBUTES
   nLength As Long
   lpSecurityDescriptor As Long
   bInheritHandle As Long
End Type

Private Declare Function CreateDirectory Lib "kernel32" Alias "CreateDirectoryA" _
(ByVal lpPathName As String, _
lpSecurityAttributes As SECURITY_ATTRIBUTES) As Long

>>今回はこちらを使用します。
>>セキュリティ属性にポインタを指定する場合
WinNT: バージョン 3.1 以降
Windows: Windows 95 以降

Public Const MAX_PATH = 260

Private Declare Function CreateDirectory Lib "kernel32" Alias _
"CreateDirectoryA" (ByVal lpPathName As String, Security As Long) As Long

lpPathName
作成するディレクトリのパス名を指定します。
パス名の最大長は、MAX_PATH 文字です。
Security
セキュリティ属性が入った
SECURITY_ATTRIBUTES構造体へのポインタを指定します。

関数が成功すると、0 以外の値が返ります。
関数が失敗すると、0 が返ります。

結果 = CreateDir（作成するフォルダ名を絶対パスで指定）

使用例
X = CreateDir("c:\test",)

'
'[ディレクトリを作成します]
'■ 引数
'dirPath:作成するフォルダ名を絶対パスで指定します。
'□ 戻り値（Treu=作成、False=失敗）
Public Function CreateDir(ByVal dirPath As String) As Boolean
   '最大文字数MAX_PATHを超えていないかをチェックする
   If MAX_PATH < len(dirPath) Then Exit Function
   CreateDir = CreateDirectory(dirPath, 0) = 0
End Function

TOP

ファイルのコピー

コピーするファイルのセキュリティ属性は、新しいファイルにはコピーされません。
コピーするファイルのファイル属性は、新しいファイルにコピーされます。

たとえば、コピーするファイルに読取専用属性が設定されていれば、
新しく作成したファイルにも読取専用属性が設定されます。

使用API

'［ファイルをコピーします］
Private Declare Function CopyFile Lib "kernel32" Alias "CopyFileA" _
(ByVal lpExistingFileName As String, _
ByVal lpNewFileName As String, _
ByVal bFailIfExists As Long) As Long

lpExistingFileName
コピーするファイル名が入った NULL で終わる文字列を指定
lpNewFileName
新しいファイルのファイル名が入った NULL で終わる文字列を指定
bFailIfExists
lpNewFileName で指定したファイルがすでに存在していたときの動作を指定
>>TRUE を指定すると、関数は失敗します (コピーは行われません)。
>>FALSE を指定すると、既存のファイルを上書きし、関数は成功します。

関数が成功すると、0 以外の値が返ります。
関数が失敗すると、0 が返ります。

結果 = doesCopyFile（コピーするファイル名を絶対パスで指定, _
コピー先ファイル名を絶対パスで指定, _
コピー先に同じ名前のファイルがあった場合に中止するか？）

使用例
X = doesCopyFile("c:\test\test.txt","c:\test\test.bak",true)

'
'[ファイルをコピーします]
'■ 引数
'dirPathFileName:コピーするファイル名を絶対パスで指定します。
'copyDPFileName:コピー先ファイル名を絶対パスで指定します。
'flgFailIfExists:コピー先に同じ名前のファイルがあった場合に中止するか？
'                  (True=コピーしない,False=上書きする)
'□ 戻り値（Treu=作成、False=失敗）
Public Function doesCopyFile(ByVal dirPathFileName As String, _
                                        ByVal copyDPFileName As String, _
                                        ByVal flgFailIfExists As Boolean) As Boolean
   doesCopyFile = CopyFile(dirPathFileName, copyDPFileName, flgFailIfExists) <> 0
End Function

TOP

指定範囲長方形の色反転

指定された長方形の内部の色を、論理 NOT 演算を使って反転します。

モノクロ画面では、白ピクセルは黒に、黒ピクセルは白に反転します。
カラー画面では、画面の色の生成方法によって反転色は異なります。

InvertRect 関数を 2 回呼び出すと、元のカラー表示に戻ります。

使用API

'［指定範囲長方形の色反転］

Public Type RECT
   Left As Long
   Top As Long
   Right As Long
   Bottom As Long
End Type

Private Declare Function InvertRect Lib "user32" Alias "InvertRect" _
(ByVal hdc As Long, _
lpRect As RECT) As Long

hdc
デバイスコンテキストのハンドルを指定
lpRect
長方形の座標が入った、RECT 構造体へのポインタを指定します。

関数が成功すると、0 以外の値が返ります。
関数が失敗すると、0 が返ります。

結果 = doesInvertRect(反転させるデバイスコンテキストのハンドルを指定, _
矩形の左上角のｘ座標, 矩形の左上角の y 座標, _
矩形の右下角のｘ座標, 矩形の右下角の y 座標)

使用例
X = doesInvertRect(picture1.hDC,0,0,picture1.Width,picture1.Height)

'
'[指定範囲長方形の色反転]
'■ 引数
'
'□ 戻り値（Treu=作成、False=失敗）
Public Function doesInvertRect(ByRef LhDC As Long, _
                                        ByVal Lleft As Long, ByVal LTop As Long, _
                                        ByVal LRight As Long, _
                                        ByVal LBottom As Long) As Boolean
   Dim r As RECT
   With r
      .Left = Lleft
      .Top = LTop
      .Right = LRight
      .Bottom = LBottom
   End With
   doesInvertRect = InvertRect (LhDC, r) <> 0
End Function

TOP

Windows98リソースの取得

Windows98上のみ利用可能です。(訂正日: 2009/05/21)

使用API

'［Windows98リソースの取得］
Private Declare Function MyGetFreeSystemResources Lib "rsrc32" Alias _
"_MyGetFreeSystemResources32@4" _
(ByVal idx As Long) As Long

idx
取得したいフラグを指定します。
0 = システム
1 = GDI
2 = User

結果 = pGetSysRes(INDEX値)

使用例
Private Sub SetLblResous()
    Dim i As Long
    Dim Resous(2) As Long
    For i = 0 To 2
        Resous(i) = pGetSysRes(i)
    Next i
    label1.caption = "Sys : " & Resous(0) & "％,GDI : " & Resous(1) & "％,User : " & Resous(2) & "％"
End Sub

'
'[Windows98リソースの取得]
'■ 引数
' 0 : システム
' 1 : GDI
' 2 : User
'□ 戻り値（％単位での空きリソース値が返ってきます。エラー時には100）
Public Function pGetSysRes(ByVal Index As Long) As Long
On Error GoTo ErrHandle
   pGetSysRes = MyGetFreeSystemResources(Index)
   Exit Function
ErrHandle:
   pGetSysRes = 100
End Function

TOP

マウス下の色を取得

ピクセルは、現在のクリッピング領域の内側になければなりません。

使用API

'［指定した座標のRGB値を取得する］
Private Declare Function GetPixel Lib "gdi32" Alias "GetPixel" _
(ByVal hdc As Long, ByVal x As Long, _
ByVal y As Long) As Long

hdc
デバイスコンテキストのハンドルを指定します。
x
色を取得するピクセルの X 座標を、論理単位で指定します。
y
色を取得するピクセルの Y 座標を、論理単位で指定します。

関数が成功すると、RGB 値が返ります。
現在のクリッピング領域外の座標が指定された時には、CLR_INVALID が返ります。

'座標
Public Type POINTAPI
x As Long
y As Long
End Type

'[マウスカーソルの現在の位置を、スクリーン座標で取得]
Private Declare Function GetCursorPos Lib "user32" _
(lpPoint As POINTAPI) As Long

lpPoint
POINT 構造体へのポインタを指定します。
この構造体に、マウスカーソルの位置がスクリーン座標で格納されます。

関数が成功すると 0 以外の値が返ります。
関数が失敗すると 0 が返ります。

'［現在スレッドに属する指定ウィンドウに、マウスのキャプチャーを設定］
Private Private Declare Function SetCapture Lib "user32" _
(ByVal hwnd As Long) As Long

hwnd
マウスをキャプチャーする、現在スレッドに属するウィンドウのハンドルを指定

関数が成功すると以前にマウスをキャプチャーしていたウィンドウのハンドルが返ります。そのようなウィンドウがない場合は、NULL が返ります。

マウスのキャプチャーが必要なくなったら、
ReleaseCapture 関数を呼び出して、マウスのキャプチャーを解除してください。

'[指定ウィンドウのクライアント領域デバイスコンテキストのハンドルを取得]
Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long

hWnd :デバイスコンテキストを取得するウィンドウハンドルを指定

関数が成功すると、
指定したウィンドウのクライアント領域のデバイスコンテキストのハンドルが返ります。
関数が失敗すると、NULL が返ります。

デバイスコンテキストが不要になったら、ReleaseDC 関数で解放してください。

'[通常のマウス入力処理に戻します]
Private Declare Function ReleaseCapture Lib "user32" () As Long

関数が成功すると、0 以外の値が返ります。
関数が失敗すると、0 が返ります。

デバイスコンテキストが解放されたときは、1 が返ります。
デバイスコンテキストが解放されなかったときは、0 が返ります。

結果 = pGetSysRes(INDEX値)

使用例

MouseDown時に、Call SetCapture(Me.hwnd)
MouseUp時に、Call ReleaseCapture　　　　　　　　　　　　　　　を実行するようにします。、

Private Sub Img_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
   'ボタンがクリックされたままになっている場合のみ取得する
   If Button <> 1 Then Exit Sub
   '
   Label1.BackColor = (GetMouseMoveColr(Me.hwnd))
   Text1.Text = Hex(Label1.BackColor)
End Sub

'
'[マウス下の色を取得]
'■ 引数
'Lhwnd:デバイスコンテキストを取得するウィンドウハンドルを指定
'□ 戻り値（成功時=RGB値, 失敗時＝0）
Public Function GetMouseMoveColr(ByVal Lhwnd As Long) As Long
   Dim scrDC As Long, lngCol As Long
   Dim mpoint As POINTAPI

   'ディスクトップのDCを取得
   scrDC = GetDC(0)
   'マウスの位置座標を取得
   Call GetCursorPos(mpoint)
   'マウス座標位置の色を取得
   lngCol = GetPixel(scrDC, mpoint.X, mpoint.Y)
   If lngCol <> -1 Then
      'エラーが無ければ続ける
      '色をセット
      GetMouseMoveColr = lngCol
   Else
      GetMouseMoveColr = RGB(0, 0, 0)
   End If
   'ゴミかたす
   Call ReleaseDC(Lhwnd, scrDC)
End Function

TOP