Excel VBA質問箱 IV

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

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


27650 / 76732 ←次へ | 前へ→

【54399】Re:Formに描画(API LineTo など)した絵をBitMapで保存できますか?
発言  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
2 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 発言

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