| |
こんにちわ。お世話になっております。
54343の質問の方と似ているのですが、既に描画した絵をBitmapで保存する
または、コピーがしたいのですが？どの様にすればいいのでしょうか？
やりたい事は
Worksheet1に置いたコマンドボタンをクリックすると、UserForm1とUserForm2
がモードレスで表示される。(この時、UF1は画面の4/5,UF2は画面1/5の大きさで表示
され、この二つのUserFormで全画面表示になる。）そしてUserForm2にある描画開始
ボタンを押すと、UserForm1にAPIのLIneToなどを使って描画がされる。描画が終了
したら、UserForm2にある終了ボタンを押すとUserForm1に書いた絵を保存ができる
のならば保存を、できないのであればコピーをしてUserForm3（これもモードレスです
）に表示してUF1,UF2をUnLoadしてUF3を表示したままworksheetに戻るという作業で
す。
再現できるようにコードをアップします。
必要な物 新規ワークブックに
Worksheet(1)にコマンドボタンを一つ（ボタンは右はしに）
UserForm1
UserForm2 にはコマンドボタン（オブジェクト名 描画開始、終了)の二つ
（ボタンの配置は左側に縦に２つでおねがいします）
UserForm3
です。
標準モジュールに
Option Explicit
'ウインドウのハンドル取得 API
Public Declare Function FindWindow Lib "user32" _
Alias "FindWindowA" (ByVal lpClassName As String, _
ByVal lpWindowName As String) As Long
'デバイスコンテキストのコピー用 API
Public Declare Function BitBlt Lib "gdi32" _
(ByVal hDesrDC As Long, ByVal X As Long, ByVal Y As Long, _
ByVal nWidth As Long, ByVal nHeight As Long, ByVal _
hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, _
ByVal dwRop As Long) As Long
Public Const SRCCOPY = &HCC0020 '定数 コピー元をコピー
'デバイスコンテキスト取得 API
Public Declare Function GetDC Lib "user32" _
(ByVal hwnd As Long) As Long
'デバイスコンテキストの開放 API
Public Declare Function ReleaseDC Lib "user32" _
(ByVal hwnd As Long, ByVal hdc As Long) As Long
'ウインドウ情報取得 API
Public Declare Function GetWindowRect Lib "user32" _
(ByVal hwnd As Long, lpRect As RECT) As Long
Public Type RECT
Left As Long
Top As Long
Right As Long
Buttom As Long
End Type
'描画時 開始位置指示 API
Public Declare Function MoveToEx Lib "gdi32" _
(ByVal hdc As Long, ByVal X As Long, ByVal Y As Long, _
ByVal pLastPoint As Long) As Long
'描画時 直線描画 API
Public Declare Function LineTo Lib "gdi32" _
(ByVal hdc As Long, ByVal XEnd As Long, _
ByVal YEnd As Long) As Long
Public UF1hwnd As Long 'UserForm1のハンドル
Public UF1hDC As Long 'UserForm1のデバイスコンテキスト
Public UF3hwnd As Long 'UserForm3のハンドル
Public UF3hDC As Long 'UserForm3のデバイスコンテキスト
Sub 描画()
UserForm1.Show (vbModeless)
UserForm2.Show (vbModeless)
Call Form_size_change_and_move
End Sub
Sub Form_size_change_and_move()
Dim HwndEXL As Long 'エクセルのハンドル
Dim eRect As RECT 'RECT構造体
Dim EXLtop As Long, EXLleft As Long, EXLright As Long, EXLbuttom As Long
'エクセルのハンドル取得
HwndEXL = FindWindow("XLMAIN", "Microsoft Excel - " & ThisWorkbook.Name)
If HwndEXL = 0 Then GoTo err_trap:
'エクセル画面の位置取得
Call GetClientRect(HwndEXL, eRect)
EXLleft = eRect.Left
EXLtop = eRect.Top
EXLright = eRect.Right
EXLbuttom = eRect.Buttom
'UserForm1 を画面の4/5の大きさに設定する
With UserForm1
.Left = EXLleft
.Top = EXLtop
.Width = ((EXLright - EXLleft) * (4 / 5)) * 72 / 96
.Height = EXLbuttom * 72 / 96
End With
'UserForm2 を画面の1/5の大きさに設定する
With UserForm2
.Left = ((EXLright - EXLleft) * (4 / 5)) * 72 / 96
.Top = EXLtop
.Width = ((EXLright - EXLleft) * (1 / 5)) * 72 / 96
.Height = EXLbuttom * 72 / 96
End With
Exit Sub
err_trap:
MsgBox "FindWindow エラー", vbCritical
'これが出てしまう方はコンパネのフォルダ設定の
'登録されてある拡張子は表示しないのチェックを外して下さい
End Sub
UserForm1のInitializeに
Private Sub UserForm_Initialize()
UserForm1.StartUpPosition = 0
End Sub
UserForm2のInitializeに
Private Sub UserForm_Initialize()
UserForm2.StartUpPosition = 0
End Sub
UserForm2 のコマンドボタンに
Private Sub 終了_Click()
Dim ret As Long 'BitBltが成功か否か？0=否 成功<>0
'ここでしたい事は
'UserForm1をUnLoadする前にUserForm3を表示し
'UserForm1に描画した絵をUserForm3にコピーして
'Worksheetに戻りたい（出来た絵を見ながら次の作業に
'移りたい)
'現状:BitBltを使うとフォーム同士が重なりあっていて
'UserForm3が写りこんでしまう（UserForm1と3の大きさはどうしても
'このくらいは必要)
'本当はUserForm3の大きさにあわせて縮小したい
'bitblt にはこだわってはいない
'Bitmapで保存できるのならば、UserForm3にImageを配置し
'LoadPictureで表示したい。（こちらの方が縮小など楽ですよね？）
UserForm3.Show (vbModeless)
'waitしないと描画に失敗することがある為
Application.Wait (Now() + TimeValue("00:00:01"))
ret = BitBlt(UF3hDC, 0, 0, UserForm1.Width, UserForm1.Height, _
UF1hDC, 0, 0, SRCCOPY)
Unload UserForm2
Unload UserForm1
End Sub
Private Sub 描画開始_Click()
'描画原点
Dim centerX As Long, centerY As Long
'UserForm1 のハンドル取得
UF1hwnd = FindWindow(vbNullString, UserForm1.Caption)
'UserForm1 のデバイスコンテキスト取得
UF1hDC = GetDC(UF1hwnd)
'UserForm1の中央の値の取得（正しい計算ではない）
centerX = (UserForm1.Width * 96 / 72) / 2
centerY = (UserForm1.Height * 96 / 72) / 2
'描画原点に移動
MoveToEx UF1hDC, centerX, centerY, 0
'放射線上に円を書く
With WorksheetFunction
For i = 1 To 10000
LineTo UF1hDC, centerX + (300 * Sin(.Radians(0.036 * i))), _
centerY - (300 * Cos(.Radians(0.036 * i)))
MoveToEx UF1hDC, centerX, centerY, 0
Next
End With
End Sub
UserForm3のInitializeに
Private Sub UserForm_Initialize()
UserForm3.StartUpPosition = 0
End Sub
worksheet1に
Private Sub CommandButton1_Click()
Call 描画
End Sub
で以上です。保存後worksheetのコマンドボタンを押して下さい。
実際の作業ではUserForm2にリストボックスがありテキストファイルを読み込み
listをスクロールさせながら対応する行を描画していきます。この作業が重く
（例はXYの２次元描画ですが、XYZの3次元描画をしていきます。2万行ぐらいで
描画終了まで、２、３分かかります。）UserForm1を消してしまうと同じ絵を見る
のにまたまたなければいけない為質問させてもらいました。ヒント、またはURL
でもよろしいのでよろしくお願いします。
|
|
みそじのおじさん
- 08/3/11(火) 14:51 -
