• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

Harddisk Seri noyu hücreye yazdırma

C

CILEKESH

Katılım
26 Kasım 2006
Mesajlar
234
Excel Vers. ve Dili
2010-2013 Türkçe
Sub Düğme1_Tıklat()
Dim fso As Object
Dim drv As Object
Set fso = CreateObject("Scripting.FileSystemObject")
Set drv = fso.Drives.Item("C")
MsgBox "Drive Serial Number is " & Hex(drv.SerialNumber)
End Sub


Yukarıdaki kodu msjbox a değilde excel sayfasında herhangi bir hücreye yazdırmak istenirse Kod Nasıl yazılır?
 
CILEKESH' Alıntı:
Sub Düğme1_Tıklat()
Dim fso As Object
Dim drv As Object
Set fso = CreateObject("Scripting.FileSystemObject")
Set drv = fso.Drives.Item("C")
MsgBox "Drive Serial Number is " & Hex(drv.SerialNumber)
End Sub


Yukarıdaki kodu msjbox a değilde excel sayfasında herhangi bir hücreye yazdırmak istenirse Kod Nasıl yazılır?
Genişletmek için tıkla ...

Merhaba
Kodu bununla değiştirin.
Kod: 
Option Explicit
Sub Düğme1_Tıklat()
Dim fso As Object
Dim drv As Object
Set fso = CreateObject("Scripting.FileSystemObject")
Set drv = fso.Drives.Item("C")
Range("A1") = Hex(drv.serialnumber)
End Sub
 
İhsan Tank' Alıntı:
Merhaba
Kodu bununla değiştirin.
Kod: 
Option Explicit
Sub Düğme1_Tıklat()
Dim fso As Object
Dim drv As Object
Set fso = CreateObject("Scripting.FileSystemObject")
Set drv = fso.Drives.Item("C")
Range("A1") = Hex(drv.serialnumber)
End Sub
Genişletmek için tıkla ...

Teşekkür ederim işe yaradı, Hücreye yazılan harflerle karışık olan "ECA57DDD"
bu değerin içindeki rakamları formülle nasıl ayırırım? (Yani formul girilen hücrenin sonucu bu örmekte "57" olacak mesela?
 
CILEKESH' Alıntı:
Teşekkür ederim işe yaradı, Hücreye yazılan harflerle karışık olan "ECA57DDD"
bu değerin içindeki rakamları formülle nasıl ayırırım? (Yani formul girilen hücrenin sonucu bu örmekte "57" olacak mesela?
Genişletmek için tıkla ...

Moduleye eklediniz kodu bununla değiştirin ve Harddisk bulma kodunu çalıştırın.
Kod: 
Option Explicit
Sub Düğme1_Tıklat()
Dim fso As Object
Dim drv As Object
Set fso = CreateObject("Scripting.FileSystemObject")
Set drv = fso.Drives.Item("C")
Range("A1") = Hex(drv.serialnumber)
Range("B1") = "=Numaraal(A1)"
End Sub
[COLOR="Red"]Function NumaraAl(hucre)
Dim i As Integer, sayi
For i = 1 To Len(hucre)
sayi = Mid(hucre, i, 1)
If IsNumeric(sayi) = True Then
NumaraAl = NumaraAl & sayi
End If
Next i
End Function[/COLOR]
Kırmızı olan makro KTF'dir ve Ali Hocadan alıntıdır.
 
Kod çalıştı ama Numaraal formülü çalışmadı hücre "ad" hatası verdi
 
CILEKESH' Alıntı:
Verdiğiniz Kod Userform5'in Activite olayında yazılı
Genişletmek için tıkla ...

Merhaba
Userform5'in Active olayındaki kodu bununla değiştirin.
Kod: 
Private Sub UserForm_Activate()
Application.OnTime Now + TimeSerial(0, 0, 5), "Kapat"
Dim lngFormHwnd As Long, lngFormStyle As Long
Me.BorderStyle = fmBorderStyleNone
If Application.Version < 9 Then
lngFormHwnd = FindWindow("THUNDERXFRAME", Me.Caption)
Else
lngFormHwnd = FindWindow("THUNDERDFRAME", Me.Caption)
End If
lngFormStyle = GetWindowLong(lngFormHwnd, GWL_STYLE)
lngFormStyle = lngFormStyle And Not WS_BORDER
SetWindowLong lngFormHwnd, GWL_STYLE, lngFormStyle
DrawMenuBar lngFormHwnd
Dim fso As Object
Dim drv As Object
Dim ts, kaplan, trabzonspor
Set fso = CreateObject("Scripting.FileSystemObject")
Set drv = fso.Drives.Item("C")
Sheets("TAHAKKUKLAR").Range("A1000") = Hex(drv.serialnumber)
Sheets("TAHAKKUKLAR").Range("B1000").ClearContents
For ts = 1 To Len(Sheets("TAHAKKUKLAR").Range("A1000"))
If IsNumeric(Mid(Sheets("TAHAKKUKLAR").Range("A1000"), ts, 1)) = True Then
Sheets("TAHAKKUKLAR").Range("B1000") = Sheets("TAHAKKUKLAR"). _
Range("A1000") & Mid(Sheets("TAHAKKUKLAR"). _
Range("A1000"), ts, 1)
End If
Next
End Sub
Bu kod ile değiştirin.
 
Active yi aynen değiştirdim, a1000 hücresine (ECA57DDD) b1000 hücresine
(ECA57DDD7) yazdı... Ben sadece rakamların yazılmasını istiyorum


Function NumaraAl(hucre)
Dim i As Integer, sayi
For i = 1 To Len(hucre)
sayi = Mid(hucre, i, 1)
If IsNumeric(sayi) = True Then
NumaraAl = NumaraAl & sayi
End If
Next i
End Function

Activeden sonra yazılmış olan
Bu kod kalacak mı?
 
4 nolu mesajdaki kırmızı yeri bir modül içine koyun

veya 7 nolu mesajınızdaki dosyanın,

bunun yerine

Kod: 
Sheets("TAHAKKUKLAR").Range("B1000") = "=Numaraal(A1000)"

bununla değiştirin

Kod: 
Sheets("TAHAKKUKLAR").Range("B1000") = NumaraAl(Sheets("TAHAKKUKLAR").Range("A1000"))
 
İhsan bey Halit bey teşekkür ederim Kodlarınız işe yaradı,

=EĞER(ŞİFRE!D1=0;"Userform1 çalıştır";Userform2 çalıştır)

Şimdi formulle anlatmaya çalıştığımı kod ile yazmam lazım,

Yani D1 hücresindeki değer sıfırdan başka bir değerse Userform2 çalışacak,
Sıfır ise Userform1 çalışacak.
 
CILEKESH' Alıntı:
İhsan bey Halit bey teşekkür ederim Kodlarınız işe yaradı,

=EĞER(ŞİFRE!D1=0;"Userform1 çalıştır";Userform2 çalıştır)

Şimdi formulle anlatmaya çalıştığımı kod ile yazmam lazım,

Yani D1 hücresindeki değer sıfırdan başka bir değerse Userform2 çalışacak,
Sıfır ise Userform1 çalışacak.
Genişletmek için tıkla ...

Sorunuzun bu konu ile alakasını çözemedim açıkcası
 
Açıklayayım,

A1 hücresine Harddiskin seri nosunu yazdırdık,
B1 hücresine harflerden ayıklayarak sadece rakamları seçtik
C1 hücresine programın açılışında ekrana gelen userform5 vasıtasıyla b1 hücresindeki rakamı yazdırdık
Böylelikle B1=C1 oldu
D1 hücresine B1-C1 yazdık sonuç sıfır oldu.
Program başka bir PC ye yüklendiğinde is sonuç sıfır olmayacak.

Şimdi enson sorduğum soruya gelelim, D1=0 koşulu doğruysa Userform1 çalışır ve program normal seyirinde devam eder.

D1=0 koşulu yanlışsa Userform2 çalışsın ve kullanıcının programı kullanamayacağı bilgisi verilsin.
 
Basit bir güvenlik önlemi olduğunun farkındayım, Sanırım Format atılınca da program çalışmamış olacak, Ama benim işimi görür,
 
CILEKESH' Alıntı:
Açıklayayım,

A1 hücresine Harddiskin seri nosunu yazdırdık,
B1 hücresine harflerden ayıklayarak sadece rakamları seçtik
C1 hücresine programın açılışında ekrana gelen userform5 vasıtasıyla b1 hücresindeki rakamı yazdırdık
Böylelikle B1=C1 oldu
D1 hücresine B1-C1 yazdık sonuç sıfır oldu.
Program başka bir PC ye yüklendiğinde is sonuç sıfır olmayacak.

Şimdi enson sorduğum soruya gelelim, D1=0 koşulu doğruysa Userform1 çalışır ve program normal seyirinde devam eder.

D1=0 koşulu yanlışsa Userform2 çalışsın ve kullanıcının programı kullanamayacağı bilgisi verilsin.
Genişletmek için tıkla ...

Kod: 
Sub Kapat()
Unload UserForm5
Sheets("Gelirler").Select
UserForm1.Show
End Sub

Bahsettiğim koşul bu koda eklenecek,
Bu kod sorgulama yapmadan Userform5 kapatıp Userform1 açıyor Koşul 0 dan farklı olursa Userform6 yı açsın örneğin.
 
CILEKESH' Alıntı:
Kod: 
Sub Kapat()
Unload UserForm5
Sheets("Gelirler").Select
UserForm1.Show
End Sub

Bahsettiğim koşul bu koda eklenecek,
Bu kod sorgulama yapmadan Userform5 kapatıp Userform1 açıyor Koşul 0 dan farklı olursa Userform6 yı açsın örneğin.
Genişletmek için tıkla ...

Merhaba
Bu kodu bununla değiştirip dener misiniz_?
Kod: 
Sub Kapat()
Unload UserForm5
Sheets("Gelirler").Select
If Sheets("Şifre").Range("D1") = 0 Then
userform1.Show
Else
userform2.Show
End If
End Sub
 
Dim fso As Object
Dim drv As Object
Set fso = CreateObject("Scripting.FileSystemObject")
Set drv = fso.Drives.Item("C")
Sheets("ŞİFRE").Range("A1") = Hex(drv.SerialNumber)
Sheets("ŞİFRE").Range("B1") = NumaraAl(Sheets("ŞİFRE").Range("A1"))
Sheets("ŞİFRE").Range("C1") = 282503 'Bu şifre her bilgisayda değişecektir.
Sheets("Hesap Özeti").Range("E3") = "=TODAY()"
Sheets("TAHAKKUKLAR").Range("A1") = "=TODAY()"
Sheets("Hesap Özeti").Range("b5") = "=TODAY()"
End Sub

Arkadaşlar merhaba, Kırmızı ile işaretlediğim kod Excel 2010 kurulu iken çalışıyordu şimdi 2007 kurdum çalışmıyor? sebebi nedir nasıl düzeltirim.?
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst