网页中包含Activex控件，网页关闭时出现应用程序错误
vb6做的activex控件，包括两个类模块，只是关闭ie的时候出现错误对话框，错误内容："0xxxxxxxx"指令引用的"0xxxxxxx"内存，该内存不能为"Writtem"
有没有遇见过这种错误的高手
希望高手指点一下，在线等，急 --------------------编程问答-------------------- 控件代码不拿上来,谁会知道啊
你自己做好退出的处理了吗? --------------------编程问答-------------------- 在IE中本来用一个变通的方法解决了，但是换了一个基于IE内核的软件，又出问题了，我觉得是推出没有处理好，现在把代码发上来，请高手协助，在线等，谢谢！！
Option Explicit
Option Base 0
'Reserved space around picturebox
Private Const PictureBoxLeft As Long = 0
Private Const PictureBoxTop As Long = 0
Private Const PictureBoxRight As Long = 0
Private Const PictureBoxBottom As Long = 240 '240 because form has a menu
'Mouse button for grab and drag
Private Const ButtonDrag As Integer = 1 'Left Mouse
Private PaintLeft As Long
Private PaintTop As Long
Private Const TwipsPerPixel As Long = 15 'Is this ever not true?
Private m_Image As New cImage
Private m_Jpeg As cJpeg
Private m_FileName As String
Private sFFolder As String
Private sSName As String
Private sDCode As String
Private sFPath As String
Private Type PALETTEENTRY
peRed As Byte
peGreen As Byte
peBlue As Byte
peFlags As Byte
End Type
Private Type LOGPALETTE
palVersion As Integer
palNumEntries As Integer
palPalEntry(255) As PALETTEENTRY
End Type
Private Type GUID
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(7) As Byte
End Type
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Private Type PicBmp
Size As Long
Type As Long
hBmp As Long
hPal As Long
Reserved As Long
End Type
Private Const RASTERCAPS As Long = 38
Private Const RC_PALETTE As Long = &H100
Private Const SIZEPALETTE As Long = 104
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 GetDeviceCaps Lib "gdi32" (ByVal hDC As Long, ByVal iCapabilitiy As Long) As Long
Private Declare Function GetSystemPaletteEntries Lib "gdi32" (ByVal hDC As Long, _
ByVal wStartIndex As Long, ByVal wNumEntries As Long, lpPaletteEntries As PALETTEENTRY) As Long
Private Declare Function CreatePalette Lib "gdi32" (lpLogPalette As LOGPALETTE) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hDC As Long, ByVal hObject As Long) As Long
Private Declare Function BitBlt Lib "gdi32" (ByVal hdcDest As Long, ByVal XDest As Long, ByVal YDest As Long, ByVal nWidth As Long, ByVal nHeight As Long, _
ByVal hdcSrc 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 GetForegroundWindow Lib "user32" () As Long
Private Declare Function SelectPalette Lib "gdi32" (ByVal hDC As Long, ByVal hPalette _
As Long, ByVal bForceBackground As Long) As Long
Private Declare Function RealizePalette Lib "gdi32" (ByVal hDC As Long) As Long
Private Declare Function GetWindowDC Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hDC As Long) As Long
Private Declare Function GetDesktopWindow Lib "user32" () As Long
Private Declare Function OleCreatePictureIndirect Lib "olepro32.dll" (PicDesc As _
PicBmp, RefIID As GUID, ByVal fPictureOwnsHandle As Long, IPic As IPicture) As Long
Public Event SaveEnd()
Public Event click()
--------------------编程问答--------------------
Public Sub imgopen(fname)
Dim MyPic As StdPicture
Dim FileName As String
FileName = fname
Set MyPic = LoadPicture(FileName)
Picture1.Picture = LoadPicture(FileName)
Set m_Image = New cImage
m_Image.CopyStdPicture MyPic
Set MyPic = Nothing
End Sub
Public Sub imgsave(fname)
Dim FileName As String
FileName = fname
SaveImage m_Image, FileName
Set m_Jpeg = New cJpeg
m_Jpeg.SetSamplingFrequencies 1, 1, 1, 1, 1, 1
m_Jpeg.Quality = 100
m_Jpeg.SampleHDC m_Image.hDC, m_Image.Width, m_Image.Height
m_Jpeg.SaveFile FileName
'Set m_Image = Nothing
'Set m_Jpeg = Nothing
End Sub
Public Sub SaveImage(TheImage As cImage, FileName As String)
Set m_Image = TheImage 'Call this before the form loads to initialize it
m_FileName = FileName
End Sub
Public Sub directsave(leftupX, leftupY, rightdownX, rightdownY)
On Error Resume Next
Dim fs, f, s, shijian, FileName1, p, fn
If Not IsNumeric(leftupX) Or Not IsNumeric(leftupY) Or Not IsNumeric(rightdownX) Or Not IsNumeric(rightdownY) Then
Exit Sub
End If
Set fs = CreateObject("Scripting.FileSystemObject")
shijian = Time
p = FileFolder
If p <> "" Then
If fs.folderexists(p) Then
If Right(p, 1) <> "\" Then
p = p & "\"
End If
Else
p = "C:\"
MsgBox "警告：文件路径不存在，文件将被保存在系统的根目录(c:\)中！"
End If
Else
p = "c:\"
End If
FileName1 = "tempname"
If fs.fileExists(p & FileName1 & ".jpg") Then
fs.DeleteFile p & FileName1 & ".jpg"
End If
fn = p & FileName1 & ".bmp"
Dim hWndScreen As Long
'获得桌面的窗口句柄
hWndScreen = GetDesktopWindow()
SavePicture CaptureWindow(hWndScreen, False, leftupX, leftupY, rightdownX, rightdownY), fn
imgopen fn
imgsave p & FileName1 & ".jpg"
If fs.fileExists(p & FileName1 & ".jpg") Then
fs.DeleteFile fn
SaveName = FileName1 & ".jpg"
FilePath = p
RaiseEvent SaveEnd
Else
SaveName = ""
End If
Set fs = Nothing
End Sub
Public Function CreateBitmapPicture(ByVal hBmp As Long, ByVal hPal As Long) As Picture
Dim r As Long
Dim Pic As PicBmp
Dim IPic As IPicture
Dim IID_IDispatch As GUID
'填充IDispatch界面
With IID_IDispatch
.Data1 = &H20400
.Data4(0) = &HC0
.Data4(7) = &H46
End With
'填充Pic
With Pic
.Size = Len(Pic)
' Pic结构长度
.Type = vbPicTypeBitmap
' 图像类型
.hBmp = hBmp
' 位图句柄
.hPal = hPal
' 调色板句柄
End With
'建立Picture图像
r = OleCreatePictureIndirect(Pic, IID_IDispatch, 1, IPic)
'返回Picture对象
Set CreateBitmapPicture = IPic
End Function
Public Function CaptureWindow(ByVal hWndSrc As Long, ByVal Client As Boolean, ByVal _
LeftSrc As Long, ByVal TopSrc As Long, ByVal WidthSrc As Long, ByVal HeightSrc As Long) As Picture
Dim hDCMemory As Long
Dim hBmp As Long
Dim hBmpPrev As Long
Dim r As Long
Dim hdcSrc As Long
Dim hPal As Long
Dim hPalPrev As Long
Dim RasterCapsScrn As Long
Dim HasPaletteScrn As Long
Dim PaletteSizeScrn As Long
Dim LogPal As LOGPALETTE
If Client Then
hdcSrc = GetDC(hWndSrc)
Else
hdcSrc = GetWindowDC(hWndSrc)
End If
hDCMemory = CreateCompatibleDC(hdcSrc)
hBmp = CreateCompatibleBitmap(hdcSrc, WidthSrc, HeightSrc)
hBmpPrev = SelectObject(hDCMemory, hBmp)
'获得屏幕属性
RasterCapsScrn = GetDeviceCaps(hdcSrc, RASTERCAPS)
HasPaletteScrn = RasterCapsScrn And RC_PALETTE
PaletteSizeScrn = GetDeviceCaps(hdcSrc, SIZEPALETTE)
'如果屏幕对象有调色板则获得屏幕调色板
If HasPaletteScrn And (PaletteSizeScrn = 256) Then
'建立屏幕调色板的拷贝
LogPal.palVersion = &H300
LogPal.palNumEntries = 256
r = GetSystemPaletteEntries(hdcSrc, 0, 256, LogPal.palPalEntry(0))
hPal = CreatePalette(LogPal)
'将新建立的调色板选如建立的内存绘图句柄中
hPalPrev = SelectPalette(hDCMemory, hPal, 0)
r = RealizePalette(hDCMemory)
End If
'拷贝图像
r = BitBlt(hDCMemory, 0, 0, WidthSrc, HeightSrc, hdcSrc, LeftSrc, TopSrc, vbSrcCopy)
hBmp = SelectObject(hDCMemory, hBmpPrev)
If HasPaletteScrn And (PaletteSizeScrn = 256) Then
hPal = SelectPalette(hDCMemory, hPalPrev, 0)
End If
'释放资源
r = DeleteDC(hDCMemory)
r = ReleaseDC(hWndSrc, hdcSrc)
Set CaptureWindow = CreateBitmapPicture(hBmp, hPal)
End Function
Private Function NumToStr(nNum)
If nNum < 10 Then
NumToStr = "0" & nNum
Else
NumToStr = nNum
End If
End Function
Public Property Get DeptCode() As Variant
DeptCode = sDCode
End Property
Public Property Let DeptCode(ByVal vNewValue As Variant)
sDCode = vNewValue
'PropertyChanged "DeptCode"
End Property
Public Property Get FileFolder() As Variant
FileFolder = sFFolder
End Property
Public Property Let FileFolder(ByVal vNewValue As Variant)
sFFolder = vNewValue
'PropertyChanged "FileFolder"
End Property
Public Property Get SaveName() As Variant
SaveName = sSName
End Property
Public Property Let SaveName(ByVal vNewValue As Variant)
sSName = vNewValue
End Property
Public Property Get FilePath() As Variant
FilePath = sFPath
End Property
Public Property Let FilePath(ByVal vNewValue As Variant)
sFPath = vNewValue
End Property
Public Sub WindShow(w, h)
UserControl.Width = w * 15
UserControl.Height = h * 15
Picture1.Width = w * 15
Picture1.Height = h * 15
End Sub
Public Sub WindClose()
UserControl.Width = 1
UserControl.Height = 1
End Sub
Public Sub EndForm()
UserControl.Enabled = False
End Sub
Private Sub Picture1_Click()
RaiseEvent click
End Sub
Public Sub MovFile(DestPath)
Dim fs
Set fs = CreateObject("Scripting.FileSystemObject")
fs.MoveFile FilePath & SaveName, DestPath
Set fs = Nothing
End Sub
Public Sub DelFile(DestPath)
Dim fs
Set fs = CreateObject("Scripting.FileSystemObject")
fs.DeleteFile DestPath
'MsgBox DestPath
Set fs = Nothing
End Sub
Private Sub UserControl_Terminate()
Set m_Image = Nothing
Set m_Jpeg = Nothing
End Sub
Public Property Get FileSize() As Variant
Dim fs, f
Set fs = CreateObject("Scripting.FileSystemObject")
Set f = fs.GetFile(SaveName)
FileSize = f.Size
Set f = Nothing
Set fs = Nothing
End Property
--------------------编程问答-------------------- Private m_Image As New cImage
Private m_Jpeg As cJpeg
是两个处理图形的类模块，是从网上下载的，原封不动，最后生成ocx控件具有抓图功能，在IE中功能使用正常，但是关闭IE的时候，IE报告错误，见顶贴
补充：VB , 网络编程
