| |
▼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
'========================================================================
|
|
BRG
- 08/2/24(日) 17:11 -
