VBA projekte speichern und wiederherstellen (Autodesk/AutoCAD VBA)

Anbei ein paar routinen um VBA projekte automatisch als text zu speichern

die function exportall kann man hin und wieder ja mal anstarten...
und im worst case leere dvb mit diesem code fuellen
und IMPORTALL aufrufen

hilft auch wenn die dvb groesser und groesser wird ...

const dir_drive ="C:"

Public Enum typeofVar

vbEmpty '0

vbNull '1
vbInteger '2
vbLong '3
vbSingle '4

vbDouble '5
vbCurrency '6
vbDate '7
vbString '8

vbObject '9
vbError '10
vbBoolean '11
vbVariant '12
vbDataObject '13
vbDecimal '14
vbByte '15

End Enum

Sub importall()

Dim VBE As Object
Set VBE = ThisDrawing.Application.VBE

Dim files() As String
files() = vbaSortedFiles(dir_drive & "\" & "vba\ACAD-SRC")

For i = 1 To UBound(files)
Debug.Print files(i)
myFileName = dir_drive & "\" & "vba\ACAD-SRC\" & files(i)
On Error Resume Next
ThisDrawing.Application.VBE.ActiveVBProject.VBComponents.Import myFileName
Next

End Sub

Sub export_daily()
On Error Resume Next
outdir = dir_drive & "\" & "vba\ACAD-SRC\" & format(Now, "yyyymmdd-hhmmss")
MkDir outdir
On Error GoTo 0
Call vbaExport(outdir)
End Sub

Sub exportall()
On Error Resume Next
outdir = "c:\vba\ACAD-SRC"
Call vbaExport(outdir)
outdir = "d:\vba\ACAD-SRC"
Call vbaExport(outdir)
outdir = dir_drive & "\" & "vba\ACAD-SRC"
Call vbaExport(outdir)

Call References_List
On Error GoTo 0
End Sub
Public Sub vbaExport(outdir)
Dim VBE As Object
Set VBE = ThisDrawing.Application.VBE
Dim comp As VBComponent
'Dim outdir As String

If DIR(outdir, vbDirectory) = "" Then
MkDir outdir
End If
For Each comp In VBE.ActiveVBProject.VBComponents
Select Case comp.TYPE
Case vbext_ct_StdModule
comp.Export outdir & "\" & comp.NAME & ".bas"
Case vbext_ct_Document, vbext_ct_ClassModule
comp.Export outdir & "\" & comp.NAME & ".cls"
Case vbext_ct_MSForm
comp.Export outdir & "\" & comp.NAME & ".frm"
Case Else
comp.Export outdir & "\" & comp.NAME
End Select
Next comp

Debug.Print "VBA files were exported to : " & outdir
End Sub

Sub References_List()
'Macro purpose: To remove missing references from the VBE

For i = 1 To ThisDrawing.Application.VBE.ActiveVBProject.References.count

Set Item = ThisDrawing.Application.VBE.ActiveVBProject.References.Item(i)
'item.IsBroken
On Error Resume Next
Err.Clear
'INFO = ITEM.name & "|" & ITEM.Major & "|" & ITEM.Minor & "|" & ITEM.Description & "|" & "BUILD IN:" & ITEM.BuiltIn & "|" & ITEM.GUID & "|" & ITEM.FullPath
'Debug.Print info

If Err.number = 0 Then
out = out & Info & vbCrLf
Else
say Item.NAME & " MISSING !!! " & str(Err.number) & Err.Description

Err.Clear
ThisDrawing.Application.VBE.ActiveVBProject.References.AddFromGuid Item.GUID, 1, 0
If Err.number <> 0 Then
Debug.Print "NOT LOADED BY GUID"
Else: say "... Loaded"
Err.Clear
End If

If Err.number <> 0 Then
Err.Clear
ThisDrawing.Application.VBE.ActiveVBProject.References.AddFromFile Item.FullPath, 1, 0
say "Finally not loaded"
Err.Clear
End If

On Error GoTo 0

If Err <> 0 Then
MsgBox "A missing reference has been encountered!" _
& "You will need to remove the reference manually.", _
vbCritical, "Unable To Remove Missing Reference"
End If
End If
Next
On Error GoTo 0
Call vbafilewrite(dir_drive & "\" & "VBA\acad32.ref", out)
Debug.Print out
out = ""
Call vbafileread(dir_drive & "\" & "VBA\acad32.ref", out)
Debug.Print Len(out) & "##"
Dim A() As String

Call vbatexttoarray(A(), out, "|")
For j = 0 To UBound(A, 1)
Debug.Print A(j, 0)

On Error Resume Next
ThisDrawing.Application.VBE.ActiveVBProject.References.AddFromGuid A(j, 5), A(j, 1), A(j, 2)
ThisDrawing.Application.VBE.ActiveVBProject.References.AddFromFile A(j, 6)
On Error GoTo 0
Next

End Sub

Sub References_remove_all()
'Macro purpose: To remove missing references from the VBE

Dim theref As Object, i As Long
Dim VBE As VBE
Set VBE = ThisDrawing.Application.VBE
Dim VBAPROJECT As VBProject
Dim VBPROJECTS As VBProject
Set VBAPROJECTS = VBE.VBPROJECTS
Dim Item As reference
Dim Info As String
Set VBAPROJECT = ThisDrawing.Application.VBE.ActiveVBProject
On Error Resume Next
For i = 1 To ThisDrawing.Application.VBE.ActiveVBProject.References.count
Set Item = ThisDrawing.Application.VBE.ActiveVBProject.References.Item(i)

Err.Clear
Debug.Print "remove " & Item.NAME
ThisDrawing.Application.VBE.ActiveVBProject.References.Remove Item

Next
On Error GoTo 0
End Sub
Sub references_from_list()
Dim j As Integer
Dim A() As String
Dim out As String
Call vbafileread(dir_drive & "\" & "VBA\acad32.ref", out)
Debug.Print Len(out) & "##"

Call vbatexttoarray(A(), out, "|")
For j = 0 To UBound(A, 1)
Debug.Print A(j, 0);

End Sub

Function vbafileread(ByRef file As String, ByRef text As String) As Long
Err.Clear
'On Error Resume Next
FF = FreeFile()

Open file For Binary As #FF
text = String$(LOF(FF), 32)
Get #FF, 1, text
Close #FF
vbafileread = Err.number
On Error GoTo 0
Err.Clear
End Function
Function vbafilewrite(ByRef file, ByRef text As String) As Long
Err.Clear
' On Error Resume Next

FF = FreeFile()
Open file For Output As #FF
Print #FF, text
Close #FF
vbafilewrite = Err.number
On Error GoTo 0
Err.Clear
End Function

Sub vbatexttoarray(ByRef A() As String, ByRef text As String, Optional del As String = ",", Optional sort As Boolean = False)
Dim b() As String
Dim b2() As String
b = Split(text, vbCrLf)
c = UBound(b) - 1
If c < 0 Then Exit Sub
If sort Then vbasort b
For i = 0 To c
b2 = Split(b(i), del)
If i = 0 Then
ReDim A(0 To UBound(b), 0 To UBound(b2))
End If
For j = 0 To UBound(b2)
A(i, j) = b2(j)
Next
Next

End Sub
'Sortiert einen Array nach alphabetischer Reihenfolge
Sub vbasort(sortarray() As String, Optional ByVal varStart As Long, Optional ByVal varEnd As Long)
Dim i As Long, j As Long, RandIndex As Long, Partition As String
Dim low As Long, high As Long
If UBound(sortarray) < 0 Then Exit Sub
low = IIf(varStart = 0, LBound(sortarray), varStart)
high = IIf(varEnd = 0, UBound(sortarray), varEnd)

If low < high Then
If high - low = 1 Then
If UCase(sortarray(low)) > UCase(sortarray(high)) Then
vbaswap sortarray(low), sortarray(high)
End If
Else
'Einen zufälligen Ausgangspunkt generieren
RandIndex = Rnd() * (high - low) + low
vbaswap sortarray(high), sortarray(RandIndex)
Partition = UCase(sortarray(high))
Do
'Von beiden Seiten auf den Ausgangspunkt "zugehen"
i = low: j = high
Do While (i < j) And (UCase(sortarray(i)) <= Partition)
i = i + 1
Loop
Do While (j > i) And (UCase(sortarray(j)) >= Partition)
j = j - 1
Loop

'Wenn der Ausgangspunkt noch nicht erreicht ist, sind 2 Elemente auf
'beiden Seiten funktionsunfähig, deswegen werden sie vertauscht
If i < j Then
vbaswap sortarray(i), sortarray(j)
End If
Loop While i < j

'Den Ausgangspunkt zu seinem richtigen Platz im Array führen
vbaswap sortarray(i), sortarray(high)

'Die QuickSort-Routine rekursiv nochmals aufrufen
If (i - low) < (high - i) Then
vbasort sortarray, low, i - 1
vbasort sortarray, i + 1, high
Else
vbasort sortarray, i + 1, high
vbasort sortarray, low, i - 1
End If
End If
End If
End Sub

'Vertauscht die Werte der zwei angegebenen Variablen
Private Sub vbaswap(First As String, Second As String)
Dim varTemp As String

varTemp = First
First = Second
Second = varTemp
End Sub

Function vbaSortedFiles(ByVal dir_path As String, Optional ByVal exclude_self As Boolean = True, Optional ByVal exclude_parent As Boolean = True) As String()
Dim fso As FileSystemObject
Dim fso_folder As folder
Dim Txt As String
Dim fso_file As file
Dim i As Long
Dim file_names() As String

' Make a new File System object.
Set fso = New FileSystemObject

' Get the FSO Folder (directory) object.
Set fso_folder = fso.GetFolder(dir_path)

' Make the list of names.
ReDim file_names(1 To fso_folder.files.count)
i = 1
For Each fso_file In fso_folder.files
file_names(i) = fso_file.NAME
i = i + 1
Next fso_file

' Sort the list of files.
vbasort file_names, 1, fso_folder.files.count

' Return the sorted list.
vbaSortedFiles = file_names
End Function

Function vbe_get_current_file()
Dim VBE As Object
Set VBE = Application.VBE
Debug.Print VBE.ActiveVBProject.Filename
Debug.Print VBE.ActiveVBProject.BuildFileName
'Debug.Print vbe.ActiveVBProject.SaveAs

'Debug.Print vbe.ActiveVBProject.MakeCompiledFile

End Function

Function vartypeinfo(ByRef var) As String

Dim i As Long
i = VarType(var)
Dim R As String
Dim A(30) As String
If i >= 8192 Then
R = "ARRAY "
i = i - 8192
End If
K = 0
A(K) = "vbEmpty 0 Empty (nicht initialisiert)": K = K + 1
A(K) = "vbNull 1 Null (keine gültigen Daten)": K = K + 1
A(K) = "vbInteger 2 Ganzzahl (Integer)": K = K + 1
A(K) = "vbLong 3 Ganzzahl (Long)": K = K + 1
A(K) = "vbSingle 4 Fließkommazahl einfacher Genauigkeit": K = K + 1
A(K) = "vbDouble 5 Fließkommazahl doppelter Genauigkeit": K = K + 1
A(K) = "vbCurrency 6 Währungsbetrag (Currency)": K = K + 1
A(K) = "vbDate 7 Datumswert (Date)": K = K + 1
A(K) = "vbString 8 Zeichenfolge (String)": K = K + 1
A(K) = "vbObject 9 Objekt": K = K + 1
A(K) = "vbError 10 Fehlerwert": K = K + 1
A(K) = "vbBoolean 11 Boolescher Wert (Boolean)": K = K + 1
A(K) = "vbVariant 12 Variant (nur bei Datenfeldern mit Variant-Werten)": K = K + 1
A(K) = "vbDataObject 13 Ein Datenzugriffsobjekt": K = K + 1
A(K) = "vbDecimal 14 Dezimalwert": K = K + 1
A(K) = "vbByte 17 Byte-Wert": K = K + 1
R = R & A(i)
vartypeinfo = R

'debug.print r
End Function

IM FALLE DES SUPERGAUS hilft dann folgende vorgehensweise
ALLE Module bis auf dieses loeschen und importall aufrufen.
Is klar dieses Modul speichert man auch noch mal als textdatei extra ab um es
in eine leere dvb einzufuegen !

------------------
Wer es nicht versucht, hat schon verlorn
Und bei 3 Typos gibts den vierten gratis !

Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP