Excel VBA質問箱 IV

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

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


27941 / 76732 ←次へ | 前へ→

【54104】Re:フォーム上のイメージに文字を追加する方法
お礼  BRG  - 08/2/24(日) 17:11 -

引用なし
パスワード
   ▼ichinose さん:
大変貴重なアドバイスをありがとうございました。

コードを記載しなかった件については大変申し訳ありませんでした。というのも私が素人なもので作成途中にどんどん追加削除を繰り返した挙句、どこがどうなっているのか簡潔に記載できなかったため、混乱させてもいけないと思い、控えさせていただきました。

さて、本日お返事をいただいてから試行錯誤の結果、下記のことがわかりました。

◆VBA作成したBMPは通常のBMPと異なるファイルになる
ichinoseさんがご指摘されているとおり、このマクロというより、VBAで作成したもの全てになると思いますが、私のKBC.dllを利用してBMPに変換したファイルでも同様の症状で、JPGへの変換ができなかったりWindowsフォトギャラリー等でも開けませんでした。ただ、一度ペイントで開いて保存しなおせば有効なファイルになりました。(どの色数でも)

◆明熊さんのSaveJPG.DLLで直接クリップボードファイルのものをjpgに変換すると上記の問題は起こらない。

上記の結果に基づいて、SaveJPG.DLLのインストール後、いただいたコードの一部に下記のように追加することにより、イメージ通りの作業ができるようになりました。
ありがとうございました。

'--------------------------------------------------------------
Public Declare Function CliptoJPEG Lib "SaveJPG.DLL" _
(ByVal jpgf As String, ByVal Value As Byte, ByVal Prgrs As Boolean) As Integer
'--------------------------------------------------------------
========================================================================
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()
'----------------------------------------------------------
Dim s As Integer
  ActiveSheet.Pictures(1).CopyPicture xlScreen, xlBitmap
  s = CliptoJPEG(”保存するファイル名”, 80, False)
'----------------------------------------------------------
       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
'========================================================================

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 お礼

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