[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『VBA ユーザーフォームのイメージコントロール内に図形を描画させたい』（マカロニグラタン）
こんにちは。うまく伝わるといいのですが、下記のようなことを
やりたいと思っています。
図形のテスト問題をVBAのユーザーフォームを用いて作成しています。
テスト問題はユーザーフォーム内のイメージコントロール（Image1）内に
画像を呼び出して表示させています。
例えば正方形の図形を画像として一つ表示させています。
テスト問題として「対角線を入力しなさい」と出題したとします。
回答者はそのイメージコントロール内に線分を入力します（1点目クリック、2点目をクリックのような感じで）。
書かれた線分の位置を記録して合っていれば正解、間違っていれば不正解と表示
します。
（人によって多少ずれるとは思いますので許容範囲は持たせようと思います。）
今回の質問は・・
1.イメージコントロール内をクリックして線分を書かせる方法
2.記述した線分の座標位置を取得する方法
を知りたいです。（そもそもできるかもわからないですが・・）
＜ 使用 Excel：Excel2016、使用 OS：Windows10 ＞
APIだと↓こんな感じの記事が引っ掛かりましたよ。 なんか準備が大変そうですね...(やった事ないからそう見えるだけかも知れませんが^^;)
Excel Gamer - Shadow Slash Ｃｈａｐｔｅｒ.１３４ [ APIによる描画処理６：図形描画実践編 ]
http://shadowslasheizan.blog114.fc2.com/blog-entry-160.html
（白茶） 2021/12/27(月) 11:49
ちょっと待ち時間ができたので、自身の勉強がてら見様見真似で書いてみまたモノを貼っときます。 (いまだにあんまり理解してません^^; 正直「合ってんのか?コレ...」って感じです)
Option Explicit
Private Type POINTAPI
X As Long
Y As Long
End Type
Private Type LOGPEN
lopnStyle As Long
lopnWidth As POINTAPI
lopnColor As Long
End Type
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Private Declare PtrSafe Function WindowFromAccessibleObject Lib "oleacc.dll" (ByVal IAcessible As Object, ByRef hwnd As LongPtr) As Long
Private Declare PtrSafe Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
Private Declare PtrSafe Function ScreenToClient Lib "user32" (ByVal hwnd As LongPtr, lpPoint As POINTAPI) As Long
Private Declare PtrSafe Function GetDC Lib "user32" (ByVal hwnd As LongPtr) As LongPtr
Private Declare PtrSafe Function ReleaseDC Lib "user32" (ByVal hwnd As LongPtr, ByVal hDC As LongPtr) As Long
Private Declare PtrSafe Function SelectObject Lib "gdi32" (ByVal hDC As LongPtr, ByVal hObject As LongPtr) As LongPtr
Private Declare PtrSafe Function DeleteObject Lib "gdi32" (ByVal hObject As LongPtr) As Long
Private Declare PtrSafe Function CreatePenIndirect Lib "gdi32" (lpLogPen As LOGPEN) As LongPtr
Private Declare PtrSafe Function MoveToEx Lib "gdi32" (ByVal hDC As LongPtr, ByVal X As Long, ByVal Y As Long, lpPoint As POINTAPI) As Long
Private Declare PtrSafe Function LineTo Lib "gdi32" (ByVal hDC As LongPtr, ByVal X As Long, ByVal Y As Long) As Long
Private Declare PtrSafe Function GetClientRect Lib "user32" (ByVal hwnd As LongPtr, lpRect As RECT) As Long
Private Declare PtrSafe Function InvalidateRect Lib "user32" (ByVal hwnd As LongPtr, lpRect As RECT, ByVal bErase 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 Const PS_USERSTYLE = 7
Private Const PS_ALTERNATE = 8
Private Const PS_STYLE_MASK = &HF&
Private WithEvents Image1 As MSForms.Image, WithEvents BtnClear As MSForms.CommandButton
Private Label1 As MSForms.Label
Private LabelPos1 As MSForms.Label, LabelPos2 As MSForms.Label
Private hDC As LongPtr
Private Flg As Boolean, pt As POINTAPI
Private Property Get fmhwnd() As Long
WindowFromAccessibleObject Me, fmhwnd
End Property
Private Sub BtnClear_Click()
Dim r As RECT
GetClientRect fmhwnd, r
InvalidateRect fmhwnd, r, 0&
LabelPos1.Caption = "始点:"
LabelPos2.Caption = "終点:"
End Sub
Private Sub Image1_Click()
Dim cur As POINTAPI
GetCursorPos pt
ScreenToClient fmhwnd, pt
Flg = Not Flg
If Flg Then
MoveToEx hDC, pt.X, pt.Y, cur
LabelPos1.Caption = "始点:" & pt.X & "/" & pt.Y
LabelPos2.Caption = "終点:"
Else
LabelPos2.Caption = "終点:" & pt.X & "/" & pt.Y
Dim p As POINTAPI, pn As LOGPEN, hPen As LongPtr, hPenOld As LongPtr
p.X = 3
pn.lopnStyle = PS_SOLID
pn.lopnWidth = p
pn.lopnColor = &HFF&
hPen = CreatePenIndirect(pn)
hPenOld = SelectObject(hDC, hPen)
LineTo hDC, pt.X, pt.Y
SelectObject hDC, hPenOld
DeleteObject hPen
End If
End Sub
Private Sub UserForm_Initialize()
Set Image1 = Me.Controls.Add("Forms.Image.1", "Image1")
With Image1
.Top = 3
.Left = 3
.Width = 108
.Height = 108
.MousePointer = fmMousePointerCross
' .Picture = LoadPicture("C:\xxx\test.bmp")
End With
Set Label1 = Me.Controls.Add("Forms.Label.1", "Label1")
With Label1
.Top = 108 + 3
.Left = 3
.Width = 108
.Caption = "対角線を入力しなさい"
.TextAlign = fmTextAlignCenter
End With
Set LabelPos1 = Me.Controls.Add("Forms.Label.1", "LabelPos1")
With LabelPos1
.Top = 3
.Left = 108 + 6
.Width = 72
End With
Set LabelPos2 = Me.Controls.Add("Forms.Label.1", "LabelPos2")
With LabelPos2
.Top = 3 + 15
.Left = 108 + 6
.Width = 72
End With
Set BtnClear = Me.Controls.Add("Forms.CommandButton.1", "BtnClear")
With BtnClear
.Top = 48 + 3
.Left = 108 + 6
.Width = 72
.Caption = "クリア"
End With
BtnClear_Click
hDC = GetDC(fmhwnd)
End Sub
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
If Flg Then Image1_Click
ReleaseDC fmhwnd, hDC
End Sub
（白茶） 2021/12/27(月) 23:45
（白茶）さん...ちゃんと動いてますよ〜面白〜イ。 （白茶）さんの書かれたコードを一箇所だけ変更して(内容一緒)…遊ばせていただきました。(_ _)ﾍﾟｺｯ
Private Sub Image1_Click()
Dim cur As POINTAPI
GetCursorPos pt
ScreenToClient fmhwnd, pt
Flg = Not Flg
If Flg Then
MoveToEx hDC, pt.x, pt.y, cur
With LabelPos1
LabelPos1 = "クリック位置座標 始点: x=" & pt.x & " y=" & pt.y
.Top = 3
.Left = 108 + 6
.Width = 150
End With
Else
Dim p As POINTAPI, pn As LOGPEN, hPen As LongPtr, hPenOld As LongPtr
p.x = 3
pn.lopnStyle = PS_SOLID
pn.lopnWidth = p
pn.lopnColor = &HFF&
hPen = CreatePenIndirect(pn)
hPenOld = SelectObject(hDC, hPen)
LineTo hDC, pt.x, pt.y
SelectObject hDC, hPenOld
DeleteObject hPen
With LabelPos2
LabelPos2 = "クリック位置座標 終点: x=" & pt.x & " y=" & pt.y
.Top = 3 + 15
.Left = 108 + 6
.Width = 150
End With
End If
End Sub
（白茶）さん…ありがとうございます。
つい、閲覧してしまった方ヘ...ｵﾓﾁどうぞ♪ (*･v･)_Ω~ 良いお年を〜。+゜
（あみな） 2021/12/28(火) 15:43
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.