Sample 100

よく見かける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]


indexへ戻る

MENU 50〜59 


50カラーマウスソースコードダウンロード  API 
場所問わず、マウス下の色を取得したり、2色の色を合成したりするサンプルです。

51テキスト出力(Sampleのみ)(色、フォントサイズ、角度、太さ等の指定が可能)  API
角度指定、フォントの太さ指定、フォント名指定、(縁取り、影付きも可能)混合バイト文字にも対応

52画像をフィールドイン[幕を左から開く] DownLoad  Pic API  

53メニュー選択時に説明を表示する DownLoad  Pic API 
メニューが選択された時に、自動的に説明を表示するサンプルです。

54TYPE定義配列の初期化を一括して処理する API 

55ステータスバーにプログレスバー追加する簡単な方法

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

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


’[指定された時間にわたって、現在のスレッドの実行を中断します]
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long) 

dwMilliseconds  : 
実行を中断する時間を、ミリ秒(ms)単位で指定します。0 を指定すると、現在のスレッドは、優先順位が等しく実行の準備ができているほかのスレッドに残りのタイムスライスを譲ります。そのようなスレッドが存在しない場合は、この関数は即座に制御を返します。
INFINITE = &HFFFF ' Infinite timeout を指定すると、実行が無制限に中断されます。


'[強制的に再描画する]
Private Declare Function UpdateWindow Lib "user32" _
(ByVal
hwnd As Long) As Long

hwnd
現在スレッドに属するウィンドウのハンドルを指定

指定されたウィンドウの更新リージョンが空ではない場合、ウィンドウへ WM_PAINT メッセージを送信し、そのウィンドウのクライアント領域を更新します。

関数が成功すると、0 以外の値が返ります。
関数が失敗すると、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

TYPE定義配列の初期化を一括して処理する 例

使用API
'指定されたメモリブロックに値 0 を書き込みます
Private Declare Sub ZeroMemory Lib "KERNEL32" Alias _
                      "RtlMoveMemory" (dest
As Any, ByVal numBytes As Long)

dest    :書き込みたいメモリブロックの開始アドレスへのポインタを指定
Length :書き込みたいメモリブロックのサイズをバイト単位で指定

 

ユーザー定義配列等で一括して入力値をクリアしたい場合に使用します。

使用例

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
D
im hProcess
hWnd =
FindWindow(Title, vbNullString)
If hWnd = 0 Then Exit Function

'ウィンドウハンドルからプロセスハンドルを取得
Call GetWindowThreadProcessId(hWnd, PID)
hProcess = OpenProcess(PROCESS_VM_READ, 0, PID)

GetWindowProcess = hProcess

E
nd Function

Single型をHex値(16進数)へ変換

使用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

Double型をHex値(16進数)へ変換

使用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

TOP