|
▼みそじのおじさん さん、VBWASURETA さん:
こんにちは
ごめんなさい。うそ書いてました。
Image1.Picture.Handle
はHBITMAPの間違いでした。
で、お詫びにちょっとサンプル書きました。
みそじのおじさん さんのサンプルに以下を追加するだけでとりあえず動きます。
十分検討してない(開放など)ので不安ですが、とりあえずと言う事でお願いします。
準備
1.paint等で、適当に白(何でも良い)のbmpファイルを作成しておく
'//////////////////標準モジュール/////////////////
'////////////以下追加分/////////////
Public Const MM_TWIPS = 6
Public Declare Function CreateCompatibleDC Lib "gdi32" _
(ByVal hdc As Long) As Long
Public Declare Function SetMapMode Lib "gdi32" _
(ByVal hdc As Long, ByVal nMapMode As Long) As Long
Public Declare Function SelectObject Lib "gdi32" _
(ByVal hdc As Long, ByVal hObject As Long) As Long
Public Declare Function DeleteDC Lib "gdi32" _
(ByVal hdc As Long) As Long
'///////////////UserForm1追加分//////////////////
Private Sub UserForm_Resize()
Const Fm_PictureSizeModeStretch As Long = 1
Me.Controls.Add "Forms.Image.1", "image1", False
With Me.Controls("image1")
.Top = Me.Top
.Left = Me.Left
.Height = Me.InsideHeight
.Width = Me.InsideWidth
'以下は適当に環境に合わせて下さい。準備1で準備したbmpファイルのフルパス
.Picture = LoadPicture("E:\Data\Office\Excel\WhiteBMP.bmp")
.PictureSizeMode = Fm_PictureSizeModeStretch
' .AutoSize = True
.Visible = True
End With
Me.Repaint
End Sub
'//////////////UserForm2////////////////////////////////////////
'CommandButton1_Clickは変更して下さい。
Private Sub CommandButton1_Click()
Call DrawLines
End Sub
'適当に1本の線を引くだけです。
Private Sub DrawLines()
Dim centerX As Long, centerY As Long
Dim hBmp As Long, hdc As Long
Dim hComDC As Long
Dim ret As Long
Dim i As Long
Dim img As MSForms.Image
Set img = UserForm1.Controls.Item("image1")
hBmp = img.Picture.Handle
hdc = GetDC(0)
hComDC = CreateCompatibleDC(hdc)
ret = ReleaseDC(0, hdc)
ret = SetMapMode(hComDC, MM_TWIPS)
ret = SelectObject(hComDC, hBmp)
MoveToEx hComDC, 0, 0, 0
ret = LineTo(hComDC, img.Width * 10, img.Height * -10)
ret = DeleteDC(hComDC)
UserForm1.Repaint
Set img = Nothing
End Sub
>(うすい頭がさらにうすくなりそうです....)
私はもっと年上ですが、もう乗り越えたようです。
かなり薄くなってますが^ ^;
ファイルへの保存は不精してますが、savepaictureでやってみて下さい。
|
|