| |
おはようございます。
シートに配置された画像を一度ファイルに落とした後、
それをImageコントロールで読み込むという考え方です。
新規ブックに
ユーザーフォーム（Userform1)を作成します。
コントロールは イメージコントロール（Image1）ひとつ
適当なシートをアクティブにした後、
Sub Macro1()
ActiveSheet.Pictures.Insert "画像パス.jpg"
End Sub
このようなコードでシートに画像を配置してください。
標準モジュールに
'============================================================
Sub test1()
Dim imgnm As String
Dim shp As Shape
Call del_html(ThisWorkbook.path & "\ctmp.htm")
Set shp = ActiveSheet.Shapes("Picture 1")
' ↑実際の名前
With Workbooks.Add
shp.Copy
.Worksheets(1).Paste
.SaveAs Filename:=ThisWorkbook.path & "\ctmp.htm", _
FileFormat:=xlHtml, _
ReadOnlyRecommended:=False, _
CreateBackup:=False
.Close False
End With
UserForm1.Show vbModeless
With UserForm1.Image1
imgnm = get_imgnm(ThisWorkbook.path & "\ctmp.htm")
If imgnm <> "" Then .Picture = LoadPicture(imgnm)
End With
Call del_html(ThisWorkbook.path & "\ctmp.htm")
End Sub
'============================================================
Function get_imgnm(htmlnm As String) As String
On Error Resume Next
Dim fso As Object
Dim fl As Object
get_imgnm = ""
Set fso = CreateObject("Scripting.FileSystemObject")
With fso
For Each fl In .getfolder(.GetParentFolderName(htmlnm) & "\" & .getbasename(htmlnm) & ".files").Files
If UCase(fl.Name) Like UCase("image001.*") Then
get_imgnm = fl.path
Exit For
End If
Next
End With
Set fso = Nothing
End Function
'============================================================
Sub del_html(path As String)
On Error Resume Next
Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")
With fso
.getfile(path).Delete
.getfolder(.GetParentFolderName(path) & "\" & .getbasename(path) & ".files").Delete
End With
Set fso = Nothing
End Sub
Thisworkbook.Pathをコード内で使っていますから、
一度保存した後、test1を実行してみてください。
画像を別の新規ブックにコピーし、Htmlで保存します。
ここから、画像ファイルをサーチし、Imageコントロールに読み込む
というアルゴリズムです。
画像をファイルに落とす方法は他にもあったかと思いますが、
今回は、Htmlから、取得しました。
|
|
ichinose
- 06/7/5(水) 8:48 -
