窗口创建完成后我就用GDI画个背景和一些字上去,调试的时候销毁窗口连VB6也一起关了,搞了两天还找不到原因,只知道窗口关闭后,释放GDI+对象,虽然返回值=0,但是对象还在,不知道为什么
我把不停的画字的那倒计时子程序删了以后,销毁窗口就正常了.没分了,请好心的大神帮忙解答下
程序代码：Public Sub 创建窗口()
Dim wMsg As Msg
Dim ResData() As Byte, Stream As Object
If Img Then GdipDisposeImage Img
ResData = LoadResData(102, "CUSTOM")
CreateStreamOnHGlobal ResData(0), False, Stream
GdipLoadImageFromStream Stream, Img
Set Stream = Nothing
GdipGetImageHeight Img, PngHeight
GdipGetImageWidth Img, PngWidth
ghWith = (Screen.Width / Screen.TwipsPerPixelX) - PngWidth - 1
gHeight = (Screen.Height / Screen.TwipsPerPixelY) - GetTaskbarHeight - PngHeight
DeskWin = FindWindowEx(0&, 0&, "Progman", vbNullString)
DeskWin = FindWindowEx(DeskWin, 0&, "SHELLDLL_DefView", vbNullString)
DeskWin = FindWindowEx(DeskWin, 0&, "SysListView32", vbNullString)
If RegisterWindowClass = False Then
gHwnd = FindWindow(gClassName, gAppName)
If gHwnd > 0 Then
MoveWindow gHwnd, ghWith, gHeight, PngWidth, PngHeight, False
Delay 100
Call 画图
Do While 倒计时() = False
Delay 100
Loop
End If
Else
If CreateWindows Then
Call 画图
Do While GetMessage(wMsg, 0&, 0&, 0&)
Delay 0
Call TranslateMessage(wMsg)
Call DispatchMessage(wMsg)
If 倒计时() Then
Exit Do
End If
Loop
End If
End If
Debug.Print UnregisterClass(gClassName$, 0&)
释放内存
If IsIDE() = False Then DestroyWindow gHwnd&
End Sub
'注册窗口类
Public Function RegisterWindowClass() As Boolean
Dim wc As WNDCLASS
nowTime = Now
With wc
.style = CS_HREDRAW Or CS_VREDRAW
.lpfnwndproc = GetAddress(AddressOf WndProc)
.hInstance = GetModuleHandle(vbNullString)
.hIcon = LoadIconByNum(0&, IDI_APPLICATION)
.hCursor = LoadCursorByNum(0&, IDC_ARROW)
.hbrBackground = COLOR_WINDOW
.lpszClassName = gClassName$
.lpszMenuName = vbNullString
.cbClsextra = 0&
.cbWndExtra2 = 0&
End With
RegisterWindowClass = RegisterClass(wc) <> 0
End Function
'创建窗体以及子类化操作
Public Function CreateWindows() As Boolean 'WS_EX_TOOLWINDOW WS_DLGFRAME WS_POPUP Or WS_VISIBLE
gHwnd& = CreateWindowEx(WS_EX_TOOLWINDOW, gClassName$, gAppName$, _
WS_OVERLAPPEDWINDOW, ghWith, gHeight, PngWidth, PngHeight, DeskWin, 0&, GetModuleHandle(vbNullString), ByVal 0&)
' gHwnd = CreateWindowEx(&H10&, gClassName$, gAppName$, &HCF0000, ghWith, gHeight, PngWidth, PngHeight, 0&, 0&, GetModuleHandle(vbNullString), ByVal 0&)
Call ShowWindowAsync(gHwnd&, SW_SHOWNORMAL)
SetWindowPos gHwnd, HWND_TOPMOST, 0, 0, 0, 0, SWP_NOMOVE Or SWP_NOSIZE
Call UpdateWindow(gHwnd)
CreateWindows = (gHwnd& <> 0)
End Function
Private Sub 释放内存()
With blendFunc32bpp
.AlphaFormat = AC_SRC_ALPHA
.BlendFlags = 0
.BlendOp = AC_SRC_OVER
.SourceConstantAlpha = 0
End With
UpdateLayeredWindow gHwnd, hdc, ByVal 0&, WinSize, mDC, SrcPoint, 0, blendFunc32bpp, ULW_ALPHA
If m_Pen Then Call GdipDeletePen(m_Pen)
If m_Brush Then Call GdipDeleteBrush(m_Brush)
If FontFam Then Call GdipDeleteFontFamily(FontFam)
If CurFont Then Call GdipDeleteFont(CurFont)
If StrFormat Then Call GdipDeleteFont(StrFormat)
If Img Then Call GdipDisposeImage(Img)
If Graphics Then Call GdipDeleteGraphics(Graphics)
Call SelectObject(mDC, OldBitmap)
Call DeleteObject(MainBitmap)
Call DeleteObject(OldBitmap)
Call DeleteDC(mDC)
Call ReleaseDC(gHwnd, hdc)
End Sub
'窗体的消息处理函数，该函数在窗体注册时指定的
Public Function WndProc(ByVal hWnd As Long, ByVal uMsg As Long, _
ByVal wParam As Long, ByVal lParam As Long) As Long
Select Case uMsg&
Case WM_PRINT
Case WM_CREATE
Case WM_DESTROY
Call PostQuitMessage(0&)
Case WM_QUIT
Case WM_CLOSE
DestroyWindow gHwnd&
Case WM_LBUTTONUP, WM_RBUTTONUP
DestroyWindow gHwnd&
End Select
WndProc = DefWindowProc(hWnd&, uMsg&, wParam&, lParam&)
End Function
Public Function GetAddress(ByVal lngAddr As Long) As Long
GetAddress = lngAddr&
End Function
Private Function 倒计时() As Boolean
倒计时 = False
If IsDate(nowTime) Then
t = DateDiff("s", Now, DateAdd("s", 3, nowTime))
days = Int(t / 86400)
t = t Mod 86400
hours = Int(t / 3600)
t = t Mod 3600
Minutes = Int(t / 60)
t = t Mod 60
If t >= 0 Then
DrawGdiPlusString "本窗口将在：" & Right$("0" & CStr(t), 2) + "秒后关闭"
Call PostMessage(gHwnd&, WM_LBUTTONDOWN, 0, ByVal MAKELPARAM(10, 10))
Else
Call PostMessage(gHwnd&, WM_LBUTTONUP, 0, ByVal MAKELPARAM(10, 10))
倒计时 = True
End If
End If
End Function
Private Sub 画图()
Dim CurWinLong As Long
Dim TempBI As BITMAPINFO
With TempBI.bmiHeader
.biSize = Len(TempBI.bmiHeader)
.biBitCount = 32
.biHeight = PngHeight
.biWidth = PngWidth
.biPlanes = 1
.biSizeImage = .biWidth * .biHeight * (.biBitCount / 8)
End With
hdc = GetDC(gHwnd)
mDC = CreateCompatibleDC(hdc)
MainBitmap = CreateDIBSection(mDC, TempBI, DIB_RGB_COLORS, ByVal 0, 0, 0)
OldBitmap = SelectObject(mDC, MainBitmap)
GdipCreateFromHDC mDC, Graphics
If Graphics = 0 Then 释放内存: Exit Sub
CurWinLong = GetWindowLong(gHwnd, GWL_EXSTYLE)
SetWindowLong gHwnd, GWL_EXSTYLE, CurWinLong Or WS_EX_LAYERED
SrcPoint.x = 0
SrcPoint.y = 0
WinSize.cx = PngWidth
WinSize.cy = PngHeight
GdipCreatePen1 MakeARGB(vbBlack, 170), 2, UnitPixel, m_Pen
GdipCreateSolidFill MakeARGB(vbCyan, 120), m_Brush
GdipCreateFontFamilyFromName "微软雅黑", 0, FontFam
GdipCreateFont FontFam, 20, FontStyleBold, UnitPoint, CurFont
GdipCreateStringFormat 0, 0, StrFormat
GdipSetStringFormatAlign StrFormat, StringAlignmentNear
GdipDrawImageRect Graphics, Img, 0, 0, PngWidth, PngHeight
With blendFunc32bpp
.AlphaFormat = AC_SRC_ALPHA
.BlendFlags = 0
.BlendOp = AC_SRC_OVER
.SourceConstantAlpha = 255
End With
UpdateLayeredWindow gHwnd, hdc, ByVal 0&, WinSize, mDC, SrcPoint, 0, blendFunc32bpp, ULW_ALPHA 'Or ULW_OPAQUE
DrawGdiPlusString "本窗口将在：15秒后关闭"
nowTime = Now
' ReleaseDC gHwnd, hdc
Debug.Print m_Pen, m_Brush, FontFam, CurFont, hdc, mDC
End Sub
Private Sub DrawGdiString()
With rcLayout
.Top = 2
.Left = 5
.Width = PngWidth
.Height = PngHeight / 5
End With
Call GdipAddPathString(Path, "信息提示窗口 BY QQ:82850696", -1, FontFam, 1, 15, rcLayout, StrFormat)
End Sub
Private Sub DrawGdiString2()
With rcLayout
.Top = 50
.Left = 5
.Width = PngWidth
.Height = PngHeight - 50
End With
Call GdipAddPathString(Path, 局_文本, -1, FontFam, 1, 15, rcLayout, StrFormat)
End Sub
Private Sub DrawGdiString3()
' GdipCreatePen1 MakeARGB(vbMagenta, 170), 2, UnitPixel, m_Pen
' GdipCreateSolidFill MakeARGB(vbGreen, 100), m_Brush
With rcLayout
.Top = 220
.Left = 330
.Width = PngWidth
.Height = PngHeight / 5
End With
Call GdipAddPathString(Path, "阿牛工作室 出品", -1, FontFam, 1, 20, rcLayout, StrFormat)
End Sub
Private Sub DrawGdiPlusString(ByVal DrawStr As String)
On Error Resume Next
GdipCreatePath FillModeWinding, Path
GdipGraphicsClear Graphics, &H0
GdipDrawImageRect Graphics, Img, 0, 0, PngWidth, PngHeight
GdipSetTextRenderingHint Graphics, TextRenderingHintClearTypeGridFit '6.绘制图形
Call DrawGdiString
Call DrawGdiString2
Call DrawGdiString3
With rcLayout
.Width = PngWidth
.Height = PngHeight / 5
.Left = 5
.Top = 220
End With
Call GdipAddPathString(Path, DrawStr, -1, FontFam, 1, 16, rcLayout, StrFormat)
GdipSetSmoothingMode Graphics, SmoothingModeAntiAlias
GdipDrawPath Graphics, m_Pen, Path
GdipFillPath Graphics, m_Brush, Path
GdipDeletePath Path
UpdateLayeredWindow gHwnd, hdc, ByVal 0&, WinSize, mDC, SrcPoint, 0, blendFunc32bpp, ULW_ALPHA
DoEvents
End Sub
Private Function ColorARGB(ByVal alpha As Byte, ByVal red As Byte, ByVal green As Byte, ByVal blue As Byte) As Long
Dim bytestruct As COLORBYTES
Dim Result As COLORLONG
With bytestruct
.AlphaByte = alpha
.RedByte = red
.GreenByte = green
.BlueByte = blue
End With
LSet Result = bytestruct
ColorARGB = Result.longval
End Function
Private Function MakeARGB(ByVal lColor As Long, Optional ByVal alpha As Byte = 255) As Long
Dim rgbq As RGBQUAD
CopyMemory rgbq, lColor, 4
MakeARGB = ColorARGB(alpha, rgbq.rgbBlue, rgbq.rgbGreen, rgbq.rgbRed)
End Function
Dim wMsg As Msg
Dim ResData() As Byte, Stream As Object
If Img Then GdipDisposeImage Img
ResData = LoadResData(102, "CUSTOM")
CreateStreamOnHGlobal ResData(0), False, Stream
GdipLoadImageFromStream Stream, Img
Set Stream = Nothing
GdipGetImageHeight Img, PngHeight
GdipGetImageWidth Img, PngWidth
ghWith = (Screen.Width / Screen.TwipsPerPixelX) - PngWidth - 1
gHeight = (Screen.Height / Screen.TwipsPerPixelY) - GetTaskbarHeight - PngHeight
DeskWin = FindWindowEx(0&, 0&, "Progman", vbNullString)
DeskWin = FindWindowEx(DeskWin, 0&, "SHELLDLL_DefView", vbNullString)
DeskWin = FindWindowEx(DeskWin, 0&, "SysListView32", vbNullString)
If RegisterWindowClass = False Then
gHwnd = FindWindow(gClassName, gAppName)
If gHwnd > 0 Then
MoveWindow gHwnd, ghWith, gHeight, PngWidth, PngHeight, False
Delay 100
Call 画图
Do While 倒计时() = False
Delay 100
Loop
End If
Else
If CreateWindows Then
Call 画图
Do While GetMessage(wMsg, 0&, 0&, 0&)
Delay 0
Call TranslateMessage(wMsg)
Call DispatchMessage(wMsg)
If 倒计时() Then
Exit Do
End If
Loop
End If
End If
Debug.Print UnregisterClass(gClassName$, 0&)
释放内存
If IsIDE() = False Then DestroyWindow gHwnd&
End Sub
'注册窗口类
Public Function RegisterWindowClass() As Boolean
Dim wc As WNDCLASS
nowTime = Now
With wc
.style = CS_HREDRAW Or CS_VREDRAW
.lpfnwndproc = GetAddress(AddressOf WndProc)
.hInstance = GetModuleHandle(vbNullString)
.hIcon = LoadIconByNum(0&, IDI_APPLICATION)
.hCursor = LoadCursorByNum(0&, IDC_ARROW)
.hbrBackground = COLOR_WINDOW
.lpszClassName = gClassName$
.lpszMenuName = vbNullString
.cbClsextra = 0&
.cbWndExtra2 = 0&
End With
RegisterWindowClass = RegisterClass(wc) <> 0
End Function
'创建窗体以及子类化操作
Public Function CreateWindows() As Boolean 'WS_EX_TOOLWINDOW WS_DLGFRAME WS_POPUP Or WS_VISIBLE
gHwnd& = CreateWindowEx(WS_EX_TOOLWINDOW, gClassName$, gAppName$, _
WS_OVERLAPPEDWINDOW, ghWith, gHeight, PngWidth, PngHeight, DeskWin, 0&, GetModuleHandle(vbNullString), ByVal 0&)
' gHwnd = CreateWindowEx(&H10&, gClassName$, gAppName$, &HCF0000, ghWith, gHeight, PngWidth, PngHeight, 0&, 0&, GetModuleHandle(vbNullString), ByVal 0&)
Call ShowWindowAsync(gHwnd&, SW_SHOWNORMAL)
SetWindowPos gHwnd, HWND_TOPMOST, 0, 0, 0, 0, SWP_NOMOVE Or SWP_NOSIZE
Call UpdateWindow(gHwnd)
CreateWindows = (gHwnd& <> 0)
End Function
Private Sub 释放内存()
With blendFunc32bpp
.AlphaFormat = AC_SRC_ALPHA
.BlendFlags = 0
.BlendOp = AC_SRC_OVER
.SourceConstantAlpha = 0
End With
UpdateLayeredWindow gHwnd, hdc, ByVal 0&, WinSize, mDC, SrcPoint, 0, blendFunc32bpp, ULW_ALPHA
If m_Pen Then Call GdipDeletePen(m_Pen)
If m_Brush Then Call GdipDeleteBrush(m_Brush)
If FontFam Then Call GdipDeleteFontFamily(FontFam)
If CurFont Then Call GdipDeleteFont(CurFont)
If StrFormat Then Call GdipDeleteFont(StrFormat)
If Img Then Call GdipDisposeImage(Img)
If Graphics Then Call GdipDeleteGraphics(Graphics)
Call SelectObject(mDC, OldBitmap)
Call DeleteObject(MainBitmap)
Call DeleteObject(OldBitmap)
Call DeleteDC(mDC)
Call ReleaseDC(gHwnd, hdc)
End Sub
'窗体的消息处理函数，该函数在窗体注册时指定的
Public Function WndProc(ByVal hWnd As Long, ByVal uMsg As Long, _
ByVal wParam As Long, ByVal lParam As Long) As Long
Select Case uMsg&
Case WM_PRINT
Case WM_CREATE
Case WM_DESTROY
Call PostQuitMessage(0&)
Case WM_QUIT
Case WM_CLOSE
DestroyWindow gHwnd&
Case WM_LBUTTONUP, WM_RBUTTONUP
DestroyWindow gHwnd&
End Select
WndProc = DefWindowProc(hWnd&, uMsg&, wParam&, lParam&)
End Function
Public Function GetAddress(ByVal lngAddr As Long) As Long
GetAddress = lngAddr&
End Function
Private Function 倒计时() As Boolean
倒计时 = False
If IsDate(nowTime) Then
t = DateDiff("s", Now, DateAdd("s", 3, nowTime))
days = Int(t / 86400)
t = t Mod 86400
hours = Int(t / 3600)
t = t Mod 3600
Minutes = Int(t / 60)
t = t Mod 60
If t >= 0 Then
DrawGdiPlusString "本窗口将在：" & Right$("0" & CStr(t), 2) + "秒后关闭"
Call PostMessage(gHwnd&, WM_LBUTTONDOWN, 0, ByVal MAKELPARAM(10, 10))
Else
Call PostMessage(gHwnd&, WM_LBUTTONUP, 0, ByVal MAKELPARAM(10, 10))
倒计时 = True
End If
End If
End Function
Private Sub 画图()
Dim CurWinLong As Long
Dim TempBI As BITMAPINFO
With TempBI.bmiHeader
.biSize = Len(TempBI.bmiHeader)
.biBitCount = 32
.biHeight = PngHeight
.biWidth = PngWidth
.biPlanes = 1
.biSizeImage = .biWidth * .biHeight * (.biBitCount / 8)
End With
hdc = GetDC(gHwnd)
mDC = CreateCompatibleDC(hdc)
MainBitmap = CreateDIBSection(mDC, TempBI, DIB_RGB_COLORS, ByVal 0, 0, 0)
OldBitmap = SelectObject(mDC, MainBitmap)
GdipCreateFromHDC mDC, Graphics
If Graphics = 0 Then 释放内存: Exit Sub
CurWinLong = GetWindowLong(gHwnd, GWL_EXSTYLE)
SetWindowLong gHwnd, GWL_EXSTYLE, CurWinLong Or WS_EX_LAYERED
SrcPoint.x = 0
SrcPoint.y = 0
WinSize.cx = PngWidth
WinSize.cy = PngHeight
GdipCreatePen1 MakeARGB(vbBlack, 170), 2, UnitPixel, m_Pen
GdipCreateSolidFill MakeARGB(vbCyan, 120), m_Brush
GdipCreateFontFamilyFromName "微软雅黑", 0, FontFam
GdipCreateFont FontFam, 20, FontStyleBold, UnitPoint, CurFont
GdipCreateStringFormat 0, 0, StrFormat
GdipSetStringFormatAlign StrFormat, StringAlignmentNear
GdipDrawImageRect Graphics, Img, 0, 0, PngWidth, PngHeight
With blendFunc32bpp
.AlphaFormat = AC_SRC_ALPHA
.BlendFlags = 0
.BlendOp = AC_SRC_OVER
.SourceConstantAlpha = 255
End With
UpdateLayeredWindow gHwnd, hdc, ByVal 0&, WinSize, mDC, SrcPoint, 0, blendFunc32bpp, ULW_ALPHA 'Or ULW_OPAQUE
DrawGdiPlusString "本窗口将在：15秒后关闭"
nowTime = Now
' ReleaseDC gHwnd, hdc
Debug.Print m_Pen, m_Brush, FontFam, CurFont, hdc, mDC
End Sub
Private Sub DrawGdiString()
With rcLayout
.Top = 2
.Left = 5
.Width = PngWidth
.Height = PngHeight / 5
End With
Call GdipAddPathString(Path, "信息提示窗口 BY QQ:82850696", -1, FontFam, 1, 15, rcLayout, StrFormat)
End Sub
Private Sub DrawGdiString2()
With rcLayout
.Top = 50
.Left = 5
.Width = PngWidth
.Height = PngHeight - 50
End With
Call GdipAddPathString(Path, 局_文本, -1, FontFam, 1, 15, rcLayout, StrFormat)
End Sub
Private Sub DrawGdiString3()
' GdipCreatePen1 MakeARGB(vbMagenta, 170), 2, UnitPixel, m_Pen
' GdipCreateSolidFill MakeARGB(vbGreen, 100), m_Brush
With rcLayout
.Top = 220
.Left = 330
.Width = PngWidth
.Height = PngHeight / 5
End With
Call GdipAddPathString(Path, "阿牛工作室 出品", -1, FontFam, 1, 20, rcLayout, StrFormat)
End Sub
Private Sub DrawGdiPlusString(ByVal DrawStr As String)
On Error Resume Next
GdipCreatePath FillModeWinding, Path
GdipGraphicsClear Graphics, &H0
GdipDrawImageRect Graphics, Img, 0, 0, PngWidth, PngHeight
GdipSetTextRenderingHint Graphics, TextRenderingHintClearTypeGridFit '6.绘制图形
Call DrawGdiString
Call DrawGdiString2
Call DrawGdiString3
With rcLayout
.Width = PngWidth
.Height = PngHeight / 5
.Left = 5
.Top = 220
End With
Call GdipAddPathString(Path, DrawStr, -1, FontFam, 1, 16, rcLayout, StrFormat)
GdipSetSmoothingMode Graphics, SmoothingModeAntiAlias
GdipDrawPath Graphics, m_Pen, Path
GdipFillPath Graphics, m_Brush, Path
GdipDeletePath Path
UpdateLayeredWindow gHwnd, hdc, ByVal 0&, WinSize, mDC, SrcPoint, 0, blendFunc32bpp, ULW_ALPHA
DoEvents
End Sub
Private Function ColorARGB(ByVal alpha As Byte, ByVal red As Byte, ByVal green As Byte, ByVal blue As Byte) As Long
Dim bytestruct As COLORBYTES
Dim Result As COLORLONG
With bytestruct
.AlphaByte = alpha
.RedByte = red
.GreenByte = green
.BlueByte = blue
End With
LSet Result = bytestruct
ColorARGB = Result.longval
End Function
Private Function MakeARGB(ByVal lColor As Long, Optional ByVal alpha As Byte = 255) As Long
Dim rgbq As RGBQUAD
CopyMemory rgbq, lColor, 4
MakeARGB = ColorARGB(alpha, rgbq.rgbBlue, rgbq.rgbGreen, rgbq.rgbRed)
End Function