Malicious Office (OOXML) — malware analysis report

Static analysis result for SHA-256 6cb9e96409846575…

MALICIOUS

Office (OOXML)

73.7 KB Created: 2020-08-25 13:34:43 UTC Authoring application: Microsoft Excel 16.0300 First seen: 2021-01-23
MD5: f2487ee7b1a1ba7215a967559482a5cd SHA-1: e56809cba9c900c22e12a5cd626dc7c2aac1b829 SHA-256: 6cb9e96409846575b061294e0217e3743a44fae01617fa85ed2d5037d734bf58
210 Risk Score

Heuristics 7

  • VBA project inside OOXML medium 5 related findings OOXML_VBA
    Document contains a VBA project — VBA macros present (project part renamed away from vbaProject.bin: xl/printerSettings.bin)
  • WScript.Shell usage critical OLE_VBA_WSCRIPT
    WScript.Shell usage
    Matched line in script
      Set myWS = CreateObject("WScript.Shell")
  • VBA project part renamed to evade filename detection high OOXML_VBA_PROJECT_RENAMED
    The VBA project is bound through the OOXML relationship/content type but its part is not named vbaProject.bin. Legitimate Office producers always emit vbaProject.bin; renaming it hides the macros from path-only scanners (observed in the SVCReady loader).
  • CreateObject call high OLE_VBA_CREATEOBJ
    CreateObject call
    Matched line in script
        Set Enc = CreateObject("System.Text.UTF8Encoding")
  • GetObject call high OLE_VBA_GETOBJ
    GetObject call
    Matched line in script
    Set wmi = GetObject("WinMgmts:")
  • Environ() call (env variable access) low OLE_VBA_ENVIRON
    Environ() call (env variable access)
    Matched line in script
        computerid = Left(Environ$("computername"), 2) & Left(serial, 4) & Left(cpu, 4)
  • Embedded URL info EMBEDDED_URL
    One or more URLs were extracted from the document. The URL itself is not a detection — see the per-URL labels for which channel (macro, JS, link annotation, document body, ...) reached each URL.
    URL http://www.planlamamuhendisi.com/lisans.html In document text (OOXML body / shared strings)
    • http://planlamamuhendisi.comIn document text (OOXML body / shared strings)
    • http://planlamamuhendisi.com�In document text (OOXML body / shared strings)
    • http://www.planlamamuhendisi.com/lisans.html�In document text (OOXML body / shared strings)
    • https://www.linkedin.com/in/ggeciciIn document text (OOXML body / shared strings)

Extracted artifacts 3

Files carved from inside the sample during analysis.

FilenameKindSourceSize
macros.bas vba-macro oletools.olevba.extract_macros (decoded VBA source from OOXML) 29868 bytes
SHA-256: 3fe94ed4416f0c4361d5c9cafe44644492785681282e746f4f2b20500b83dea7
Preview script
First 1,000 lines of the extracted script
Attribute VB_Name = "BuÇalışmaKitabı"
Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = True
Attribute VB_TemplateDerived = False
Attribute VB_Customizable = True

Attribute VB_Name = "Sayfa1"
Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = True
Attribute VB_TemplateDerived = False
Attribute VB_Customizable = True

Attribute VB_Name = "Module1"
'--------------------------------------------------------------------------------------------------------'
'Eklenti İsmi: Excel WBS Renklendir v1' Update: 16.10.2020
'--------------------------------------------------------------------------------------------------------'
'Açıklama: Primavera ve MS Project uygulamalarından aktarılmış WBS düzenini kırılımlara göre renklendirme ve gruplama yaparak daha görsel ve kullanışlı hale getirmenize yardımcı olur.'
'--------------------------------------------------------------------------------------------------------'
'E-Mail: gurkangecici@gmail.com'
'--------------------------------------------------------------------------------------------------------'
Option Compare Text

Sub FollowingHyperlink()
    Application.ScreenUpdating = False
    
    If Not ActiveWorkbook Is Nothing Then
        ActiveWorkbook.FollowHyperlink Address:="http://www.planlamamuhendisi.com/lisans.html", NewWindow:=True
    Else
        
        Workbooks.Add
        ActiveWorkbook.FollowHyperlink Address:="http://www.planlamamuhendisi.com/lisans.html", NewWindow:=True
        Workbooks.Close
        
    End If
    
End Sub

Sub Browse()
    'MsgBox "Lütfen bir dosya açınız!"
    MsgBox "Please open a file!"
    
End Sub
Sub DeleteBlankRows()

Dim x As Long

With ActiveSheet

    For x = .Cells.SpecialCells(xlCellTypeLastCell).Row To 1 Step -1
        If WorksheetFunction.CountA(.Rows(x)) = 0 Then
            ActiveSheet.Rows(x).Delete
        End If
    Next

End With

End Sub

Sub Delete_Columns()
    
    Dim C As Integer
    
    C = ActiveSheet.Cells.SpecialCells(xlLastCell).Column
    
    Do Until C = 0
        
        If WorksheetFunction.CountA(Columns(C)) = 0 Then
            
            Columns(C).Delete
            
        End If
        
        C = C - 1
        
    Loop
    
End Sub

Public Sub cccolorizer(ByRef control As Office.IRibbonControl)
    
    Application.ScreenUpdating = False
    
    Dim i           As Long, r1 As Range, r2 As Range
    Dim d1          As Range
    Dim rng_cells   As Range
    Dim rng_start   As Range
    Dim rng_end     As Range
    Dim Hucre       As String
    Dim Lastrow     As Long
    Dim Lastcol     As Long
    Dim k           As Integer
    Dim x           As Integer
    Dim colnum      As Integer
    Dim colnum2     As Integer
    Dim dblmax      As Integer
    Dim coletter    As String
    Dim lastcoletter    As String
    Dim coletter2   As String
    Dim colrng      As Range
    Dim validc As String
    Dim tmp         As String
    Dim serial      As String
    Dim requestid   As String
    Dim requestid2  As String
    Dim actid       As String
    Dim cpu         As String
    Dim computerid  As String
    
    Dim myRegKey    As String
    Dim myValue     As String
    Dim myAnswer    As Integer
    
    serial = MBSerialNumber()
    cpu = CpuId()
    
    computerid = Left(Environ$("computername"), 2) & Left(serial, 4) & Left(cpu, 4)
    
    requestid = Trim(Left(cpu, 2) & Mid(serial, 2) & Left(cpu, 3) & Left(serial, 2) & Right(serial, 3) & Mid(cpu, 3))
    
    
    myRegKey = "HKEY_CURRENT_USER\SOFTWARE\WBSRenklendir\WBSRenklendir"
    
    validc = StrReverse(SHA1(StrReverse(EncodeBase64(requestid))))
   
    actid = Left(Trim(validc), 5) & "-" & Mid(validc, 12, 5) & "-" & Mid(validc, 19, 5) & "-" & Mid(validc, 31, 5) & "-" & Right(validc, 5)
    
   
    If RegKeyRead(myRegKey) = "" Then
        'MsgBox "Eklentiyi kullanabilmeniz için lisans anahtarı girmeniz gerekmektedir.", vbInformation, "Lisans Anahtarı!"
        MsgBox "You must enter a license key to use the add-in.", vbInformation, "License Key!"
        UserForm2.Show
        Exit Sub
    ElseIf actid = RegKeyRead(myRegKey) Then
        
    Else
        'MsgBox "Lisans anahtarı değiştirilmiş veya bozulmuş olabilir. Doğru lisans anahtarınızı tekrar girmeniz gerekmektedir.", vbCritical, "Lisans Anahtarı!"
        MsgBox "The license key may have been changed or corrupted. You must re-enter your correct license key.", vbCritical, "License Key!"
        UserForm2.Show
        Exit Sub
    End If
    
    If Application.Workbooks.Count = 0 Then
        Call Browse
        Exit Sub
    End If
    
      
      

Application.ScreenUpdating = True
    On Error Resume Next
    'Set colrng = Application.InputBox("Kırılım içeren kolonu seçiniz", "Kolon Seç", "", 50, 50, Type:=8)
    Set colrng = Application.InputBox("Select the column which contains breakdown", "Select Column", "", 50, 50, Type:=8)
    On Error GoTo 0
    On Error Resume Next
Application.ScreenUpdating = False
    
    
    If colrng Is Nothing Then
        'MsgBox ("Kolon Seçmediniz!")
        MsgBox ("Column not selected!")
        Exit Sub
    End If
    
    If Application.CountA(colrng) = 0 Then
        'MsgBox "Seçilen Kolon Boş!"
        MsgBox "Selected column is empty!"
        Exit Sub
    End If
    
    colnum = colrng.Column
    colnum2 = colnum - 1
    coletter = Split(Cells(1, colnum).Address, "$")(1)
    coletter2 = Split(Cells(1, colnum2).Address, "$")(1)
    
    Lastrow = ActiveSheet.Range(coletter & Rows.Count).End(xlUp).Row
    Lastcol = ActiveSheet.Cells(1, Columns.Count).End(xlToLeft).Column
    lastcoletter = Split(Cells(1, Lastcol).Address, "$")(1)
    
   

'MsgBox "cift" & counteven & "tek" & countodd

'Dim bosluk As Integer
'totsum = 0
'For i = 2 To Lastrow
'Hucre = ActiveSheet.Cells(i, colnum).Value
'bosluk = (Application.WorksheetFunction.Find(Left(Trim(Hucre), 1), Hucre) - 1)
'totsum = totsum + (Application.WorksheetFunction.Find(Left(Trim(Hucre), 1), Hucre) - 1)
'Next i
''MsgBox totsum
'checknum = totsum Mod 2

'Dim bosluk As Integer
'totsum = 0
'For i = 2 To Lastrow
'Hucre = ActiveSheet.Cells(i, colnum).Value
'bosluk = (Application.WorksheetFunction.Find(Left(Trim(Hucre), 1), Hucre) - 1) Mod 2
'totsum = totsum + bosluk
'Next i
'MsgBox totsum
'checknum = totsum

    Call DeleteBlankRows

    Call Delete_Columns

   counteven = 0

Dim tek As Integer
 For i = 2 To Lastrow
 Hucre = ActiveSheet.Cells(i, colnum).Value
tek = (Application.WorksheetFunction.Find(Left(Trim(Hucre), 1), Hucre) - 1) Mod 2
If (Application.WorksheetFunction.Find(Left(Trim(Hucre), 1), Hucre) - 1) Mod 2 = 0 Then
counteven = counteven + 1
ElseIf (Application.WorksheetFunction.Find(Left(Trim(Hucre), 1), Hucre) - 1) Mod 2 = 1 Then
countodd = countodd + tek
End If
toplam = toplam + tek
Next i


    
    Dim actnameF As Range
    Dim actidF As Range
    Dim tasknameF As Range
    Dim gorevadF As Range
    Dim summF As Range
    Dim ozetF As Range

'    If (counteven > countodd) Then
With Range("1:1")
Set actnameF = .Find(What:="Activity Name", LookAt:=xlWhole, MatchCase:=False, SearchFormat:=False)
Set actidF = .Find(What:="Activity ID", LookAt:=xlWhole, MatchCase:=False, SearchFormat:=False)
Set tasknameF = .Find(What:="Task Name", LookAt:=xlWhole, MatchCase:=False, SearchFormat:=False)
Set gorevadF = .Find(What:="Görev Adı", LookAt:=xlWhole, MatchCase:=False, SearchFormat:=False)
Set summF = .Find(What:="Summary", LookAt:=xlWhole, MatchCase:=False, SearchFormat:=False)
Set ozetF = .Find(What:="Özet", LookAt:=xlWhole, MatchCase:=False, SearchFormat:=False)
 If (Not (actidF Is Nothing) = True) And (Not (actnameF Is Nothing) = False) Then
 'MsgBox """Activity Name"" kolonunun eklenmesi gerekmektedir!", vbExclamation, "WBS Colorizer"
 MsgBox """Activity Name"" column must be added!", vbExclamation, "WBS Colorizer"
 Exit Sub
 ElseIf (Not (actidF Is Nothing) = False) And (Not (actnameF Is Nothing) = True) Then
 'MsgBox """Activity ID"" kolonunun eklenmesi gerekmektedir!", vbExclamation, "WBS Colorizer"
 MsgBox """Activity ID"" column must be added!", vbExclamation, "WBS Colorizer"
 Exit Sub
 ElseIf (Not (actidF Is Nothing) = False) And (Not (tasknameF Is Nothing) = True) And (Not (summF Is Nothing) = False) Then
 'MsgBox """Summary"" kolonunun eklenmesi gerekmektedir!", vbExclamation, "WBS Colorizer"
 MsgBox """Summary"" column must be added!", vbExclamation, "WBS Colorizer"
 Exit Sub
 ElseIf (Not (actidF Is Nothing) = False) And (Not (gorevadF Is Nothing) = True) And (Not (ozetF Is Nothing) = False) Then
 'MsgBox """Özet"" kolonunun eklenmesi gerekmektedir!", vbExclamation, "WBS Colorizer"
 MsgBox """Özet"" column must be added!", vbExclamation, "WBS Colorizer"
 Exit Sub
 ElseIf (Not (actidF Is Nothing) = False) And (Not (actnameF Is Nothing) = False) And (Not (ozetF Is Nothing) = True) And (Not (gorevadF Is Nothing) = False) Then
 'MsgBox """Görev Adı"" kolonunun eklenmesi gerekmektedir!", vbExclamation, "WBS Colorizer"
 MsgBox """Görev Adı"" column must be added!", vbExclamation, "WBS Colorizer"
 Exit Sub
 ElseIf (Not (actidF Is Nothing) = False) And (Not (actnameF Is Nothing) = False) And (Not (summF Is Nothing) = True) And (Not (tasknameF Is Nothing) = False) Then
 'MsgBox """Task Name"" kolonunun eklenmesi gerekmektedir!", vbExclamation, "WBS Colorizer"
 MsgBox """Task Name"" column must be added!", vbExclamation, "WBS Colorizer"
 Exit Sub
 ElseIf (Not (actidF Is Nothing) = False) And (Not (actnameF Is Nothing) = False) And (Not (gorevadF Is Nothing) = False) And (Not (tasknameF Is Nothing) = False) Then
 'MsgBox "WBS kolon başlıklarında eksiklik mevcut! Kolon başlıklarınızı eklediğinize emin olduktan sonra tekrar deneyin.", vbExclamation, "WBS Colorizer"
 MsgBox "WBS column headers are missing! Try again after making sure you have added your column headers.", vbExclamation, "WBS Colorizer"
 Exit Sub
 End If
End With



'End If

'    If counteven < countodd Then
'With ActiveSheet.Cells
' Set rFind = .Find(What:="Task Name", LookAt:=xlWhole, MatchCase:=False, SearchFormat:=False)
' Set tFind = .Find(What:="Görev Adı", LookAt:=xlWhole, MatchCase:=False, SearchFormat:=False)
' If rFind Is Nothing Then
' If tFind Is Nothing Then
' MsgBox "Görev Adı (Task Name) kolonunun eklenmesi gerekmektedir!"
' Exit Sub
' End If
' End If
'
'End With
'
'With ActiveSheet.Cells
' Set rFind = .Find(What:="Summary", LookAt:=xlWhole, MatchCase:=False, SearchFormat:=False)
' Set tFind = .Find(What:="Özet", LookAt:=xlWhole, MatchCase:=False, SearchFormat:=False)
'
'If rFind Is Nothing Then
'If tFind Is Nothing Then
' MsgBox "Özet (Summary) kolonunun eklenmesi gerekmektedir!"
' Exit Sub
' End If
' End If
'
'
'End With

'End If

    



    colnum = colrng.Column

    colnum2 = colnum - 1
    coletter = Split(Cells(1, colnum).Address, "$")(1)

      
         Columns("A").EntireColumn.Insert
'            Columns("A").HorizontalAlignment = xlCenter
            Range("A1").Value = "WBS Level"

'            ActiveSheet.UsedRange.Columns.AutoFit
           
    
'        If colnum = 1 Then
'            Columns("A").EntireColumn.Insert
'            Columns("A").HorizontalAlignment = xlCenter
'            Range("A1").Value = "WBS Level"
'            Columns("A").Columns.AutoFit
'        ElseIf colnum <> 1 Then
'            Columns(coletter & ":" & coletter).EntireColumn.Insert
'            Columns(coletter & ":" & coletter).HorizontalAlignment = xlCenter
'            Range(coletter & "1").Value = "WBS Level"
'
'        End If
    
    

 
    colnum = colrng.Column
    colnum2 = colnum - 1
    coletter = Split(Cells(1, colnum).Address, "$")(1)
    coletter2 = Split(Cells(1, colnum2).Address, "$")(1)
    
    Lastrow = ActiveSheet.Range(coletter & Rows.Count).End(xlUp).Row
    Lastcol = ActiveSheet.Cells(1, Columns.Count).End(xlToLeft).Column
    lastcoletter = Split(Cells(1, Lastcol).Address, "$")(1)
    
    If (Not (actidF Is Nothing) = True) Then
        
    For i = 2 To Lastrow
        Dim calc As Long
      
        
        Hucre = ActiveSheet.Cells(i, colnum).Value
        ActiveSheet.Cells(i, 1).Value = (Application.WorksheetFunction.Find(Left(Trim(Hucre), 1), Hucre) - 1) / 2
        If (ActiveSheet.Cells(i, 1).Value) * 2 Mod 2 = 1 Then
            ActiveSheet.Columns(1).Delete
            'MsgBox coletter2 & i & " hücresinde kayma var. İlgili hücrenin boşluk sayısını kontrol ediniz. " & vbCrLf & "Benzer WBS veya aktivite ile aynı hizada olduğundan emin olunuz!", vbOKOnly + vbCritical, "Hata!"
   MsgBox "Unexpected character error!" & vbCrLf & "Check the number of space character in the " & coletter2 & i & " cell!" & vbCrLf & "Be sure that indent of the characters are in same alignment with similar WBS or activities!", vbOKOnly + vbCritical, "Error!"
            
            Exit Sub
        End If
                
    Next i
    
    ElseIf (Not (tasknameF Is Nothing) = True) Or (Not (gorevadF Is Nothing) = True) Then
    For i = 2 To Lastrow
    Hucre = ActiveSheet.Cells(i, colnum).Value
    ActiveSheet.Cells(i, 1).Value = (Application.WorksheetFunction.Find(Left(Trim(Hucre), 1), Hucre) - 1) / 3
        If (ActiveSheet.Cells(i, 1).Value) * 3 Mod 3 > 0 Then
            ActiveSheet.Columns(1).Delete
            'MsgBox coletter2 & i & " hücresinde kayma var. İlgili hücrenin boşluk sayısını kontrol ediniz. " & vbCrLf & "Benzer WBS veya aktivite ile aynı hizada olduğundan emin olunuz!", vbOKOnly + vbCritical, "Hata!"
         MsgBox "Unexpected character error!" & vbCrLf & "Check the number of space character in the " & coletter2 & i & " cell!" & vbCrLf & "Be sure that indent of the characters are in same alignment with similar WBS or activities!", vbOKOnly + vbCritical, "Error!"
            
            Exit Sub
        End If
  Next i
  End If
  
  
  ActiveSheet.UsedRange.Columns.AutoFit
  Columns("A").HorizontalAlignment = xlCenter
  
 
    
    For i = 2 To Lastrow
        
        dblmax = Application.WorksheetFunction.Max(ActiveSheet.Range("A1:A" & Lastrow))
        
        Set r1 = Range("A" & i)
        Set r2 = Range("A" & i & ":" & lastcoletter & i)
        
        '        If r1.Value = 0 Then
        '        r2.Interior.ColorIndex = 3
        '        r2.Font.ColorIndex = 2
        '
        '        End If
        '
        '        If r1.Value = 1 Then
        '        r2.Interior.ColorIndex = 1
        '        r2.Font.ColorIndex = 2
        '
        '        End If
        
        If r1.Value = dblmax Then
            r2.Interior.ColorIndex = 2
            
        ElseIf r1.Value = 0 Then
            r2.Interior.Color = RGB(0, 0, 255)
            r2.Font.Color = vbYellow
            r2.Font.Bold = True
            
        ElseIf r1.Value = 1 Then
            r2.Interior.Color = RGB(128, 255, 128)
            r2.Font.Color = vbBlack
            
        ElseIf r1.Value = 2 Then
            r2.Interior.Color = RGB(255, 255, 0)
            r2.Font.Color = vbBlue
            
        ElseIf r1.Value = 3 Then
            r2.Interior.Color = RGB(0, 0, 255)
            r2.Font.Color = vbWhite
            
        ElseIf r1.Value = 4 Then
            r2.Interior.Color = RGB(255, 0, 0)
            r2.Font.Color = vbWhite
            
        ElseIf r1.Value = 5 Then
            r2.Interior.Color = RGB(128, 255, 255)
            r2.Font.Color = vbBlack
            
        ElseIf r1.Value = 6 Then
            r2.Interior.Color = RGB(255, 128, 255)
            r2.Font.Color = vbBlack
            
        ElseIf r1.Value = 7 Then
            r2.Interior.Color = RGB(255, 255, 128)
            r2.Font.Color = vbBlack
            
        ElseIf r1.Value = 8 Then
            r2.Interior.Color = RGB(0, 0, 0)
            r2.Font.Color = vbWhite
            
        ElseIf r1.Value = 9 Then
            r2.Interior.Color = RGB(192, 192, 192)
            r2.Font.Color = vbWhite
            
        ElseIf r1.Value = 10 Then
            r2.Interior.Color = RGB(0, 128, 0)
            r2.Font.Color = vbWhite
            
        ElseIf r1.Value = 11 Then
            r2.Interior.Color = RGB(0, 0, 160)
            r2.Font.Color = vbWhite
            
        ElseIf r1.Value = 12 Then
            r2.Interior.Color = RGB(128, 64, 0)
            r2.Font.Color = vbWhite
            
        ElseIf r1.Value = 13 Then
            r2.Interior.Color = RGB(128, 0, 128)
            r2.Font.Color = vbWhite
            
        ElseIf r1.Value = 14 Then
            r2.Interior.Color = RGB(255, 128, 64)
            r2.Font.Color = vbWhite
            
        ElseIf r1.Value = 15 Then
            r2.Interior.Color = RGB(128, 128, 192)
            r2.Font.Color = vbWhite
            
        ElseIf r1.Value = 16 Then
            r2.Interior.Color = RGB(128, 128, 64)
            r2.Font.Color = vbWhite
            
        ElseIf r1.Value = 17 Then
            r2.Interior.Color = RGB(128, 128, 128)
            r2.Font.Color = vbWhite
            
        ElseIf r1.Value = 18 Then
            r2.Interior.Color = RGB(64, 128, 192)
            r2.Font.Color = vbWhite
            
        ElseIf r1.Value = 19 Then
            r2.Interior.Color = RGB(128, 128, 192)
            r2.Font.Color = vbWhite
        End If
        
    Next i
       '************Ekleme********************'
If (Not (actidF Is Nothing) = True) Then
With Range("1:1")
 Set rFind = .Find(What:="Activity Name", LookAt:=xlWhole, MatchCase:=False, SearchFormat:=False)
 colactnum = rFind.Column
 If rFind Is Nothing Then
 MsgBox "Activity Name Kolonu Yok! Hiyerarşi yapısının Activity ID kolonunda olduğuna ve Activity Name kolonun mevcut olduğundan emin olunuz."
 Exit Sub

 End If
End With

For i = 2 To Lastrow
Hucre2 = ActiveSheet.Cells(i, colactnum).Value
If Hucre2 <> "" Then
Range("A" & i).ClearContents
Range("A" & i & ":" & lastcoletter & i).Interior.ColorIndex = 2
Range("A" & i & ":" & lastcoletter & i).Font.ColorIndex = 0
End If

If Range("A" & i) = "" Then
Range("A" & i) = dblmax
End If

Next i
End If

Dim sumf As Range
Dim sumt As Range
Dim colsumnum As Integer

If (Not (tasknameF Is Nothing) = True) Or (Not (gorevadF Is Nothing) = True) Then
With Range("1:1")
 Set sumf = .Find(What:="Summary", LookAt:=xlWhole, MatchCase:=False, SearchFormat:=False)
 Set sumt = .Find(What:="Özet", LookAt:=xlWhole, MatchCase:=False, SearchFormat:=False)
 
 If sumf Is Nothing Then
 colsumnum = sumt.Column
 ElseIf sumt Is Nothing Then

 colsumnum = sumf.Column
 
 
 End If
End With


For i = 2 To Lastrow
Hucre3 = ActiveSheet.Cells(i, colsumnum).Value

If Hucre3 = "NO" Or Hucre3 = "HAYIR" Or Hucre3 = "hayır" Then
Range("A" & i).ClearContents
Range("A" & i & ":" & lastcoletter & i).Interior.ColorIndex = 2
Range("A" & i & ":" & lastcoletter & i).Font.ColorIndex = 0
End If

If Range("A" & i) = "" Then
Range("A" & i) = dblmax
End If


Next i
End If
   

 '************Ekleme********************'
    
    Cells.ClearOutline
    Range("A1" & ":" & lastcoletter & "1").Interior.Color = RGB(240, 240, 240)
    Rows(1).RowHeight = 30
    Rows(1).VerticalAlignment = xlCenter
    Rows(1).HorizontalAlignment = xlCenter
    Rows(2).RowHeight = 25
    Rows(2).VerticalAlignment = xlCenter
    
    Dim cell        As Range
    
    Set rng_start = Range("A" & 2)
    Set rng_end = rng_start.End(xlDown)
    Set rng_cells = Range(rng_start, rng_end)
    For Each cell In rng_cells
        
        Dim row_off As Integer
        row_off = 1
        
        Do While cell.Offset(row_off) > cell And cell.Offset(row_off).Row <= rng_end.Row
            row_off = row_off + 1
        Loop
        
        If row_off > 1 Then
            Range(cell.Offset(1), cell.Offset(row_off - 1)).EntireRow.Group
        End If
    Next cell
    Columns(1).Columns.Delete
    Application.ScreenUpdating = True
    UserForm1.Show
    '    MsgBox ("İşlem tamamlandı!" & Chr(10) & "----------------------------" & Chr(10) & "http://planlamamuhendisi.com")
    
    
    
End Sub

Public Sub rreset(ByRef control As Office.IRibbonControl)
    
    If Application.Workbooks.Count = 0 Then
        Call Browse
        Exit Sub
    End If
    
    If Range("B1").Interior.Color = RGB(240, 240, 240) Then
        
        ActiveSheet.Cells.ClearFormats
        ActiveSheet.Rows.UseStandardHeight = True
        ActiveSheet.Cells.ClearOutline
        If Range("a1") = "WBS Level" Then
            Columns("A").Columns.Delete
        End If
    Else
        'MsgBox "Geri alınacak herhangi birşey yok!"
        MsgBox "Nothing to undo!"
    End If
    
    If Range("A1") = "WBS Level" Then
        Columns("A").Columns.Delete
    Else
    End If
End Sub

Attribute VB_Name = "UserForm1"
Attribute VB_Base = "0{B9EE6164-1941-485C-AAD5-7A1A656B930D}{C92343E1-D4E9-4DCE-A075-9D336A69C6FB}"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Attribute VB_TemplateDerived = False
Attribute VB_Customizable = False


Private Sub CommandButton1_Click()
Unload UserForm1
End Sub

Private Sub CommandButton2_Click()

If Range("B1").Interior.Color = RGB(240, 240, 240) Then

ActiveSheet.Cells.ClearFormats
ActiveSheet.Rows.UseStandardHeight = True
ActiveSheet.Cells.ClearOutline
If Range("a1") = "WBS Level" Then
Columns("A").Columns.Delete
End If
Else
'MsgBox "Geri alınacak herhangi bir işlem yok."
MsgBox "Nothing to undo!"
End If

If Range("A1") = "WBS Level" Then
Columns("A").Columns.Delete
Else
End If
End Sub


Private Sub Label1_Click()

End Sub

Private Sub Label5_Click()
ActiveWorkbook.FollowHyperlink Address:="https://www.linkedin.com/in/ggecici", NewWindow:=True
Unload Me
End Sub

Private Sub Label7_Click()
ActiveWorkbook.FollowHyperlink Address:="mailto:gurkangecici@gmail.com", NewWindow:=True

Unload Me
End Sub

Private Sub Label8_Click()
ActiveWorkbook.FollowHyperlink Address:="http://planlamamuhendisi.com", NewWindow:=True
Unload Me
End Sub




Private Sub UserForm_Click()

End Sub

Attribute VB_Name = "UserForm2"
Attribute VB_Base = "0{B4C81EC3-8003-4046-87A0-17B66DA74C75}{B506F480-6D8D-4A9D-8C44-0625B1FD682B}"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Attribute VB_TemplateDerived = False
Attribute VB_Customizable = False

Option Explicit





Private Sub CommandButton6_Click()
Call FollowingHyperlink
End Sub



Private Sub CommandButton7_Click()

Dim obj As New DataObject
Dim txt As String

'Put some text inside a string variable
  txt = TextBox1.text

'Make object's text equal above string variable
  obj.SetText txt

'Place DataObject's text into the Clipboard
  obj.PutInClipboard

'Notify User
  'MsgBox "PC ID Kopyalandı!", vbInformation
  MsgBox "PC ID Copied!", vbInformation


End Sub

Private Sub Label1_Click()

End Sub

Private Sub TextBox1_Change()

End Sub

Private Sub UserForm_Initialize()

Dim serial As String
Dim cpu As String
Dim requestid As String

serial = MBSerialNumber()
 cpu = CpuId()
 
 requestid = Trim(Left(cpu, 2) & Mid(serial, 2) & Left(cpu, 3) & Left(serial, 2) & Right(serial, 3) & Mid(cpu, 3))
    
   
 
TextBox1.text = requestid

   
  
End Sub

Private Sub TextBox2_Change()
 
   If TextBox2.Value = "" Then
   CommandButton1.Enabled = False
   Else
   CommandButton1.Enabled = True
   End If
End Sub


Public Sub CommandButton1_Click()
 Dim tmp As String
 Dim serial As String
 Dim requestid As String
 Dim requestid2 As String
 Dim actid As String
 Dim validc As String
 Dim cpu As String
 Dim computerid As String
 Dim i As Integer
  Dim myRegKey As String
Dim myValue As String
Dim myAnswer As Integer
 
 
 serial = MBSerialNumber()
 cpu = CpuId()
 
 computerid = Left(Environ$("computername"), 2) & Left(serial, 4) & Left(cpu, 4)
 requestid = Trim(Left(cpu, 2) & Mid(serial, 2) & Left(cpu, 3) & Left(serial, 2) & Right(serial, 3) & (Mid(cpu, 3)))
  myRegKey = "HKEY_CURRENT_USER\SOFTWARE\WBSRenklendir\WBSRenklendir"
  
 For i = 2 To Len(requestid)
 requestid2 = requestid & Hex((Asc(Mid(requestid, i, 1))))
Next

   
    validc = StrReverse(SHA1(StrReverse(EncodeBase64(requestid))))
    'validc = StrReverse(SHA1(StrReverse(Left(EncodeBase64(requestid), (InStr(EncodeBase64(requestid), "=") - 1)))))
   
    actid = Left(Trim(validc), 5) & "-" & Mid(validc, 12, 5) & "-" & Mid(validc, 19, 5) & "-" & Mid(validc, 31, 5) & "-" & Right(validc, 5)
    
    myValue = actid
If TextBox2.text = actid Then
  RegKeySave myRegKey, myValue
      
'MsgBox "Lisansınız başarıyla aktif edildi.", vbOKOnly + vbInformation, "Lisans Başarılı!"
MsgBox "Your license has been successfully activated.", vbOKOnly + vbInformation, "Activation Successful!"
Unload Me


Else
MsgBox "Your license key is invalid!", vbOKOnly + vbCritical, "Activation Error!"
'MsgBox "Lisans kodunuz hatalı!", vbOKOnly + vbCritical, "Hata!"
End If
End Sub



Attribute VB_Name = "Module2"
Public Function SHA1(ByVal s As String) As String
    Dim Enc As Object, Prov As Object
    Dim Hash() As Byte, i As Integer

    Set Enc = CreateObject("System.Text.UTF8Encoding")
    Set Prov = CreateObject("System.Security.Cryptography.SHA1CryptoServiceProvider")

    Hash = Prov.ComputeHash_2(Enc.GetBytes_4(s))

    SHA1 = ""
    For i = LBound(Hash) To UBound(Hash)
        SHA1 = SHA1 & Hex(Hash(i) \ 16) & Hex(Hash(i) Mod 16)
    Next
End Function

Function RegKeyRead(i_RegKey As String) As String
Dim myWS As Object

  On Error Resume Next
  'access Windows scripting
  Set myWS = CreateObject("WScript.Shell")
  'read key from registry
  RegKeyRead = myWS.RegRead(i_RegKey)
End Function

Function RegKeyExists(i_RegKey As String) As Boolean
Dim myWS As Object

  On Error GoTo ErrorHandler
  'access Windows scripting
  Set myWS = CreateObject("WScript.Shell")
  'try to read the registry key
  myWS.RegRead i_RegKey
  'key was found
  RegKeyExists = True
  Exit Function
  
ErrorHandler:
  'key was not found
  RegKeyExists = False
End Function

Sub RegKeySave(i_RegKey As String, _
               i_Value As String, _
      Optional i_Type As String = "REG_SZ")
Dim myWS As Object

  'access Windows scripting
  Set myWS = CreateObject("WScript.Shell")
  'write registry key
  myWS.RegWrite i_RegKey, i_Value, i_Type

End Sub
Function RegKeyDelete(i_RegKey As String) As Boolean
Dim myWS As Object

  On Error GoTo ErrorHandler
  'access Windows scripting
  Set myWS = CreateObject("WScript.Shell")
  'delete registry key
  myWS.RegDelete i_RegKey
  'deletion was successful
  RegKeyDelete = True
  Exit Function

ErrorHandler:
  'deletion wasn't successful
  RegKeyDelete = False
End Function

Public Function MBSerialNumber() As String
Dim objs As Object
Dim obj As Object
Dim wmi As Object
Dim sAns As String
Set wmi = GetObject("WinMgmts:")
Set objs = wmi.InstancesOf("Win32_BaseBoard")
For Each obj In objs
    sAns = sAns & obj.SerialNumber
    If sAns < objs.Count Then sAns = sAns & ","
Next
MBSerialNumber = sAns

End Function

Function EncodeBase64(text$)
    Dim b
    With CreateObject("ADODB.Stream")
        .Open: .Type = 2: .Charset = "utf-8"
        .WriteText text: .Position = 0: .Type = 1: b = .Read
        With CreateObject("Microsoft.XMLDOM").createElement("b64")
            .DataType = "bin.base64": .nodeTypedValue = b
            EncodeBase64 = Replace(Mid(.text, 5), vbLf, "")
        End With
        .Close
    End With
End Function
    

Function DecodeBase64(b64$)
    Dim b
    With CreateObject("Microsoft.XMLDOM").createElement("b64")
        .DataType = "bin.base64": .text = b64
        b = .nodeTypedValue
        With CreateObject("ADODB.Stream")
            .Open: .Type = 1: .Write b: .Position = 0: .Type = 2: .Charset = "utf-8"
            DecodeBase64 = .ReadText
            .Close
        End With
    End With
End Function

Function CpuId() As String
Dim computer As String
Dim wmi As Variant
Dim processors As Variant
Dim cpu As Variant
Dim cpu_ids As String

    computer = "."
    Set wmi = GetObject("winmgmts:" & _
        "{impersonationLevel=impersonate}!\\" & _
        computer & "\root\cimv2")
    Set processors = wmi.ExecQuery("Select * from " & _
        "Win32_Processor")

    For Each cpu In processors
        cpu_ids = cpu_ids & ", " & cpu.ProcessorId
    Next cpu
    If Len(cpu_ids) > 0 Then cpu_ids = Mid$(cpu_ids, 3)

    CpuId = cpu_ids
End Function

 



Attribute VB_Name = "DPB"
Attribute VB_Base = "0{0C37D1FC-290E-4798-9CBA-ACF7402388A7}{4A6988EE-DF6D-4F09-AD71-EEA9E452C694}"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Attribute VB_TemplateDerived = False
Attribute VB_Customizable = False
vbaProject_00.bin vba-project OOXML VBA project: xl/vbaProject.bin 81920 bytes
SHA-256: ab75c01f922ed9aa60a45f720d8401de0c6533dfb053b2cd2b80a8df644f7424
vbaProject_01.bin vba-project OOXML VBA project: xl/printerSettings.bin 83535 bytes
SHA-256: ec75a93cbceaacb28cc08a3736f2c3422cb9ac67bc09bf6534ad2fefe20c5fcd

Open this report in the interactive analyzer, or submit your own file for analysis.