Microsoft Office Excel ® Kod Kılavuzu

Microsoft Office Excel® Code Guide

1 Ocak 2004 Perşembe

Own Your File Manager

 
'UserForm1
 
'Referans List
    '1) Name: VBA, Description: Visual Basic For Applications, FullPath: C:\PROGRA~2\COMMON~1\MICROS~1\VBA\VBA7\VBE7.DLL
    '2) Name: Excel, Description: Microsoft Excel 14.0 Object Library, FullPath: C:\Program Files (x86)\Microsoft Office\Office14\EXCEL.EXE
    '3) Name: stdole, Description: OLE Automation, FullPath: C:\Windows\SysWOW64\stdole2.tlb
    '4) Name: Office, Description: Microsoft Office 14.0 Object Library, FullPath: C:\Program Files (x86)\Common Files\Microsoft Shared\OFFICE14\MSO.DLL
    '5) Name: MSForms, Description: Microsoft Forms 2.0 Object Library, FullPath: C:\Windows\SysWOW64\FM20.DLL
    '6) Name: MSComctlLib, Description: Microsoft Windows Common Controls 6.0 (SP6), FullPath: C:\Windows\SysWow64\MSCOMCTL.OCX
'AddTools on UserForm1:
    '1) Frame1
    '2) Frame1 \ Label1, Label2, Label3
    '3) Label4, TextBox1, TextBox2
    '4) TreeView1, ListView1
    '5) ImageList1

Option Explicit
Dim Ekran As New Class1
Private Sub UserForm_Initialize()
    On Error Resume Next
    Me.Caption = "[PBİD®] Make Your Own File Manager..."
    Call Resimlik_Kur
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set Ekran.Ekran1 = Me
    Call Ekran_Kur
    Call Directory_Plan
End Sub
Private Sub UserForm_Resize()

    On Error Resume Next
    If Me.Width = 498 Then
        Label1.Enabled = False
        Label2.Enabled = False
        Label3.Enabled = False
        Me.Move (Application.UsableWidth - Me.Width) / 2, (Application.UsableHeight - Me.Height) / 2
    Else
        Label1.Enabled = True
        Label2.Enabled = True
        Label3.Enabled = True
    End If
    Frame1.Width = Me.InsideWidth
    TextBox1.Width = (Me.Width - 60) * 3 / 4
    With TextBox2
        .Left = TextBox1.Left + TextBox1.Width
        .Width = (Me.Width - 60) * 1 / 4
    End With
    With TreeView1
        .Width = 360
        .Height = Me.InsideHeight - .Top
    End With
    With ListView1
        .Left = TreeView1.Left + 360
        .Width = Me.InsideWidth - .Left
        .Height = Me.InsideHeight - .Top
    End With
End Sub
Private Sub Frame1_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal Y As Single)

    On Error Resume Next
    Call Menu_Format
End Sub
Private Sub Label1_Click()

    On Error Resume Next
    CB1 Me.Left + 2.25 + 18, Me.Top + 2.25 + 46, 1
End Sub
Private Sub Label1_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal Y As Single)

    On Error Resume Next
    Call Menu_Format
    With Label1
        .BackColor = &HC0E0FF
        .BackStyle = fmBackStyleOpaque
        .BorderStyle = fmBorderStyleSingle
        .BorderColor = &HC00000
    End With
End Sub
Private Sub Label2_Click()

    On Error Resume Next
    CB2 Me.Left + 2.25 + 89, Me.Top + 2.25 + 46, 1
End Sub
Private Sub Label2_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal Y As Single)

    On Error Resume Next
    Call Menu_Format
    With Label2
        .BackColor = &HC0E0FF
        .BackStyle = fmBackStyleOpaque
        .BorderStyle = fmBorderStyleSingle
        .BorderColor = &HC00000
    End With
End Sub
Private Sub Label3_Click()

    On Error Resume Next
    CB3 Me.Left + 2.25 + 161, Me.Top + 2.25 + 46, 1
End Sub
Private Sub Label3_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal Y As Single)

    On Error Resume Next
    Call Menu_Format
    With Label3
        .BackColor = &HC0E0FF
        .BackStyle = fmBackStyleOpaque
        .BorderStyle = fmBorderStyleSingle
        .BorderColor = &HC00000
    End With
End Sub
Private Sub TreeView1_Click()

    On Error GoTo Hata:
    hFolder = TreeView1.SelectedItem.FullPath
    hFolder = VBA.Right(hFolder, VBA.Len(hFolder) - 3)
    TextBox1.Value = hFolder
    Call File_Plan
    Call SubDirectory_Plan
Hata:
End Sub
Private Sub ListView1_Click()

    On Error GoTo Hata
    TextBox2.Value = ListView1.SelectedItem.Text
    Exit Sub
Hata:
    TextBox2.Value = ""
End Sub
Private Sub ListView1_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As stdole.OLE_XPOS_PIXELS, ByVal Y As stdole.OLE_YPOS_PIXELS)

    On Error GoTo Hata
    If Button = 2 Then CB2 x + ListView1.Left, Y + ListView1.Top, 3
    Exit Sub
Hata:
    TextBox2.Value = ""
End Sub
Private Sub TreeView1_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As stdole.OLE_XPOS_PIXELS, ByVal Y As stdole.OLE_YPOS_PIXELS)

    On Error Resume Next
    If Button = 2 Then CB2 x + TreeView1.Left, Y + TreeView1.Top, 2
End Sub
Sub Resimlik_Kur()

    On Error Resume Next
    Set CB(1) = Application.CommandBars.Add("", msoBarPopup, , True)
    Set CBB(1) = CB(1).Controls.Add(1, , , , True)
    Set CBB(2) = CB(1).Controls.Add(1, , , , True)
    Set CBB(3) = CB(1).Controls.Add(1, , , , True)
    CBB(1).FaceId = 720
    CBB(2).FaceId = 23
    CBB(3).FaceId = 764
    With ImageList1
        .ListImages.Clear
        .ListImages.Add 1, "Kapalı", CBB(1).Picture
        .ListImages.Add 2, "Açık", CBB(2).Picture
        .ListImages.Add 3, "Git", CBB(3).Picture
    End With
    Set CB(1) = Nothing
    Set CBB(1) = Nothing
    Set CBB(2) = Nothing
    Set CBB(3) = Nothing
End Sub
Sub Directory_Plan()
    On Error Resume Next
    Set ScrhFolder = FSO.GetFolder("c:\")
    hNumber = 0
    hRepeat = 0
    hNodeKey = "Key_" & hNumber
    Label4.Caption = hNumber + 1
    hNumber = hNumber + 1
    With TreeView1
        .Nodes.Add , , hNodeKey, "C:", "Kapalı", "Açık"
        .Nodes(hNodeKey).Expanded = True
    End With
    For Each hFolder1 In ScrhFolder.SubFolders
        hParentLong = VBA.Len(hFolder)
        hNodeLong = VBA.Len(hFolder1)
        hNodeName = VBA.Right(hFolder1, (hNodeLong - hParentLong))
        hNodeKey = "Key_" & hNumber
        Label4.Caption = hNumber + 1
        hNumber = hNumber + 1
        hParentKey = "Key_0"
        With TreeView1
            .Nodes.Add hParentKey, 4, hNodeKey, hNodeName, "Kapalı", "Açık"
            .Nodes(hNodeKey).Expanded = True
            .Nodes(hNodeKey).BackColor = VBA.RGB(242, 242, 242)
        End With
    Next hFolder1
    On Error GoTo 10
10: With TreeView1
11:     hTotal = .Nodes.Count
13:     If hTotal > 10 Then Exit Sub
14:     If hTotal = hRepeat Then Exit Sub
15:     For hCounter = 1 To hTotal
16:         Set hParent = .Nodes(hCounter)
17:         If hParent.Children = 0 Then
18:             .Nodes(hCounter).ForeColor = vbBlue
19:             hFolder = hParent.FullPath
20:             Set ScrhFolder = FSO.GetFolder(hFolder)
21:             On Error GoTo 36
22:             If hFolder = "C:\System Volume Information" Then GoTo 36
23:             For Each hFolder1 In ScrhFolder.SubFolders
24:                 hParentLong = VBA.Len(hFolder) + 1
25:                 hNodeLong = VBA.Len(hFolder1)
26:                 hNodeName = VBA.Right(hFolder1, (hNodeLong - hParentLong))
27:                 hNodeKey = "Key_" & hNumber: Label4.Caption = hNumber + 1: hNumber = hNumber + 1
28:                 hParentKey = hParent.Key
29:                 With TreeView1
30:                     .Nodes.Add hParentKey, 4, hNodeKey, hNodeName, "Kapalı", "Açık"
31:                     .Nodes(hNodeKey).Expanded = True
32:                 End With
33:             Next hFolder1
34:         Else
35:             .Nodes(hCounter).ForeColor = &H404000
36:         End If
37:         If hCounter = hTotal Then GoTo 11
38:         DoEvents
39:         hRepeat = hTotal
40:     Next hCounter
41:     Label4.Caption = " " & "Mustafa ULUSARAÇ
01ulusarac@superonline.com"
42: End With
End Sub
Private Sub SubDirectory_Plan()

    On Error Resume Next
    Dim x As Integer
    If TreeView1.SelectedItem.Children > 0 Then
        For x = 1 To TreeView1.SelectedItem.Children
            TreeView1.Nodes.Remove TreeView1.SelectedItem.Child.Index
            VBA.DoEvents
            Me.Repaint
        Next x
    End If
    On Error GoTo Hata
    hFolder = TreeView1.SelectedItem.FullPath
    hFolder = VBA.Right(hFolder, VBA.Len(hFolder) - 3)
    Set ScrhFolder = FSO.GetFolder(hFolder)
    For Each hFolder1 In ScrhFolder.SubFolders
        hParentLong = VBA.Len(hFolder)
        hNodeLong = VBA.Len(hFolder1)
        hNodeName = VBA.Right(hFolder1, (hNodeLong - hParentLong))
        hNumber = VBA.Val(Label4.Caption) + 1
        hNodeKey = "Key_" & hNumber
        Label4.Caption = hNumber + 1
        hNumber = hNumber + 1
        hParentKey = TreeView1.SelectedItem.Key
        With TreeView1
            .Nodes.Add hParentKey, 4, hNodeKey, hNodeName, "Kapalı", "Açık"
            .Nodes(hNodeKey).Expanded = True
            .Nodes(hNodeKey).BackColor = VBA.RGB(242, 242, 242)
        End With
    Next hFolder1
    Exit Sub
Hata:
    VBA.Err.Clear
End Sub
Sub File_Plan()

    On Error Resume Next
    hNumber = 1
    Set ScrhFolder = Nothing
    Set ScrhFolder = FSO.GetFolder(hFolder)
    If FSO.FolderExists(ScrhFolder) = False Then
        MsgBox "Geçerli Klasör Yolu Tanımladığınızdan Emin Olun." & vbCrLf & vbCrLf & "Mustafa ULUSARAÇ
01ulusarac@superonline.com", vbInformation, "[PBİD®]Lütfen Dikkat!!!"
        End
    End If
    With ListView1
        .ListItems.Clear
        If VBA.IsError(ScrhFolder.Files) = True Then Exit Sub
        For Each ScrFile In ScrhFolder.Files
            .ListItems.Add hNumber, "Key:" & hNumber, ScrFile.Name, Icon:="Git"
            .ListItems(hNumber).ListSubItems.Add 1, "Key:" & hNumber & "1", VBA.Format(ScrFile.DateLastModified, "dd.mmm.yyyy")
            .ListItems(hNumber).ListSubItems.Add 2, "Key:" & hNumber & "2", ScrFile.Size
            .ListItems(hNumber).ListSubItems.Add 3, "Key:" & hNumber & "3", ScrFile.Attributes
            .ListItems(hNumber).ListSubItems.Add 4, "Key:" & hNumber & "4", ScrFile.Type
            .ListItems(hNumber).EnsureVisible
            hNumber = hNumber + 1
        Next ScrFile
    End With
End Sub
Sub Menu_Format()

    On Error Resume Next
    With Label1
        .BackStyle = fmBackStyleTransparent
        .BorderStyle = fmBorderStyleNone
    End With
    With Label2
        .BackStyle = fmBackStyleTransparent
        .BorderStyle = fmBorderStyleNone
    End With
    With Label3
        .BackStyle = fmBackStyleTransparent
        .BorderStyle = fmBorderStyleNone
    End With
End Sub
Sub Ekran_Kur()

    On Error Resume Next
    With Me
        .BackColor = VBA.RGB(242, 242, 242)
        With Frame1
            .Caption = ""
            .BackColor = VBA.RGB(242, 242, 242)
            .BorderStyle = fmBorderStyleNone
            .SpecialEffect = fmSpecialEffectFlat
            .Left = 0
            .Top = 0
            .Height = 24
            .Width = Me.Width
            With Label1
                .Left = 6
                .Top = 6
                .Height = 12
                .Width = 36
                .SpecialEffect = fmSpecialEffectFlat
                .BackStyle = fmBackStyleTransparent
                .BorderStyle = fmBorderStyleNone
                .Caption = "File"
                .TextAlign = fmTextAlignCenter
            End With
            With Label2
                .Left = 48
                .Top = 6
                .Height = 12
                .Width = 36
                .SpecialEffect = fmSpecialEffectFlat
                .BackStyle = fmBackStyleTransparent
                .BorderStyle = fmBorderStyleNone
                .Caption = "Edit"
                .TextAlign = fmTextAlignCenter
            End With
            With Label3
                .Left = 90
                .Top = 6
                .Height = 12
                .Width = 36
                .SpecialEffect = fmSpecialEffectFlat
                .BackStyle = fmBackStyleTransparent
                .BorderStyle = fmBorderStyleNone
                .Caption = "Help"
                .TextAlign = fmTextAlignCenter
            End With
        End With
        With Label4
            .Left = 0
            .Top = 24
            .Height = 18
            .Width = 60
            .SpecialEffect = fmSpecialEffectFlat
            .Picture = ImageList1.ListImages(2).Picture
            .PicturePosition = fmPicturePositionLeftCenter
            .ControlTipText = "Folder"
            .Caption = ""
            .TextAlign = fmTextAlignCenter
            .Font.Name = "Arial Narrow"
            .Font.Size = 8
        End With
        With TextBox1
            .Left = Label4.Left + Label4.Width
            .Top = 24
            .Height = 18
            .Width = (Me.InsideWidth - 60) * 3 / 4
            .SpecialEffect = fmSpecialEffectFlat
            .BackStyle = fmBackStyleTransparent
            .ForeColor = vbBlue
            .Font.Name = "Arial Nrrow"
            .Font.Size = 10
        End With
        With TextBox2
            .Left = TextBox1.Left + TextBox1.Width
            .Top = 24
            .Height = 18
            .Width = (Me.InsideWidth - 60) * 1 / 4
            .SpecialEffect = fmSpecialEffectFlat
            .BackStyle = fmBackStyleTransparent
            .ForeColor = vbBlue
            .Font.Name = "Arial Nrrow"
            .Font.Size = 10
        End With
        With TreeView1
            .Left = 0
            .Top = 42
            .Height = Me.InsideHeight - .Top
            .Width = 360
            .FullRowSelect = False
            .GetVisibleCount
            .LineStyle = tvwRootLines
            .Style = tvwTreelinesPlusMinusPictureText
            .ImageList = ImageList1
            .Appearance = ccFlat
            .BorderStyle = ccNone
        End With
        With ListView1
            .Left = 360
            .Top = 42
            .Width = Me.InsideWidth - 360
            .Height = Me.InsideHeight - .Top
            .Appearance = ccFlat
            .BorderStyle = ccNone
            .MultiSelect = True
            Set .Icons = ImageList1
            .Gridlines = True
            .View = lvwReport
            .FullRowSelect = True
            With .ColumnHeaders
                .Add , , "Dosya Adı", 120
                .Add , , "Tarih", 54, 2
                .Add , , "Byt", 60, 1
                .Add , , "Attiributes", 60, 1
                .Add , , "Type", 60, 0
                .Add , , "...", 24, 0
            End With
            .ForeColor = &H404000
            .BackColor = VBA.RGB(242, 242, 242)
        End With
    End With
End Sub
 
'Module1
 
Option Explicit
Public CB(1 To 12) As Office.CommandBar
Public CBB(1 To 120) As Office.CommandBarButton
Public hCounter As Double, hNumber As Double, hTotal As Double, hRepeat As Double
Public hFile, hFolder, hFolder1
Public FSO, ScrhFolder, ScrhFolder1, ScrFile
Public hParent As Node
Public hNodeName As Variant, hNodeKey As Variant, hParentKey As Variant
Public hNodeLong As Double, hParentLong As Double
Public Sub FormAç()
    On Error Resume Next
    Load UserForm1
End Sub
'Menü Kurgu
Public Function CB1(ByVal hLeft As Variant, ByVal hTop As Variant, ByVal Kaynak As Variant)

    On Error Resume Next
    Set CB(1) = Application.CommandBars.Add("", msoBarPopup, , True)
    With CB(1)
        Set CBB(1) = .Controls.Add(1, , , , True)
        With CBB(1)
            .BeginGroup = True
            .Caption = "Open File"
            .FaceId = 23
            .Enabled = True
            .OnAction = "Cmd_OpenFile"
        End With
        Set CBB(2) = .Controls.Add(1, , , , True)
        With CBB(2)
            .BeginGroup = False
            .Caption = "ReFresh"
            .FaceId = 720
            .Enabled = True
            .OnAction = "Cmd_ReFresh"
        End With
        Set CBB(3) = .Controls.Add(1, , , , True)
        With CBB(3)
            .BeginGroup = True
            .Caption = "Close"
            .FaceId = 1640
            .Enabled = True
            .OnAction = "Cmd_Close"
        End With
        .ShowPopup hLeft, hTop
        .Delete
    End With
End Function
Public Function CB2(ByVal hLeft As Variant, ByVal hTop As Variant, ByVal Kaynak As Variant)
    On Error Resume Next
    Set CB(2) = Application.CommandBars.Add("", msoBarPopup, , True)
    With CB(2)
        Set CBB(1) = .Controls.Add(1, , , , True)
        With CBB(1)
            .BeginGroup = True
            .Caption = "lvwIcon"
            .FaceId = 3053
            If Kaynak = 2 Then
                .Enabled = False
            Else
                .Enabled = True
            End If
            .OnAction = "Cmd_lvwIcon"
        End With
        Set CBB(2) = .Controls.Add(1, , , , True)
        With CBB(2)
            .BeginGroup = False
            .Caption = "lvwList"
            .FaceId = 3873
            If Kaynak = 2 Then
                .Enabled = False
            Else
                .Enabled = True
            End If
            .OnAction = "Cmd_lvwList"
        End With
        Set CBB(3) = .Controls.Add(1, , , , True)
        With CBB(3)
            .BeginGroup = False
            .Caption = "lvwReport"
            .FaceId = 1958
            If Kaynak = 2 Then
                .Enabled = False
            Else
                .Enabled = True
            End If
            .OnAction = "Cmd_lvwReport"
        End With
        Set CBB(4) = .Controls.Add(1, , , , True)
        With CBB(4)
            .BeginGroup = False
            .Caption = "lvwSmallIcon"
            .FaceId = 3052
            If Kaynak = 2 Then
                .Enabled = False
            Else
                .Enabled = True
            End If
            .OnAction = "Cmd_lvwSmallIcon"
        End With
        Set CBB(5) = .Controls.Add(1, , , , True)
        With CBB(5)
            .BeginGroup = True
            .Caption = "Cut"
            .FaceId = 7026
            If Kaynak = 1 Then
                .Enabled = False
            Else
                .Enabled = True
            End If
            If Kaynak = 2 Then
                .OnAction = "Cmd_CutTree"
            Else
                .OnAction = "Cmd_CutList"
            End If
        End With
        Set CBB(6) = .Controls.Add(1, , , , True)
        With CBB(6)
            .BeginGroup = False
            .Caption = "Copy"
            .FaceId = 1641
            If Kaynak = 1 Then
                .Enabled = False
            Else
                .Enabled = True
            End If
            If Kaynak = 2 Then
                .OnAction = "Cmd_CopyTree"
            Else
                .OnAction = "Cmd_CopyList"
            End If
        End With
        Set CBB(7) = .Controls.Add(1, , , , True)
        With CBB(7)
            .BeginGroup = False
            .Caption = "Paste"
            .FaceId = 5985
            If Kaynak = 1 Then
                .Enabled = False
            Else
                .Enabled = True
            End If
            If Kaynak = 2 Then
                .OnAction = "Cmd_PasteTree"
            Else
                .OnAction = "Cmd_PasteList"
            End If
        End With
        Set CBB(8) = .Controls.Add(1, , , , True)
        With CBB(8)
            .BeginGroup = True
            .Caption = "Delete"
            .FaceId = 1671
            If Kaynak = 1 Then
                .Enabled = False
            Else
                .Enabled = True
            End If
            If Kaynak = 2 Then
                .OnAction = "Cmd_DeleteTree"
            Else
                .OnAction = "Cmd_DeleteList"
            End If
        End With
        Set CBB(9) = .Controls.Add(1, , , , True)
        With CBB(9)
            .BeginGroup = False
            .Caption = "New Folder"
            .FaceId = 1589
            If Kaynak = 1 Or Kaynak = 3 Then
                .Enabled = False
            Else
                .Enabled = True
            End If
            .OnAction = "Cmd_NewFolder"
        End With
        .ShowPopup hLeft, hTop
        .Delete
    End With
End Function
Public Function CB3(ByVal hLeft As Variant, ByVal hTop As Variant, ByVal Kaynak As Variant)

    On Error Resume Next
    Set CB(3) = Application.CommandBars.Add("", msoBarPopup, , True)
    With CB(3)
        Set CBB(1) = .Controls.Add(1, , , , True)
        With CBB(1)
            .BeginGroup = True
            .Caption = "Help"
            .FaceId = 983
            .Enabled = True
            .OnAction = "Cmd_Help"
        End With
        .ShowPopup hLeft, hTop
        .Delete
    End With
End Function
'Menü1 Komutları
Private Sub Cmd_OpenFile()

    On Error Resume Next
    MsgBox "Cmd_OpenFile"
End Sub
Private Sub Cmd_ReFresh()

    On Error Resume Next
    MsgBox "Cmd_ReFresh"
End Sub
Private Sub Cmd_Close()

    On Error Resume Next
    Unload UserForm1
End Sub
'Menü2 Komutları
Private Sub Cmd_lvwIcon()

    On Error Resume Next
    UserForm1.ListView1.View = lvwIcon
End Sub
Private Sub Cmd_lvwList()

    On Error Resume Next
    UserForm1.ListView1.View = lvwList
End Sub
Private Sub Cmd_lvwReport()

    On Error Resume Next
    UserForm1.ListView1.View = lvwReport
End Sub
Private Sub Cmd_lvwSmallIcon()

    On Error Resume Next
    UserForm1.ListView1.View = lvwSmallIcon
End Sub
Private Sub Cmd_CutTree()

    On Error Resume Next
    MsgBox "Cmd_CutTree"
End Sub
Private Sub Cmd_CutList()

    On Error Resume Next
    MsgBox "Cmd_CutList"
End Sub
Private Sub Cmd_CopyTree()

    On Error Resume Next
    MsgBox "Cmd_CopyTree"
End Sub
Private Sub Cmd_CopyList()

    On Error Resume Next
    MsgBox "Cmd_CopyList"
End Sub
Private Sub Cmd_PasteTree()

    On Error Resume Next
    MsgBox "Cmd_PasteTree"
End Sub
Private Sub Cmd_PasteList()

    On Error Resume Next
    MsgBox "Cmd_PasteList"
End Sub
Private Sub Cmd_DeleteTree()

    On Error GoTo Hata
    hFolder = UserForm1.TextBox1.Value
    If hFolder = "" Then
        MsgBox "Lütfen geçerli bir KLASÖR' üişaretleyiniz?" & vbCrLf & vbCrLf & "Mustafa ULUSARAÇ 01ulusaracqsuperonline.com", vbInformation, "[PBİD®] Lütfen dikkat!!!"
    Else
        If MsgBox(hFolder & vbCrLf & "KLASÖR'ünü SİLME devam etmek istiyor musunuz?" & vbCrLf & vbCrLf & "Mustafa ULUSARAÇ 01ulusaracqsuperonline.com", vbOKCancel, "[PBİD®] Lütfen dikkat!!!") = vbOK Then
            Set ScrhFolder = FSO.GetFolder(hFolder)
            ScrhFolder.Delete
        End If
    End If
    Exit Sub
Hata:
    MsgBox "KLASÖR içinde silinemez dosya olabilir veya geçerli KLASÖR'ü seçtiğinizden emin olun." & vbCrLf & vbCrLf & "Mustafa ULUSARAÇ
01ulusarac@superonline.com", vbInformation, "[PBİD®]Lütfen Dikkat!!!"
End Sub
Private Sub Cmd_DeleteList()

    On Error GoTo Hata
    Dim TamYol As Variant
    hFolder = UserForm1.TextBox1.Value
    hFile = UserForm1.TextBox2.Value
    TamYol = hFolder & "\" & hFile
    If hFile = "" Or hFolder = "" Then
        MsgBox "Lütfen geçerli bir DOSYA'yı işaretleyiniz?" & vbCrLf & vbCrLf & "Mustafa ULUSARAÇ 01ulusaracqsuperonline.com", vbInformation, "[PBİD®] Lütfen dikkat!!!"
    Else
        If MsgBox(hFile & vbCrLf & "DOSYA'yı SİLME devam etmek istiyor musunuz?" & vbCrLf & vbCrLf & "Mustafa ULUSARAÇ 01ulusaracqsuperonline.com", vbOKCancel, "[PBİD®] Lütfen dikkat!!!") = vbOK Then
            Set ScrFile = FSO.GetFile(TamYol)
            ScrFile.Delete
            hFolder = UserForm1.TreeView1.SelectedItem.FullPath
            If hFolder = "C:" Then hFolder = "C:\"
            UserForm1.TextBox1.Value = hFolder
            UserForm1.TextBox2.Value = ""
            'Call UserForm1.DosyaEnvanteri
        End If
    End If
    Exit Sub
Hata:
    MsgBox "Silinemez bir DOSYA olabilir veya geçerli DOSYA'yıseçtiğinizden emin olun." & vbCrLf & vbCrLf & "Mustafa ULUSARAÇ
01ulusarac@superonline.com", vbInformation, "[PBİD®]Lütfen Dikkat!!!"
End Sub
Private Sub Cmd_NewFolder()

    On Error Resume Next
    MsgBox "Cmd_NewFolder"
End Sub
'Menü3 Komutları
Private Sub Cmd_Help()
    On Error Resume Next
    MsgBox "Cmd_Help"
End Sub'Sub References_List()
'    On Error Resume Next
'    Dim Eleman, hNumber
'    hNumber = 1
'    For Each Eleman In ThisWorkbook.VBProject.References
'        Sheets(1).Cells(hNumber, 1) = hNumber & ") Name: "
'        Sheets(1).Cells(hNumber, 2) = Eleman.Name
'        Sheets(1).Cells(hNumber, 3) = ", Description: "
'        Sheets(1).Cells(hNumber, 4) = Eleman.Description
'        Sheets(1).Cells(hNumber, 5) = ", FullPath: "
'        Sheets(1).Cells(hNumber, 6) = Eleman.FullPath
'        hNumber = hNumber + 1
'    Next Eleman
'End Sub
 
'Class1
 
Option Explicit
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function FindWindowA Lib "user32" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
Private Declare Function GetWindowLongA Lib "user32" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Declare Function SetWindowLongA Lib "user32" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Declare Function ShowWindow Lib "user32" (ByVal hwnd As Long, ByVal nCmdShow As Long) As Long
Private Declare Function DrawMenuBar Lib "user32" (ByVal hwnd As Long) As Long
Dim PENCERE As Long, TARZ As Long
Public Property Set Ekran1(objForm As Object)
    On Error Resume Next
    PENCERE = FindWindow(vbNullString, objForm.Caption)
    TARZ = GetWindowLong(PENCERE, (-16)) Or &H80000 Or &H20000 Or &H10000
    SetWindowLong PENCERE, (-16), TARZ
    ShowWindow PENCERE, 3
    DrawMenuBar PENCERE
End Property
 


Blog Arşivi

Bu gadget'ta bir hata oluştu

Bu Blogda Ara

Contributor

Contributor
Mustafa ULUSARAÇ İstanbul, TÜRKİYE
free counters
T. C. Central Bank Indicative Exchange Rates
Currency Exchange Rate Widget,Currency Converter Widget
Borsa İstanbul