Question

我刚刚删除了这篇文章，因为它没有提出正确的问题。所以我有一个Tiff，我想加载到UserForm。我希望能够根据用户输入获取tiff文件。但首先我想至少在UserForm中拉一个tiff文件。 Image2 show＆＃34; Nothing＆＃34;。

Image2.Picture = LoadPicture("C:\users\jneely\desktop\NewB Gage Drawings\1LF-35701-BC01T0-20-K1-A.tiff")

Answer 1

我知道这可以将* .PNG图像加载到userform，也可以使用tiff（未经测试）

Option Explicit
Option Private Module

'corrigé en 64 bits par PL le 11-10-15 , 32 bit version is here  http://www.jkp-ads.com/articles/apideclarations.asp


Private Type GUID
Data1 As Long
data2 As Integer
Data3 As Integer
Data4(0 To 7) As Byte
End Type

Private Type PICTDESC
Size As Long
Type As Long
hPic As LongPtr
hPal As LongPtr
End Type

Private Type GdiplusStartupInput
GdiplusVersion As Long
DebugEventCallback As LongPtr
SuppressBackgroundThread As Long
SuppressExternalCodecs As Long
End Type

Private Declare PtrSafe Function GdiplusStartup Lib "GDIPlus" ( _
token As LongPtr, _
inputbuf As GdiplusStartupInput, _
Optional ByVal outputbuf As LongPtr = 0) As LongPtr


Private Declare PtrSafe Function GdipCreateBitmapFromFile Lib "GDIPlus" ( _
ByVal Filename As LongPtr, _
bitmap As LongPtr) As LongPtr

Private Declare PtrSafe Function GdipCreateHBITMAPFromBitmap Lib "GDIPlus" ( _
ByVal bitmap As LongPtr, _
hbmReturn As LongPtr, ByVal background As Long) As LongPtr

Private Declare PtrSafe Function GdipDisposeImage Lib "GDIPlus" (ByVal image As LongPtr) As LongPtr


Private Declare PtrSafe Function GdiplusShutdown Lib "GDIPlus" (ByVal token As LongPtr) As LongPtr


Private Declare PtrSafe Function OleCreatePictureIndirect Lib "oleaut32.dll" (PicDesc As PICTDESC, RefIID As GUID, ByVal fPictureOwnsHandle As LongPtr, IPic As IPicture) As LongPtr

Public Function LoadImage(ByVal strFName As String) As IPicture 'image en *.PNG
Dim uGdiInput As GdiplusStartupInput
Dim hGdiPlus As LongPtr
Dim hGdiImage As LongPtr
Dim hBitmap As LongPtr

uGdiInput.GdiplusVersion = 1

If GdiplusStartup(hGdiPlus, uGdiInput) = 0 Then
    If GdipCreateBitmapFromFile(StrPtr(strFName), hGdiImage) = 0 Then
        GdipCreateHBITMAPFromBitmap hGdiImage, hBitmap, 0
        Set LoadImage = ConvertToIPicture(hBitmap)
        GdipDisposeImage hGdiImage
    End If
        GdiplusShutdown hGdiPlus
End If
End Function

Public Function ConvertToIPicture(ByVal hPic As LongPtr) As IPicture
Dim uPicInfo As PICTDESC
Dim IID_IDispatch As GUID
Dim IPic As IPicture

Const PICTYPE_BITMAP = 1

With IID_IDispatch
    .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

With uPicInfo
    .Size = Len(uPicInfo)
    .Type = PICTYPE_BITMAP
    .hPic = hPic
    .hPal = 0
End With

OleCreatePictureIndirect uPicInfo, IID_IDispatch, True, IPic

Set ConvertToIPicture = IPic
End Function

像这样使用Image2.Picture = LoadImage("C:\users\jneely\desktop\NewB Gage Drawings\1LF-35701-BC01T0-20-K1-A.tiff")

UserForm中的Laodpicture

1 个答案: