پرفروش ترين
برترين
آخرين محصولات فروشگاه
فایل الکترونیکی آموزش اکسل پیشرفته ۲۰۱۰
آموزش ایجاد فایل چندکاربره با سطح دسترسی مشخص
نمایش نتایج: از شماره 1 تا 8 , از مجموع 8

موضوع: شماره سریال کول دیسک

  1. #1


    آخرین بازدید
    2021/09/04
    تاریخ عضویت
    September 2012
    محل سکونت
    قم
    نوشته ها
    193
    امتیاز
    451
    سپاس
    234
    سپاس شده
    508 در 132 پست
    تعیین سطح نشده است

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

    سلام دوستان
    میخوام سریال کول دیسک بگیرم و تو سلول بذارم و برای سلول شرط بذارم و لطفاَ نظراتتون تو این تاپیک بگید
    اخطار: این یک موضوع قدیمی است
    به دلیل قدیمی بودن موضوع، ممکن است برخی فایل های ضمیمه به درستی کار نکنند. لطفا در صورت عدم ضرورت، از بالا آوردن موضوعات قدیمی خودداری نمایید.

  2.  

  3. #2


    آخرین بازدید
    2021/09/04
    تاریخ عضویت
    September 2012
    محل سکونت
    قم
    نوشته ها
    193
    امتیاز
    451
    سپاس
    234
    سپاس شده
    508 در 132 پست
    تعیین سطح نشده است

    دوستان لطفاً این بررسی کنید ببینید مشکلش کجاست که سریال کول دیسک نمیده
    کد PHP:
    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 wmiServiceswmiDiskDriveswmiDiskDrivequerywmiDiskPartitionswmiDiskPartitionwmiLogicalDiskswmiLogicalDisk
         
        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 

  4. #3


    آخرین بازدید
    2021/09/04
    تاریخ عضویت
    September 2012
    محل سکونت
    قم
    نوشته ها
    193
    امتیاز
    451
    سپاس
    234
    سپاس شده
    508 در 132 پست
    تعیین سطح نشده است

    دوستان این فانکشن هم دوستای خارجیمون تو شرکت ماکروسافت بهم دادن البته با کلی دردسر اما کدها و فانکشنها جواب نمیده
    کد PHP:
    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 

  5. #4


    آخرین بازدید
    2022/12/05
    تاریخ عضویت
    October 2011
    محل سکونت
    مشهد
    نوشته ها
    4,399
    امتیاز
    12760
    سپاس
    4,646
    سپاس شده
    12,136 در 3,226 پست
    سطح اکسل
    70.00 %

    کدی که بالا گذاشتید به صورت زیر اصلاح کنید و فرضا اگر فلش دیسک شما با نام k نمایش داده میشه به صورت زیر تابع رو بنویسید:
    کد PHP:
    GetSerialNum("K:\") 
    کد PHP:

    Public Declare Function GetVolumeInformation Lib "kernel32" _
      Alias 
    "GetVolumeInformationA" (ByVal lpRootPathName As String_
      ByVal lpVolumeNameBuffer 
    As StringByVal nVolumeNameSize As Long_
      lpVolumeSerialNumber 
    As LonglpMaximumComponentLength As Long_
      lpFileSystemFlags 
    As LongByVal 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(2550)
        
    sFSNBuff String(2550)
     
       
        
    sAppPath Left(sAppPath2) & "\"
     
       
        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 




  6. #5


    آخرین بازدید
    2021/09/04
    تاریخ عضویت
    September 2012
    محل سکونت
    قم
    نوشته ها
    193
    امتیاز
    451
    سپاس
    234
    سپاس شده
    508 در 132 پست
    تعیین سطح نشده است

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

  7. #6


    آخرین بازدید
    2022/12/05
    تاریخ عضویت
    October 2011
    محل سکونت
    مشهد
    نوشته ها
    4,399
    امتیاز
    12760
    سپاس
    4,646
    سپاس شده
    12,136 در 3,226 پست
    سطح اکسل
    70.00 %

    خدمت شما
    فايل هاي پيوست شده فايل هاي پيوست شده




  8. #7


    آخرین بازدید
    2021/09/04
    تاریخ عضویت
    September 2012
    محل سکونت
    قم
    نوشته ها
    193
    امتیاز
    451
    سپاس
    234
    سپاس شده
    508 در 132 پست
    تعیین سطح نشده است

    نقل قول نوشته اصلی توسط vatanparast نمایش پست ها
    خدمت شما
    مرسی دوست خوبم واقعا عالی بود

  9. #8


    آخرین بازدید
    2021/09/04
    تاریخ عضویت
    September 2012
    محل سکونت
    قم
    نوشته ها
    193
    امتیاز
    451
    سپاس
    234
    سپاس شده
    508 در 132 پست
    تعیین سطح نشده است

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


اطلاعات موضوع

کاربرانی که در حال مشاهده این موضوع هستند

در حال حاضر 1 کاربر در حال مشاهده این موضوع است. (0 کاربران و 1 مهمان ها)

موضوعات مشابه

  1. مقایسه دو فایل اکسل
    توسط Hamid.Mcse90 در انجمن توابع اکسل - Excel Functions
    پاسخ ها: 2
    آخرين نوشته: 2013/12/28, 20:14
  2. فوری: مقایسه اعداد
    توسط mitra.mgh در انجمن توابع اکسل - Excel Functions
    پاسخ ها: 4
    آخرين نوشته: 2013/10/08, 19:43
  3. مقایسه وحذف داده های تکراری
    توسط sohrabahmadi در انجمن سوالات پیرامون ويژوال بيسيك - VBA Questions
    پاسخ ها: 4
    آخرين نوشته: 2013/09/21, 21:17
  4. مقایسه
    توسط sohrabahmadi در انجمن سوالات پیرامون ويژوال بيسيك - VBA Questions
    پاسخ ها: 2
    آخرين نوشته: 2013/01/06, 20:16
  5. مقایسه 2 فایل مختلف
    توسط ~M*E*H*D*I~ در انجمن سوالات پیرامون ويژوال بيسيك - VBA Questions
    پاسخ ها: 19
    آخرين نوشته: 2012/04/04, 17:28

بازدید کنندگان با جستجو های زیر این صفحه را پیدا کرده اند

انجمن اكسل ايران , اكسل , اكسس , سوال و جواب اكسل , سوال اكسس , انجمن اكسل ايران , توابع اكسل, آموزش اكسل, آموزش اكسس, VBA, ويژوال بيسيك

کلمات کلیدی این موضوع

علاقه مندی ها (Bookmarks)

مجوز های ارسال و ویرایش

  • شما نمیتوانید موضوع جدیدی ارسال کنید
  • شما امکان ارسال پاسخ را ندارید
  • شما نمیتوانید فایل پیوست کنید.
  • شما نمیتوانید پست های خود را ویرایش کنید
  •  
  • BB code ها فعال هستند
  • شکلک ها فعال هستند
  • کد [IMG] فعال است
  • کد [VIDEO] فعال است
  • کد HTML غیر فعال است