Excel VBA質問箱 IV

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

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


27947 / 76732 ←次へ | 前へ→

【54098】Re:フォーム上のイメージに文字を追加する方法
回答  bykin  - 08/2/24(日) 14:15 -

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

ichinoseはん、

>作成したbmpファイルをクリックして開こうとすると、
>形式が違うという趣旨のエラーが出て、開きません。

↑これ、試してみたけどわての環境ではちゃんと開きまっせ。
(WindowsXP+Excel2003)

ところで、ワークシート使わん方法で考えてみました。
前提条件:
1.ユーザーフォームにImage1を配置
2.元画像ファイルは C:\test.bmp

Option Explicit

Private Const DT_LEFT As Long = &H0
Private Const DT_BOTTOM As Long = &H8
Private Const DT_SINGLELINE As Long = &H20
Private Const TRANSPARENT As Long = 1
Private Const GUID_IDISPATCH_INTERFACE As String = "{00020400-0000-0000-C000-000000000046}"
Private Const CF_BITMAP As Long = 2
Private Const CF_PALETTE As Long = 9
Private Const PICTYPE_BITMAP As Long = 1
Private Const IMAGE_BITMAP As Long = 0
Private Const LR_COPYRETURNORG As Long = &H4
Private Const LR_LOADFROMFILE As Long = &H10
Private Const LOGPIXELSX As Long = 88

Private Type POINTAPI
  X As Long
  Y As Long
End Type

Private Type RECT
  Left As Long
  Top As Long
  Right As Long
  Bottom As Long
End Type

Private Type BITMAP
  bmType As Long
  bmWidth As Long
  bmHeight As Long
  bmWidthBytes As Long
  bmPlanes As Integer
  bmBitsPixel As Integer
  bmBits As Long
End Type

Private Type SIZEAPI
  cx As Long
  cy As Long
End Type

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

Private Type PictDesc
  cbSizeofStruct As Long
  picType As Long
  hImage As Long
  Option1 As Long
  Option2 As Long
End Type

Private Declare Function CLSIDFromString Lib "ole32" _
            (ByVal lpsz As Long, _
             ByRef ID As GUID) As Long

Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hDC As Long) As Long

Private Declare Function DeleteDC Lib "gdi32" (ByVal hDC As Long) As Long

Private Declare Function GetObject Lib "gdi32" _
             Alias "GetObjectA" _
            (ByVal hObject As Long, _
             ByVal nCount As Long, _
             ByRef lpObject As Any) As Long

Private Declare Function SelectObject Lib "gdi32" _
            (ByVal hDC As Long, _
             ByVal hObject As Long) As Long

Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long

Private Declare Function SetRect Lib "user32" _
            (ByRef lpRect As RECT, _
             ByVal X1 As Long, _
             ByVal Y1 As Long, _
             ByVal X2 As Long, _
             ByVal Y2 As Long) As Long

Private Declare Function CreateFont Lib "gdi32" _
             Alias "CreateFontA" _
            (ByVal nHeight As Long, _
             ByVal nWidth As Long, _
             ByVal nEscapement As Long, _
             ByVal nOrientation As Long, _
             ByVal fnWeight As Long, _
             ByVal fdwItaric As Long, _
             ByVal fdwUnderline As Long, _
             ByVal fdwStrikeOut As Long, _
             ByVal fdwCharSet As Long, _
             ByVal fdwOutputPrecision As Long, _
             ByVal fdwClipPrecision As Long, _
             ByVal fdwQuality As Long, _
             ByVal fdwPitchAndFamily As Long, _
             ByVal lpszFace As String) As Long

Private Declare Function DrawText Lib "user32" _
             Alias "DrawTextA" _
            (ByVal hDC As Long, _
             ByVal lpStr As String, _
             ByVal nCount As Long, _
             ByRef lpRect As RECT, _
             ByVal wFormat As Long) As Long

Private Declare Function SetTextColor Lib "gdi32" _
            (ByVal hDC As Long, _
             ByVal crColor As Long) As Long

Private Declare Function SetBkMode Lib "gdi32" _
            (ByVal hDC As Long, _
             ByVal nBkMode As Long) As Long

Private Declare Function GetTextExtentPoint32 Lib "gdi32" _
             Alias "GetTextExtentPoint32A" _
            (ByVal hDC As Long, _
             ByVal lpString As String, _
             ByVal cbString As Long, _
             ByRef lpSize As SIZEAPI) As Long

Private Declare Function OleCreatePictureIndirect Lib "olepro32.dll" _
            (ByRef lpPicDesc As PictDesc, _
             ByRef RefIID As GUID, _
             ByVal fPictureOwnsHandle As Long, _
             ByRef iPic As stdole.IPictureDisp) As Long

Private Declare Function IsClipboardFormatAvailable Lib "user32" (ByVal wFormat As Long) As Long

Private Declare Function OpenClipboard Lib "user32" (ByVal hWnd As Long) As Long

Private Declare Function CloseClipboard Lib "user32" () As Long

Private Declare Function EmptyClipboard Lib "user32" () As Long

Private Declare Function GetClipboardData Lib "user32" (ByVal wFormat As Long) As Long

Private Declare Function SetClipboardData Lib "user32" _
            (ByVal wFormat As Long, _
             ByVal hMem As Long) As Long

Private Declare Function LoadImage Lib "user32" Alias "LoadImageA" (ByVal hInst As Long, ByVal lpsz As String, ByVal un1 As Long, ByVal n1 As Long, ByVal n2 As Long, ByVal un2 As Long) As Long

Private Declare Function GetDeviceCaps Lib "gdi32" _
            (ByVal hDC As Long, _
             ByVal nIndex As Long) As Long

Private Sub UserForm_Click()
  Const COPYRIGHT As String = "Copyright(c) 2008 bykin"
  Const FILE_ORIGINAL As String = "C:\test.bmp"
  Const FILE_MODIFIED As String = "C:\test2.bmp"
  Const FONT_SIZE As Long = 11
  Const FONT_NAME As String = "MS ゴシック"
  Dim hDC As Long
  Dim hBmp As Long
  Dim hFont As Long
  Dim hOrgBmp As Long
  Dim hOrgFont As Long
  Dim hPalette As Long
  Dim hImg As Long
  Dim tBitmap As BITMAP
  Dim tRect As RECT
  Dim tSize As SIZEAPI
  Dim PicDesc As PictDesc
  Dim IdispatchID As GUID
  Dim Pic As stdole.IPictureDisp
  Dim Pos As POINTAPI
  Dim Ratio As Single
  
  On Error Resume Next
  With Me.Image1
  
    '一旦Image1に元画像を表示(=確認用)
    .Picture = stdole.LoadPicture(FILE_ORIGINAL)
    .AutoSize = False
    .AutoSize = True
    MsgBox "変換前"
    
    '元画像BMPファイルからデバイスコンテキストを直接作成
    hBmp = LoadImage(0, FILE_ORIGINAL, IMAGE_BITMAP, 0, 0, LR_LOADFROMFILE)
    hDC = CreateCompatibleDC(0)
    hOrgBmp = SelectObject(hDC, hBmp)
    GetObject hBmp, Len(tBitmap), tBitmap
    
    '文字描画用オブジェクト設定
    Ratio = 72 / GetDeviceCaps(hDC, LOGPIXELSX)
    hFont = CreateFont(CLng(Int(FONT_SIZE / Ratio)), 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, FONT_NAME)
    hOrgFont = SelectObject(hDC, hFont)
    SetTextColor hDC, vbBlack
    SetBkMode hDC, TRANSPARENT
    
    '文字列の幅と高さで描画範囲(画像の右下)を設定
    GetTextExtentPoint32 hDC, COPYRIGHT, LenB(StrConv(COPYRIGHT, vbFromUnicode)), tSize
    Pos.X = tBitmap.bmWidth - tSize.cx
    Pos.Y = tBitmap.bmHeight - tSize.cy
    SetRect tRect, Pos.X, Pos.Y, tBitmap.bmWidth, tBitmap.bmHeight
    
    '文字出力
    DrawText hDC, COPYRIGHT, -1, tRect, DT_BOTTOM Or DT_SINGLELINE Or DT_LEFT
    
    '画像をクリップボードにコピー
    If OpenClipboard(0) <> 0 Then
      EmptyClipboard
      SetClipboardData CF_BITMAP, hBmp
      CloseClipboard
    End If
    
    '描画オブジェクト/デバイスコンテキストの後始末
    SelectObject hDC, hOrgFont
    DeleteObject hFont
    SelectObject hDC, hOrgBmp
    DeleteDC hDC
    DeleteObject hBmp
  
    'クリップボードからImage1に画像をコピー
    If IsClipboardFormatAvailable(CF_BITMAP) <> 0 Then
      If OpenClipboard(0) <> 0 Then
        hImg = GetClipboardData(CF_BITMAP)
        hPalette = GetClipboardData(CF_PALETTE)
        PicDesc.Option1 = hPalette
        If hImg <> 0 Then
          CLSIDFromString ByVal StrPtr(GUID_IDISPATCH_INTERFACE), IdispatchID
          With PicDesc
            .cbSizeofStruct = Len(PicDesc)
            .picType = PICTYPE_BITMAP
            .hImage = hImg
          End With
          If OleCreatePictureIndirect(PicDesc, IdispatchID, 0, Pic) = 0 Then
            Set .Picture = Pic
            MsgBox "変換後"
            
            '新規BMPファイルに出力
            stdole.SavePicture .Picture, FILE_MODIFIED
            
            'このままではImage1に表示された画像が消える場合がある
            '(フォームが他のウィンドウの背面に回ったとき等)ので
            '出力したファイルを読み込む(=確認用)
            .Picture = stdole.LoadPicture(FILE_MODIFIED)
            MsgBox "保存しました"
          End If
        End If
        EmptyClipboard
        CloseClipboard
      End If
    End If
  End With
End Sub

ユーザーフォームを表示させ、クリックしてください。
Copyrightの文字列が画像右下に追加され、新しいファイルC:\test2.bmpとして保存されます。
(フォームを表示させるコードは書いてまへんがF5キーでも表示できます。)

試してみてな。
ほな。

0 hits

【54075】フォーム上のイメージに文字を追加する方法 BRG 08/2/23(土) 12:45 質問
【54091】Re:フォーム上のイメージに文字を追加する... ichinose 08/2/24(日) 9:16 発言
【54098】Re:フォーム上のイメージに文字を追加する... bykin 08/2/24(日) 14:15 回答
【54109】Re:フォーム上のイメージに文字を追加する... ichinose 08/2/24(日) 21:02 発言
【54130】Re:フォーム上のイメージに文字を追加する... BRG 08/2/25(月) 21:37 お礼
【54104】Re:フォーム上のイメージに文字を追加する... BRG 08/2/24(日) 17:11 お礼

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