| |
▼BRG さん：
おはようございます。
>今のところ各種画像をBMP化して、別フォーム上にImage表示させるところまでは行ったのですが、VBと違いPrintやLine等、VBAには描画の機能が一切無い為に、その後の一切の加工ができずに困っています。
この掲示板では、取り合えず出来てるコードは、提示されたほうがよいですよ！！
>フォルダー内の画像にまとめて(c)マークのような文字を追加したいと考えています。
>エクセルVBAでファイル管理システムを作ったので、できればVBA上でできればと考えています。
方法としては、
・画像をシートに取り込む
・オートシェイプを使って、Ｃマークを作成する
・上記の二つの図形をグループ化し、クリップボードにコピーする。
・クリップボードの内容をユーザーフォームのイメージコントロールに取り込む
・何とかImageコントロールに画像が取り込めれば、SavePictureメソッドで
ファイルの保存を行える
という方針でアプローチしました。
先に結果を申し上げると、
Ｃマークが付いた画像をイメージコントロールに表示し、
そこから、ファイルの保存までは成功しました。
が、作成したbmpファイルをクリックして開こうとすると、
形式が違うという趣旨のエラーが出て、開きません。
↑これは、よくわかりません。
但し、ExcelやWordでの図の挿入や
Imageコントロールへの読み込みは可能です。
保存の方法に別案があれば・・・ですが。
取り合えず、コードを提示します。
尚、クリップボードの図形からStdpictureを作るコードは、
りんさん投稿の
www.vbalab.net/vbaqa/c-board.cgi?cmd=one;no=46923;id=excel
↑これを使わせてもらいました。
新規ブックにユーザーフォーム（UserForm1）だけ作成してください。
コントロールは、コードで挿入しますから、何も配置しないで下さい。
まず、Userform1のモジュールに
'===============================================================
Option Explicit
Private WithEvents btn_fl_select As MSForms.CommandButton
Private WithEvents img_pic As MSForms.Image
Private Const CF_ENHMETAFILE = 14
Private Declare Function IsClipboardFormatAvailable Lib "user32.dll" (ByVal wFormat As Long) As Long
Private Declare Function OpenClipboard Lib "user32.dll" (ByVal hwnd As Long) As Long
Private Declare Function GetClipboardData Lib "user32.dll" (ByVal wFormat As Long) As Long
Private Declare Function CloseClipboard Lib "user32.dll" () As Long
Private Const vbPicTypeBitmap = 1
Private Const vbPicTypeIcon = 3
Private Const vbPicTypeEMetafile = 4
Private Type TPICTDESC
cbSizeofStruct As Long
picType As Long
hImage As Long
Option1 As Long
Option2 As Long
End Type
Private Type TGUID
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(1 To 8) As Byte
End Type
Private Declare Function OleCreatePictureIndirect Lib "olepro32.dll" _
(lpPictDesc As TPICTDESC, _
RefIID As TGUID, _
ByVal fPictureOwnsHandle As Long, _
ByRef IPic As IPicture) As Long
'========================================================================
Public Function Clipboard_GetMetafile() As StdPicture
Dim hEmf As Long
Dim TPICTDESC As TPICTDESC
Dim TGUID As TGUID
Set Clipboard_GetMetafile = Nothing
If IsClipboardFormatAvailable(CF_ENHMETAFILE) = False Then Exit Function
If OpenClipboard(CLng(0)) = False Then Exit Function
hEmf = GetClipboardData(CF_ENHMETAFILE)
Call CloseClipboard
If hEmf = 0 Then Exit Function
With TPICTDESC
.cbSizeofStruct = Len(TPICTDESC)
.picType = vbPicTypeEMetafile
.hImage = hEmf
End With
With TGUID
.Data1 = &H20400
.Data4(1) = &HC0
.Data4(8) = &H46
End With
Call OleCreatePictureIndirect(TPICTDESC, TGUID, True, Clipboard_GetMetafile)
End Function
'========================================================================
Private Sub btn_fl_select_Click()
Dim flnm As Variant
Dim crng As Range
Dim 元画像 As Shape
Dim c_mark As Shape
With Workbooks.Add
Set crng = .ActiveSheet.Range("a1")
End With
'On Error Resume Next
flnm = Application.GetOpenFilename(, , "Select picture files")
If TypeName(flnm) <> "Boolean" Then
Set 元画像 = crng.Parent.Pictures.Insert(flnm).ShapeRange.Item(1)
If Err.Number = 0 Then
With crng.MergeArea
元画像.left = .left
元画像.top = .top
End With
Set c_mark = mk_c(crng.Parent, crng.left, crng.top, CLng(元画像.Width / 10))
With c_mark
.left = 元画像.Width - .Width
.top = 元画像.Height - .Height
End With
With crng
With .Parent.Shapes.Range(Array(c_mark.Name, 元画像.Name)).Group
.CopyPicture Appearance:=xlScreen, Format:=xlBitmap
End With
With .Parent.Pictures.Paste
.Copy
End With
img_pic.Picture = Clipboard_GetMetafile()
DoEvents
Call SavePicture(img_pic.Picture, ThisWorkbook.Path & "\sample.bmp")
.Parent.Parent.Close False
End With
Me.Repaint
Application.CutCopyMode = False
End If
End If
End Sub
'========================================================================
Function mk_c(ByVal sht As Worksheet, left As Single, top As Single, Optional ByVal sz As Long = 14) As Shape
Set mk_c = sht.Shapes.AddTextbox(msoTextOrientationHorizontal, _
left, top, 20, 20)
With mk_c
.Line.Visible = msoFalse
.Fill.Transparency = 1#
With .TextFrame
.AutoSize = True
With .Characters
.Text = ChrW(&H24B8)
.Font.Size = sz
End With
End With
End With
End Function
'========================================================================
Private Sub UserForm_Initialize()
With Me
.Width = 360
.Height = 400
Set btn_fl_select = .Controls.Add("Forms.CommandButton.1", , True)
With btn_fl_select
.Caption = "ファイル選択"
.left = 30
.top = 12
.Width = 72
.Height = 24
End With
Set img_pic = .Controls.Add("Forms.Image.1", , True)
With img_pic
.left = 30
.top = 48
.Width = 264
.Height = 252
.PictureSizeMode = fmPictureSizeModeStretch
End With
End With
End Sub
標準モジュールに
'=================================================================
Sub main()
UserForm1.Show vbModeless
End Sub
一度、ブックを保存してから、mainを実行してください。
ファイル選択ボタンをクリックして、Ｃマークを付けたい画像を
選択してください。
イメージコントロールにＣマークの付いた画像が表示されます。
このブックと同じフォルダにsample.bmpとして、保存されます。
参考にしてみてください。
尚、Win2000＆Excel2002で確認しました。
|
|
ichinose
- 08/2/24(日) 9:16 -
