VBA Makro soll nur auf einem PC laufen
30.01.2018 04:06:43
Rainer
Hallo Dietmar,
Jetzt hast du die Aufgabe endlich genannt: VBA Makro soll nur auf einem PC laufen.
Ich ändere mal den Betreff.
Leider habe ich keine Ahnung was dein Code macht und werde ihn auch nicht ausführen.
Aber ich habe den Code hier reinkopiert, so können ihn sich auch die Experten anschauen, ohne die XLSM Datei zu öffnen. Manche laden so etwas ungern herunter.
Ich stelle den Beitrag auf OFFEN und hoffe dass dir jemand helfen kann. Meine Kenntnisse übersteigt es.
Gruß,
Rainer
Private Sub Workbook_Open()
Call Installieren
Call Abfrage
End Sub
Sub Installieren()
Dim strSQL As String
Dim strWMI As String
Dim oWMI As Object
Dim objItem As Object
Dim stringFP As String
Dim stringPC As String
Dim stringEndNumber As String
Dim myFileSystemObject As Object
strSQL = "Select * from Win32_Processor"
strWMI = "winmgmts:\\.\root\cimv2"
Set oWMI = GetObject(strWMI).ExecQuery(strSQL)
For Each objItem In oWMI
stringPC = objItem.ProcessorId
Next
Set myFileSystemObject = CreateObject("Scripting.FileSystemObject")
stringFP = myFileSystemObject.GetDrive("C:").SerialNumber
stringEndNumber = stringPC & stringFP
Application.ScreenUpdating = False
Range("AD200").Value = stringFP
Range("AE200").Value = stringPC
Application.ScreenUpdating = True
' Call MakroFiltern
End Sub
Sub InstalLoeschen()
Dim Namen(1 To 3)
Namen(1) = "Modul1"
Namen(2) = "Modul7"
Namen(3) = "Modul2"
For x = 1 To UBound(Namen)
Set VBP = Application.VBE.ActiveVBProject
VBP.VBComponents.Remove VBP.VBComponents(Namen(x))
Next x
End Sub
Sub Abfrage()
Dim strSQL As String
Dim strWMI As String
Dim oWMI As Object
Dim objItem As Object
Dim stringFP As String
Dim stringPC As String
Dim stringEndNumber As String
Dim myFileSystemObject As Object
strSQL = "Select * from Win32_Processor"
strWMI = "winmgmts:\\.\root\cimv2"
Set oWMI = GetObject(strWMI).ExecQuery(strSQL)
For Each objItem In oWMI
stringPC = objItem.ProcessorId
Next
Set myFileSystemObject = CreateObject("Scripting.FileSystemObject")
stringFP = myFileSystemObject.GetDrive("C:").SerialNumber
stringEndNumber = stringPC & stringFP
Application.ScreenUpdating = False
Range("AD201").Value = stringFP
Range("AE201").Value = stringPC
Application.ScreenUpdating = True
' Call vergleichen
End Sub
Sub vergleichen()
Application.Wait (Now + TimeValue("00:00:05"))
If Range("AD200") = Range("AD201") Then
MsgBox "FP erfolgreich!"
End If
If Range("AE200") = Range("AE201") Then
MsgBox "PC erfolgreich!"
End If
If Range("AD200") Range("AD201") Then
MsgBox "FP Fehler!"
'Call ausschalten
Else
If Range("AE200") Range("AE201") Then
MsgBox "PC Fehler!"
'Call ausschalten
End If
End If
End Sub
Sub ausschalten()
Set objWMI = GetObject("WinMgmts:{impersonationLevel=impersonate, (Shutdown)}!/root/cimv2")
Set objItems = objWMI.ExecQuery("SELECT * FROM Win32_OperatingSystem")
For Each objItem In objItems
objItem.Shutdown
Next objItem
End Sub
Sub MakroFiltern()
With ThisWorkbook.VBProject.VBComponents("DieseArbeitsmappe").CodeModule
.DeleteLines 2, 1
End With
'Call InstalLoeschen
End Sub