Verweis auf Solver.xla

Hallo,
ich habe ein Problem, dass ich zwar im Forum schon angesprochen gefunden habe, aber bisher ohne Lösung.
Ich möchte per Makro einen Verweis auf den Solver in VisualBasic unter Extras\Verweise aktivieren.
Dies ist nicht zu verwechseln mit der Einbindung des AddIns unter Excel mit AddIns.Add("Solver.xla").Installed=True - dies aktiviert leider nur den Solver im AddIn-Manager.
Das Makro soll also in VisualBasic unter Extras\Verweise nach dem Pfad von Solver.xla suchen (da auf verschiedenen Rechnern dieser unterschiedlich sein kann) und wenn er gefunden wurde, soll dieser Verweis aktiviert werden.

Falls jmd. weiss, wie man die Aktivierung realisiert, wäre ich sehr dankbar.
Viele Grüsse,
Anya

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hallo
probier mal das aus.
Ich hatte das mal für eine andere Datei geschrieben, ... sollte aber eigentlich funktionieren

Option Explicit
'Für Dateisuche
Private Declare Function GetDriveType Lib "kernel32" _
        Alias "GetDriveTypeA" (ByVal nDrive As String) _
        As Long
Private Declare Function GetLogicalDriveStrings Lib _
        "kernel32" Alias "GetLogicalDriveStringsA" _
        (ByVal nBufferLength As Long, ByVal lpBuffer _
        As String) As Long
'Konstanten zur Dateisuche
Private Const DRIVE_REMOVABLE = 2
Private Const DRIVE_FIXED = 3
Private Const DRIVE_REMOTE = 4
Private Const DRIVE_CDROM = 5
Private Const DRIVE_RAMDISK = 6
'Anzahl lokaler laufwerke/Partitionen
Public LocDrivesCount As Byte
'Dateiname zur Prüfung zur angeben !!!
Public Const CheckRef As String = "SOLVER.XLA"
Sub Install_Solver_Reference()
Dim i As Long, n As Long, totFiles As Long, GlobalFound As Boolean
Dim gefFile As String, dname As String, Qe As Integer
Dim Suchpfad As String
Dim oldStatus As Variant
'Zuerst im Installationspfad suchen
Suchpfad = Application.Path
If ResCheckReference = True Then
    MsgBox "Verweis ist bereits installiert"
    Exit Sub
End If
Application.ScreenUpdating = True
oldStatus = Application.StatusBar
With Application.FileSearch
    .LookIn = Suchpfad
    .SearchSubFolders = True
    'Datei aus Konstanten übernehmen
    .Filename = CheckRef
    If .Execute() > 0 Then
        totFiles = .FoundFiles.Count
        For i = 1 To .FoundFiles.Count
            gefFile = .FoundFiles(i)
            Application.VBE.ActiveVBProject.References.AddFromFile gefFile
            MsgBox "Referenz auf : " & gefFile & " wurde erstellt"
            Exit Sub
        Next i
    Else
        MsgBox "Datei SOLVER.XLA wurde nicht gefunden." & Chr$(13) & _
            "Soll der gesamte Rechner durchsucht werden ?", vbYesNo + vbQuestion, "Fehler"
        If Qe = vbNo Then
            Application.StatusBar = oldStatus
            Application.ScreenUpdating = True
            Exit Sub
        End If
    End If
End With
'Schleife für alle lokalen Laufwerke
'Keine USB, keine CD-ROM, keine Disketten, Keine Netzlaufwerke
For i = 1 To CountLocalDrives
    With Application.FileSearch
        Application.StatusBar = "Durchsucht wird Laufwerk: " & GetLocalDriveName(i)
        .LookIn = GetLocalDriveName(i)
        .SeachSubFolders = True
        .Filename = CheckRef
        If .Execute() > 0 Then
            totFiles = .FoundFiles.Count
            For n = 1 To .FoundFiles.Count
                gefFile = .FoundFiles(n)
                Application.VBE.ActiveVBProject.References.AddFromFile gefFile
                MsgBox "Referenz auf : " & gefFile & " wurde erstellt"
                GlobalFound = True
            Next n
        End If
    End With
Next i
If GlobalFound = False Then
    MsgBox "Datei: " & CheckRef & " wurde nicht gefunden." & Chr$(13) & _
        "Überprüfen Sie bitte Ihre Office-Installation"
End If
End Sub
Public Function ResCheckReference() As Boolean
Dim objRef As Object
For Each objRef In ActiveWorkbook.VBProject.References
    With objRef
        Debug.Print objRef.fullpath
        If InStr(1, objRef.fullpath, CheckRef) > 0 Then
            ResCheckReference = True
            Exit Function
        End If
    End With
Next
ResCheckReference = False
End Function
Private Function CountLocalDrives() As Byte
Dim DriveSpace As Byte, myDrives As String
Dim StringLen As String, DriveLen As String, x As Byte
Dim Laufwerk As String
StringLen = Space(32)
DriveSpace = 32
DriveLen = GetLogicalDriveStrings(DriveSpace, StringLen)
myDrives = Left(StringLen, DriveLen)
LocDrivesCount = 0
Do While x < Len(myDrives)
    'Nach ASCII Leer suchen
    x = InStr(myDrives, Chr$(0))
    If x > 0 Then
        Laufwerk = Left$(myDrives, x - 1)
        myDrives = Mid$(myDrives, x + 1, Len(myDrives))
        If GetDriveType(Laufwerk) = 3 Then
            LocDrivesCount = LocDrivesCount + 1
        End If
    Else
        Exit Do
    End If
Loop
CountLocalDrives = LocDrivesCount
End Function
Private Function GetLocalDriveName(ByVal getDrive As Byte) As String
Dim DriveSpace As Byte, myDrives As String
Dim StringLen As String, DriveLen As String
Dim Laufwerk As String
Dim x As Byte, n As Byte
StringLen = Space(32)
DriveSpace = 32
DriveLen = GetLogicalDriveStrings(DriveSpace, StringLen)
myDrives = Left(StringLen, DriveLen)
n = 0
Do While x < Len(myDrives)
    x = InStr(myDrives, Chr$(0))
    If x > 0 Then
        Laufwerk = Left$(myDrives, x - 1)
        n = n + 1
        If n = getDrive Then
            GetLocalDriveName = Laufwerk
            Exit Function
        End If
        myDrives = Mid$(myDrives, x + 1, Len(myDrives))
    End If
Loop
End Function

Gruss Rainer

Beliebteste Forumthreads (12 Monate)

8 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

8
Beiträge zum Forumthread

Beiträge zu diesem Forumthread