title image


Smiley Re: Dialoge, Module und Klassenmodule exportieren
Hi,



mit Fehlerbehandlung (existente Objekte mit gleichem Namen werden nicht importiert, in Thisdocument nur, wenn es leer ist).



Sub ImportVBEProject()  Dim TempDir As String  Const ExportSubDir = "\!VBE_EXPORT\"  On Error Resume Next  TempDir = Environ("temp")  If Len(TempDir) = 0 Then MsgBox "Kann TEMP-Directory nicht ermitteln, Abbruch": Exit Sub  TempDir = TempDir & ExportSubDir  If Len(Dir(TempDir)) = 0 Then MsgBox TempDir & " ist leer, Abbruch": Exit Sub  If MsgBox("Import?", vbYesNo) = vbNo Then Exit Sub  ImportProject ActiveDocument, TempDir  MsgBox "OK"End SubPrivate Function ImportProject(doc As Document, srcdir As String) ' Word  Dim N As Object, f As String, i As Integer, s As String, j As Long, j1 As Long, m As Boolean    On Error Resume Next  f = Dir(srcdir)  Do    If f = "ThisDocument.cld" Then      If doc.VBProject.VBComponents("ThisDocument").CodeModule.CountOfLines = 0 Then        i = FreeFile        Open srcdir & f For Input As i:  s = Input(LOF(i), i): Close i        ' remove class module header        Do: j1 = j + 1: j = InStr(j1, s, vbCrLf & "Attribute"): Loop While j        If j1 > 1 Then          j = InStr(j1 + 1, s, vbCrLf)          If (j > 0) And (j < Len(s)) Then _            doc.VBProject.VBComponents("ThisDocument").CodeModule.AddFromString Mid$(s, j)        End If      End If    Else      m = False      For Each N In doc.VBProject.VBComponents        m = LCase(f) Like LCase(N.Name) & ".*": If m Then Exit For      Next N      If Not m Then doc.VBProject.VBComponents.Import srcdir & f    End If    f = Dir  Loop While Len(f)End Function



Grüße

Wolfram

geschrieben von

Login

E-Mail:
  

Passwort:
  

Beitrag anfügen

Symbol:
 
 
 
 
 
 
 
 
 
 
 
 
 

Überschrift: