よく見かけるVBサンプル集
BACK -Page-Next-
NEXT
[00〜09] [10〜19] [20〜29] [30〜39] [40〜49]
[50〜59] [60〜69] [70〜79] [80〜89] [90〜99]
MENU 50〜59
50カラーマウスのソースコードダウンロード
API
場所問わず、マウス下の色を取得したり、2色の色を合成したりするサンプルです。
51テキスト出力(Sampleのみ)(色、フォントサイズ、角度、太さ等の指定が可能)
API
角度指定、フォントの太さ指定、フォント名指定、(縁取り、影付きも可能)混合バイト文字にも対応
52画像をフィールドイン[幕を左から開く] DownLoad Pic API
53メニュー選択時に説明を表示する DownLoad
Pic API
メニューが選択された時に、自動的に説明を表示するサンプルです。
54TYPE定義配列の初期化を一括して処理する例 API
56ウインドウ名からプロセスハンドルを取得する API New
57Single型をHex値(16進数)へ変換 API New
58Double型ほHex値(16進数)へ変換 API New
使用API |
'[ビットブロック転送](論理単位で指定) 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 : コピー先のデバイスコンテキストハンドルを指定 関数が成功すると、0 以外の値が返ります。 ’[指定された時間にわたって、現在のスレッドの実行を中断します] dwMilliseconds : '[強制的に再描画する] hwnd 指定されたウィンドウの更新リージョンが空ではない場合、ウィンドウへ WM_PAINT メッセージを送信し、そのウィンドウのクライアント領域を更新します。 関数が成功すると、0
以外の値が返ります。 |
画面の切り替えに使用する場合等に使います。
オブジェクトを指定する場合(formやPictureboxなど)
結果 = LeftToEffect(描画先のオブジェクト,
描画元のオブジェクト, _幕の幅サイズ(1〜), _
対象オブジェクトのフォームのスケールモードかどうか?)
使用例
Picture1.AutoReDraw = TRUE になっていることが条件です。
Picture1.AutoRedraw = True
X = Call LeftToEffect(Picture1, Picture2, 20, Me.ScaleMode = vbPixels)
'[画像をフィールドイン[幕を左から開く]] '------------------------------------------------------------ ' 描画対象のオブジェクトを指定する場合 ' (自動的に再描画を行います) '------------------------------------------------------------ '■ 引数 ' DestImage:描画先のオブジェクト、SrcBitmap:描画元のオブジェクト、 ' DrwW:幕の幅サイズ(1〜) 'scalePIXEL: ' 対象オブジェクトのフォームのスケールモード(scaleMode)が ' PIXELに指定している場合に指定してください。 ' (PIXELに指定しない場合、初期値のTwipのままであれば正常に動作します。) Sub LeftToEffect(ByRef DestImage As Object, ByRef SrcBitmap As Object, _ ByVal DrwW As Long, _ ByVal scalePIXEL As Boolean) Dim i As Integer, j As Integer, srcX As Integer Dim EffTable() As Integer Dim TimeCount&, LongInt& Dim SizeYX As Integer, SizeW As Long, SizeH As Long SizeYX = DrwW& '一度に描画する幅のサイズ ReDim EffTable(SizeYX) As Integer 'scaleに合わせて、描画サイズを修正する SizeW = SrcBitmap.Width SizeH = SrcBitmap.Height If scalePIXEL = False Then SizeW = SizeW \ Screen.TwipsPerPixelX SizeH = SizeH \ Screen.TwipsPerPixelY End If 'テーブル初期化 For i = 0 To SizeYX: EffTable(i) = -1: Next i i = 0 '------------------------------------------------------ Do While EffTable(0) < (SizeW / 2) If SizeYX - i >= 0 Then EffTable(SizeYX - i) = SizeYX - i For j = 0 To SizeYX If (EffTable(j) >= 0) And (EffTable(j) < (SizeW / 2)) Then srcX = EffTable(j) * 2 Call BitBlt(DestImage.hDC, srcX, 0, 2, SizeH, _ SrcBitmap.hDC, srcX, 0, vbSrcCopy) EffTable(j) = EffTable(j) + (SizeYX + 1) End If Next j '再描画 DestImage.Refresh DoEvents 'ウェイト Sleep 100 i = i + 1 'インクルメント Loop End Sub |
オブジェクトのデバイスコンテキストを利用する場合
結果 = LeftToEffectEX(描画先のHDC, 描画先のhwnd, 描画元のHDC, _
描画元の高さ、描画元の幅, _
幕の幅サイズ(1〜), _
対象オブジェクトのフォームのスケールモードかどうか?)
使用例
Picture1.AutoReDraw =
FALSE になっていることが条件です。
その為、描画後は再描画されないために画像は保持されません。
Picture1.AutoRedraw = False
X = Call LeftToEffectEX(Picture1.hDC, Picture1.hwnd, Picture2.hDC, _
Picture2.Height, Picture2.Width, _
20, _
Me.ScaleMode = vbPixels)
'[画像をフィールドイン[幕を左から開く]] '------------------------------------------------------------ ' オブジェクトのデバイスコンテキストを利用する場合 ' 自動的に再描画を行います。 '------------------------------------------------------------ '■ 引数 ' DestImageDC:描画先のHDC、DestImagehwnd:描画先のhwnd ' SrcBitmapDC:描画元のHDC ' SrcH:描画元の高さ、SrcW:描画元の幅 ' DrwW:幕の幅サイズ(1〜) 'scalePIXEL: ' 対象オブジェクトのフォームのスケールモード(scaleMode)が ' PIXELに指定している場合に指定してください。 ' (PIXELに指定しない場合、初期値のTwipのままであれば正常に動作します。) ' -*-*注意*-*- ' これを利用する場合には、描画先の.AutoRedraw を False にする必要があります。 ' LeftToEffectの拡張版 (LeftToEffectよりレンポンスは良いハズです(謎)) Sub LeftToEffectEX(ByRef DestImageDC As Long, ByRef DestImagehwnd As Long, _ ByRef SrcBitmapDC As Long, _ ByVal SrcH As Long, ByVal SrcW As Long, _ ByVal DrwW As Long, _ ByVal scalePIXEL As Boolean) Dim i As Integer, j As Integer, srcX As Integer Dim TimeCount As Long, LongInt As Long Dim EffTable() As Integer ReDim EffTable(DrwW&) As Integer '一度に描画する幅のサイズ ' テーブルの初期化 For i = 0 To DrwW&: EffTable(i) = -1: Next i 'scaleに合わせて、描画サイズを修正する If scalePIXEL = False Then SrcW& = SrcW& \ Screen.TwipsPerPixelX SrcH& = SrcH& \ Screen.TwipsPerPixelY End If i = 0 '------------------------------------------------------ Do While EffTable(0) < (SrcW& / 2) If DrwW& - i >= 0 Then EffTable(DrwW& - i) = DrwW& - i For j = 0 To DrwW& If (EffTable(j) >= 0) And (EffTable(j) < (SrcW& / 2)) Then srcX = EffTable(j) * 2 Call BitBlt(DestImageDC, srcX, 0, 2, SrcH&, SrcBitmapDC, srcX, 0, vbSrcCopy) EffTable(j) = EffTable(j) + (DrwW& + 1) End If Next j '再描画 CALL UpdateWindow(DestImagehwnd) 'ウェイト DoEvents Sleep 100 'インクルメント i = i + 1 Loop End Sub |
使用API |
'指定されたメモリブロックに値 0 を書き込みます Private Declare Sub ZeroMemory Lib "KERNEL32" Alias _ "RtlMoveMemory" (dest As Any, ByVal numBytes As Long) dest
:書き込みたいメモリブロックの開始アドレスへのポインタを指定
|
ユーザー定義配列等で一括して入力値をクリアしたい場合に使用します。
使用例
TYPE AAA
lngTEST1 as long
strTEST2 as string
END TYPE
'------------------------------------------------------------ ' 配列の初期化を一括して処理する例 '------------------------------------------------------------ Call ZeroMemory(AAA, Len(AAA))
|
使用例
プログレスバーを表示させたい時に、ProgressBar1.Visible
= True します。
処理が終わったら、ProgressBar1.Visible = False します。
1.フォーム上にプログレスバーとステータスバーを追加します。
以下のコードをフォームのSub FORM_LOAD ()欄へ追加してください。 |
Dim
NewPanel As Object '-- プログレスバーの非表示 ProgressBar1.Visible = False '-- ステータスバーにプログレスバーを追加する領域を確保します。 Set NewPanel = StatusBar1.Panels.Add NewPanel.Style = sbrNormal NewPanel.Key = "PROGRESS" NewPanel.Width = 1000 '-- ステータスバー再描画 StatusBar1.Refresh '-- プログレスバー設定 ProgressBar1.Top = StatusBar1.Top + 30 'ここは調整して ProgressBar1.Height = StatusBar1.Height - 30 'ここは調整して ProgressBar1.Left = StatusBar1.Panels("PROGRESS").Left ProgressBar1.Width = StatusBar1.Panels("PROGRESS").Width ProgressBar1.ZOrder 0 'プログレスバーを最上位表示 |
使用API |
Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpszClassName As String, ByVal lpszWindowName As String) As Long
Declare Function GetWindowThreadProcessId Lib "user32" (ByVal hWnd As Long, ByRef lpdwProcessId As Long) As Long Declare Function OpenProcess Lib "kernel32" (ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal dwProcessId As Long) As Long Const PROCESS_VM_READ As Long = &H10 |
使用例
x =GetWindowProcess("電卓")
以下を標準モジュールへ追加 |
Function
GetWindowProcess(ByVal
Title
As
String)
As Long 'ウインドウ名からプロセスハンドルを取得する Dim hWnd As Long Dim PID As Long Dim hProcess hWnd = FindWindow(Title, vbNullString) If hWnd = 0 Then Exit Function 'ウィンドウハンドルからプロセスハンドルを取得 Call GetWindowThreadProcessId(hWnd, PID) hProcess = OpenProcess(PROCESS_VM_READ, 0, PID) GetWindowProcess = hProcess End Function |
使用API |
Declare Sub CopyValtoVal Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal length As Long) |
使用例
x =SingleToHex(b)
以下を標準モジュールへ追加 |
Function
SingleToHex(ByVal
s
As
Single,
_ Optional ByVal direction As Boolean = False) As String Dim i& Dim b(3) As Byte Dim st$, st2 As String Call CopyValtoVal(b(0), s, 4) If direction = False Then For i = 0 To 3 st = Hex(b(i)) st2 = st2 + String(2 - Len(st), "0") + st If i < 3 Then st2 = st2 + " " Next i Else For i = 3 To 0 Step -1 st = Hex(b(i)) st2 = st2 + String(2 - Len(st), "0") + st If i > 0 Then st2 = st2 + " " Next i End If SingleToHex = st2 End Function |
使用API |
Declare Sub CopyValtoVal Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal length As Long) |
使用例
x =SingleToHex(b)
以下を標準モジュールへ追加 |
Function
DoubleToHex(ByVal
d
As
Double,
_ Optional ByVal direction As Boolean = False) As String Dim i& Dim b(7) As Byte Dim st$, st2$ As String Call CopyValtoVal(b(0), d, 7) If direction = False Then For i = 0 To 7 st = Hex(b(i)) st2 = st2 + String(2 - Len(st), "0") + st If i < 7 Then st2 = st2 + " " Next i Else For i = 7 To 0 Step -1 st = Hex(b(i)) st2 = st2 + String(2 - Len(st), "0") + st If i > 0 Then st2 = st2 + " " Next i End If DoubleToHex = st2 End Function |