オートシェイプもどきを作成
 　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　玄関へお回り下さい。
ExcelやWordのオートシェイプ（もどき）をVBで作成　　　  (395)
Excel 又は Word で作成したい図形をオートシェイプを使って作成して、*.wmf 形式で保存してピクチャーボックスに表示して下さい。使用するコントロールは下図を参考にして下さい。
CommandButton ４個　PictureBox １個　TextBox 1個　です。
　　　　 Option Explicit　　 'SampleNo=239　WindowsXP VB6.0(SP5) 2002.06.27
'ウィンドウに関するデータを取得する(P59)
Private Declare Function GetWindowLong Lib "user32" _
　　Alias "GetWindowLongA" (ByVal hwnd As Long, _
　　ByVal nIndex As Long) As Long
'ウィンドウに関する属性を変更する(P60)
Private Declare Function SetWindowLong Lib "user32" _
　　Alias "SetWindowLongA" (ByVal hwnd As Long, _
　　ByVal nIndex As Long, ByVal dwNewLong As Long) As Long

Private Const GWL_STYLE = (-16)　　　　 'ウィンドウスタイル(P61)
Private Const WS_THICKFRAME = &H40000　 'リサイズ可能な枠線を持つ(48)
Private Mps As Boolean　'カーソル位置のフラグ
Private XPos As Long　　'マウスポインターのX座標
Private YPos As Long　　'マウスポインターのY座標

Private Sub Command1_Click()
　　'PictureBoxに文字を記入
　　With Picture1
　　　　.Move 1500, 700, 2400, 1100
　　　　.ForeColor = vbRed
　　　　.FontBold = True
　　End With
　　Locate Picture1, 4, 1, Text1.Text
End Sub

Private Sub Command2_Click()
　　'PictureBoxに書いた文字を消去
　　Picture1.Cls
End Sub

Private Sub Command3_Click()
　　'雲形吹き出しの画像を表示
　　Set Picture1.Picture = LoadPicture("test1.wmf")
End Sub

Private Sub Command4_Click()
　　'ブロック矢印の画像を表示
　　Set Picture1.Picture = LoadPicture("test0.wmf")
End Sub

Private Sub Form_Load()
　　'初期表示
　　Call sSetSyelipu(0)
End Sub

Private Sub Form_MouseMove(Button As Integer, _
　　　　　　　　　　　　　 Shift As Integer, X As Single, Y As Single)
　　'マウスポインターがPictureBox外に移動した場合
　　If Mps = True Then
　　　　'移動枠を削除してフラットに
　　　　Call sSetSyelipu(2)
　　　　Picture1.BorderStyle = 0
　　End If
　　Mps = False
End Sub

Private Sub Picture1_MouseMove(Button As Integer, _
　　　　　　　　　　　　　　Shift As Integer, X As Single, Y As Single)
　　'マウスポインターがPictureBox内に移動したのが最初の時だけ
　　If Mps = True Then
　　　　'移動できる枠線を表示
　　　　Call sSetSyelipu(1)
　　Else
　　　　Mps = True
　　End If
End Sub

Private Sub sSetSyelipu(sNo As Integer)
　　'指定のウィンドウのピクチャーボックスを作成
　　Dim Result As Long
　　Dim WStyle As Long
　　If sNo = 0 Then
　　　　Set Picture1.Picture = LoadPicture("test1.wmf")
　　End If
　　If sNo = 1 Then
　　　　Picture1.BorderStyle = 1
　　　　DoEvents
　　End If
　　'現在のスタイルを取得
　　WStyle = GetWindowLong(Picture1.hwnd, GWL_STYLE)
　　'そのスタイルに新しいスタイルを追加
　　If sNo <= 1 Then
　　　　WStyle = WStyle Or WS_THICKFRAME
　　Else
　　　　WStyle = WStyle Xor WS_THICKFRAME
　　End If
　　'新しいスタイルを設定
　　Result = SetWindowLong(Picture1.hwnd, GWL_STYLE, WStyle)
　　Picture1.ZOrder (1)
End Sub

Private Sub Locate(myObj As Object, X As Long, Y As Long, myStr As String)
'ピクチャーボックスに文字を表示するための自作関数
　　Dim sm As Integer
　　With myObj
　　　　sm = .ScaleMode
　　　　.ScaleMode = vbCharacters　 'キャラクターモード
　　　　.CurrentX = X
　　　　.CurrentY = Y
　　End With
　　myObj.Print myStr
　　myObj.ScaleMode = sm
End Sub

'以下は、ピクチャーボックスをドラッグ・アンド・ドロップするための処理
Private Sub Picture1_DragDrop(Source As Control, X As Single, Y As Single)
'同一コントロール内でドロップした場合の補正
　　Source.Move (Picture1.Left + X - XPos), (Picture1.Top + Y - YPos)
End Sub

Private Sub Picture1_MouseDown(Button As Integer, _
　　　　　　　　　　　　Shift As Integer, X As Single, Y As Single)
'ドラッグ開始位置の保存とドラッグの開始
　　YPos = Y
　　XPos = X
　　Picture1.Drag vbBeginDrag
End Sub

Private Sub Form_DragDrop(Source As Control, _
　　　　　　　　　　　　　　　　　　X As Single, Y As Single)
'フォーム上にドロップした時の補正
　　Source.Move X - XPos, Y - YPos
End Sub
　
　　　下記のようにコントロールを配置して下さい。 ピクチャーボックスの枠線は
　　　サイズ変更用の枠線を表示させた状態です。
　　　

　　　　実行結果でサイズ変更した図です（合成しています　Pictureが１個なので）
　　　
API関数を使って、移動できる枠線を持ったピクチャーボックスを作成し、ピクチャーボックスに表示したメタファイルを変形させています。
マウスポインターがコントロール上にある場合だけ枠線を表示するようにしております。
回転や鏡像を表示するとメタファイルからビットマップファイルに変換されるので、画像の方で用意しておき画像を切り替えた方が簡単かと思います。
掲示板で質問があり、それらしい物が作れるか試して見ただけなので、移動とサイズ変更を中心にテストしてみました。（当然ながらこれ以外の図形も作成できます。）

ラインだけならバックカラーを黒のピクチャーボックスを移動・サイズ変更する事で可能となります。但しその場合枠線の部分より高さをマウスのドラッグで低く（線の太さ）する事はできませんのであらかじめピクチャーボックスの高さをコードで設定しておく必要があります。
ラインをメタファイルで作成してファイルの高さをラインの高さより上下に余裕を持たせて作ればドラッグでも細いラインが作れます。（上記はサイズ指定で作成）

サブクラス化や画像ファイルをメタファイルとして扱えばもう少しはそれらしくなるかとは思うのですが、私の頭の方が拒否反応をおこしておりますので、今回はオートシェイプもどきの”もどき”でご勘弁を。
使用目的によっては、雲形吹き出しの形に切り抜いたフォームやコントロールを作成する事も可能なのでそちらの方も試して見て下さい。　




2004/08/04