شماره سریال کول دیسک

[hosseinamerey]

سلام دوستان
میخوام سریال کول دیسک بگیرم و تو سلول بذارم و برای سلول شرط بذارم و لطفاَ نظراتتون تو این تاپیک بگید

[hosseinamerey]

دوستان لطفاً این بررسی کنید ببینید مشکلش کجاست که سریال کول دیسک نمیده

Function GetUSBSerialNo(ByVal DriveLetter As String)
        Dim PnPID As String
        PnPID = USBSerialNo(DriveLetter)
     
        If Not Trim(PnPID) = "" Then
            GetUSBSerialNo = formatSerialNo(PnPID)
        Else
            GetUSBSerialNo = ""
       End If
     
    End Function
     
     
    Function USBSerialNo(ByVal DriveLetter As String)
     
    Dim objFSO
    Dim objFolder
    Dim Directory
    Const OverwriteExisting = True
     
    Dim SerialNo As String
     
    Dim ComputerName
    ComputerName = "."
    Dim wmiServices, wmiDiskDrives, wmiDiskDrive, query, wmiDiskPartitions, wmiDiskPartition, wmiLogicalDisks, wmiLogicalDisk
     
    Set wmiServices = GetObject( _
        "winmgmts:{impersonationLevel=Impersonate}!//" _
        & ComputerName)
     
    Set wmiDiskDrives = wmiServices.ExecQuery("SELECT Caption, DeviceID,PNPDeviceID FROM Win32_DiskDrive")
     
    For Each wmiDiskDrive In wmiDiskDrives
     
        SerialNo = wmiDiskDrive.PNPDeviceID '1
     
     query = "ASSOCIATORS OF {Win32_DiskDrive.DeviceID='" _
            & wmiDiskDrive.deviceid & "'} WHERE AssocClass = Win32_DiskDriveToDiskPartition"
        Set wmiDiskPartitions = wmiServices.ExecQuery(query)
     
        For Each wmiDiskPartition In wmiDiskPartitions
            Set wmiLogicalDisks = wmiServices.ExecQuery _
                ("ASSOCIATORS OF {Win32_DiskPartition.DeviceID='" _
                 & wmiDiskPartition.deviceid & "'} WHERE AssocClass = Win32_LogicalDiskToPartition")
     
            For Each wmiLogicalDisk In wmiLogicalDisks
     
            If (wmiLogicalDisk.deviceid = DriveLetter) And (wmiLogicalDisk.DriveType = 2) Then '2
                USBSerialNo = SerialNo
                Exit Function
            End If
     
            Next
        Next
    Next
    End Function
     
     
    Function formatSerialNo(ByVal PnPID As String)
        Dim arrSerialNo
        Dim arrSerialNo1
        arrSerialNo = Split(PnPID, "\")
        Dim i
        arrSerialNo1 = Split(arrSerialNo(UBound(arrSerialNo)), "&")
     
        If UBound(arrSerialNo1) > 0 Then
            formatSerialNo = arrSerialNo1(UBound(arrSerialNo1) - 1)
        Else
            formatSerialNo = arrSerialNo1(UBound(arrSerialNo1))
        End If
     
    End Function
     
 

 
Private Sub Command1_Click()
MsgBox GetUSBSerialNo(J)
End Sub 

[hosseinamerey]

دوستان این فانکشن هم دوستای خارجیمون تو شرکت ماکروسافت بهم دادن البته با کلی دردسر اما کدها و فانکشنها جواب نمیده

Public Function GetSerialNum(ByVal sAppPath As String) As Long
    Dim jSerNum As Long
    Dim sFSNBuff As String
    Dim sSerNum As String
    Dim sVolBuff As String
    Dim sDrvSave As String
    Dim sDirSave As String
 
    ' ** Init.
    sVolBuff = String(255, 0)
    sFSNBuff = String(255, 0)
 
    ' ** Make sure sAppPath is set to "x:\".
    sAppPath = Left(sAppPath, 2) & "\"
 
    ' ** Save info.
    sDrvSave = Left(CurDir(), 2)
    sDirSave = CurDir(sAppPath)
 
    ' ** Change to the root of sAppPath.
    Call ChDrive(Left(sAppPath, 2))
    Call ChDir(sAppPath)
 
    ' ** Get serial number for "x:\".
    Call GetVolumeInformation(sAppPath, "", 0, jSerNum, 0, 0, "", 0)
 
    ' ** If error, get serial number for "x:".
    If jSerNum = 0 Then
        sAppPath = Left(sAppPath, 2)
        Call GetVolumeInformation(sAppPath, sVolBuff, 255, jSerNum, 0, 0, _
          sFSNBuff, 255)
    End If
 
    ' ** Return to saved directory and drive.
    Call ChDir(sDirSave)
 
    ' ** Return.
    GetSerialNum = jSerNum
End Function 

[~M*E*H*D*I~]

کدی که بالا گذاشتید به صورت زیر اصلاح کنید و فرضا اگر فلش دیسک شما با نام k نمایش داده میشه به صورت زیر تابع رو بنویسید:

GetSerialNum("K:\") 

Public Declare Function GetVolumeInformation Lib "kernel32" _
  Alias "GetVolumeInformationA" (ByVal lpRootPathName As String, _
  ByVal lpVolumeNameBuffer As String, ByVal nVolumeNameSize As Long, _
  lpVolumeSerialNumber As Long, lpMaximumComponentLength As Long, _
  lpFileSystemFlags As Long, ByVal lpFileSystemNameBuffer As String, _
  ByVal nFileSystemNameSize As Long) As Long
Public Function GetSerialNum(ByVal sAppPath As String) As Long
    Dim jSerNum As Long
    Dim sFSNBuff As String
    Dim sSerNum As String
    Dim sVolBuff As String
    Dim sDrvSave As String
    Dim sDirSave As String
 
   
    sVolBuff = String(255, 0)
    sFSNBuff = String(255, 0)
 
   
    sAppPath = Left(sAppPath, 2) & "\"
 
   
    sDrvSave = Left(CurDir(), 2)
    sDirSave = CurDir(sAppPath)
 
    
    Call ChDrive(Left(sAppPath, 2))
    Call ChDir(sAppPath)
 
   
    Call GetVolumeInformation(sAppPath, "", 0, jSerNum, 0, 0, "", 0)
 
    
    If jSerNum = 0 Then
        sAppPath = Left(sAppPath, 2)
        Call GetVolumeInformation(sAppPath, sVolBuff, 255, jSerNum, 0, 0, _
          sFSNBuff, 255)
    End If
 
 
    Call ChDir(sDirSave)
 
  
    GetSerialNum = jSerNum
End Function 

[hosseinamerey]

جناب استاد ممنون باز هم کد ها به عنوان یه ماکرو جواب نداد
امکانش هست یه نمونه فایل برام بذاری :

[~M*E*H*D*I~]

خدمت شما

[hosseinamerey]

خدمت شما

مرسی دوست خوبم واقعا عالی بود

[hosseinamerey]

حالا جطوری میشه وقتی این فلش دیسک تو هر سیستمی که میزنیم نام درایو برای فلش ثابت باشه یا با یه متغییر بشه به این نام درایو مثلاً درایو k برسیم
اصلا همجین جیزی میشه