VBA生成的二维码图片如何把他放在USERFORM上

大氵寿

QRCODE_test.zip (109.42 KB, 下载次数: 36)

2023-4-26 11:39 上传

点击文件名下载附件

我在EXCEL里用VBA生成了一个二维码图片, 但是我希望吧这个二维码图片放在USERFORM上,
我尝试用 userform1.image 去粘贴发现无法执行.
这个应该怎么改?

opiona

https://club.excelhome.net/thread-1535960-1-1.html

梧叶沙沙

loadpicture

大氵寿

梧叶沙沙 发表于 2023-4-26 15:14
loadpicture

多谢, loadpicture 是针对物理存在一个图片文件进行导入.
能否直接从内存里把他粘贴上去.

大氵寿

opiona 发表于 2023-4-26 15:10
https://club.excelhome.net/thread-1535960-1-1.html

多谢, 学习一下..但是我想把图片从剪切板放入用户窗体..

tspliu

大氵寿 发表于 2023-4-26 16:31
多谢, 学习一下..但是我想把图片从剪切板放入用户窗体..

对图片数据结构进行了解，然后利用windowsAPI去绘制或许能实现
如果打算用LoadPicture方法是不支持的。还是建议保存一下，再load。

opiona

大氵寿 发表于 2023-4-26 16:31
多谢, 学习一下..但是我想把图片从剪切板放入用户窗体..

先将剪切板内的图片 导出为图片文件
再将文件读取到image



下面是将剪切板图片 保存为文件的函数

1. 
   
2. '''Sub test()
   
3. '''    Select Case ClipboardToJPG("c:\test.jpg")
   
4. '''        Case 0:
   
5. '''            MsgBox "剪贴板图片已保存"
   
6. '''        Case 1:
   
7. '''            MsgBox "剪贴板图片保存失败"
   
8. '''        Case 2:
   
9. '''            MsgBox "剪贴板中无图片"
   
10. '''        Case 3:
    
11. '''            MsgBox "剪贴板无法打开，可能被其他程序所占用"
    
12. '''        Case 4:
    
13. '''            MsgBox "GDI+错误"
    
14. '''    End Select
    
15. '''End Sub
    
16. 
    
17. Option Explicit
    
18. Private Type GUID
    
19.     Data1 As Long
    
20.     Data2 As Integer
    
21.     Data3 As Integer
    
22.     Data4(0 To 7) As Byte
    
23. End Type
    
24. 
    
25. #If VBA7 And Win64 Then
    
26.     Private Declare PtrSafe Function OpenClipboard Lib "user32" (ByVal hwnd As LongPtr) As Long
    
27.     Private Declare PtrSafe Function CloseClipboard Lib "user32" () As Long
    
28.     Private Declare PtrSafe Function GetClipboardData Lib "user32" (ByVal wFormat As Long) As Long
    
29.     Private Declare PtrSafe Function GdiplusStartup Lib "GDIPlus" (token As LongPtr, inputbuf As GdiplusStartupInput, ByVal outputbuf As LongPtr) As LongPtr
    
30.     Private Declare PtrSafe Function GdiplusShutdown Lib "GDIPlus" (ByVal token As LongPtr) As LongPtr
    
31.     Private Declare PtrSafe Function GdipDisposeImage Lib "GDIPlus" (ByVal Image As LongPtr) As LongPtr
    
32.     Private Declare PtrSafe Function GdipSaveImageToFile Lib "GDIPlus" (ByVal Image As LongPtr, ByVal filename As LongPtr, clsidEncoder As GUID, encoderParams As Any) As LongPtr
    
33.     Private Declare PtrSafe Function CLSIDFromString Lib "ole32" (ByVal str As LongPtr, id As GUID) As LongPtr
    
34.     Private Declare PtrSafe Function GdipCreateBitmapFromHBITMAP Lib "GDIPlus" (ByVal hbm As LongPtr, ByVal hPal As LongPtr, BITMAP As LongPtr) As LongPtr
    
35.     Private Type EncoderParameter
    
36.         GUID As GUID
    
37.         NumberOfValues As Long
    
38.         type As Long
    
39.         Value As LongPtr
    
40.     End Type
    
41.     Private Type GdiplusStartupInput
    
42.         GdiplusVersion As Long
    
43.         DebugEventCallback As LongPtr
    
44.         SuppressBackgroundThread As Long
    
45.         SuppressExternalCodecs As Long
    
46.     End Type
    
47. #Else
    
48.     Private Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
    
49.     Private Declare Function CloseClipboard Lib "user32" () As Long
    
50.     Private Declare Function GetClipboardData Lib "user32" (ByVal wFormat As Long) As Long
    
51.     Private Declare Function GdiplusStartup Lib "GDIPlus" (token As Long, inputbuf As GdiplusStartupInput, ByVal outputbuf As Long) As Long
    
52.     Private Declare Function GdiplusShutdown Lib "GDIPlus" (ByVal token As Long) As Long
    
53.     Private Declare Function GdipDisposeImage Lib "GDIPlus" (ByVal Image As Long) As Long
    
54.     Private Declare Function GdipSaveImageToFile Lib "GDIPlus" (ByVal Image As Long, ByVal filename As Long, clsidEncoder As GUID, encoderParams As Any) As Long
    
55.     Private Declare Function CLSIDFromString Lib "ole32" (ByVal str As Long, id As GUID) As Long
    
56.     Private Declare Function GdipCreateBitmapFromHBITMAP Lib "GDIPlus" (ByVal hbm As Long, ByVal hPal As Long, BITMAP As Long) As Long
    
57.     Private Type EncoderParameter
    
58.         GUID As GUID
    
59.         NumberOfValues As Long
    
60.         type As Long
    
61.         Value As Long
    
62.     End Type
    
63.     Private Type GdiplusStartupInput
    
64.         GdiplusVersion As Long
    
65.         DebugEventCallback As Long
    
66.         SuppressBackgroundThread As Long
    
67.         SuppressExternalCodecs As Long
    
68.     End Type
    
69. #End If
    
70. 
    
71. Private Const CF_BITMAP = 2
    
72. Private Type EncoderParameters
    
73.     Count As Long
    
74.     Parameter As EncoderParameter
    
75. End Type
    
76. 
    
77. Public Function ClipboardToJPG(ByVal destfilename As String, Optional ByVal quality As Byte = 100) As Integer
    
78.     Rem  该函数用于取出剪贴板中图片转换为jpg文件另存到指定路径****
    
79.     Rem  参数说明：
    
80.     Rem      destfilename:要保存的jpg文件的完整路径，必要参数；
    
81.     Rem      quality: jpg文件的质量，0-100之间的数值，数值越大，图片质量越高
    
82.     Rem      返回值：
    
83.     Rem      0-保存成功；1-保存失败；2-剪贴板中无位图数据；3-无法打开剪贴板
    
84.     Dim tSI As GdiplusStartupInput
    
85.    
    
86.     #If VBA7 Then
    
87.         Dim lRes As LongPtr
    
88.         Dim lGDIP As LongPtr
    
89.         Dim lBitmap As LongPtr
    
90.         Dim hBmp As LongPtr
    
91.     #Else
    
92.         Dim lRes As Long
    
93.         Dim lGDIP As Long
    
94.         Dim lBitmap As Long
    
95.         Dim hBmp As Long
    
96.     #End If
    
97.    
    
98.     Rem  尝试打开剪贴板
    
99.     If OpenClipboard(0) Then
    
100.         Rem  尝试取出剪贴板中位图的句柄
     
101.         hBmp = GetClipboardData(CF_BITMAP)
     
102.         Rem  如果hBmp为0，说明剪贴板中没有存放图片
     
103.         If hBmp = 0 Then
     
104.             ClipboardToJPG = 2
     
105.             CloseClipboard
     
106.             Exit Function
     
107.         End If
     
108.         CloseClipboard
     
109.     Else   '如果openclipboard返回0(False)，说明剪贴板被其他程序所占用
     
110.         ClipboardToJPG = 3
     
111.         Exit Function
     
112.     End If
     
113.     Rem  初始化 GDI+
     
114.     tSI.GdiplusVersion = 1
     
115.     lRes = GdiplusStartup(lGDIP, tSI, 0)
     
116.     If lRes = 0 Then
     
117.         Rem  从句柄创建 GDI+ 图像
     
118.         lRes = GdipCreateBitmapFromHBITMAP(hBmp, 0, lBitmap)
     
119.         If lRes = 0 Then
     
120.             Dim tJpgEncoder As GUID
     
121.             Dim tParams As EncoderParameters
     
122.             Rem  初始化解码器的GUID标识
     
123.             CLSIDFromString StrPtr("{557CF401-1A04-11D3-9A73-0000F81EF32E}"), tJpgEncoder
     
124.             Rem  设置解码器参数
     
125.             tParams.Count = 1
     
126.             With tParams.Parameter ' Quality
     
127.                 Rem  得到Quality参数的GUID标识
     
128.                 CLSIDFromString StrPtr("{1D5BE4B5-FA4A-452D-9CDD-5DB35105E7EB}"), .GUID
     
129.                 .NumberOfValues = 1
     
130.                 .type = 4
     
131.                 .Value = VarPtr(quality)
     
132.             End With
     
133.             Rem  保存图像
     
134.             lRes = GdipSaveImageToFile(lBitmap, StrPtr(destfilename), tJpgEncoder, tParams)
     
135.             If lRes = 0 Then
     
136.                 ClipboardToJPG = 0  '转换成功
     
137.             Else
     
138.                 ClipboardToJPG = 1  '转换失败
     
139.             End If
     
140.             Rem  销毁GDI+图像
     
141.             GdipDisposeImage lBitmap
     
142.         End If
     
143.         Rem  销毁 GDI+
     
144.         GdiplusShutdown lGDIP
     
145.     Else
     
146.         ClipboardToJPG = 4
     
147.     End If
     
148. End Function
     
149. 
     

复制代码

nicleyuan

Public Function ClipboardToJPG(ByVal destfilename As String, Optional ByVal quality As Byte = 80) As Integer
    Rem  该函数用于取出剪贴板中图片转换为jpg文件另存到指定路径****
    Rem  参数说明：
    Rem      destfilename:  要保存的jpg文件的完整路径，必要参数；
    Rem      quality:            jpg文件的质量，0-100之间的数值，数值越大，图片质量越高
    Rem  返回值：  0-保存成功；1-保存失败；2-剪贴板中无位图数据；3-无法打开剪贴板
    Dim tSI As GdiplusStartupInput
   
    #If VBA7 Then
        Dim lRes As LongPtr
        Dim lGDIP As LongPtr
        Dim lBitmap As LongPtr
        Dim hBmp As LongPtr
    #Else
        Dim lRes As Long
        Dim lGDIP As Long
        Dim lBitmap As Long
        Dim hBmp As Long
    #End If
   
    Rem  尝试打开剪贴板
    If OpenClipboard(0) Then
        Rem  尝试取出剪贴板中位图的句柄
        hBmp = GetClipboardData(CF_BITMAP)
        Rem  如果hBmp为0，说明剪贴板中没有存放图片
        If hBmp = 0 Then
            ClipboardToJPG = 2
            CloseClipboard
            Exit Function
        End If
        CloseClipboard
    Else   '如果openclipboard返回0(False)，说明剪贴板被其他程序所占用
        ClipboardToJPG = 3
        Exit Function
    End If
    Rem  初始化 GDI+
    tSI.GdiplusVersion = 1
    lRes = GdiplusStartup(lGDIP, tSI, 0)
    If lRes = 0 Then
        Rem  从句柄创建 GDI+ 图像
        lRes = GdipCreateBitmapFromHBITMAP(hBmp, 0, lBitmap)
        If lRes = 0 Then
            Dim tJpgEncoder As GUID
            Dim tParams As EncoderParameters
            Rem  初始化解码器的GUID标识
            CLSIDFromString StrPtr("{557CF401-1A04-11D3-9A73-0000F81EF32E}"), tJpgEncoder
            Rem  设置解码器参数
            tParams.Count = 1
            With tParams.Parameter ' Quality
                Rem  得到Quality参数的GUID标识
                CLSIDFromString StrPtr("{1D5BE4B5-FA4A-452D-9CDD-5DB35105E7EB}"), .GUID
                .NumberOfValues = 1
                .type = 4
                .Value = VarPtr(quality)
            End With
            Rem  保存图像
            lRes = GdipSaveImageToFile(lBitmap, StrPtr(destfilename), tJpgEncoder, tParams)
            If lRes = 0 Then
                ClipboardToJPG = 0  '转换成功
            Else
                ClipboardToJPG = 1  '转换失败
            End If
            Rem  销毁GDI+图像
            GdipDisposeImage lBitmap
        End If
        Rem  销毁 GDI+
        GdiplusShutdown lGDIP
    Else
        ClipboardToJPG = 4
    End If
End Function

https://club.excelhome.net/thread-1535960-3-1.html

ivccav

其实这是非常简单的问题。把二维码并转为StdPicture对象即可使用，不用保存为文件。

https://club.excelhome.net/thread-1577992-1-1.html



程序文件和示例代码.zip (731.18 KB, 下载次数: 40)

2023-4-26 20:32 上传

点击文件名下载附件

opiona

ivccav 发表于 2023-4-26 20:32
其实这是非常简单的问题。把二维码并转为StdPicture对象即可使用，不用保存为文件。

https://club ...

代码内添加Logo的函数不错
不知道能否改进一下:
  不管Logo图片原来多大
  在函数中直接缩小到二维码的几分之一
  或按比例缩小后放上去

1. Rem 二维码添加logo
   
2. Public Sub QRCodeAddLogo(ByVal QRPath As String, ByVal LogoPath As String, ByVal PathOut As String, Optional ByVal IntZoom As Integer = 3)
   
3.     Rem QRPath      原始图片,二维码图片
   
4.     Rem LogoPath   中心Logo图片文件
   
5.     Rem PathOut     输出图片名称
   
6.     Rem IntZoom     中心Logo占原始图片的比例
   
7.    
   
8.     Dim Logo, IMG As Object
   
9.     Dim IP, FSO As Object
   
10.    
    
11.     Set IMG = CreateObject("WIA.ImageFile")
    
12.     Set Logo = CreateObject("WIA.ImageFile")
    
13.     Set IP = CreateObject("WIA.ImageProcess")
    
14.    
    
15.     IMG.LoadFile QRPath
    
16.     Logo.LoadFile LogoPath
    
17.     Rem 怎样将Logo这个图片进行缩小,以适应二维码图片的大小
    
18.     '''    IP.Filters(1).Properties("Left") = IMG.Width /  IntZoom
    
19.     '''    IP.Filters(1).Properties("Top") = IMG.Height /  IntZoom
    
20.    
    
21.     IP.Filters.Add IP.FilterInfos("Stamp").FilterID
    
22.     Set IP.Filters(1).Properties("ImageFile") = Logo
    
23.     IP.Filters(1).Properties("Left") = (IMG.Width - Logo.Width) / 2
    
24.     IP.Filters(1).Properties("Top") = (IMG.Height - Logo.Height) / 2
    
25.     Set IMG = IP.Apply(IMG)
    
26.     Set FSO = CreateObject("Scripting.FileSystemObject")
    
27.     If FSO.FileExists(PathOut) = True Then
    
28.         Kill PathOut  '//删除文件
    
29.     End If
    
30.    
    
31.     IMG.SaveFile PathOut
    
32. End Sub

复制代码