Sample 01

イメージシフト

DownLoad

Command1
Picture1
Picture2

をフォームに貼り付けて、以下のコードを、フォームのソースコードへコピーして貼り付けてください。

Picture2　にお好きな画像を貼り付ければ実行できます。

VB4以降であれば、問題なく実行可能なはずです。

手抜きしてます(￣▽￣;)すみません。
描画対象を[書込みと読込み]を同じオブジェクトへ指定すると下半分ダブってしまいます。

このままの場合は、全部読込んでから　書込みしてください。

Option Explicit

Private Declare Function GetPixel Lib "gdi32" _
                     (ByVal hdc As Long, _
                      ByVal x As Long, _
                      ByVal y As Long) As Long
Private Declare Function SetPixelV Lib "gdi32" _
                     (ByVal hdc As Long, _
                      ByVal x As Long, _
                      ByVal y As Long, _
                      ByVal crColor As Long) As Long
'--------------------------------------------------------------
Private Sub Command1_Click()

    Dim p As Long

    p = CLng(Text1.Text)
    Screen.MousePointer = 11

    Call BitMapShift(Picture2.hdc, _
                           Picture1.hdc, _
                           p, _
                           Picture2.ScaleWidth, _
                           Picture2.ScaleHeight)
                           Picture1.Refresh

    Screen.MousePointer = 0
End Sub
'--------------------------------------------------------------
Private Sub Form_Load()

    '初期設定(サンプルということで...)
    Picture1.AutoSize = False 
    Picture1.AutoRedraw = True 
    Picture1.BorderStyle = 0 
    Picture1.ScaleMode = vbPixels 'ピクセル

    Picture2.AutoSize = True
    Picture2.AutoRedraw = True
    Picture2.BorderStyle = 0
    Picture2.ScaleMode = vbPixels 'ピクセル
End Sub
'------------------------------------------
'画像をシフトする
'------------------------------------------
Private Sub BitMapShift(ByVal PichDC As Long, _
                                  ByVal OuthDC As Long, _
                                  ByVal Power As Long, _
                                  ByVal PictX As Long, _
                                  ByVal PictY As Long)
    Dim i As Integer
    Dim shiftw As Long, halfw As Long
    Dim y As Long, x As Long

    '
    '　0は、エラー
    '　必要に応じて、変更してください。
    'If Power = 0 Then Exit Sub

    '
    '初期値設定
    '
    i = PictY '画像の幅
    shiftw = PictY / Power 'シフト幅
    '
    '画像幅よりシフト幅が大きい場合は、修正する
    '
    If shiftw > i Then
        shiftw = i
    End If
    '
    '　シフト開始　(横にシフト)
    '
    For y = 0 To PictY
        '
        '読込んで書込む
        'シフトして失われる部分を反対側から書込む
        For x = 0 To shiftw + 1
            Call SetPixelV(OuthDC, PictX - shiftw + x, y, GetPixel(PichDC, x, y))
        Next x
        '
        '読込んで書込む
        'そのまま　シフト
        For x = 0 To PictX - shiftw - 1
            Call SetPixelV(OuthDC, x, y, GetPixel(PichDC, x + shiftw, y))
        Next x
    DoEvents
    Next y

End Sub