| |
こんにちは
フォームの形を変えるのはやったこと無いので、残りを。
PSETや、LINEは、APIを使います。
ユーザーフォームを１つ作って、ユーザーフォームのモジュールに下記コードを
コピペして下さい。
Option Explicit
Private Declare Function GetDC Lib "user32.dll" _
(ByVal hwnd As Long) As Long
Private Declare Function ReleaseDC Lib "user32.dll" _
(ByVal hwnd As Long, ByVal hdc As Long) As Long
Private Declare Function GetActiveWindow Lib "user32.dll" () As Long
Private Declare Function SetPixelV Lib "gdi32.dll" _
(ByVal hdc As Long, ByVal X As Long, ByVal Y As Long, ByVal crColor As Long) As Long
Private Declare Function CreatePen Lib "gdi32.dll" _
(ByVal fnPenStyle As Long, ByVal nWidth As Long, _
ByVal crColor As Long) As Long
Private Const PS_solid = 0 '実線
Private Const PS_DASH = 1 '破線
Private Const PS_DOT = 2 '点線
Private Const PS_DASHDOT = 3 '一点鎖線
Private Const PS_DASHDOTDOT = 4 '二点鎖線
Private Const PS_NULL = 5 '非表示
Private Const PS_INSIDEFRAME = 6 '塗りつぶし
Private Declare Function DeleteObject Lib "gdi32.dll" _
(ByVal hObject As Long) As Long
Private Declare Function SelectObject Lib "gdi32.dll" _
(ByVal hdc As Long, ByVal hgdiobj As Long) As Long
Private Declare Function MoveToEx Lib "gdi32.dll" _
(ByVal hdc As Long, ByVal X As Long, ByVal Y As Long, _
ByVal lpPoint As Long) As Long
Private Declare Function LineTo Lib "gdi32.dll" _
(ByVal hdc As Long, ByVal nXEnd As Long, ByVal nYEnd As Long) As Long
Private hwnd As Long
Private Sub UserForm_Activate()
hwnd = GetActiveWindow 'ウインドウハンドル取得
If hwnd = 0 Then
MsgBox "エラーです"
Unload Me
End If
End Sub
Private Sub UserForm_Click()
Dim hdc As Long
Dim hpen As Long
Dim hpenSave As Long
Dim col As Long
col = RGB(255, 0, 0) '色コード
hdc = GetDC(hwnd) 'デバイスコンテキストを取得
hpen = CreatePen(PS_solid, 5, col) 'ペンを作成 5は太さ
hpenSave = SelectObject(hdc, hpen) 'デバイスコンテキストに作成したペンを選択と共に、元のペンを記憶しておく
MoveToEx hdc, 0, 0, 0 '書き始めに移動
LineTo hdc, Me.Width / 0.75, Me.Height / 0.75 '線を引く
SelectObject hdc, hpenSave 'デバイスコンテキストのペンを元に戻す
DeleteObject hpen '作成したペンを削除
ReleaseDC hwnd, hdc 'デバイスコンテキストを開放（削除してはダメ）
End Sub
Private Sub UserForm_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
Dim hdc As Long
Dim col As Long
If Button = 2 Then
hdc = GetDC(hwnd) 'デバイスコンテキストを取得
col = RGB(0, 0, 255) '色コード
SetPixelV hdc, X / 0.75, Y / 0.75, col '指定位置に点を書く
ReleaseDC hwnd, hdc 'デバイスコンテキストを開放
End If
End Sub
ユーザーフォームを表示して、ユーザーフォームをクリックすると
赤い斜めの線が引かれます。（芸がない＾＾；）
MovoToExとLineToのサンプルです。
ユーザーフォームを右ボタン押してドラッグすると、なぞったところに
青い点が引かれます。(SetPixcelVのサンプル)
座標系はピクセルなので、フォームのポイント座標の0.75倍だそうです。
Windowsのオブジェクトを操作することになるので、
作成したオブジェクトをDeleteしなかったり、
オブジェクトをSelectObjectしたままで、元のオブジェクトに戻さなかったり、
Getしたデバイスコンテキストを開放すべきところを削除してしまったり、
してしまうと、Windowsが不安定になる恐れがありますので、
各関数の使い方をしっかり勉強して、
クラッシュしてもよい環境で実験して下さい。
API関数のリファレンスは、こちらが参考になります。
http://www.geocities.jp/winapi_database/
また、関数名でweb検索すると、使用例などがたくさんでてきます。
|
|
ｎｉ
- 04/11/17(水) 19:03 -
