Program Yapmak | Programcılık Hakkında Her Şey | VİSUAL BASİC 6.0 | C, C++ ve C# Yazılım Dilleri | VB.NET Yazılım Dili

ActiveX DLL Yazilimi

ActiveX DLL Yazılımı
VB6.0 da ActiveX DLL yazılımına ilişkin, kolleksiyon yapısı, For...Each kullanımını aktifleştirme, özel data dosyası oluşturma ve personellere ait bilgilerin ve resimlerin bu dosyada saklanmasına ilişkin ve daha birçok püf noktanın anlatıldığı, bu döküman ve örneği incelemenizi tavsiye ederim.
DLL Yazılımı


* Bu dökümanda VB6.0'da DLL nasıl yazılır?
* Kendimize özel kayıt dosyası nasıl oluşturulur?
* Kolleksiyon yapısı nasıl oluşturulur?
* Yazdığımız DLL'i kullanan şahıslar için item erişimlerinde For...Each döngü kullanımına uyumluluk nasıl sağlanır?
* Resim bilgisinin kayıt dosyasında saklanması ve kullanımı,
* VBRUN.PropertyBag objesinin kullanımı,
* Resmin, belirtilen alana uyumlu bir şekilde kesilip ölçeklendirilmesi,
* DLL içindeki class'ların birbirleri ile iletişiminde özel fonksiyon tanımlamaları nasıl yapılır?
* Yazılan DLL'in yazılım sırasında kod kontrolü nasıl gerçekleştirilir?
konuları işlenecektir.

DLL projesinin test edildiği EXE uygulamasının ekran görüntüsü...


DLL Projesi Oluşturma


VB6.0 editöründe "Yeni Proje" (New Project) olarak karşımıza çıkan iletişim penceresinde "ActiveX DLL" seçilerek "OK" butonuna basılır. (Figür-1)


-----------Figür-1-----------

Oluşturulan yeni projede, varsayılan olarak 1 adet class (Class1) ekli olarak gelecektir. Öncelikle, proje adını "MyDLL001" olarak değiştirin. Siz bu bölümde kendi DLL isminizi verebilirsiniz! (Figür-2)


-----------Figür-2-----------

Daha sonra projede mevcut bulunan "Class1" isimli class adını "CPersons" olarak değiştirin. (Figür-3)


-----------Figür-3-----------

Projeye yeni bir class daha ekleyin. Ekleme işlemini "Project" penceresinde "MyDLL001" isimli proje adına mouse-sağ-klik işlemi ile açılan menü yardımıyla veya "Project>Add Class Module" menüsü ile de yapabilirsiniz. (Figür-4)


-----------Figür-4-----------


-----------Figür-5---------

Eklemiş olduğunuz yeni class'a "CPerson" ismini verin ve Figür-4 ve Figür-5 deki işlemleri tekrarlayarak, bir class daha ekleyip bu class ismini de "CLayout" olarak değiştirin.

Yazacağımız DLL'i test etmek için projemize "File>Add Project..." menüsünden yeni bir EXE projesi ekleyin. (Figür-6 ve Figür-7)


-----------Figür-6---------


-----------Figür-7---------

Uygulamayı çalıştırdığımızda varsayılan proje olarak "MyDLL001" projesi gözükecektir. Bu nedenle yeni eklediğimiz "Project1" isimli projeyi, başlangıçta çalışacak şekilde set etmeliyiz. Bunun için "Project" penceresinde "Project1" isimli proje adına mouse-sağ-klik işlemi ile açılan menü yardımıyla "Set as Start Up" menüsü seçilir. (Figür-8)


-----------Figür-8---------

"MyDLL001" projesinde herhangi bir class seçilerek kod penceresinde açılır ve "Project>MyDLL001 Properties..." menüsü yardımıyla, MyDLL001 isimli projenin özellikler ekranı açılır. Bu pencerede projece açıklaması ("Project Description:") bölümüne ":) MyDLL Sample Library" yazılır. Yazılan bu açıklama, yazdığımız DLL'i kullanan şahıslar "Project>References..." menüsü yardımıyla kendi yazdıkları projeye bizim DLL'i eklemek istediklerinde, açılan referans listesinde bu açıklamayı göreceklerdir. Herhangi bir açıklama girmezseniz "MyDLL001" olarak gözükeceltir. (Figür-9)


-----------Figür-9---------

Daha sonra "Project1" projesindeki formun kod pencesi açılır ve "Project>References..." menüsü yardımı ile referans penceresi açılır. Bu pencerede bilgisayarımızda yüklü olan ActiveX DLL listesi görünecek ve listede seçili olanların hemen altında bizim projenin adını göreceksiniz. Test projesi olduğu için açıklamayı değil "MyDLL001" proje adı gözükecektir. Referans olarak "Project1" e "MyDLL001" projesini işaretleyip "OK" butonuna basarak onaylayın. (Figür-10)


-----------Figür-10---------

Tüm bu işlemler bittikten sonra, "MyDLL001" isimli projede bulunan "CPersons" ve "CPerson" isimli classların "Instancing" özelliklerini "PublicNotCreated" olarak işaretleyin. (Figür-11) Bu bölümdeki seçenekleri kısaca açıklarsak;
- Private: Bu class'ın sadece bu projede kullanılabileceği, yazmış olduğumuz DLL'i kullanan şahısların bu class'a erişemeyeceği anlamına gelir.
- PublicNotCreated: Bu class'ın bu projede oluşturulabileceği, DLL'i kullanan şahısların bu class'ı görebileceği fakat "New" komutu ile oluşturamayacağı anlamına gelir. Bu şekilde tanımlanmış olan class'lar DLL'i yazan kullanıcı tarafından "Function veya Property" yoluyla diğer şahıslara ulaştırılabilir.
- MultiUse: Bu class hem kullanıcılar tarafından hem de proje içinde "New" komutu ile oluşturulabilir.
- GlobalMultiUse: DLL'i kullanan şahıslar "New" komutunu kullanmadan da bu class içindeki fonksiyon ve özelliklere direkt olarak erişebilir. Yani;


Dim objClass1 As New CPerson
objClass.Name = "Test"
'şeklinde değil

Name = "Test"
'şeklinde direkt olarak özelliğe erişebilir.



-----------Figür-11---------

CPerson


Bu class, tek bir personele ait bilgileri barındırır. Personele ait bilgilere bu class üstünden erişeceğiz. Aşağıda class'a ait kodlar sunulmuştur. Dilerseniz daha fazla özellik ekleyebilirsiniz.


Option Explicit

Dim m_nIndex        As Long
Dim m_sName         As String
Dim m_sSurName      As String
Dim m_sMobile        As String
Dim m_sTelephone    As String
Dim m_sFax          As String
Dim m_sAddress      As String
Dim m_sEmail        As String
Dim m_sDescription  As String
Dim m_objPicture    As IPicture

Public Property Get Index() As Long
    If m_nIndex = 0 Then
        VBA.Err.Raise 35605, , "This item's control has been deleted"
    End If
    Index = m_nIndex
End Property
Friend Property Let Index(ByVal newVal As Long)
    m_nIndex = newVal
End Property

Public Property Get FullName() As String
    FullName = m_sName & VBA.IIf((m_sSurName = vbNullString), vbNullString, " ") & m_sSurName
End Property

Public Property Get Name() As String
    Name = m_sName
End Property
Public Property Let Name(ByVal newVal As String)
    m_sName = newVal
End Property

Public Property Get SurName() As String
    SurName = m_sSurName
End Property
Public Property Let SurName(ByVal newVal As String)
    m_sSurName = newVal
End Property

Public Property Get Telephone() As String
    Telephone = m_sTelephone
End Property
Public Property Let Telephone(ByVal newVal As String)
    m_sTelephone = newVal
End Property

Public Property Get Fax() As String
    Fax = m_sFax
End Property
Public Property Let Fax(ByVal newVal As String)
    m_sFax = newVal
End Property

Public Property Get Mobile() As String
    Mobile = m_sMobile
End Property
Public Property Let Mobile(ByVal newVal As String)
    m_sMobile = newVal
End Property

Public Property Get Email() As String
    Email = m_sEmail
End Property
Public Property Let Email(ByVal newVal As String)
    m_sEmail = newVal
End Property

Public Property Get Address() As String
    Address = m_sAddress
End Property
Public Property Let Address(ByVal newVal As String)
    m_sAddress = newVal
End Property

Public Property Get Description() As String
    Description = m_sDescription
End Property
Public Property Let Description(ByVal newVal As String)
    m_sDescription = newVal
End Property

Public Property Get Picture() As IPicture
    Set Picture = m_objPicture
End Property
Public Property Let Picture(newVal As IPicture)
    Set m_objPicture = newVal
End Property
Public Property Set Picture(newVal As IPicture)
    Set m_objPicture = newVal
End Property


"CPerson" class'ında dikkat ettiyseniz "Index" i set ettiğimiz property "Friend" olarak tanımlanmıştır.

Friend Property Let Index(ByVal newVal As Long)
    m_nIndex = newVal
End Property

Buradaki "Friend" tanımı kısaca;
Bu DLL içindeki class'ların (veya objelerin) Index değerini değiştirmesine karşın, DLL'i kullanan şahısların bu özelliğe erişemeyecek olmalarıdır. Yani DLL'i kullanan kişiler için bu özellik "ReadOnly" sadece okunabilirdir.

CPersons


Bu class, personel eklenmesi, silinmesi ve güncellenmesi işlemlerini gerçekleştirir. Class'a ait kodlar aşağıda sunulmuştur.


Option Explicit

Dim m_coll As New VBA.Collection

Public Property Get Items(nIndex As Long) As CPerson
    Set Items = m_coll.Item(nIndex)
End Property

Public Property Get NewEnum() As IUnknown
    Set NewEnum = m_coll.[_NewEnum]
End Property

Public Property Get Count() As Long
    Count = m_coll.Count()
End Property

Public Function Add(Optional nIndex As Long, Optional sName As String, Optional sSurName As String) As CPerson
    Dim newItem As New CPerson
    Dim item1 As CPerson
    Dim i As Long
    Dim nNewIndex As Long
    
    newItem.Name = sName
    newItem.SurName = sSurName
    nNewIndex = m_coll.Count() + 1
    If nIndex > 0 And nIndex < nNewIndex Then
        newItem.Index = nIndex
        m_coll.Add newItem, , nIndex
        'sonraki item larin indexlerini düzenle
        For i = (nIndex + 1) To m_coll.Count()
            Set item1 = m_coll.Item(i)
            item1.Index = i
            Set item1 = Nothing
        Next i
    Else
        newItem.Index = nNewIndex
        m_coll.Add newItem
    End If
    Set Add = newItem
    Set newItem = Nothing
End Function

Public Sub Remove(nIndex As Long)
    Dim i As Long
    Dim item1 As CPerson
    
    Set item1 = m_coll.Item(nIndex)
    item1.Index = 0 'item is remove
    Set item1 = Nothing
    Call m_coll.Remove(nIndex)
    
    For i = nIndex To m_coll.Count
        Set item1 = m_coll.Item(i)
        item1.Index = i
        Set item1 = Nothing
    Next i
End Sub

Public Sub Clear()
    Dim item1 As CPerson
    Dim i As Long
    
    For i = 1 To m_coll.Count()
        Set item1 = m_coll.Item(1)
        item1.Index = 0
        Set item1 = Nothing
        Call m_coll.Remove(1)
    Next i
End Sub


"CPersons" class'ının genel bölümünde "Dim m_coll As New VBA.Collection" olarak tanımlanmış olan "m_coll" objesi, personel class'larını (CPerson) saklamak için kullanılır. "CPersons" class'ı Terminate olduğunda m_coll içindeki tüm class'larda yok edilecektir. (eğer CPerson üyeleri farklı bir noktada kullanılmıyorlarsa)

    Dim persons As New MyDLL001.CPersons
    Dim person As MyDLL001.CPerson

    Set person = persons.Items.Add()
    'Persons objesini Nothing'e çekiyoruz
    'fakat person objesi persons objesini
    'tuttuğu için persons objesi hiçbir zaman
    'CPersons_Terminate alt programına girmez
    Set persons = Nothing
    'person objesini Nothing'e çekiyoruz
    'person objesinin Nothing olması ile
    'persons objeside CPersons_Terminate
    'alt programına girer
    Set person = Nothing

"CPersons" class'ının "Add", "Remove" ve "Clear" bölümlerinde m_coll yapısına eklenmiş olan CPerson class'larinin Index değerleri yeniden hesaplanır. Silinen bir item için index değeri '0' (Sıfır) olarak tayin edilir. Böylece, genel yapıdan (CPersons class'ından) silinmiş olan bir CPerson üyesini kullanan bir alt program, Index değerine bakarak bu üyenin silinip-silinmediğini anlar.
"CPersons" class'ı vasıtasıyla silinen bir üye (CPerson), programın herhangi bir bölümünde kullanılmıyorsa, silme (m_coll.Remove ItemIndex) işlemi neticesinde memory alanından da kaldırılmış olur.
Fakat "CPersons"  class'ındaki herhangi bir üye, programın farklı bir alt programında kullanılıyorsa, "CPersons" class'ında tanımlı olan tüm üyeler askıda tutulur. Ancak ilgili üyenin kullanımı sona erdiğinde "CPersons" ve alt üyeleri olan "CPerson" class'ları memory alanından kaldırılır.

"CPersons" class'ındaki Items özelliği;

Public Property Get Items(nIndex As Long) As CPerson
    Set Items = m_coll.Item(nIndex)
End Property

"Tolls>Procedure Attributes..." vasıtasıyla açılan pencerde "Procedure ID" eklentisi, varsayılan (Default) olarak ayarlanır. (Figür-12) Bu bize şunu sağlar;

    Dim persons As New CPersons
    Dim person As CPerson
    
    'Normalde collection içine eklenmiş olan "CPerson"
    'üyelerine ulaşmak için "persons.Items(1)" özelliği
    'kullanılmaktadır.
    Set person = persons.Items(1)
    'Items özelliğinin "Procedure ID" eklentisi "Default"
    'yapıldığında, aşağıdaki şekilde de "CPerson" üyelerine
    'erişim sağlanabilmektedir.
    Set person = persons(1)

Not: Bir class'ta sadece bir özellik "Default" olabilir.


-----------Figür-12---------

"CPersons" class'ındaki NewEnum özelliği;

Public Property Get NewEnum() As IUnknown
    Set NewEnum = m_coll.[_NewEnum]
End Property

yazmış olduğumuz DLL'i kullanan şahıslar için "For...Each" kullanımını sağlar. Bu kullanımın sağlanması için, NewEnum özelliğinin (property veya function olabilir ve isminin NewEnum olması şart değildir.) "Tolls>Procedure Attributes..." vasıtasıyla açılan pencerde belirtilmesi gerekmektedir. (Figür-13)


    Dim persons As New CPersons
    Dim person As CPerson

    Call person.Add(,"Name1")
    Call person.Add(,"Name2")
    Call person.Add(,"Name3")
    For Each person in persons
        Debug.Print person.Name
    Next person


NewEnum özelliğinin Attribute değerleri set edilmemiş olsaydı, uygulama;

    For Each person in persons

satırında hata verecekti.


-----------Figür-13---------

"CPerson" class'ı için de "FullName" özelliğini varsayılan olarak uygun gördüm. (Figür-14)


-----------Figür-14---------

CLayout


Bu class, "CPersons" class'ına erişim için kullanılmış ve DLL'i kullanan şahıslar, sadece bu class'ı "New" yöntemi ile oluşturabilir. Ayrıca bu class, mevcut personel listesinin dosyaya kaydedlip-açılması işlemlerini de gerçekleştir. Bu class'a ait kodlar aşağıda sunulmuştur.


Option Explicit

Dim m_sCurFile As String
Dim m_objPersons As New CPersons

Public Property Get Persons() As CPersons
    Set Persons = m_objPersons
End Property

Public Function LoadFromFile(ByVal sFileName As String) As Boolean
    Dim prop1 As VBRUN.PropertyBag
    Dim nFreeFile As Integer
    Dim nFileSize As Long
    Dim bytDatas() As Byte
    Dim i As Long
    Dim nCount As Long
    Dim item1 As CPerson
    
    On Error GoTo son:
    Call m_objPersons.Clear
    nFreeFile = VBA.FreeFile()
    Open sFileName For Binary Access Read As #nFreeFile
    nFileSize = VBA.LOF(nFreeFile)
    If nFileSize > 0 Then
        Set prop1 = New VBRUN.PropertyBag
        ReDim bytDatas(nFileSize - 1)
        Get #nFreeFile, , bytDatas
        prop1.Contents = bytDatas
        nCount = prop1.ReadProperty("items.Count", 0)
        For i = 1 To nCount
            Set item1 = m_objPersons.Add()
            item1.Name = prop1.ReadProperty("item" & i & ".name", vbNullString)
            item1.SurName = prop1.ReadProperty("item" & i & ".surname", vbNullString)
            item1.Telephone = prop1.ReadProperty("item" & i & ".telephone", vbNullString)
            item1.Fax = prop1.ReadProperty("item" & i & ".fax", vbNullString)
            item1.Mobile = prop1.ReadProperty("item" & i & ".mobile", vbNullString)
            item1.Email = prop1.ReadProperty("item" & i & ".email", vbNullString)
            item1.Address = prop1.ReadProperty("item" & i & ".address", vbNullString)
            item1.Description = prop1.ReadProperty("item" & i & ".description", vbNullString)
            item1.Picture = prop1.ReadProperty("item" & i & ".picture", Nothing)
            Set item1 = Nothing
        Next i
        Set prop1 = Nothing
    End If
    m_sCurFile = sFileName
    LoadFromFile = True
son:
    If nFreeFile Then Close nFreeFile
    If Not prop1 Is Nothing Then Set prop1 = Nothing
End Function

Public Function SaveToFile(Optional ByVal sFileName As String) As Boolean
    Dim prop1 As VBRUN.PropertyBag
    Dim nFreeFile As Integer
    Dim item1 As CPerson
    Dim bytDatas() As Byte
    
    On Error GoTo son:
    If sFileName = vbNullString Then sFileName = m_sCurFile
    KillFile sFileName
    nFreeFile = VBA.FreeFile()
    Open sFileName For Binary Access Write As #nFreeFile
    
    Set prop1 = New VBRUN.PropertyBag
    Call prop1.WriteProperty("items.count", m_objPersons.Count())
    For Each item1 In m_objPersons
        Call prop1.WriteProperty("item" & item1.Index & ".name", item1.Name)
        Call prop1.WriteProperty("item" & item1.Index & ".surname", item1.SurName)
        Call prop1.WriteProperty("item" & item1.Index & ".telephone", item1.Telephone)
        Call prop1.WriteProperty("item" & item1.Index & ".fax", item1.Fax)
        Call prop1.WriteProperty("item" & item1.Index & ".mobile", item1.Mobile)
        Call prop1.WriteProperty("item" & item1.Index & ".email", item1.Email)
        Call prop1.WriteProperty("item" & item1.Index & ".address", item1.Address)
        Call prop1.WriteProperty("item" & item1.Index & ".description", item1.Description)
        Call prop1.WriteProperty("item" & item1.Index & ".picture", item1.Picture)
    Next item1
    bytDatas = prop1.Contents
    Put #nFreeFile, , bytDatas
    Debug.Print LOF(nFreeFile)
    Set prop1 = Nothing
    
    m_sCurFile = sFileName
    SaveToFile = True
son:
    If nFreeFile Then Close nFreeFile
    If Not prop1 Is Nothing Then Set prop1 = Nothing
End Function

Private Sub KillFile(ByVal sFileName As String)
    On Error GoTo son:
    Kill sFileName
son:
    If VBA.Err Then VBA.Err.Clear
End Sub


"CLayout" class'ında dosyaya yazma ve okuma işlemleri "VBARUN.PropertyBag" objesi yardımı ile sağlanır.
Örneğin;


    Dim prop1 As New VBRUN.PropertyBag
    Dim strName As String
    Dim iPic As IPicture

    strName = "Gökhan ERDOĞDU"
    'Call prop1.WriteProperty("özellikadı", özellikdeğeri)
    Call prop1.WriteProperty("Name", strName)
    'Tanımlamış olduğumuz "Name" özelliğine ait byte dizilimine "prop1.Contents" vasıtasıyla erişebiliriz.
    
    'Mesela aynı şekilde bir resim bilgisini de tanıtabliriz.
    Set iPic = LoadPicture("c:deneme.jpeg")
    Call prop1.WriteProperty("picture", iPic) 'Picture veya picture faketmez
    'Aynı şekilde tanımlamış olduğumuz "Name" ve "Picture" özelliğine ait byte dizilimine "prop1.Contents" vasıtasıyla erişebiliriz.

    'Bilgileri geri çağırmak için
    strName = prop1.ReadProperty("name", vbNullString)
    Set iPic = prop1.ReadProperty("Picture", Nothing)
    'Dikkat ederseniz özellik isimlerinde küçük-büyük harf önemli değildir.


DLL'imizi kullanan şahıslar için "CPersons" objesini "Persons" özelliği ile döndürüyoruz.
Çünkü DLL'i kullanan şahıslar "CPersons" ve "CPerson" class'larını "New" yöntemi ile oluşturamıyorlar.
Biz bu class'ları CLayout.Persons ve CPersons.Items özellikleri içinde oluşturup, kullanıcı tarafına gönderiyoruz.


Public Property Get Persons() As CPersons
    Set Persons = m_objPersons
End Property


Bundan sonraki aşamada yazmış olduğumuz DLL'i herhangi bir EXE uygulamasında nasıl kullanacağımız!

DLL'i Test Etme


"MyDLL001" isimli projeyi "File>Make prjMyDLL001.dll..." menüsü yardımıyla, DLL olarak derleyebilir ve daha sonra yeni bir (bağımsız) proje açıp, bu projede DLL olarak kullanabiliriz.

Fakat "MyDLL001" isimli projeye "Project1" isimli projeji daha önce eklemiştik ve eklemiş olduğumuz bu projeye "MyDLL001" projesini referans olarak göstermiştik. Bu bize, yazmış olduğumuz DLL'i derlemeden test etme imkanı sunar. Böylece derleyici, yazmakta olduğumuz DLL kodlarına da atlayabilir. Eklemiş olduğumuz "Project1" içindeki "Form1" formunun "Caption" bölümünü "Personel Bilgi Formu" olarak tanımlıyor ve aşağıdaki kontrolleri ekliyoruz.


1- ComboBox:
        Name = cboID
2- CommandButton(s):
        Name = cmdAdd; Caption = "Ekle"
        Name = cmdUpdate; Caption = "Güncelle"
        Name = cmdDelete; Caption = "Sil"
        Name = cmdOK; Caption = "Tamam"
        Name = cmdClose; Caption = "Kapat"
3- Frame: Name = framePersonInfo; Caption = "Personel Bilgisi"
4- TextBox(s):
        Name = txtName
        Name = txtSurname
        Name = txtTelephone
        Name = txtMobile
        Name = txtFax
        Name = txtEmail
        Name = txtAddress
        Name = txtDescription
4- PictureBox:
        Name = Picture1
5- CommonDialog:
        Name = openDLG


"Form1" e ait kodlar aşağıda sunulmuştur.

Option Explicit

Dim m_nOldIndex As Long
Dim m_objPersons As New MyDLL001.CLayout

Private Sub cboID_Click()
    Call CheckUpdate
    Call SelectPerson(VBA.Val(cboID.Text))
    cmdUpdate.Enabled = False
End Sub

Private Sub cmdAdd_Click()
    Dim item1 As MyDLL001.CPerson

    Call CheckUpdate
    Set item1 = m_objPersons.Persons.Add()
    If item1 Is Nothing Then
        MsgBox "Yeni kayıt eklenemedi!", vbExclamation, "Hata"
    Else
        Call LoadCombo(item1.Index)
        cmdOK.Enabled = True
    End If
    Set item1 = Nothing
End Sub

Private Sub cmdClose_Click()
    Unload Me
End Sub

Private Sub cmdDelete_Click()
    Dim nIndex As Long
    nIndex = VBA.Val(cboID.Text)
    Call m_objPersons.Persons.Remove(nIndex)
    Call LoadCombo(nIndex)
    cmdOK.Enabled = True
End Sub

Private Sub cmdOK_Click()
    Call m_objPersons.SaveToFile
    Unload Me
End Sub

Private Sub cmdUpdate_Click()
    Call UpdateRecord(VBA.Val(cboID.Text))
End Sub

Private Sub UpdateRecord(ByVal nIndex As Long)
    Dim item1 As MyDLL001.CPerson
    
    With m_objPersons.Persons
        If nIndex > 0 And nIndex <= .Count Then
            Set item1 = .Items(nIndex)
            With item1
                .Name = txtName.Text
                .SurName = txtSurname.Text
                .Telephone = txtTelephone.Text
                .Mobile = txtMobile.Text
                .Fax = txtFax.Text
                .Email = txtEmail.Text
                .Address = txtAdress.Text
                .Description = txtDescription.Text
                .Picture = Picture1.Picture
            End With
            Set item1 = Nothing
            cmdOK.Enabled = True
        End If
    End With
End Sub

Private Sub CheckUpdate()
    If cmdUpdate.Enabled Then
        If MsgBox("Kaydı güncellemek ister misiniz?", vbQuestion + vbYesNo, "Güncelleme") = vbYes Then
            Call UpdateRecord(m_nOldIndex)
        End If
        cmdUpdate.Enabled = False
    End If
End Sub

Private Sub Form_Load()
    Call InitGDIPlus
    Picture1.ScaleMode = vbPixels
    m_objPersons.LoadFromFile VB.App.Path & VBA.IIf((VBA.Right(VB.App.Path, 1) = ""), "", "") & "personel.dat"
    Call LoadCombo(1)
End Sub

Private Sub Form_Unload(Cancel As Integer)
    Call TermGDIPlus
End Sub

Private Sub LoadCombo(ByVal nDefault As Long)
    Dim i As Long
    Dim bSelect As Boolean
    
    Call cboID.Clear
    For i = 1 To m_objPersons.Persons.Count
        Call cboID.AddItem(i)
    Next i
    If nDefault <= 0 Then nDefault = 1
    If nDefault > cboID.ListCount Then nDefault = cboID.ListCount
    If (nDefault > 0) And (nDefault <= cboID.ListCount) Then
        bSelect = (cboID.ListIndex = (nDefault - 1))
        cboID.ListIndex = nDefault - 1
        If bSelect Then Call SelectPerson(nDefault)
    End If
End Sub

Private Sub ClearInfo()
    Dim obj1 As Control
    
    On Error Resume Next
    For Each obj1 In Me.Controls
        If obj1.Container.Name = framePersonInfo.Name Then
            Select Case VBA.TypeName(obj1)
                Case "TextBox":
                    obj1.Text = vbNullString
                Case "PictureBox":
                    Set obj1.Picture = Nothing
            End Select
        End If
    Next obj1
End Sub

Private Sub SelectPerson(ByVal nIndex As Long)
    Dim item1 As MyDLL001.CPerson
    Call ClearInfo
    
    m_nOldIndex = nIndex
    With m_objPersons.Persons
        If nIndex <= 0 Then nIndex = 1
        If nIndex > .Count Then nIndex = .Count
        If nIndex > 0 And nIndex <= .Count Then
            Set item1 = .Items(nIndex)
            With item1
                txtName.Text = .Name
                txtSurname.Text = .SurName
                txtTelephone.Text = .Telephone
                txtMobile.Text = .Mobile
                txtFax.Text = .Fax
                txtEmail.Text = .Email
                txtAdress.Text = .Address
                txtDescription.Text = .Description
                Set Picture1.Picture = .Picture
            End With
            Set item1 = Nothing
        End If
    End With
End Sub

Private Sub LoadPictureBox(ByVal sFileName As String)
    Picture1.Cls
    Call LoadThumbnailPicture(Picture1.hdc, sFileName, Picture1.ScaleWidth, Picture1.ScaleHeight)
    Set Picture1.Picture = Picture1.image
    Picture1.Refresh
End Sub
    
Private Sub Picture1_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
    Static sX As Single
    Static sY As Single
    
    If Button = 1 Then
        If sX = 0 And sY = 0 Then
            sX = X: sY = Y
        ElseIf Abs(sX - X) > 4 Or Abs(sY - Y) > 4 Then
            sX = 0: sY = 0
            If MsgBox("Resim boş olarak tanımlansın mı?", vbQuestion + vbYesNo, "Bos") = vbYes Then
                Set Picture1.Picture = Nothing
                cmdUpdate.Enabled = True
                Exit Sub
            End If
        End If
    End If
End Sub

Private Sub Picture1_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
    Dim nIndex As Long
    
    If Button = 1 Then
        nIndex = VBA.Val(cboID.Text)
        If nIndex > 0 And nIndex <= m_objPersons.Persons.Count Then
            openDLG.filename = vbNullString
            openDLG.Filter = "All Pictures (*.bmp; *.jpeg; *.jpg)|*.bmp; *.jpeg; *.jpg|BMP File (*.bmp)|*.bmp|JPEG File (*.jpg; *.jpeg)|*.jpg; *.jpeg"
            Call openDLG.ShowOpen
            If openDLG.filename <> vbNullString Then
                Call LoadPictureBox(openDLG.filename)
                cmdUpdate.Enabled = True
            End If
        End If
    End If
End Sub

Private Sub txtAdress_Change()
    cmdUpdate.Enabled = True
End Sub

Private Sub txtDescription_Change()
    cmdUpdate.Enabled = True
End Sub

Private Sub txtEmail_Change()
    cmdUpdate.Enabled = True
End Sub

Private Sub txtFax_Change()
    cmdUpdate.Enabled = True
End Sub

Private Sub txtMobile_Change()
    cmdUpdate.Enabled = True
End Sub

Private Sub txtName_Change()
    cmdUpdate.Enabled = True
End Sub

Private Sub txtSurname_Change()
    cmdUpdate.Enabled = True
End Sub

Private Sub txtTelephone_Change()
    cmdUpdate.Enabled = True
End Sub


Personel resminin yüklendiği bölümde "LoadPictureBox" fonksiyonu kullanılmıştır.
Bu fonksiyon "mdlGDIPlus" modülü içinde  tanımlanmış ve GDIPlus fonksiyonları kullanılarak resim process işlemleri yapılmıştır.
Fonksiyon kısaca, belirtilen resmi "Picture1" objesinin alanına uygunlaştırır.
Bu işlem sırasında yüklenen resmin genişlik ve yükseklik degerlerinin de "Picture1" objesinin genişlik/yükseklik oranına bağlı akalar keser (crop işlemi).
Böylece dosyada saklanacak olan resmin boyutları resmin görünümü bozulmayacak şekilde (crop işleminde ödün veriyoruz) asgari boyutlara indirilmiş olur.

mdlGDIPlus


Ayrıca personele ait resmin yüklenmesi ve uygun boyutlara getirilmesi için "mdlGDIPlus" isimli bir modülü projeye ekliyoruz.
GDIPlus apilerinin tümü için GDI Analog Saat Örneği isimli dökümanımı inceleyebilirsiniz.
B projede kullandığım GDIPlus fonksiyonları bu modülün içinde tanımlıdır.
Bu modülün kodları;


Option Explicit

Public Enum GpUnit  ' aka Unit
   UnitWorld      ' 0 -- World coordinate (non-physical unit)
   UnitDisplay    ' 1 -- Variable -- for PageTransform only
   UnitPixel      ' 2 -- Each unit is one device pixel.
   UnitPoint      ' 3 -- Each unit is a printer's point, or 1/72 inch.
   UnitInch       ' 4 -- Each unit is 1 inch.
   UnitDocument   ' 5 -- Each unit is 1/300 inch.
   UnitMillimeter ' 6 -- Each unit is 1 millimeter.
End Enum

' NOTE: Enums evaluate to a Long
Public Enum GpStatus   ' aka Status
    Ok = 0
    GenericError = 1
    InvalidParameter = 2
    OutOfMemory = 3
    ObjectBusy = 4
    InsufficientBuffer = 5
    NotImplemented = 6
    Win32Error = 7
    WrongState = 8
    Aborted = 9
    FileNotFound = 10
    ValueOverflow = 11
    AccessDenied = 12
    UnknownImageFormat = 13
    FontFamilyNotFound = 14
    FontStyleNotFound = 15
    NotTrueTypeFont = 16
    UnsupportedGdiplusVersion = 17
    GdiplusNotInitialized = 18
    PropertyNotFound = 19
    PropertyNotSupported = 20
End Enum

Public Type GdiplusStartupInput
    GdiplusVersion As Long              ' Must be 1 for GDI+ v1.0, the current version as of this writing.
    DebugEventCallback As Long          ' Ignored on free builds
    SuppressBackgroundThread As Long    ' FALSE unless you're prepared to call
                                        ' the hook/unhook functions properly
    SuppressExternalCodecs As Long      ' FALSE unless you want GDI+ only to use
                                        ' its internal image codecs.
End Type

Public Declare Function GdiplusStartup Lib "gdiplus" (token As Long, inputbuf As GdiplusStartupInput, Optional ByVal outputbuf As Long = 0) As GpStatus
Public Declare Sub GdiplusShutdown Lib "gdiplus" (ByVal token As Long)

Public Declare Function GdipCreateFromHDC Lib "gdiplus" (ByVal hdc As Long, graphics As Long) As GpStatus
Public Declare Function GdipDeleteGraphics Lib "gdiplus" (ByVal graphics As Long) As GpStatus

Public Declare Function GdipDrawImageRect Lib "gdiplus" (ByVal graphics As Long, ByVal image As Long, ByVal X As Single, ByVal Y As Single, ByVal Width As Single, ByVal Height As Single) As GpStatus
Public Declare Function GdipLoadImageFromFile Lib "gdiplus" (ByVal filename As String, image As Long) As GpStatus
Public Declare Function GdipDisposeImage Lib "gdiplus" (ByVal image As Long) As GpStatus
Public Declare Function GdipGetImageWidth Lib "gdiplus" (ByVal image As Long, Width As Long) As GpStatus
Public Declare Function GdipGetImageHeight Lib "gdiplus" (ByVal image As Long, Height As Long) As GpStatus
Public Declare Function GdipGetImagePixelFormat Lib "gdiplus" (ByVal image As Long, PixelFormat As Long) As GpStatus
Public Declare Function GdipCloneBitmapAreaI Lib "gdiplus" (ByVal X As Long, ByVal Y As Long, ByVal Width As Long, ByVal Height As Long, ByVal PixelFormat As Long, ByVal srcBitmap As Long, dstBitmap As Long) As GpStatus

Private m_nToken As Long

Public Sub LoadThumbnailPicture(ByVal hDestDC As Long, ByVal sFileName As String, ByVal nWidth As Long, ByVal nHeight As Long)
    If hDestDC = 0 Then Exit Sub
    
    Dim graphic As Long
    Dim image1 As Long
    Dim thumb1 As Long
    Dim nPixelFormat As Long
    Dim nImgW As Long, nImgH As Long
    Dim nX As Long, nY As Long, nW As Long, nH As Long
    Dim dSrcAspect As Double, dDstAspect As Double
    
    If GdipLoadImageFromFile(VBA.StrConv(sFileName, vbUnicode), image1) <> Ok Then GoTo son:
    If GdipGetImageWidth(image1, nImgW) <> Ok Then GoTo son:
    If GdipGetImageHeight(image1, nImgH) <> Ok Then GoTo son:
    '<Crop image>
        If GdipGetImagePixelFormat(image1, nPixelFormat) <> Ok Then GoTo son:
        dSrcAspect = nImgW / nImgH
        dDstAspect = nWidth / nHeight
        If dSrcAspect > dDstAspect Then
            nH = nImgH
            nW = nImgH * dDstAspect
            nX = (nImgW - nW) 2
            nY = 0
        Else
            nW = nImgW
            nH = nImgW / dDstAspect
            nX = 0
            nY = (nImgH - nH) 2
        End If
        If GdipCloneBitmapAreaI(nX, nY, nW, nH, nPixelFormat, image1, thumb1) <> Ok Then GoTo son:
    '</Crop image>
    If GdipCreateFromHDC(hDestDC, graphic) <> Ok Then GoTo son:
    If GdipDrawImageRect(graphic, thumb1, 0, 0, nWidth, nHeight) <> Ok Then GoTo son:
son:
    Call GdipDisposeImage(thumb1)
    Call GdipDisposeImage(image1)
    Call GdipDeleteGraphics(graphic)
End Sub

Public Function InitGDIPlus() As Boolean
    Dim GpInput As GdiplusStartupInput
    
    If m_nToken = 0 Then
        GpInput.GdiplusVersion = 1
        If GdiplusStartup(m_nToken, GpInput) <> Ok Then
            m_nToken = 0
            MsgBox "Error loading GDI+!", vbCritical, "Error"
        End If
    End If
    InitGDIPlus = (m_nToken <> 0)
End Function

Public Sub TermGDIPlus()
    Call GdiplusShutdown(m_nToken)
    m_nToken = 0
End Sub


Resmin kırpılma işlemi kısaca şu kriterlere göre yapılır.

    'nX, nY, nW ve nH değerleri, kırpılacak olan orjinal resmin
    'koordinat ve büyüklükleri için kullanılmıştır.
    ' Orjinal resmin genişlik / yükseklik oranı
    dSrcAspect = nImgW / nImgH
    ' Resmin yükleneceği alanın genişlik / yükseklik oranı
    dDstAspect = nWidth / nHeight
    ' iki oran karşılaştırılıyor
    If dSrcAspect > dDstAspect Then
        ' eğer orjinal oran
        ' çizilecek alanın oranından büyük ise
        ' orjinal resmin genişliği bu orana göre büyük oluyor
        ' bu nedenle orjinal resmin genişliği kırpılacak
        nH = nImgH ' yükseklik orjinal resimle aynı
        nW = nImgH * dDstAspect 'genişlik, yüklenecek olan alan oranına göre hesaplanıyor
        nX = (nImgW - nW) 2 'resim yatayda ortalanıyor
        nY = 0
    Else
        ' aynı şekilde orjinal resmin yüksekliği kırpılacak
        nW = nImgW
        nH = nImgW / dDstAspect
        nX = 0
        nY = (nImgH - nH) 2
    End If
    'nX, nY, nW ve nH değerlerine göre kırpılan orjinal resim
    'daha sonra yükleneceği alan boyutlarına scale işlemi
    'ile çiziliyor.


Program kodlarını aşağıdaki linke tıklayarak indirebilirsiniz!
Dosyayı indirmek için

Tıklayınız

Herkese iyi çalışmalar

Gökhan ERDOĞDU
Sincan Laptop tamiratı ile alakalı içeriklerin bulunduğu web siteden bilgilere ulaşabilirsiniz. Sincan'da laptop tamiratını en iyi yapan yerleri sorgulayabilirsiniz. Cihan KOÇ
=> Sen de ücretsiz bir internet sitesi kurmak ister misin? O zaman burayı tıkla! <=