Excel VBA質問箱 IV

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

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


4772 / 13644 ツリー ←次へ | 前へ→

【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 発言[未読]

【54392】Formに描画(API LineTo など)した絵をB...
質問  みそじのおじさん  - 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

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

【54394】Re:Formに描画(API LineTo など)した絵...
質問  みそじのおじさん  - 08/3/11(火) 15:42 -

引用なし
パスワード
   標準モジュールの宣言文が抜けていました。追加して下さい。

Public Declare Function GetClientRect Lib "user32" _
  (ByVal hwnd As Long, lpRect As RECT) As Long

【54395】Re:Formに描画(API LineTo など)した絵...
回答  VBWASURETA  - 08/3/11(火) 16:15 -

引用なし
パスワード
   ▼みそじのおじさん さん:
こんにちは。

一応、あるにはありますが。
VBのサンプルなのでExcel VBAでも可能かわかりません。

APIなのでWIN系なら大丈夫と思いますが
ただ、載せて頂いたソースが無駄になりそうな方法です。

//www.surveytec.com/prog/vb/kouza2/chap2.html

後は、ALT+PrintScreenキーで取得したハードコピーを保存する方法が
一番簡単ですがタイトルバーまでが描画されます。

【54396】Re:Formに描画(API LineTo など)した絵...
発言  neptune  - 08/3/11(火) 16:19 -

引用なし
パスワード
   ▼みそじのおじさん さん:
こんにちは

提案になりますが、
最初から白(適当です)のBMPをpictureに設定した、imageをuserformに用意して、
そのimageコントロールに描画すればどうですか?

そうすれば保存は簡単ですよね。

ちなみにHDCは
hdc=image1.Picture.Handle
で取得できます。

【54398】Re:Formに描画(API LineTo など)した絵...
質問  みそじのおじさん  - 08/3/11(火) 17:38 -

引用なし
パスワード
   とりあえず UserForm3のコードも間違っていたので訂正します

Private Sub UserForm_Initialize()

UF3hwnd = FindWindow(vbNullString, Me.Caption)
UF3hDC = GetDC(UF3hwnd)

With UserForm3

 .StartUpPosition = 0
 .Left = 0
 .Top = 100
 .Width = 300
 .Height = 300
 
End With

End Sub

【54399】Re:Formに描画(API LineTo など)した絵...
発言  VBWASURETA  - 08/3/11(火) 17:45 -

引用なし
パスワード
   ▼みそじのおじさん さん:

先ほど書いたハードコピーのサンプルです。
ハードコピーからBitmap形式保存はYukiさんソースから
拝借しました。
後、Sendkeyは使いたくなかったのでAPIにしました。
色々と不具合が多いので。


Private Type GUID
  Data1 As Long
  Data2 As Integer
  Data3 As Integer
  Data4(0 To 7) As Byte
End Type

Private Type PicBmp
  Size As Long
  Type As Long
  hBmp As Long
  hPal As Long
  Reserved As Long
End Type

Private Declare Function OpenClipboard Lib "user32" _
        (ByVal hWnd As Long) As Long
Private Declare Function CloseClipboard Lib "user32" () As Long
Private Declare Function GetClipboardData Lib "user32" _
        (ByVal wFormat As Long) As Long
Private Declare Function CopyImage Lib "user32" _
        (ByVal handle As Long, _
         ByVal un1 As Long, ByVal n1 As Long, _
         ByVal n2 As Long, ByVal un2 As Long) As Long
Private Declare Function OleCreatePictureIndirect Lib "olepro32.dll" _
        (PicDesc As PicBmp, _
         RefIID As GUID, ByVal fPictureOwnsHandle As Long, _
         IPic As IPictureDisp) As Long

Private Declare Function timeGetTime Lib "winmm.dll" () As Long

'****************************************************
'キーボードイベント
Private Declare Sub keybd_event Lib "user32.dll" _
  (ByVal bVk As Byte, ByVal bScan As Byte, _
  ByVal dwFlags As Long, ByVal dwExtraInfo As Long)
Private Const KEYEVENTF_KEYUP = &H2
Private Const KEYEVENTF_EXTENDEDKEY = &H1
Private Const VK_ALT = &H12
Private Const VK_SNAPSHOT = &H2C

Private Declare Function MapVirtualKey Lib "user32" _
  Alias "MapVirtualKeyA" (ByVal wCode As Long, _
  ByVal wMapType As Long) As Long
'****************************************************


Private Const CF_BITMAP = 2
Private Const PICTYPE_BITMAP = 1
Private Const IMAGE_BITMAP = 0
Private Const LR_COPYRETURNORG = &H4

Private Sub sSetSendKeys(bVk1 As Long, _
        Optional bVk2 As Long = 0, Optional bVk3 As Long = 0)
  
  If bVk2 = 0& And bVk3 = 0& Then
    Call keybd_event(CByte(bVk1), MapVirtualKey(CByte(bVk1), 0), _
            KEYEVENTF_EXTENDEDKEY Or 0, 0)
    Call keybd_event(CByte(bVk1), MapVirtualKey(CByte(bVk1), 0), _
            KEYEVENTF_EXTENDEDKEY Or KEYEVENTF_KEYUP, 0)
  ElseIf bVk3 = 0& Then
    Call keybd_event(CByte(bVk1), MapVirtualKey(CByte(bVk1), 0), _
            KEYEVENTF_EXTENDEDKEY Or 0, 0)
    Call keybd_event(CByte(bVk2), MapVirtualKey(CByte(bVk2), 0), _
            KEYEVENTF_EXTENDEDKEY Or 0, 0)
    Call keybd_event(CByte(bVk2), MapVirtualKey(CByte(bVk2), 0), _
            KEYEVENTF_EXTENDEDKEY Or KEYEVENTF_KEYUP, 0)
    Call keybd_event(CByte(bVk1), MapVirtualKey(CByte(bVk1), 0), _
            KEYEVENTF_EXTENDEDKEY Or KEYEVENTF_KEYUP, 0)
  ElseIf (bVk1 <> 0&) And (bVk2 <> 0&) And (bVk3 <> 0&) Then
    Call keybd_event(CByte(bVk1), MapVirtualKey(CByte(bVk1), 0), _
            KEYEVENTF_EXTENDEDKEY Or 0, 0)
    Call keybd_event(CByte(bVk2), MapVirtualKey(CByte(bVk2), 0), _
            KEYEVENTF_EXTENDEDKEY Or 0, 0)
    Call keybd_event(CByte(bVk2), MapVirtualKey(CByte(bVk2), 0), _
            KEYEVENTF_EXTENDEDKEY Or KEYEVENTF_KEYUP, 0)
    Call keybd_event(CByte(bVk3), MapVirtualKey(CByte(bVk3), 0), _
            KEYEVENTF_EXTENDEDKEY Or 0, 0)
    Call keybd_event(CByte(bVk3), MapVirtualKey(CByte(bVk3), 0), _
            KEYEVENTF_EXTENDEDKEY Or KEYEVENTF_KEYUP, 0)
    Call keybd_event(CByte(bVk1), MapVirtualKey(CByte(bVk1), 0), _
            KEYEVENTF_EXTENDEDKEY Or KEYEVENTF_KEYUP, 0)
  End If
  StopTime (50)
End Sub

Private Sub StopTime(st As Long)
  Dim lngSt As Long
  lngSt = timeGetTime
  Do While timeGetTime - lngSt < st
    DoEvents
  Loop
End Sub

Function GetBitMap() As IPictureDisp
 Dim iid As GUID
 Dim Pic As PicBmp
 Dim ObjPic As IPictureDisp
 Dim hBitmap As Long
 Dim CopyBitmap As Long

 With iid
  .Data1 = &H20400
  .Data4(0) = &HC0
  .Data4(7) = &H46
 End With

 OpenClipboard 0
 hBitmap = GetClipboardData(CF_BITMAP)
 If hBitmap = 0 Then
  CloseClipboard
  Exit Function
 End If

 CopyBitmap = CopyImage(hBitmap, _
             IMAGE_BITMAP, 0, 0, _
             LR_COPYRETURNORG)
 CloseClipboard

 With Pic
  .Size = Len(Pic)
  .Type = PICTYPE_BITMAP
  .hBmp = CopyBitmap
 End With

 OleCreatePictureIndirect Pic, iid, 1, ObjPic
 Set GetBitMap = ObjPic
End Function

Function test()
  Dim setfile As String
  
  setfile = "C:\test.bmp"
  'Alt + PrintScreenキーでのハードコピー取得
  Call sSetSendKeys(VK_ALT, VK_SNAPSHOT)
  SavePicture GetBitMap(), setfile
End Function

【54401】Re:Formに描画(API LineTo など)した絵...
質問  みそじのおじさん  - 08/3/11(火) 18:49 -

引用なし
パスワード
   VBWASURETA さん:

返信ありがとうございます。BitMap を扱うAPIは数が多く

困惑していたしだいです。提示していただいたサイトの理解

と提示して頂いたコードを読むのに少し時間を下さい。

(うすい頭がさらにうすくなりそうです....)

neputune さん:

提案ありがとうございます。neputune さんに教えていただいた

Findwind(FindWindowEx FindWindowFromPointなど)で子ウインドウのハンドルを取

りたかったのですが挫折してしまいFormに直接かいていたしだいです。

Image1.Picture.Handleは1度試してはいたんですが、

肝心のLoadPictureをしていなかった為エラーになっておりました。

その発想はまさに目から鱗です。

少しためしたのですが、 hdc=GetDc(UserForm1.Image1.Picture.Handle)

では、戻り値が0になってしまいデバイスコンテキストが取れません。

使い方間違っていますか?


すみません。取り急ぎお礼まで

【54403】Re:Formに描画(API LineTo など)した絵...
発言  VBWASURETA  - 08/3/11(火) 20:58 -

引用なし
パスワード
   ▼みそじのおじさん さん:
ソースの解読についてですが。

あのソースは大半はクリップボードからbmp形式で取得するためのソースです。
Bitmapヘッダー情報とビットマップデータ(バイナリデータ)を取得と設定を
していると覚えて貰えば良いかと。

残りはALT+PrintScreenキー(アクティブウィンドウのハードコピー)の
キーボードを押すAPI処理です。
キーボードの単体キー押された場合と複数キーが同時に
押された場合の定義も含まれているのであれだけの量になってます。

実際使うのはTest()関数のところだけですよ。

【54404】Re:Formに描画(API LineTo など)した絵...
発言  neptune  - 08/3/11(火) 21:23 -

引用なし
パスワード
   ▼みそじのおじさん さん、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でやってみて下さい。

【54408】Re:Formに描画(API LineTo など)した絵...
発言  VBWASURETA  - 08/3/12(水) 2:49 -

引用なし
パスワード
   ▼みそじのおじさん さん:

続いて解析2です。

HPのソースですが。すみません見つけたもののぱっと見で使えそうだったので、
参考資料として載せました。API詳しそうでしたから。

とにかく、解析してみますね。もしかしたら違うところがあるかもしれませんが。
仕事柄からか画像データ解析が多いんです^^;

因みにこのソース見ている限り、24ビット形式(ビットマップ)にしかだめそうです。
確かJPEGとBITMAPのヘッダーサイズは異なっていたはずです。


'GetObjectのAPIは画面に貼り付けられたBITMAPのヘッダーサイズを指定してヘッダー情報構造体に値を取得しています。
Private Declare Function GetObject Lib "gdi32" Alias "GetObjectA" (ByVal hObject As Long, ByVal nCount As Long, lpObject As Any) As Long

'GetBitmapBitsのAPIは画面に貼り付けられたBitmapデータつまりバイナリデータを配列に入れてますね。因みにByValは値の送り側、付いて無いのは戻り値として定義されています。このように覚えると見やすくなるかもです。
Private Declare Function GetBitmapBits Lib "gdi32" (ByVal hBitmap As Long, ByVal dwCount As Long, lpBits As Any) As Long

'SetBitmapBitsのAPIは逆にBitmapデータつまりバイナリデータの配列から該当のピクチャボックスに設定します。
Private Declare Function SetBitmapBits Lib "gdi32" (ByVal hBitmap As Long, ByVal dwCount As Long, lpBits As Any) As Long

Private Type BITMAP                                   'BITMAP構造体
    bmType As Long     'タイプ
    bmWidth As Long    '横サイズ
    bmHeight As Long    '縦サイズ
    bmWidthBytes As Long  '横サイズのバイト単位
    bmPlanes As Integer  'プレーン数
    bmBitsPixel As Integer '1ピクセルあたりのバイト数(bmp形式なので1バイトです。当然なのですけどね。ビットマップは未圧縮なのですから)
    bmBits As Long     'ポインタ
End Type

Dim Img() As Byte                                    'ピクセルデータ保存用

Private Sub UserForm_Click()
  Dim bmp As BITMAP, x As Long, y As Long
  
  'ビットマップのヘッダー情報取得
  GetObject Image1.Picture.Handle, Len(bmp), bmp                  'ビットマップ情報取得

  'ここでビットマップのバイナリデータサイズ分のサイズを二次元配列で再定義
  ReDim Img(bmp.bmWidthBytes - 1, bmp.bmHeight - 1)                  '配列サイズ変更

  'ビットマップのサイズ分バイナリデータをImgの二次元配列にセット
  GetBitmapBits Image1.Picture.Handle, bmp.bmWidthBytes * bmp.bmHeight, Img(0, 0)  '画像取込

  'ビットマップ縦サイズのループ
  For y = 0 To bmp.bmHeight - 1

    'ビットマップ横サイズのループ
    For x = 0 To bmp.bmWidthBytes - 1
      Img(x, y) = Not Img(x, y)                          '反転処理
    Next
  Next

  '1バイトずつバイナリデータを反転した後にピクチャボックスにセット
  SetBitmapBits Image1.Picture.Handle, bmp.bmWidthBytes * bmp.bmHeight, Img(0, 0)  '画像書込
End Sub

【54435】Re:Formに描画(API LineTo など)した絵...
質問  みそじのおじさん  - 08/3/12(水) 19:32 -

引用なし
パスワード
   VBWASURETA さん:

朝会社に来てNetを見てびっくり。そんな時間にこんなに詳しく解説

してもらえるとは!!本当にありがとうございます。

Alt+PrintScreen自体を使った事がなく最初は話がピンと来ていなか

ったのですが提示して頂いたコードを自分のコードに組み込んでやっ

てみました。Function test()をUserForm1が描画し終わった次点で

OldWindow=SetActiveWindow(UF1hwnd)

ret=test()

としてBitMapを保存、UserForm3にImageを配置しLoadPictureで

描画する事ができました。(描画した物とは、色が反転していまし

た。このあたりも勉強が必要ですね。)しかし出来たと言うだけで内

容を理解している、というにはほど遠い感じですね。(一日やそこらで

とても理解できる物ではないよですね?)でもBitMapを勉強するいい

きっかけになりました。BitMapを操れれば面白い事が沢山できそうで

すね。VBWASURETA さん本当にありがとうございます。(BitMaP師匠

とお呼びしていいですか?^^)


>>>API詳しそうでしたから....

いやいや、とんでもないです。このサイトで自分の質問を検索したら

Findwindowをneputuneさんに教えて頂いた日付が去年の夏くらいでし

たから...一年も経っていない超初心者です。それまでAPIといえば

ループを回すのにGetTickCountくらいしか使った事がなかった私に

APIの道を開いてくれたのはneputuneさんでした。感謝感謝です。

neputune さん:

サンプルありがとうございます。自分のコードに改造して組み込んで

みました。

Private Sub 描画開始_Click()

'描画原点
Dim centerX As Long, centerY As Long
Dim hBmp As Long, hdc As Long
Dim hComDC As Long
Dim ret As Long, hbmDefault As Long
Dim i As Long
Dim img As MSForms.Image
Dim picPicture As IPictureDisp

  Set img = UserForm1.Controls.Item("image1")
  hBmp = img.Picture.Handle
  
  hdc = GetDC(0) '<<<ここの引数が0なのが疑問です。
  '0にするとスクリーン全体のデバイスコンテキストのハンドルが取得できる
  'とありましたが、ここでいうスクリーン全体というのは、Image1を
  '指しているのでしょうか?
  
  hComDC = CreateCompatibleDC(hdc)
  ret = ReleaseDC(0, hdc)
 
  ret = SetMapMode(hComDC, MM_TWIPS)
  hbmDefault = SelectObject(hComDC, hBmp)
 

'イメージを使用した時の単位系が勉強不足で
'計算は適当です...

centerX = (img.Picture.Width / 2) * 0.65
centerY = -((img.Picture.Height / 2) * 0.65)

'描画原点に移動

MoveToEx hComDC, centerX, centerY, 0

'放射線上に円を書く

With WorksheetFunction
  For i = 1 To 10000
    LineTo hComDC, centerX + ((centerX * 2 / 3) * _
           Sin(.Radians(0.036 * i))), _
           centerY + ((centerX * 2 / 3) * _
           Cos(.Radians(0.036 * i)))
   
    MoveToEx hComDC, centerX, centerY, 0
  Next

End With

  'ここの使い方あってますかね?
  'SelectObjectを使用した時の値を hbmDefaultに保持しておいて
  'hcComDCとhBmpを切り離した後 hComDcを削除
  
  ret = DeleteDC(SelectObject(hComDC, hbmDefault))
  ret = DeleteDC(hComDC)
  
  UserForm1.Repaint
'=========================================================
' BitMapの保存
 
 Set picPicture = img.Picture
 
 SavePicture picPicture, ThisWorkbook.Path & "\test1.bmp"
'========================================================
 Set img = Nothing
 Set picPicture = Nothing
 
 
End Sub

この後UserForm3にImageを配置し、LoadPictureで表示することが

出来ました。ありがとうございます。

しかし、いくつか改善しなくてはならない所があり

1. 描画の過程を見れなくなくなってしまった。見た感じ描画が全部
  
  終わってから表示されるように見える。 (これが一番いたいです。

  作っているものは、描画の過程を見るというのが目的でした。)

2. 描画時に、今まではFormのデバイスコンテキストを使っていたので、画面でいう

  下方向が Yプラス、上がYマイナスだったのが、Imageだと通常数学で

  習う画面上がYプラス、下がYマイナスになっているので実際使って

  いるコードに大改造が必要(描画するコードだけで、3000行くらいに
 
  なってしまっています。)

この辺も時間をかけて直していかないといけないですね。でも先が見えた

感じがしてほっとしております。

【54437】Re:Formに描画(API LineTo など)した絵...
発言  VBWASURETA  - 08/3/12(水) 23:04 -

引用なし
パスワード
   ▼みそじのおじさん さん、neputuneさん:
こんばんは。

最初に書いたサンプルとHPの参考サンプルは別々ですよ?

最初に書いたハードコピーはそのソースだけで使います。
HPの参考サンプルは、一からビットマップを作るための参考サンプルです。

> VBWASURETA さん本当にありがとうございます。(BitMaP師匠
> とお呼びしていいですか?^^)

いえ^^;全然詳しくないです。
去年からC++で、DirectShowフィルタ開発PGに入ることになりまして、
覚え出したところでまだまだです^^;;

【54438】Re:Formに描画(API LineTo など)した絵...
発言  neptune  - 08/3/12(水) 23:21 -

引用なし
パスワード
   みなさんこんにちは

又、検証なしの提案になりますが、

1.の問題ですが、
imageを貼り付ける方法ですと、UserFormにimageコントロール1個だけですと

Private Const FormClassName As String = "ThunderXFrame"
Private hImage As Long

Public Function findchild() As Long
Dim ret As Long
Dim hForm As Long

  hImage = 0
  hForm = FindWindow(FormClassName, UserForm1.Caption)
  ret = EnumChildWindows(hForm, AddressOf EnumChildProc, &H0)
  findchild = hImage
End Function

Public Function EnumChildProc(ByVal hwnd As Long, _
               ByVal lParam As Long) As Long
  hImage = hwnd
  EnumChildProc = True
End Function

'子ウィンドウ取得(1個限定^ ^;;)
Private Sub CommandButton4_Click()
  Debug.Print findchild
End Sub

ってな感じでImageのHWNDが取れますから、
最初の質問時のコード 「みそじのおじさん - 08/3/11(火) 14:51 」
のような方法は取れないんですかね?(そのままでは駄目かもしれない)
・・・今日は検証する根性がありません。

2.に関しては、マジックナンバーではなく出来るだけ定数化してやるとか
 しか思い付きません。

前回のサンプルの補足:
(1)
>ret = LineTo(hComDC, img.Width * 10, img.Height * -10)
の10と-10ですが、
>ret = SetMapMode(hComDC, MM_TWIPS)
でMM_TWIPSを指定しているのでtwipsに戻すのなら本当は20なんですが、
大きさ調整で10にしただけです。(本来は20でtwips)
詳しくはMSDNでSetMapModeをお調べ下さい。

>  hdc = GetDC(0) '<<<ここの引数が0なのが疑問です。
>  '0にするとスクリーン全体のデバイスコンテキストのハンドルが取得できる
>  'とありましたが、ここでいうスクリーン全体というのは、Image1を
>  '指しているのでしょうか?
今回はメモリ上に書いているので、「スクリーン全体のデバイスコンテキスト」で
いいと思います。


ごめんなさい。今日はなんか肩がつりそうで根性ありませんでした。
ちなみに私も描画関係は殆どやったことないんで勉強になります。^ ^;;

【54439】Re:Formに描画(API LineTo など)した絵...
発言  neptune  - 08/3/12(水) 23:23 -

引用なし
パスワード
   訂正
>2.に関しては、マジックナンバーではなく出来るだけ定数化してやるとか
> しか思い付きません
2.に関しては、マジックナンバー(直接数字を書き込む)ではなく
 出来るだけ定数化、変数化してやるとかしか思い付きません。

【54450】Re:Formに描画(API LineTo など)した絵...
回答  yuu1  - 08/3/13(木) 15:56 -

引用なし
パスワード
   ▼みそじのおじさん さん:
>こんにちわ。お世話になっております。
>54343の質問の方と似ているのですが、既に描画した絵をBitmapで保存する
>または、コピーがしたいのですが?どの様にすればいいのでしょうか?

こんにちは。
やりたいことを実現するための提案です。

まず、APIでの描画は WM_PAINT(ウィンドウのクライアント領域を描画する必要があることを示します) での処理がされていないように思うのですが。
つまり描画したあとで、他のウィンドウを前面に表示して、描画したウィンドウを前面に表示すると再描画がされない。
これは致命的な欠陥だとおもうのですが...

それで提案ですが、
描画は隠しシートに図形描画で描いて、
それをコピーしてユーザーフォームのPictureへ貼る付ける。
(貼る付ける関数はweb検索すればたくさんあります)
保存は既に示されているSavePicture関数が使えます。

【54451】Re:Formに描画(API LineTo など)した絵...
発言  みそじのおじさん  - 08/3/13(木) 16:08 -

引用なし
パスワード
   こんにちわ

VBWASURETA さん:

 すぐに試して返事をしたかったもので、手のつけ易い方からやらせて

 もらいました。次は、提示して頂いたサイトにチャレンジさせてもら

 ます。

neputune さん:
 
 マジックナンバー.... 耳がいたいです......

その言葉は1週間ほど前に初めて知りました。(neputuneさんをたまにお見かけ

 するVBのサイトで)Public宣言も多用しすぎてメンテナンスに困りはててます。

 (なんてたって最近まで、引数(ひきすう)を”いんすう”と読んでいた男な

 ので.....トホホ)

 子ウインドウの件ありがとうございます。


お二人に:

私が作成しているのは、簡易2次元CAM(CADで作図したDXFファイルを読み込み

工作機械を動かすデータを生成する)というものです。基本的な機能は出来上が

っています。そこでお願いがあるのですが、私のファイルを見て頂けないでしょ

うか?一応 lzhに本体のFrom DXF to NCpro.xls、sample.dxf,clook.txt(腕

時計を削り出す工具軌跡が描画されます)、簡単な説明をつけたReadMe.txtを

用意してあるのですが...決して、ここのコードを書き換えてとか添削して欲し

いとかではありません。

現在こんな感じで質問をさせてもらったーという、意味合いでなんですが、どうで

しょう?(異業種交流の意味合いでも)例えばここの目安箱にアップするなんて事

はまづいのでしょうか?(目安箱の使い方間違ってます?)

【54452】Re:Formに描画(API LineTo など)した絵...
発言  neptune  - 08/3/13(木) 16:20 -

引用なし
パスワード
   みなさんこんにちは

先ず訂正。私の環境ではUserFormのクラス名は以下でした。
Private Const FormClassName As String = "ThunderDFrame"

取り合えず、imageには下記のような感じで描画は出来ます。
で、yuu1さんからのご指摘の問題はあります。原因はご指摘の通りです。

そこで、これは描画を見せる為の表示用で、裏で、先のサンプルのように
メモリ上で描画し、それを保存してはどうでしょうか?

imageを2つ用意しておいて1つは「描画中を見せる為の表示用」と、
もう一つは非表示でメモリ上で書き終わった時点でファイルに保存後、
再度読み込み後「表示用」と入れ替えるとか。
それなら再描画でも消えません。
↑の検証はしてませんが、メモリ上の描画のみはかなり早いはずです。
出来なかったらごめんなさい。

VBWASURETA さんの方法と比較して、より良い方法をご検討下さい。

Private Sub CommandButton1_Click()
Dim hImg As Long  'UserForm1のImageコントロールのHWND
Dim hDC As Long   'ImageのHDC
Dim img As MSForms.Image
Dim i As Long, ret As Long
Dim rc As RECT

  Set img = UserForm1.Controls.Item("image1")
  hImg = findchild
  hDC = GetDC(hImg)
  
  Call GetWindowRect(hImg, rc)
  MoveToEx hDC, rc.Left, rc.Top, 0
  LineTo hDC, rc.Right, rc.Buttom
  Sleep 500  'ちょっと時間差を付けてみただけ。
  MoveToEx hDC, rc.Right, rc.Top, 0
  LineTo hDC, rc.Left, rc.Buttom
'  'ビットマップには書いてないので保存は出来ません。
'  SavePicture img.Picture, ThisWorkbook.Path & "\test1.bmp"

  Set img = Nothing
  ret = DeleteDC(hDC)

'  UserForm1.Repaint 'これを実行すると消えます。
End Sub

【54454】Re:Formに描画(API LineTo など)した絵...
発言  VBWASURETA  - 08/3/13(木) 17:52 -

引用なし
パスワード
   ▼みそじのおじさん さん:
こんにちは。


> すぐに試して返事をしたかったもので、手のつけ易い方からやらせて
>
> もらいました。次は、提示して頂いたサイトにチャレンジさせてもら
>
> ます。

あれ?画像が反転したのですよね?
反転と聞いたので、ハードコピーとHPのサンプルで
作られたのかと思いました^^;


>私が作成しているのは、簡易2次元CAM(CADで作図したDXFファイルを読み込み
>
>工作機械を動かすデータを生成する)というものです。基本的な機能は出来上が
>
>っています。そこでお願いがあるのですが、私のファイルを見て頂けないでしょ
>
>うか?一応 lzhに本体のFrom DXF to NCpro.xls、sample.dxf,clook.txt(腕
>
>時計を削り出す工具軌跡が描画されます)、簡単な説明をつけたReadMe.txtを
>
>用意してあるのですが...決して、ここのコードを書き換えてとか添削して欲し
>
>いとかではありません。
>
>現在こんな感じで質問をさせてもらったーという、意味合いでなんですが、どうで
>
>しょう?(異業種交流の意味合いでも)例えばここの目安箱にアップするなんて事
>
>はまづいのでしょうか?(目安箱の使い方間違ってます?)

あの掲示板ってファイルも置けるんですね。
と言いますか、あの掲示板は質問するところではありませんと、
書いてありましたが^^;

多分、公になっているところですからファイルサイズは
制限されている気がしますよ?

【54461】Re:Formに描画(API LineTo など)した絵...
発言  みそじのおじさん  - 08/3/13(木) 22:30 -

引用なし
パスワード
   yuu1さん:

yuu1さんの仰るとおりで、再描画の処理をなにもしておりませんので他の画面が

かぶさった時に描画していたものが消えてしまいます。Messege系の処理

はメモ帳を終了させる時に(WM_CLOSE)しか使った事がないのですが

(WM_PAINT)勉強してみます。

提案して頂いた件について:隠しシートに描画するとの事ですが、描画

の過程を見せるというのを抜きにして、保存>表示という事でしょうか?


neputune さん:

表と裏(表現悪いですかね?)で処理をするという考え方ありがとうございます。

質問する前に、メモリ上で描画>表示とは考えていて CreateCompatibleDC
  
でメモリデバイスコンテキストの取得>>SelectObjectでデバイスコンテキスト

とメモリビットマップを組み合わせる としたかったのですが合わせたいビット

マップのハンドルが取れず壁にぶち当たっていました。neputuneさんの考えで

いくのが、自分の中ではベストかなと思っています。


VBWASURETA さん:

私の環境では、UserForm1のImageに白のBitmapをLoadして、黒の円を描画>>

Function test()を使ってUserForm3のImageに転写で、円が白に、それ以外

の部分が黒になって表示されました。あのソースだけでこうなるのはおかしい

のですかね?


みなさんへ:

私は、工場勤務の為,netをすぐ使える環境にありません(自分の使用している

機械のすぐ横にPCはありますがnetの接続はされていません。おまけに家にも

PCはありません.....)ので返事が遅れる事がございますが、ご了承下さい。

(嫁にPC買って−といってますが、二人の娘の洋服代に消えております.....)

私が昼間に返事をしている時は、工場から事務所までダッシュ、書き込んで

ダッシュで戻るの繰り返しです。

【54462】Re:Formに描画(API LineTo など)した絵...
発言  VBWASURETA  - 08/3/14(金) 0:34 -

引用なし
パスワード
   ▼みそじのおじさん さん:
こんばんは。

普通はならないですよ。
うーん、試しに実際Alt+PrintScreenキーを押して、ペイントとかのソフトで
貼り付けて見てください。多分、そうはならないです。

因みに↓このソースだけですよね?


Private Type GUID
  Data1 As Long
  Data2 As Integer
  Data3 As Integer
  Data4(0 To 7) As Byte
End Type

Private Type PicBmp
  Size As Long
  Type As Long
  hBmp As Long
  hPal As Long
  Reserved As Long
End Type

Private Declare Function OpenClipboard Lib "user32" _
        (ByVal hWnd As Long) As Long
Private Declare Function CloseClipboard Lib "user32" () As Long
Private Declare Function GetClipboardData Lib "user32" _
        (ByVal wFormat As Long) As Long
Private Declare Function CopyImage Lib "user32" _
        (ByVal handle As Long, _
         ByVal un1 As Long, ByVal n1 As Long, _
         ByVal n2 As Long, ByVal un2 As Long) As Long
Private Declare Function OleCreatePictureIndirect Lib "olepro32.dll" _
        (PicDesc As PicBmp, _
         RefIID As GUID, ByVal fPictureOwnsHandle As Long, _
         IPic As IPictureDisp) As Long

Private Declare Function timeGetTime Lib "winmm.dll" () As Long

'****************************************************
'キーボードイベント
Private Declare Sub keybd_event Lib "user32.dll" _
  (ByVal bVk As Byte, ByVal bScan As Byte, _
  ByVal dwFlags As Long, ByVal dwExtraInfo As Long)
Private Const KEYEVENTF_KEYUP = &H2
Private Const KEYEVENTF_EXTENDEDKEY = &H1
Private Const VK_ALT = &H12
Private Const VK_SNAPSHOT = &H2C

Private Declare Function MapVirtualKey Lib "user32" _
  Alias "MapVirtualKeyA" (ByVal wCode As Long, _
  ByVal wMapType As Long) As Long
'****************************************************


Private Const CF_BITMAP = 2
Private Const PICTYPE_BITMAP = 1
Private Const IMAGE_BITMAP = 0
Private Const LR_COPYRETURNORG = &H4

Private Sub sSetSendKeys(bVk1 As Long, _
        Optional bVk2 As Long = 0, Optional bVk3 As Long = 0)
  
  If bVk2 = 0& And bVk3 = 0& Then
    Call keybd_event(CByte(bVk1), MapVirtualKey(CByte(bVk1), 0), _
            KEYEVENTF_EXTENDEDKEY Or 0, 0)
    Call keybd_event(CByte(bVk1), MapVirtualKey(CByte(bVk1), 0), _
            KEYEVENTF_EXTENDEDKEY Or KEYEVENTF_KEYUP, 0)
  ElseIf bVk3 = 0& Then
    Call keybd_event(CByte(bVk1), MapVirtualKey(CByte(bVk1), 0), _
            KEYEVENTF_EXTENDEDKEY Or 0, 0)
    Call keybd_event(CByte(bVk2), MapVirtualKey(CByte(bVk2), 0), _
            KEYEVENTF_EXTENDEDKEY Or 0, 0)
    Call keybd_event(CByte(bVk2), MapVirtualKey(CByte(bVk2), 0), _
            KEYEVENTF_EXTENDEDKEY Or KEYEVENTF_KEYUP, 0)
    Call keybd_event(CByte(bVk1), MapVirtualKey(CByte(bVk1), 0), _
            KEYEVENTF_EXTENDEDKEY Or KEYEVENTF_KEYUP, 0)
  ElseIf (bVk1 <> 0&) And (bVk2 <> 0&) And (bVk3 <> 0&) Then
    Call keybd_event(CByte(bVk1), MapVirtualKey(CByte(bVk1), 0), _
            KEYEVENTF_EXTENDEDKEY Or 0, 0)
    Call keybd_event(CByte(bVk2), MapVirtualKey(CByte(bVk2), 0), _
            KEYEVENTF_EXTENDEDKEY Or 0, 0)
    Call keybd_event(CByte(bVk2), MapVirtualKey(CByte(bVk2), 0), _
            KEYEVENTF_EXTENDEDKEY Or KEYEVENTF_KEYUP, 0)
    Call keybd_event(CByte(bVk3), MapVirtualKey(CByte(bVk3), 0), _
            KEYEVENTF_EXTENDEDKEY Or 0, 0)
    Call keybd_event(CByte(bVk3), MapVirtualKey(CByte(bVk3), 0), _
            KEYEVENTF_EXTENDEDKEY Or KEYEVENTF_KEYUP, 0)
    Call keybd_event(CByte(bVk1), MapVirtualKey(CByte(bVk1), 0), _
            KEYEVENTF_EXTENDEDKEY Or KEYEVENTF_KEYUP, 0)
  End If
  StopTime (50)
End Sub

Private Sub StopTime(st As Long)
  Dim lngSt As Long
  lngSt = timeGetTime
  Do While timeGetTime - lngSt < st
    DoEvents
  Loop
End Sub

Function GetBitMap() As IPictureDisp
 Dim iid As GUID
 Dim Pic As PicBmp
 Dim ObjPic As IPictureDisp
 Dim hBitmap As Long
 Dim CopyBitmap As Long

 With iid
  .Data1 = &H20400
  .Data4(0) = &HC0
  .Data4(7) = &H46
 End With

 OpenClipboard 0
 hBitmap = GetClipboardData(CF_BITMAP)
 If hBitmap = 0 Then
  CloseClipboard
  Exit Function
 End If

 CopyBitmap = CopyImage(hBitmap, _
             IMAGE_BITMAP, 0, 0, _
             LR_COPYRETURNORG)
 CloseClipboard

 With Pic
  .Size = Len(Pic)
  .Type = PICTYPE_BITMAP
  .hBmp = CopyBitmap
 End With

 OleCreatePictureIndirect Pic, iid, 1, ObjPic
 Set GetBitMap = ObjPic
End Function

Function test()
  Dim setfile As String
  
  setfile = "C:\test.bmp"
  'Alt + PrintScreenキーでのハードコピー取得
  Call sSetSendKeys(VK_ALT, VK_SNAPSHOT)
  SavePicture GetBitMap(), setfile
End Function

【54463】Re:Formに描画(API LineTo など)した絵...
発言  VBWASURETA  - 08/3/14(金) 1:19 -

引用なし
パスワード
   ちょっと最初に提示して頂いたソースで試して見ました。
最初にフォーム1とフォーム2とが画面みっちりに表示されて、
フォーム1が画面2/3ぐらいで、フォーム2が画面1/3ぐらいに
なっているのは正しい結果ですか?
続いて描画結果としてはフォーム1にところどころ隙間がある黒い円形ですか?
因みにビットマップもそのままちゃんと取れました。
ただ、自分の環境がOS:Vista、Excel2000なので環境は違います^^;

【54464】Re:Formに描画(API LineTo など)した絵...
発言  VBWASURETA  - 08/3/14(金) 9:15 -

引用なし
パスワード
   みなさん、おはようございます。

そいえば、再描画されてませんでしたね。
WinProcで調べると色々出てくると思いますよ。
調べると何故、オブジェクト名_Clickが動くのかと
か見えてきたりもしますね。

【54548】Re:Formに描画(API LineTo など)した絵...
お礼  みそじのおじさん  - 08/3/18(火) 11:32 -

引用なし
パスワード
   みなさん こんにちわ。

返信が遅くなってしまって申し訳ありません。出張にいっていました。

みなさんからのアドバイスを元に実際に使っているコードを直しました。

1. 再描画
  
  メモリビットマップを作成し、表示用Formとメモリビットマップに

  に同時に描画をしていき、WM_PAINTが発行されたら、表示用Formに

  BitBltでコピーをするという方法をとりました。一応再描画され

  ますが、動作が不安定(自作したウインドプロシージャを元に戻した

  つもりでも、たまにエクセルが落ちてしまう。)で、この辺りも

  まだまだ勉強しないとだめですね。

2. ビットマップをコピーする

  neputuneさんのやりかたが、自分のなかではベストかなと、いいながら

  描画するコードの手直しがきつく(XYだけならいいのですが,XYZの3次元

  描画をする場合画面上には、Zという概念がないので自分でXYZのベクトル

  を合成する計算をし描画する。←プラス、マイナスを入れ替えるだけでは

  だめなんです....) 結局VBWASURETAさんに提示して頂いた,ハードコピー

  の方法を取らせてもらいました。タイトルバーも表示されますが、Formの

  Captionは可変にしてあるので(変換したファイル名になっている)どの

  ファイルを描画したかがわかって、かえって都合がよかったです。


こんな感じで無事、やりたい事ができるようになりました。みなさん本当に

ありがとうございました。

余談ですが、メッセージ系の処理っていうのは、本当に難しいですね。

(100回以上、Excelを落としてしまいまいた。)Debug.Printでしか動作確認

ができないんですね。

 私のようなアプリ系のソフトを作るのは本当はVBの方がいいんですよね?

一度VB2008の評価版をダウンしたのですが、インストールができず...VBA

で作っていたしだいです。VBならformのイベントにForm_Paintってあるん

ですもんね? このイベントがあれば、再描画がもう少し楽だったのでは と

思いました。あーVBが欲しいです...

【54550】Re:Formに描画(API LineTo など)した絵...
回答  yuu1  - 08/3/18(火) 12:55 -

引用なし
パスワード
   >提案して頂いた件について:隠しシートに描画するとの事ですが、描画
>の過程を見せるというのを抜きにして、保存>表示という事でしょうか?

シートに描画しているのを見せないという事です。見せたくないでしょう。
描画したものをユーザーフォームへ表示もできますし、保存も出来ます。

エクセルをつかうからには図形描画で絵を描いたほうが非常に簡単で何でも出来ます。
apiで描くのは大変でしょう。

>余談ですが、メッセージ系の処理っていうのは、本当に難しいですね。
>(100回以上、Excelを落としてしまいまいた。)Debug.Printでしか動作確認
>ができないんですね。

モードレスのユーザーフォームでメッセージフックは難しいと思います。
コツがわからないとすぐ落ちますから。

>私のようなアプリ系のソフトを作るのは本当はVBの方がいいんですよね?

場合によると思います。
エクセルの描画やデータベースの機能を使いこなせば楽にアプリが作成できます。
(始めから機能が備わっているので)

それで提案した方法で簡単なサンプルを作ってみました。
ユーザーフォームに
Image1
CommandButton1
CommandButton2
CommandButton3
を配置して以下をお試しください。

'標準モジュール
Option Explicit
Private Type GUID
 Data1 As Long
 Data2 As Integer
 Data3 As Integer
 Data4(0 To 7) As Byte
End Type
Private Type UPICDESC
 Size As Long
 Type As Long
 hPic As Long
 hPal As Long
 Reserved As Long
End Type
Private Declare Function GetClipboardData Lib "user32" (ByVal wFormat As Integer) As Long
Private Declare Function OleCreatePictureIndirect Lib "olepro32.dll" (picdesc As UPICDESC, RefIID As GUID, ByVal fPictureOwnsHandle As Long, ipic As IPicture) As Long
Private Declare Function CopyEnhMetaFile Lib "gdi32" Alias "CopyEnhMetaFileA" (ByVal hemfSrc As Long, ByVal lpszFile As String) As Long
Private Declare Function DeleteEnhMetaFile Lib "gdi32" (ByVal hmf As Long) As Long
Private Declare Function IIDFromString Lib "ole32" (ByVal lpsz As String, ByRef lpiid As GUID) As Long
Private Declare Function CopyImage Lib "user32" (ByVal Handle As Long, ByVal un1 As Long, ByVal n1 As Long, ByVal n2 As Long, ByVal un2 As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Const CF_ENHMETAFILE = 14
Const PICTYPE_ENHMETAFILE = 4
Const CF_BITMAP = 2 '=xlBitmap
Const PICTYPE_BITMAP = 1
Const IMAGE_BITMAP = 0
Const LR_COPYRETURNORG = 4
Private Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function EmptyClipboard Lib "user32" () As Long
Private Declare Function CloseClipboard Lib "user32" () As Long

'GetPictureメソッド クリップボードの画像オブジェクトを得る
Public Function GetPicture(ByVal Format As XlCopyPictureFormat) As IPicture
 Dim Handle&, desc As UPICDESC, id As GUID
 If OpenClipboard(0&) > 0 Then
  If Format = xlBitmap Then
   Handle = CopyImage(GetClipboardData(CF_BITMAP), IMAGE_BITMAP, 0, 0, LR_COPYRETURNORG)
  Else
   Handle = CopyEnhMetaFile(GetClipboardData(CF_ENHMETAFILE), vbNullString)
  End If
  CloseClipboard
 End If
 If Handle = 0 Then Exit Function 'イメージ取得失敗
 IIDFromString StrConv("{7BF80981-BF32-101A-8BBB-00AA00300CAB}", vbUnicode), id
 With desc
  .Size = Len(desc)
  .Type = IIf(Format = xlBitmap, PICTYPE_BITMAP, PICTYPE_ENHMETAFILE)
  .hPic = Handle
 End With
 'Pictureオブジェクトを作成
 OleCreatePictureIndirect desc, id, 1, GetPicture
 If GetPicture Is Nothing Then
  If Format = xlBitmap Then DeleteObject Handle Else DeleteEnhMetaFile Handle
 End If
End Function

'作業シート(非表示)を取得
Function SheetTemp() As Worksheet
 Const TNAME = "SheetTemp"
 With ThisWorkbook.Worksheets
  On Error Resume Next
  Set SheetTemp = .Item(TNAME)
  On Error GoTo 0
  If SheetTemp Is Nothing Then '無ければ作成
   Set SheetTemp = .Add
   SheetTemp.Name = TNAME
   SheetTemp.Visible = xlSheetVeryHidden
  End If
 End With
End Function

'↑標準モジュールここまで

'ユーザーフォームモジュール
Option Explicit

'描画例 放射線上に円を書く
Private Sub CommandButton1_Click()
 Dim pi#, tmp As Worksheet, ch As Chart, ii&, xl&, yl&, x0&, y0&, rr&
 xl = 200: yl = 200 '描画サイズ(横及び縦) ポイント単位
 rr = 100 '半径
 pi = WorksheetFunction.pi
 Set tmp = SheetTemp
 tmp.DrawingObjects.Delete
 Set ch = tmp.ChartObjects.Add(0, 0, xl, yl).Chart
 With ch
  .ChartArea.Border.LineStyle = 0
  x0 = .ChartArea.Width / 2: y0 = .ChartArea.Height / 2
  For ii = 1 To 360
   With .Shapes.AddLine(x0, y0, x0 + (rr * Sin(ii * pi / 180)), y0 - (rr * Cos(ii * pi / 180)))
    .Line.ForeColor.RGB = vbRed
   End With
  Next
 End With
 ch.CopyPicture xlScreen, xlBitmap, xlScreen
 Set Image1.Picture = GetPicture(xlBitmap)
 tmp.DrawingObjects.Delete
 tmp.Parent.Saved = True
End Sub

'bmp保存
Private Sub CommandButton2_Click()
 SavePicture Image1.Picture, ThisWorkbook.Path & "\test1.bmp"
End Sub

'閉じる
Private Sub CommandButton3_Click()
 Unload Me
End Sub

Private Sub UserForm_Initialize()
 Image1.BorderStyle = fmBorderStyleNone
 Image1.PictureSizeMode = fmPictureSizeModeZoom
 CommandButton1.Caption = "描画"
 CommandButton2.Caption = "保存"
 CommandButton3.Caption = "閉じる"
End Sub

【54551】Re:Formに描画(API LineTo など)した絵...
発言  neptune  - 08/3/18(火) 14:55 -

引用なし
パスワード
   ▼みそじのおじさん さん:
みなさん こんにちわ。

> 私のようなアプリ系のソフトを作るのは本当はVBの方がいいんですよね?
そうですね。VBでもその他でも開発言語が良いですね。

>一度VB2008の評価版をダウンしたのですが、インストールができず...VBA
>で作っていたしだいです。VBならformのイベントにForm_Paintってあるん
>ですもんね? このイベントがあれば、再描画がもう少し楽だったのでは と
>思いました。あーVBが欲しいです...
インストールが出来ないって、OSの都合?、会社が許さない?OSなら
2005はWin2000からOKですよ。

私も初心者れべるのC++ですが、簡単に描画だけなら出来ました。
保存も、Webで検索すればサンプルか、情報はありますし。

C++2008Expressのただの奴でやってみたら、たったこれだけですよ。
下記意外にちょっと宣言とかは必要ですが、
コマンドラインでファイルのパスを渡し、そのファイルから
データを処理して描画させても描画だけと言う点なら、簡単です。
文字列を処理して、計算するのが面倒ですけどね。

自動的に作成される雛形にちょっと追加するだけです。

CALLBACK WndProcに以下を追加
        // 選択されたメニューの解析:
        switch (wmId)
        {
        case IDM_DRAWLINE:        //このcase句追加
            DrawFlg = !DrawFlg;        //フラグは別途用意。
            GetClientRect(hWnd,&rc);
            InvalidateRect(hWnd,&rc,TRUE);    //更新リージョン指定
            break;
        case WM_PAINT:
        hdc = BeginPaint(hWnd, &ps);
        // TODO: 描画コードをここに追加してください...
        if (DrawFlg==TRUE){            //このif句追加
            DrawLines(hWnd,hdc);
        }
        EndPaint(hWnd, &ps);
        break;

//コマンドラインで渡されたパスのデータを処理する関数作成必要

//描画させる関数これは作成必要
//(以下は例でクライアントウィンドウに×を引くだけ)
int DrawLines(HWND hOwner,HDC hdc){
    RECT rc;

    BOOL bret = GetClientRect(hOwner,&rc);

    MoveToEx(hdc, rc.right, rc.top, NULL);
    LineTo(hdc, rc.left, rc.bottom);
    MoveToEx(hdc, rc.left, rc.top, NULL);
    LineTo(hdc, rc.right, rc.bottom);
    return 0;
}

VB,C#、C++、どれでやってもVBAでやるよりは楽に出来ると思いますね。
ちなみに、私なら作成されているソフトを全部書き直すと大変なので、
ご質問の描画関係だけ、exeでも、dllでも作成して使用することを考えて
しまいました。

【54552】Re:Formに描画(API LineTo など)した絵...
発言  VBWASURETA  - 08/3/18(火) 15:53 -

引用なし
パスワード
   皆さんこんにちは。


>>一度VB2008の評価版をダウンしたのですが、インストールができず...VBA
>>で作っていたしだいです。VBならformのイベントにForm_Paintってあるん
>>ですもんね? このイベントがあれば、再描画がもう少し楽だったのでは と
>>思いました。あーVBが欲しいです...

VSってスタンダードだとそんなにコストかからないですよ?
今の子供のゲーム機よりは安いかと・・・
因みにVS2008はXP, Vista対応、VS2005はWin2000(プラットフォームでVistaでも動作します)らしいです。
販売店員の請け売りです。

因みに自分は描画関係はC#でやってます。
Comインタフェース間はC++です。


そいえば、dllがあれば画像作れそうですよね?
.netでどこまでのアプリを対応できるかが問題になるかもですが。

【54559】Re:Formに描画(API LineTo など)した絵...
お礼  みそじのおじさん  - 08/3/19(水) 10:59 -

引用なし
パスワード
   yuu1さん:

サンプルコードありがとうございます。

ほとんどのメソッド、プロパティが初めて見る物ばかりで

興味深く拝見させてもらいました。

 私がAPIで描画をしていた訳は、描画がしたい⇒ネット

を検索⇒最初にヒットしたのがAPIだった。これだけなん

です。

エクセルに備わっている機能で私がやりたかった事がほと

んどできるのですね。いやー驚きです。

 最初から知っていれば、堅苦しいAPIの宣言もいらなかっ

たんでしょうね。(でもAPIはどの言語でも通用するので

これからの自分の為にはいい勉強になったと思っています)

サンプルコード非常に参考になりました。ありがとうござい

ます。

後一つyuu1さんにモードレスのFormのメッセージフックのこつ

をお聞きしたいのですが?(流れ的なお話でよろしいので)

よろしくお願いいたします。

VBWASURETAさん:

お礼に書き忘れていたのですが、私が書いたサンプルコー

ドを試していただきありがとうございます。

私の方で絵が反転していたのは、私の方のミスで、UF1

に描画⇒UF3にLoadPictue(真っ白なBmpをロードしていた

つもりが,提示していただいたサイトのコードを使って反転

した絵が(実はこれも試していました。すいません)ロード

されていて⇒クリップボードのコピーに失敗⇒反転した

絵がそののまま表示されていた。

クリップボードのコピーに失敗のところにResume Nextを

入れていました。(メモリ不足とのエラーが出ていた為)

申し訳ありません。

neputuneさん:

ついに、C++まで出てきましたか^^

私はフリーのBC++というのはもってますが、インクルード

辺りで止まっています。(泣 難しいです....)

 描画の所だけを他の言語にさせるという発想、んー私

からはとても出てきませんね。いつもご提案ありがとう

ございます。ファイル名を引数で渡し、文字列を描画でき

る様に変換⇒描画となるには、ほぼC++を使いこなせないと

だめですよね....(5年はかかりそうです。VBA歴2年の私

にとっては敷居がたかすぎます(泣))

 インストール出来なかったのは、OSの都合ですね。

(たぶん..サービスパック?この辺り全然詳しくないんで

す。会社は6人しかいない町工場でPCを使うのは私を含め二

人しかいませんのでダウンロードは自由なんです。)

VB2005試してみます。

最近、本業よりもこっちの方が面白くなってきてしまい

ました。勤続十何年、30過ぎての転職...んーーー嫁に怒

られますね。

【54560】Re:Formに描画(API LineTo など)した絵...
発言  neptune  - 08/3/19(水) 13:03 -

引用なし
パスワード
   みなさんこんにちは

>最近、本業よりもこっちの方が面白くなってきてしまいました。
頑張って本業に生かしてくださいませ。事務屋さんなどの業務を楽にしてやれば
喜びますよ。

ちょっと気になったのですが、メッセージフックに興味をお持ちのよう
ですが、VBAでは止めといた方が身の為です。趣味で、自分の実験で、
自分のマシンでやってみるのは自己責任ですが、特に仕事に使うものに
使うのは以ての外と思います。ついでに言うとSetTime API関数もです。

その理由はVBAそのものが不安定・・というか、勝手に広域変数が初期化されたり
する不具合もあります。もし、フック中に何らかの原因でプログラムが終わったり
すれば、・・・・悲惨です。Excelはお亡くなりになるは、下手するとOSも
道ずれにしてしまうかもしれません。(実験中に経験有り)

やはり、VBでもC#(.net以降では作った事ないので出来るかどうか知りませんけど)
C++などでその部分だけでも作成して、安心して、フックするのが安全と思いますよ。

長い目で頑張ってください。^ ^ 
私なんか.net以降は初心者のまま止まってますから^ ^;;;
でもC++は少しでもかじっておくとC#は違和感ありませんね。

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