errormsg.vbp
Form=Errormsg.Frm
Object={3B7C8863-D78F-101B-B9B5-04021C009402}#1.1#0; RICHTX32.OCX
ProjWinSize=180,497,232,97
ProjWinShow=2
IconForm="Form1"
HelpFile=""
Title="Systemfehlermeldungen"
ExeName32="errormsg.Exe"
Name="Project1"
HelpContextID="0"
StartMode=0
VersionCompatible32="0"
MajorVer=1
MinorVer=0
RevisionVer=0
AutoIncrementVer=0
ServerSupportFiles=0

errormsg.frm
VERSION 4.00
Begin VB.Form Form1
Caption = "System Fehlermeldungen"
ClientHeight = 4575
ClientLeft = 1005
ClientTop = 1815
ClientWidth = 8415
ClipControls = 0 'False
Height = 5265
Left = 945
LinkTopic = "Form1"
ScaleHeight = 305
ScaleMode = 3 'Pixel
ScaleWidth = 561
Top = 1185
Width = 8535
Begin RichTextLib.RichTextBox Rich1
Height = 4305
Left = 360
TabIndex = 0
Top = 90
Width = 7635
_ExtentX = 13467
_ExtentY = 7594
_Version = 327680
Enabled = -1 'True
ReadOnly = -1 'True
ScrollBars = 3
TextRTF = $"Errormsg.frx":0000
End
Begin VB.Menu Menu1
Caption = "&Start"
End
End
Attribute VB_Name = "Form1"
Attribute VB_Creatable = False
Attribute VB_Exposed = False
Option Explicit
Dim m_hwndEdit As Long
Private Declare Function MoveWindow Lib "user32" (ByVal hwnd As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal bRepaint As Long) As Long
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Const WM_USER = &H400
Const EM_EXSETSEL = (WM_USER + 55)
Private Type CHARRANGE
cpMin As Long
cpMax As Long
End Type
Const EM_REPLACESEL = &HC2
Const WM_GETTEXTLENGTH = &HE
Private Declare Function FormatMessage Lib "kernel32" Alias "FormatMessageA" (ByVal dwFlags As Long, lpSource As Any, ByVal dwMessageId As Long, ByVal dwLanguageId As Long, ByVal lpBuffer As String, ByVal nSize As Long, Arguments As Long) As Long
Const FORMAT_MESSAGE_ALLOCATE_BUFFER = &H100
Const FORMAT_MESSAGE_ARGUMENT_ARRAY = &H2000
Const FORMAT_MESSAGE_FROM_HMODULE = &H800
Const FORMAT_MESSAGE_FROM_STRING = &H400
Const FORMAT_MESSAGE_FROM_SYSTEM = &H1000
Const FORMAT_MESSAGE_IGNORE_INSERTS = &H200
Const FORMAT_MESSAGE_MAX_WIDTH_MASK = &HFF
Const LANG_USER_DEFAULT = &H400&
Private Function GetLastErrorStr(dwErrCode As Long) As String
Static sMsgBuf As String * 257, dwLen As Long
dwLen = FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM Or FORMAT_MESSAGE_IGNORE_INSERTS Or FORMAT_MESSAGE_MAX_WIDTH_MASK, ByVal 0&, dwErrCode, LANG_USER_DEFAULT, ByVal sMsgBuf, 256&, 0&)
If dwLen Then
GetLastErrorStr = Left$(sMsgBuf, dwLen)
Else
'GetLastErrorStr = "Unbekannter Fehler"
End If
End Function
Private Sub Form_Load()
m_hwndEdit = Rich1.hwnd
Rich1.Text = ""
End Sub
Private Sub Form_Resize()
MoveWindow m_hwndEdit, 0, 0, ScaleWidth, ScaleHeight, True
End Sub
Private Sub Form_Unload(Cancel As Integer)
Set Form1 = Nothing
End
End Sub
Private Sub Menu1_Click()
Dim dwIdx As Long, sSysdesc As String, dwErrs As Long
Static bRunning As Boolean
If bRunning Then: bRunning = False: Exit Sub
bRunning = True
MousePointer = 11
Menu1.Caption = "&Stop!"
Rich1 = ""
For dwIdx = -100 To 7000
DoEvents
If Not bRunning Then Exit For
sSysdesc = GetLastErrorStr(dwIdx)
If Len(sSysdesc) Then
dwErrs = dwErrs + 1
AppendText dwIdx & vbTab & sSysdesc & vbCrLf
End If
Next
If bRunning Then
AppendText vbCrLf & "OLE Fehlermeldungen" & " ...bitte etwas Geduld ( 655.359 Einträge! )" & vbCrLf
For dwIdx = &H80000000 To &H8009FFFF
DoEvents
If Not bRunning Then Exit For
sSysdesc = GetLastErrorStr(dwIdx)
If Len(sSysdesc) Then
dwErrs = dwErrs + 1
AppendText "&H" & Trim$(Hex(dwIdx)) & vbTab & sSysdesc & vbCrLf
End If
Next
End If
AppendText vbCrLf & "...insgesamt " & dwErrs & " Fehlermeldungseinträge ermittelt..." & vbCrLf
If bRunning Then bRunning = False
Menu1.Caption = "&Start"
MousePointer = 0
Beep
End Sub
Sub AppendText(stxt As String)
Static cr As CHARRANGE
cr.cpMin = SendMessage(m_hwndEdit, WM_GETTEXTLENGTH, 0, 0)
cr.cpMax = cr.cpMin
SendMessage m_hwndEdit, EM_EXSETSEL, 0, cr
SendMessage m_hwndEdit, EM_REPLACESEL, 0, ByVal stxt
End Sub

Hinweis : Sie werden beim Öffnen des Projektes eine Fehlermeldung erhalten, dies ist nicht passend zur Thematik gewollt, sondern entsteht durch das Fehlen der errormsg.frx.
Da dies eine Binärdatei ist, kann ich sie Ihnen nicht auf diesem Weg zur Verfügung stellen. Laden Sie das Projekt dennoch und nach Ihrem ersten Speichervorgang wird die Fehlermeldung nicht mehr erscheinen, da die entsprechende Datei neu angelegt wurde.

Um diesen Tipp nutzen zu können, erstellen Sie sich mit einem Editor Dateien, die Sie wie angegeben benennen. Starten Sie nun die *,vbp Datei oder Öffnen Sie das Projekt aus VB heraus.