Option Explicit

' この方法は、テレビのニュース番組のタイトル画面でかなりはみでた
' 半透明透過処理をしていたのを見てAlphaBlendでなんとかできないかな〜
' っと思って、思いついたのがこの方法でした。
' 通常、AlphaBlendを単純に使用すると四角の領域が見えてあまりにもカッコ悪いです

' 追記: 2005/9/12
' コードとコメントに追加や削除をしました
' TransparentBlt() をWindows98で使用するとメモリーリークを起こします
'   (TransparentBlt() はWindows98からのAPIです)
' iAlphaの範囲が1〜100になっていましたが、0〜255に変更しました
'




'APIの宣言をします

' 牛歩API
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)


'こっちのイメージをあっちに、描画するAPIです
Private Declare Function BitBlt Lib "gdi32" _
        (ByVal hDestDC As Long _
        , ByVal x As Long _
        , ByVal y As Long _
        , ByVal nWidth As Long _
        , ByVal nHeight As Long _
        , ByVal hSrcDC As Long _
        , ByVal xSrc As Long _
        , ByVal ySrc As Long _
        , ByVal dwRop As Long) As Long

'こっちのイメージをあっちに、半透明で描画するAPIです
Private Declare Function AlphaBlend Lib "msimg32.dll" _
        (ByVal hdcDest As Long _
        , ByVal nXDest As Long _
        , ByVal nYDest As Long _
        , ByVal nWidthDest As Long _
        , ByVal nHeightDest As Long _
        , ByVal hdcSrc As Long _
        , ByVal nXSrc As Long _
        , ByVal nYSrc As Long _
        , ByVal nWidthSrc As Long _
        , ByVal nHeightSrc As Long _
        , ByVal nBlendFunc As Long) As Long
    
' こっちのイメージをあっちに、指定した色を透過して描画するAPIです
Private Declare Function TransparentBlt Lib "msimg32.dll" _
        (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 crTransparent As Long) As Long

'フォームをロードします
Private Sub Form_Load()
    
    'プロパティの設定をします
    
    ' View(ユーザーに見せる方のピクチャボックス)
    picView.Picture = LoadPicture(App.Path & "\background.bmp")
    picView.AutoRedraw = True
    
    'DeskWork(処理用のピクチャボックス、通常は非表示)
    picWorkingArea.ScaleMode = vbPixels
    picWorkingArea.AutoRedraw = True
    picWorkingArea.BorderStyle = 0
    picWorkingArea.BackColor = vbWhite
    
    'Material(素材用のピクチャボックス、通常は非表示)
    picMaterial.Picture = LoadPicture(App.Path & "\starting.bmp")
    picMaterial.AutoSize = True
    picMaterial.ScaleMode = vbPixels
    picMaterial.AutoRedraw = True
    picMaterial.BorderStyle = 0
    picMaterial.BackColor = vbWhite
    
End Sub

'開始ボタンを押しました
Private Sub Command1_Click()
    Dim iAlpha          As Integer
    Dim lngTnsLeft      As Long
    Dim lngTnsTop       As Long
    Dim lngTnsWidth     As Long
    Dim lngTnsHeight    As Long
        
    '開始ボタンのイベント受付無効にします
    Command1.Enabled = False
    
    
    '素材画像の大きさに合わせるために
    'この幅はよく使うので代入します
    lngTnsWidth = picMaterial.ScaleWidth
    lngTnsHeight = picMaterial.ScaleHeight
    
    'picWorkingAreaの幅をpicMaterialと同じにします
    picWorkingArea.Width = lngTnsWidth * Screen.TwipsPerPixelX
    picWorkingArea.Height = lngTnsHeight * Screen.TwipsPerPixelY
    
    
    '擬似半透明透過処理のアニメーションを
    '行います
    For iAlpha = 0 To 255
        
        '消去します
        picView.Cls
        picWorkingArea.Cls
        
        ' 結果を描画する位置を設定します
        lngTnsLeft = iAlpha / 2
        lngTnsTop = 170
        
        
        'picViewの画像の一部を描画します
        'picView → picWorkingArea
        BitBlt picWorkingArea.hDC, 0, 0, lngTnsWidth, lngTnsHeight _
                , picView.hDC, lngTnsLeft, lngTnsTop, vbSrcCopy
                
        'picMaterialのイメージの白色を透過して描画します
        'picMaterial → picWorkingArea
        TransparentBlt _
                picWorkingArea.hDC, 0, 0, lngTnsWidth, lngTnsHeight _
                , picMaterial.hDC, 0, 0, lngTnsWidth, lngTnsHeight _
                , vbWhite
                
        'picWorkingAreaとpicMaterialの合成画像を
        'picWorkingAreaの元のあったpicViewの位置に戻します
        'picWorkingArea → picView
        'ここでミソとなるのがAlphaBlendです
        '色と色の値(各RGB)に差がなければ変化しないところが
        'この処理の重要なところです
        AlphaBlend _
                    picView.hDC, lngTnsLeft, lngTnsTop, lngTnsWidth, lngTnsHeight _
                    , picWorkingArea.hDC, 0, 0, lngTnsWidth, lngTnsHeight _
                    , iAlpha * &H10000
        
        'ループするので強制的に画面に表示します
        picView.Refresh
        
        
        ' 通常は不要ですが
        ' 処理の進行を見るため使います
        picWorkingArea.Refresh
        picMaterial.Refresh
        
        ' 早いマシンでも一定の速度で処理の進行を見るため遅くします
        MySleep 20
        
    Next
    
    '開始ボタンのイベント受付有効にします
    Command1.Enabled = True
    
End Sub


' 0だけは絶対設定しない牛歩関数
Sub MySleep(ByVal nMilliSecond As Long)
    If nMilliSecond > 0 Then
        Sleep nMilliSecond
    End If
End Sub