Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちら をご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


27657 / 76732 ←次へ | 前へ→

【54392】Formに描画(API LineTo など)した絵をBitMapで保存できますか?
質問  みそじのおじさん  - 08/3/11(火) 14:51 -

引用なし
パスワード
   こんにちわ。お世話になっております。

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 にはコマンドボタン(オブジェクト名 描画開始、終了)の二つ
     (ボタンの配置は左側に縦に2つでおねがいします)      
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の2次元描画ですが、XYZの3次元描画をしていきます。2万行ぐらいで

描画終了まで、2、3分かかります。)UserForm1を消してしまうと同じ絵を見る

のにまたまたなければいけない為質問させてもらいました。ヒント、またはURL

でもよろしいのでよろしくお願いします。
1 hits

【54392】Formに描画(API LineTo など)した絵をBitMapで保存できますか? みそじのおじさん 08/3/11(火) 14:51 質問
【54394】Re:Formに描画(API LineTo など)した絵を... みそじのおじさん 08/3/11(火) 15:42 質問
【54395】Re:Formに描画(API LineTo など)した絵を... VBWASURETA 08/3/11(火) 16:15 回答
【54396】Re:Formに描画(API LineTo など)した絵を... neptune 08/3/11(火) 16:19 発言
【54398】Re:Formに描画(API LineTo など)した絵を... みそじのおじさん 08/3/11(火) 17:38 質問
【54399】Re:Formに描画(API LineTo など)した絵を... VBWASURETA 08/3/11(火) 17:45 発言
【54401】Re:Formに描画(API LineTo など)した絵を... みそじのおじさん 08/3/11(火) 18:49 質問
【54403】Re:Formに描画(API LineTo など)した絵を... VBWASURETA 08/3/11(火) 20:58 発言
【54408】Re:Formに描画(API LineTo など)した絵を... VBWASURETA 08/3/12(水) 2:49 発言
【54435】Re:Formに描画(API LineTo など)した絵を... みそじのおじさん 08/3/12(水) 19:32 質問
【54437】Re:Formに描画(API LineTo など)した絵を... VBWASURETA 08/3/12(水) 23:04 発言
【54438】Re:Formに描画(API LineTo など)した絵を... neptune 08/3/12(水) 23:21 発言
【54439】Re:Formに描画(API LineTo など)した絵を... neptune 08/3/12(水) 23:23 発言
【54451】Re:Formに描画(API LineTo など)した絵を... みそじのおじさん 08/3/13(木) 16:08 発言
【54454】Re:Formに描画(API LineTo など)した絵を... VBWASURETA 08/3/13(木) 17:52 発言
【54461】Re:Formに描画(API LineTo など)した絵を... みそじのおじさん 08/3/13(木) 22:30 発言
【54462】Re:Formに描画(API LineTo など)した絵を... VBWASURETA 08/3/14(金) 0:34 発言
【54463】Re:Formに描画(API LineTo など)した絵を... VBWASURETA 08/3/14(金) 1:19 発言
【54452】Re:Formに描画(API LineTo など)した絵を... neptune 08/3/13(木) 16:20 発言
【54404】Re:Formに描画(API LineTo など)した絵を... neptune 08/3/11(火) 21:23 発言
【54450】Re:Formに描画(API LineTo など)した絵を... yuu1 08/3/13(木) 15:56 回答
【54464】Re:Formに描画(API LineTo など)した絵を... VBWASURETA 08/3/14(金) 9:15 発言
【54548】Re:Formに描画(API LineTo など)した絵を... みそじのおじさん 08/3/18(火) 11:32 お礼
【54550】Re:Formに描画(API LineTo など)した絵を... yuu1 08/3/18(火) 12:55 回答
【54551】Re:Formに描画(API LineTo など)した絵を... neptune 08/3/18(火) 14:55 発言
【54552】Re:Formに描画(API LineTo など)した絵を... VBWASURETA 08/3/18(火) 15:53 発言
【54559】Re:Formに描画(API LineTo など)した絵を... みそじのおじさん 08/3/19(水) 10:59 お礼
【54560】Re:Formに描画(API LineTo など)した絵を... neptune 08/3/19(水) 13:03 発言

27657 / 76732 ←次へ | 前へ→
ページ:  ┃  記事番号:
2610219
(SS)C-BOARD v3.8 is Free