VB6中使用CreatePen修改GDI画笔绘制直线失效问题求助

问题原因 #

1. 单位不匹配：VB6控件默认使用Twips单位，但GDI函数（如CreateCompatibleBitmap、MoveToEx）要求像素单位，导致内存位图尺寸错误、绘制坐标偏离可视区域。
2. 未初始化内存位图：CreateCompatibleBitmap创建的位图是未初始化的，背景非黑色，叠加后直线被掩盖。
3. 宽度为0的画笔兼容性：部分GDI环境下，宽度为0的画笔（cosmetic pen）可能无法正确渲染。

解决步骤 #

• 将控件的Twips单位转换为像素单位，用于GDI函数的尺寸和坐标参数。
• 手动填充内存DC的黑色背景，确保直线可见。
• 将画笔宽度改为1（避免宽度0的兼容性问题）。
• 规范GDI对象的清理流程，防止资源泄漏。

修正后的代码 #

' 先在模块或窗体顶部定义所需常量
Private Const PS_SOLID As Long = 0
Private Const PATCOPY As Long = &HF00021

Private Type POINTAPI
    X As Long
    Y As Long
End Type

' 声明GDI函数（如果未在模块中声明）
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 CreatePen Lib "gdi32" (ByVal nPenStyle As Long, ByVal nWidth As Long, ByVal crColor As Long) As Long
Private Declare Function MoveToEx Lib "gdi32" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long, lpPoint As POINTAPI) As Long
Private Declare Function LineTo Lib "gdi32" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject 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 DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function CreateSolidBrush Lib "gdi32" (ByVal crColor As Long) As Long
Private Declare Function PatBlt Lib "gdi32" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal dwRop As Long) As Long

Private Sub Picture1_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
    Dim lMemoryDC As Long, lMemBitMap As Long, lOrigBitmap As Long
    Dim lPointAPI As POINTAPI
    Dim lPen As Long, lOldPen As Long
    Dim pixWidth As Long, pixHeight As Long
    Dim xPix As Long, yPix As Long
    Dim hBlackBrush As Long, hOldBrush As Long
    
    Picture1.AutoRedraw = True
    
    ' 将Twips单位转换为像素单位
    pixWidth = Picture1.ScaleX(Picture1.ScaleWidth, vbTwips, vbPixels)
    pixHeight = Picture1.ScaleY(Picture1.ScaleHeight, vbTwips, vbPixels)
    xPix = Picture1.ScaleX(X, vbTwips, vbPixels)
    yPix = Picture1.ScaleY(Y, vbTwips, vbPixels)
    
    ' 创建兼容DC和位图
    lMemoryDC = CreateCompatibleDC(Picture1.hdc)
    lMemBitMap = CreateCompatibleBitmap(Picture1.hdc, pixWidth, pixHeight)
    lOrigBitmap = SelectObject(lMemoryDC, lMemBitMap)
    
    ' 填充内存DC为黑色背景
    hBlackBrush = CreateSolidBrush(RGB(0, 0, 0))
    hOldBrush = SelectObject(lMemoryDC, hBlackBrush)
    PatBlt lMemoryDC, 0, 0, pixWidth, pixHeight, PATCOPY
    SelectObject lMemoryDC, hOldBrush
    DeleteObject hBlackBrush
    
    ' 创建绿色实线画笔（宽度1）
    lPen = CreatePen(PS_SOLID, 1, RGB(0, 250, 0))
    lOldPen = SelectObject(lMemoryDC, lPen)
    
    ' 绘制十字线（使用像素坐标）
    MoveToEx lMemoryDC, xPix - 100, yPix, lPointAPI
    LineTo lMemoryDC, xPix + 100, yPix
    
    MoveToEx lMemoryDC, xPix, yPix - 100, lPointAPI
    LineTo lMemoryDC, xPix, yPix + 100
    
    ' 恢复并清理画笔
    SelectObject lMemoryDC, lOldPen
    DeleteObject lPen
    
    ' 将内存DC内容绘制到Picture1
    BitBlt Picture1.hdc, 0, 0, pixWidth, pixHeight, lMemoryDC, 0, 0, vbSrcCopy
    Picture1.Refresh
    
    ' 清理GDI资源
    SelectObject lMemoryDC, lOrigBitmap
    DeleteObject lMemBitMap
    DeleteDC lMemoryDC
End Sub

关键修改说明 #

• 使用ScaleX/ScaleY完成Twips到像素的转换，确保GDI函数使用正确的尺寸和坐标。
• 添加CreateSolidBrush和PatBlt手动填充黑色背景，避免未初始化位图的干扰。
• 将画笔宽度从0改为1，解决兼容性问题。
• 完善GDI对象的清理流程，确保所有对象都正确释放。

内容的提问来源于stack exchange，提问作者Emilio Nakhle Antoun