České diskuzní fórum o počítačích
https://pc-help.cnews.cz/
Kód: Vybrat vše
Private Sub Image1_Click()
On Error Resume Next
Dim umisteni As String
umisteni = Application.GetSaveAsFilename("C:\", , , "Najdi obrázek nebo zadej cestu")
If umisteni <> "" Then
Image1.Picture = LoadPicture(umisteni)
Image1.PictureSizeMode = fmPictureSizeModeStretch
End If
On Error GoTo 0
End Sub
Kód: Vybrat vše
Option Explicit
Private Type TGUID
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(0 To 7) As Byte
End Type
Private Declare Function OleLoadPicturePath Lib "oleaut32" (ByVal szURLorPath As Long, ByVal punkCaller As Long, ByVal dwReserved As Long, ByVal clrReserved As OLE_COLOR, ByRef riid As TGUID, ByRef ppvRet As IPicture) As Long
Public Function LoadPicture(ByVal strFileName As String) As IPicture
Dim IID As TGUID
With IID
.Data1 = &H7BF80980
.Data2 = &HBF32
.Data3 = &H101A
.Data4(0) = &H8B
.Data4(1) = &HBB
.Data4(2) = &H0
.Data4(3) = &HAA
.Data4(4) = &H0
.Data4(5) = &H30
.Data4(6) = &HC
.Data4(7) = &HAB
End With
On Error GoTo ERR_LINE
Set LoadPicture = stdole.LoadPicture(strFileName)
Exit Function
ERR_LINE:
On Error Resume Next
OleLoadPicturePath StrPtr(strFileName), 0&, 0&, 0&, IID, LoadPicture
If LoadPicture Is Nothing Then
MsgBox "Nemohu najít " & strFileName
End
End If
End Function
Private Sub Image1_Click()
On Error Resume Next
Set Me.Image1.Picture = LoadPicture(Range("a1"))
On Error GoTo 0
End SubKód: Vybrat vše
Private Declare PtrSafe Function OleLoadPicturePath Lib "oleaut32" (ByVal szURLorPath As LongPtr, ByVal punkCaller As LongPtr, ByVal dwReserved As LongPtr, ByVal clrReserved As OLE_COLOR, ByRef riid As TGUID, ByRef ppvRet As IPicture) As LongPtr