you should be able to do it in the workbook's Open event.
paste this in a Module:
add code to Workbook's Open event:'http://www.vbaexpress.com/kb/getarticle.php?kb_id=677 Function getMyCustomDocProperty() As String ' ============================================ ' Save a value in CustomDocumentProperties ' ============================================ ' Constant string for the property we are adding Const szVersion As String = "_HD" ' ======================================================================== ' If the name doesn't exist, we create it and set the initial value to 1 On Error Resume Next Dim szDocVal As String Dim cstmDocProp As DocumentProperty Set cstmDocProp = ThisWorkbook.CustomDocumentProperties(szVersion) If Err.Number > 0 Then szDocVal = GetPhysicalSerial() & "" ThisWorkbook.CustomDocumentProperties.Add _ Name:=szVersion, _ LinkToContent:=False, _ Type:=msoPropertyTypeString, _ Value:=szDocVal ' ======================================================================== Else ' ======================================================================== ' if our name exists, we need to increment the value in it by 1 ' to do this, we parse the name's RefersTo value: szDocVal = ThisWorkbook.CustomDocumentProperties(szVersion).Value ' Reset the name to refer to our new value 'ThisWorkbook.CustomDocumentProperties(szVersion).Value = CLng(szDocVal) + 1 ' ======================================================================== End If ' Explicitly clear memory Set cstmDocProp = Nothing getMyCustomDocProperty = szDocVal End Function Function GetPhysicalSerial() As Variant Dim obj As Object Dim wmi As Object Dim SNList() As String, i As Long, count As Long Set wmi = GetObject("WinMgmts:") For Each obj In wmi.InstancesOf("Win32_PhysicalMedia") If obj.SerialNumber <> "" Then count = count + 1 Next 'ReDim SNList(1 To Count, 1 To 1) ReDim SNList(1 To count) i = 1 For Each obj In wmi.InstancesOf("Win32_PhysicalMedia") 'SNList(i, 1) = obj.SerialNumber SNList(i) = Trim(obj.SerialNumber & "") Debug.Print Trim(obj.SerialNumber & "") i = i + 1 If i > count Then Exit For Next GetPhysicalSerial = SNList(1) End Function
save your workbook as .xlsmPrivate Sub Workbook_Open() Dim hd As String hd = GetPhysicalSerial() & "" If hd <> getMyCustomDocProperty() Then Application.Quit End If End Sub
to test close and re-open the workbook.
you Enable the macro if you are presented with a message.
close, the workbook again and copy and open it in
different computer.




Reply With Quote