دوستان بی خیال شین . همینجا ادامه میدیم
من این کد رو میزام --- این کد هارو توی تمام ماژول های یه پروژه باید اضافه کرد . با این کد تقریبا میشه 40 درصد خطاها رو ترمیم کرد . درضمن میشه با کمی تغییر کوچیک کاری کرد یه error log داشته باشیم و تمام اررور ها رو اونجا ذخیره کنیم و بعدا بهش رسیدگی کنیم
------------------------------------------------------------------------------
Add error handling to every module in a VB project.
Author Nigel Rivett
This VB app takes in VB project as a parameter and adds error handling to every module in it.
It creates the output files in a subdirectory \errhnd\.
The error handling will display an error message to the user including the call stack.
It may not cope with all situations as it was written for a specific project.
I make no apologies for the code as it was written very quickly.
It only considers _click as a user interaction module type - add to it as you need.
For top level (user interaction) modules it will add
Private Sub cmdUpdate_Click()
' Error Handling Start **************************
Const MODULE = "frmFuneral2" ' Error Handling
Const PROCEDURE = "cmdUpdate_Click" ' Error Handling
On Error GoTo ErrHnd ' Error Handling
GoTo errHndEnd ' Error Handling
ErrHnd: ' Error Handling
objError.ShowError MODULE, PROCEDURE, Err.Number, Err.Description, Err.Source ' Error Handling
' Err.Raise ERR_RAISE ' Error Handling
Exit Sub ' Error Handling
errHndEnd: ' Error Handling
' Error Handling End *****************************
For called modules it adds the code to return to the parent module
Function DBOpenResultSet(sProc As String) As Integer
' Error Handling Start **************************
Const MODULE = "DBAccess" ' Error Handling
Const PROCEDURE = "DBOpenResultSet" ' Error Handling
On Error GoTo ErrHnd ' Error Handling
GoTo errHndEnd ' Error Handling
ErrHnd: ' Error Handling
objError.SaveError MODULE, PROCEDURE, Err.Number, Err.Description, Err.Source ' Error Handling
Err.Raise ERR_RAISE ' Error Handling
Exit Function ' Error Handling
errHndEnd: ' Error Handling
' Error Handling End *****************************
Code
VERSION 5.00
Object = "{F9043C88-F6F2-101A-A3C9-08002B2F49FB}#1.2#0"; "COMDLG32.OCX"
Begin VB.Form frmAddErrorHandling
Caption = "Add Error Handling"
ClientHeight = 4395
ClientLeft = 60
ClientTop = 345
ClientWidth = 5790
LinkTopic = "Form1"
ScaleHeight = 4395
ScaleWidth = 5790
StartUpPosition = 3 'Windows Default
Begin VB.CommandButton cmdRemoveErrorHandling
Caption = "Remove Error Handling"
Enabled = 0 'False
Height = 495
Left = 2400
TabIndex = 3
Top = 3120
Width = 1455
End
Begin VB.CommandButton cmdAddErrorHandling
Caption = "Add Error Handling"
Enabled = 0 'False
Height = 495
Left = 4080
TabIndex = 2
Top = 3120
Width = 1575
End
Begin VB.CommandButton cmdAction
Caption = "Get Project"
Height = 375
Left = 4080
TabIndex = 1
Top = 2520
Width = 1575
End
Begin VB.CommandButton cmdCancel
Caption = "Cancel"
Height = 375
Left = 4320
TabIndex = 0
Top = 3840
Width = 1335
End
Begin MSComDlg.CommonDialog cmnDialog
Left = 600
Top = 3360
_ExtentX = 847
_ExtentY = 847
_Version = 393216
End
Begin VB.Label Label1
Caption = "Project"
Height = 255
Left = 240
TabIndex = 5
Top = 240
Width = 1095
End
Begin VB.Label lblProject
Height = 1455
Left = 240
TabIndex = 4
Top = 720
Width = 5295
WordWrap = -1 'True
End
End
Attribute VB_Name = "frmAddErrorHandling"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Dim sProject As String
Dim sPath As String
Dim aInsLines() As String
Private Sub cmdAction_Click()
' Find directory containing the files
' change command button to add error handling
' call module to add error handling
Dim i As Integer
cmnDialog.DialogTitle = "Select project"
cmnDialog.ShowOpen
sProject = cmnDialog.FileName
i = InStrRev(sProject, "\")
sPath = Left(sProject, i)
sProject = Replace(sProject, sPath, "")
If sProject <> "" And LCase(Right(sProject, 4)) = ".vbp" Then
lblProject = sPath & sProject
cmdAddErrorHandling.Enabled = True
cmdRemoveErrorHandling.Enabled = True
Else
lblProject = ""
cmdAddErrorHandling.Enabled = False
cmdRemoveErrorHandling.Enabled = False
End If
End Sub
Private Sub cmdCancel_Click()
End
End Sub
Private Sub cmdAddErrorHandling_Click()
AddErrorHandling "add"
MsgBox "Completed"
End
End Sub
Private Sub cmdRemoveErrorHandling_Click()
AddErrorHandling "remove"
MsgBox "Completed"
End
End Sub
Private Sub AddErrorHandling(sType As String)
' Populate error string array
Dim i As Integer
i = 0
i = AddToInsLines("' Error Handling Start **************************", i)
i = AddToInsLines("Const MODULE = """ & "sFileVBName" & """ ' Error Handling", i)
i = AddToInsLines("Const PROCEDURE = """ & "sModName" & """ ' Error Handling", i)
i = AddToInsLines("On Error GoTo ErrHnd ' Error Handling", i)
i = AddToInsLines(" GoTo errHndEnd ' Error Handling", i)
i = AddToInsLines("ErrHnd: ' Error Handling", i)
i = AddToInsLines(" objError.SaveError MODULE, PROCEDURE, Err.Number, Err.Description, Err.Source ' Error Handling", i)
i = AddToInsLines(" Err.Raise ERR_RAISE ' Error Handling", i)
i = AddToInsLines(" Exit Sub ' Error Handling", i)
i = AddToInsLines("errHndEnd: ' Error Handling", i)
i = AddToInsLines("' Error Handling End *****************************", i)
' Create output directory
If Dir(sPath & "ErrHnd\", vbDirectory) = "" Then
MkDir sPath & "ErrHnd\"
End If
' for each file call procedure
Dim sFile As String
sFile = Dir(sPath)
Do While sFile <> ""
Debug.Print
Debug.Print sFile;
ProcFile sPath, sFile, sType
sFile = Dir()
Loop
End Sub
Sub ProcFile(sPath As String, sFile As String, sType As String)
' process a file
' check if correct type
' open input and output
' get module name and type
' call proc to set array of lines for error
' write output file
Dim sbuf As String
Dim sInpFile As String
Dim iInpFile As Integer
Dim sOutFile As String
Dim iOutFile As Integer
Dim sFileVBName As String
Dim sModName As String
Dim sOldModName As String
Dim sModTitle As String
Dim sExitModType As String
Dim i As Integer
' Exclude non catered for file types
Select Case LCase(Right(sFile, 4))
Case ".frm", ".bas", ".cls"
Case Else
Exit Sub
End Select
' Open input and output files
iInpFile = FreeFile
Open sPath & sFile For Input As iInpFile
iOutFile = FreeFile
Open sPath & "ErrHnd\" & sFile For Output As iOutFile
Do While Not EOF(iInpFile)
Line Input #iInpFile, sbuf
If Left(sbuf, Len("Attribute VB_Name = ")) = "Attribute VB_Name = " Then
sFileVBName = Replace(Replace(sbuf, "Attribute VB_Name = ", ""), """", "")
End If
If Left(sbuf, Len("Sub ")) = "Sub " Then
sModName = Replace(sbuf, "Sub ", "")
sExitModType = "Sub"
ElseIf Left(sbuf, Len("Private Sub ")) = "Private Sub " Then
sModName = Replace(sbuf, "Private Sub ", "")
sExitModType = "Sub"
ElseIf Left(sbuf, Len("Public Sub ")) = "Public Sub " Then
sModName = Replace(sbuf, "Public Sub ", "")
sExitModType = "Sub"
ElseIf Left(sbuf, Len("Function ")) = "Function " Then
sModName = Replace(sbuf, "Function ", "")
sExitModType = "Function"
ElseIf Left(sbuf, Len("Private Function ")) = "Private Function " Then
sModName = Replace(sbuf, "Private Function ", "")
sExitModType = "Function"
ElseIf Left(sbuf, Len("Public Function ")) = "Public Function " Then
sModName = Replace(sbuf, "Public Function ", "")
sExitModType = "Function"
End If
' copy line to output - exclude error handling lines
If InStr(sbuf, "Error Handling") = 0 Then
Print #iOutFile, sbuf
End If
' new module - add error handling - this comes just after module definintion
If sModName <> sOldModName And sType = "add" Then
Debug.Print "|" & sModName;
sOldModName = sModName
i = InStr(sModName, "(")
If i <> 0 Then
sModTitle = Left(sModName, i - 1)
i = InStrRev(sModTitle, "_")
If sModName = "main()" Then
SetInsLines "Show", sModTitle, sFileVBName, sExitModType
ElseIf i = 0 Then
SetInsLines "NoShow", sModTitle, sFileVBName, sExitModType
Else
Select Case Right(sModTitle, Len(sModTitle) - i)
Case "Click", "Change", "KeyPress", "Load", "Activate"
SetInsLines "Show", sModTitle, sFileVBName, sExitModType
Case Else
SetInsLines "NoShow", sModTitle, sFileVBName, sExitModType
End Select
End If
For i = 0 To UBound(aInsLines)
Print #iOutFile, aInsLines(i)
Next
End If
End If
Loop
Close iInpFile
Close iOutFile
End Sub
Sub SetInsLines(sModType As String, sModName As String, sFileVBName As String, sExitModType As String)
Const MODLINE = 1
Const PROCLINE = 2
Const TYPELINE = 6
Const ERRRAISE = 7
Const EXITLINE = 8
aInsLines(MODLINE) = "Const MODULE = """ & sFileVBName & """ ' Error Handling"
aInsLines(PROCLINE) = "Const PROCEDURE = """ & sModName & """ ' Error Handling"
If sModType = "NoShow" Then
aInsLines(TYPELINE) = Replace(aInsLines(TYPELINE), "ShowError", "SaveError")
Mid$(aInsLines(ERRRAISE), 1, 1) = " "
Else
aInsLines(TYPELINE) = Replace(aInsLines(TYPELINE), "SaveError", "ShowError")
Mid$(aInsLines(ERRRAISE), 1, 1) = "'"
End If
If sExitModType = "Sub" Then
aInsLines(EXITLINE) = Replace(aInsLines(EXITLINE), "Function", "Sub")
Else
aInsLines(EXITLINE) = Replace(aInsLines(EXITLINE), "Sub", "Function")
End If
End Sub
Function AddToInsLines(s As String, i As Integer) As Integer
ReDim Preserve aInsLines(0 To i) As String
aInsLines(i) = s
AddToInsLines = i + 1
End Function
صفحه اصلی
انجمن
جستجو
فهرست اعضا
افزونه های فایرفاکس
» 
تشکر شده توسط :