Excel VBA質問箱 IV

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

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


27954 / 76732 ←次へ | 前へ→

【54091】Re:フォーム上のイメージに文字を追加する方法
発言  ichinose  - 08/2/24(日) 9:16 -

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


>今のところ各種画像をBMP化して、別フォーム上にImage表示させるところまでは行ったのですが、VBと違いPrintやLine等、VBAには描画の機能が一切無い為に、その後の一切の加工ができずに困っています。
この掲示板では、取り合えず出来てるコードは、提示されたほうがよいですよ!!


>フォルダー内の画像にまとめて(c)マークのような文字を追加したいと考えています。
>エクセルVBAでファイル管理システムを作ったので、できればVBA上でできればと考えています。

方法としては、

・画像をシートに取り込む
・オートシェイプを使って、Cマークを作成する
・上記の二つの図形をグループ化し、クリップボードにコピーする。
・クリップボードの内容をユーザーフォームのイメージコントロールに取り込む
・何とかImageコントロールに画像が取り込めれば、SavePictureメソッドで
 ファイルの保存を行える

という方針でアプローチしました。

先に結果を申し上げると、
Cマークが付いた画像をイメージコントロールに表示し、
そこから、ファイルの保存までは成功しました。

が、作成した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を実行してください。

ファイル選択ボタンをクリックして、Cマークを付けたい画像を
選択してください。

イメージコントロールにCマークの付いた画像が表示されます。
このブックと同じフォルダにsample.bmpとして、保存されます。

参考にしてみてください。

 尚、Win2000&Excel2002で確認しました。
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 お礼

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