在感叹deepseek强大的同时,有一点遗憾,程序运行无效果。请懂API的大神给看看哪里错了?
这是deepseek自动生成的一段代码 半透明水印
'Option Explicit
'
'deepseek的半透明水印,无效果,有待查找原因
Option Explicit
' GDI API声明
Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long
Private Declare Function SetBkMode Lib "gdi32" (ByVal hdc As Long, ByVal nBkMode As Long) As Long
Private Declare Function SetTextColor Lib "gdi32" (ByVal hdc As Long, ByVal crColor As Long) As Long
Private Declare Function TextOut Lib "gdi32" Alias "TextOutA" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long, ByVal lpString As String, ByVal nCount As Long) As Long
Private Declare Function AlphaBlend Lib "msimg32.dll" (ByVal hdcDest As Long, ByVal nXOriginDest As Long, ByVal nYOriginDest As Long, ByVal nWidthDest As Long, ByVal nHeightDest As Long, ByVal hdcSrc As Long, ByVal nXOriginSrc As Long, ByVal nYOriginSrc As Long, ByVal nWidthSrc As Long, ByVal nHeightSrc As Long, ByVal BLENDFUNCTION As Long) As Long
' 常量和结构体
Private Const TRANSPARENT = 1
Private Const AC_SRC_OVER = &H0
Private Type BLENDFUNCTION
BlendOp As Byte
BlendFlags As Byte
SourceConstantAlpha As Byte
AlphaFormat As Byte
End Type
Public Sub AddTransparentWatermark( _
ByVal picSource As PictureBox, _
ByVal watermarkText As String, _
ByVal fontSize As Integer, _
ByVal textColor As Long, _
ByVal xPos As Long, _
ByVal yPos As Long, _
Optional ByVal alpha As Byte = 128)
Dim hdcTemp As Long, hBmpTemp As Long, hBmpOld As Long
Dim blendFunc As BLENDFUNCTION
Dim picWidth As Long, picHeight As Long
' 确保以像素为单位计算尺寸
picSource.ScaleMode = vbPixels
picWidth = picSource.ScaleWidth
picHeight = picSource.ScaleHeight
' 创建临时DC和位图(初始为黑色背景)
hdcTemp = CreateCompatibleDC(picSource.hdc)
hBmpTemp = CreateCompatibleBitmap(picSource.hdc, picWidth, picHeight)
hBmpOld = SelectObject(hdcTemp, hBmpTemp)
' 清空临时DC为黑色(后续混合时黑色区域透明)
BitBlt hdcTemp, 0, 0, picWidth, picHeight, 0, 0, 0, vbMergePen
' 在临时DC上绘制透明文本
SetBkMode hdcTemp, TRANSPARENT
SetTextColor hdcTemp, textColor
With picSource.Font
.Name = "Arial"
.Size = fontSize
.Bold = True
End With
TextOut hdcTemp, xPos, yPos, watermarkText, Len(watermarkText)
' 配置混合参数(关键修正点)
blendFunc.BlendOp = AC_SRC_OVER
blendFunc.BlendFlags = 0
blendFunc.SourceConstantAlpha = alpha ' 控制整体透明度
blendFunc.AlphaFormat = 0 ' 必须设为0
' 将水印混合到原始图片
AlphaBlend picSource.hdc, xPos, yPos, picWidth, picHeight, hdcTemp, 0, 0, picWidth, picHeight, VarPtr(blendFunc)
' 清理资源
SelectObject hdcTemp, hBmpOld
DeleteObject hBmpTemp
DeleteDC hdcTemp
picSource.Refresh
End Sub
Private Sub cmdAddWatermark_Click()
' 加载图片
' Picture1.Picture = LoadPicture("C:\test.jpg")
' 添加半透明水印(参数:PictureBox, 文字, 字体大小, 颜色, X, Y, 透明度)
AddTransparentWatermark Picture1, "Confidential", 24, RGB(255, 255, 0), 0, 0, 128
' 保存为BMP(如需JPG/PNG需第三方库)
SavePicture Picture1.Image, "C:\watermarked.bmp"
End Sub
这是deepseek自动生成的一段代码 半透明水印
'Option Explicit
'
'deepseek的半透明水印,无效果,有待查找原因
Option Explicit
' GDI API声明
Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long
Private Declare Function SetBkMode Lib "gdi32" (ByVal hdc As Long, ByVal nBkMode As Long) As Long
Private Declare Function SetTextColor Lib "gdi32" (ByVal hdc As Long, ByVal crColor As Long) As Long
Private Declare Function TextOut Lib "gdi32" Alias "TextOutA" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long, ByVal lpString As String, ByVal nCount As Long) As Long
Private Declare Function AlphaBlend Lib "msimg32.dll" (ByVal hdcDest As Long, ByVal nXOriginDest As Long, ByVal nYOriginDest As Long, ByVal nWidthDest As Long, ByVal nHeightDest As Long, ByVal hdcSrc As Long, ByVal nXOriginSrc As Long, ByVal nYOriginSrc As Long, ByVal nWidthSrc As Long, ByVal nHeightSrc As Long, ByVal BLENDFUNCTION As Long) As Long
' 常量和结构体
Private Const TRANSPARENT = 1
Private Const AC_SRC_OVER = &H0
Private Type BLENDFUNCTION
BlendOp As Byte
BlendFlags As Byte
SourceConstantAlpha As Byte
AlphaFormat As Byte
End Type
Public Sub AddTransparentWatermark( _
ByVal picSource As PictureBox, _
ByVal watermarkText As String, _
ByVal fontSize As Integer, _
ByVal textColor As Long, _
ByVal xPos As Long, _
ByVal yPos As Long, _
Optional ByVal alpha As Byte = 128)
Dim hdcTemp As Long, hBmpTemp As Long, hBmpOld As Long
Dim blendFunc As BLENDFUNCTION
Dim picWidth As Long, picHeight As Long
' 确保以像素为单位计算尺寸
picSource.ScaleMode = vbPixels
picWidth = picSource.ScaleWidth
picHeight = picSource.ScaleHeight
' 创建临时DC和位图(初始为黑色背景)
hdcTemp = CreateCompatibleDC(picSource.hdc)
hBmpTemp = CreateCompatibleBitmap(picSource.hdc, picWidth, picHeight)
hBmpOld = SelectObject(hdcTemp, hBmpTemp)
' 清空临时DC为黑色(后续混合时黑色区域透明)
BitBlt hdcTemp, 0, 0, picWidth, picHeight, 0, 0, 0, vbMergePen
' 在临时DC上绘制透明文本
SetBkMode hdcTemp, TRANSPARENT
SetTextColor hdcTemp, textColor
With picSource.Font
.Name = "Arial"
.Size = fontSize
.Bold = True
End With
TextOut hdcTemp, xPos, yPos, watermarkText, Len(watermarkText)
' 配置混合参数(关键修正点)
blendFunc.BlendOp = AC_SRC_OVER
blendFunc.BlendFlags = 0
blendFunc.SourceConstantAlpha = alpha ' 控制整体透明度
blendFunc.AlphaFormat = 0 ' 必须设为0
' 将水印混合到原始图片
AlphaBlend picSource.hdc, xPos, yPos, picWidth, picHeight, hdcTemp, 0, 0, picWidth, picHeight, VarPtr(blendFunc)
' 清理资源
SelectObject hdcTemp, hBmpOld
DeleteObject hBmpTemp
DeleteDC hdcTemp
picSource.Refresh
End Sub
Private Sub cmdAddWatermark_Click()
' 加载图片
' Picture1.Picture = LoadPicture("C:\test.jpg")
' 添加半透明水印(参数:PictureBox, 文字, 字体大小, 颜色, X, Y, 透明度)
AddTransparentWatermark Picture1, "Confidential", 24, RGB(255, 255, 0), 0, 0, 128
' 保存为BMP(如需JPG/PNG需第三方库)
SavePicture Picture1.Image, "C:\watermarked.bmp"
End Sub