| |
こんにちわ。
ichinoseはん、
＞作成したbmpファイルをクリックして開こうとすると、
＞形式が違うという趣旨のエラーが出て、開きません。
↑これ、試してみたけどわての環境ではちゃんと開きまっせ。
(WindowsXP+Excel2003)
ところで、ワークシート使わん方法で考えてみました。
前提条件：
１．ユーザーフォームにImage1を配置
２．元画像ファイルは 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 = "ＭＳ ゴシック"
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 "変換前"
'元画像ＢＭＰファイルからデバイスコンテキストを直接作成
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 "変換後"
'新規ＢＭＰファイルに出力
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として保存されます。
（フォームを表示させるコードは書いてまへんがＦ５キーでも表示できます。）
試してみてな。
ほな。
|
|
![[未読]](./data/excel/image/read_icon.gif){kind=icon}
