Public PoleSouboru()
Public Slozka As String
Public ObrMeritko
Public Type BROWSEINFO
    hOwner As Long
    pidlRoot As Long
    pszDisplayName As String
    lpszTitle As String
    ulFlags As Long
    lpfn As Long
    lParam As Long
    iImage As Long
End Type
Private Declare Function SHGetPathFromIDList Lib "shell32.dll" Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) As Long
Private Declare Function SHBrowseForFolder Lib "shell32.dll" Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long
Dim subFolder As Object, fl As Object

 

Private Function GetDirectory(Optional Msg) As String
    Dim bInfo As BROWSEINFO
    Dim path As String
    Dim R As Long, x As Long, pos As Integer
    bInfo.pidlRoot = 0&
    If IsMissing(Msg) Then
        bInfo.lpszTitle = "Označte složku, jejíž obsah si přejete zobrazit:"
    Else
        bInfo.lpszTitle = Msg
    End If
    bInfo.ulFlags = &H1
    x = SHBrowseForFolder(bInfo)
    path = Space$(512)
    R = SHGetPathFromIDList(ByVal x, ByVal path)
    If R Then
        pos = InStr(path, Chr$(0))
        GetDirectory = Left(path, pos - 1)
    Else
        GetDirectory = ""
    End If
End Function

 

Sub VypisSlozky(Optional Adresar As String)
    Dim fso As Object, fl As Object
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Set fso = CreateObject("Scripting.FileSystemObject")
    If Adresar = vbNullString Then
        Slozka = GetDirectory()
    End If
    If Slozka = "" Then Exit Sub
    If Right(Slozka, 1) <> "\" Then Slozka = Slozka & "\"
    Set fl = fso.GetFolder(Slozka)
    On Error Resume Next
    With CommandBars("Officír").Controls(2)
        Do
            .RemoveItem (.ListIndex)
        Loop While .ListCount > 0
    End With
    For Each f In fl.Files
        NazevSouboru = Right(f.path, Len(f.path) - Len(Slozka))

 

        Koncovka = Right(NazevSouboru, 4)

 

        Select Case LCase(Koncovka)
            Case ".gif", ".bmp", ".png", ".wmf", ".emf", ".tif", ".tiff", ".jpg", ".jpeg", ".jpe", ".eps"
                R = R + 1
                ReDim Preserve PoleSouboru(1 To R)
                PoleSouboru(R) = NazevSouboru
        End Select
    Next f
    QuickSort PoleSouboru, LBound(PoleSouboru), UBound(PoleSouboru)

 

    For i = 1 To R
        CommandBars("Officír").Controls(2).AddItem PoleSouboru(i)
    Next i
    CommandBars("Officír").Controls(2).ListIndex = 1
    Titulek
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
End Sub

 

Sub VytvorPanelOfficir()
    Dim MujPanel As CommandBar
    Application.ScreenUpdating = False
    OdstranPanelOfficir
    Set MujPanel = CommandBars.Add
    With MujPanel
        .Name = "Officír"
        .Visible = True
        .Position = msoBarBottom
        .Protection = msoBarNoCustomize
    End With

 

    Set Nova = CommandBars("Officír").Controls.Add(Type:=msoControlButton)
    With Nova
        .FaceId = 23
        .Style = msoButtonIcon
        .TooltipText = "Vybrat složku s obrázky"
        .Enabled = True
        .OnAction = "VypisSlozky"
    End With
    Set Nova0 = CommandBars("Officír").Controls.Add(Type:=msoControlDropdown)
    With Nova0
        .Caption = "Seznam obrázků"
        .TooltipText = "Seznam obrázků ve složce " & Slozka
        .Enabled = True
        .OnAction = "VlozZeSeznamuObr"
        .Width = 150
    End With
    Set Nova0 = CommandBars("Officír").Controls.Add(Type:=msoControlDropdown)
    With Nova0
        .Caption = "Měřítko obrázků"
        .TooltipText = "Velikost vkládaných obrázků "
        .Enabled = True
        .OnAction = "MeritkoObrazky"
        .Width = 50
        For i = 5 To 100 Step 5
            .AddItem i & "%"
        Next i
        .ListIndex = 20
        MeritkoObrazky
    End With
    With CommandBars("Picture")
        .Controls(12).Copy Bar:=CommandBars("Officír")
        .Controls(14).Copy Bar:=CommandBars("Officír")
        .Controls(2).Copy Bar:=CommandBars("Officír")
        .Controls(4).Copy Bar:=CommandBars("Officír")
        .Controls(5).Copy Bar:=CommandBars("Officír")
        .Controls(6).Copy Bar:=CommandBars("Officír")
        .Controls(8).Copy Bar:=CommandBars("Officír")
        .Controls(11).Copy Bar:=CommandBars("Officír")
    End With
    With CommandBars("Draw")
        .Controls(5).Copy Bar:=CommandBars("Officír")
        .Controls(1).Copy Bar:=CommandBars("Officír")
        .Controls(2).Copy Bar:=CommandBars("Officír")
    End With
    Set Nova1 = CommandBars("Officír").Controls.Add(Type:=msoControlButton)
    With Nova1
        .FaceId = 664
        .Style = msoButtonIcon
        .TooltipText = "Objekt do levého horního rohu odstavce"
        .Enabled = True
        .OnAction = "ObjektDolevaNahoru"
    End With

 

    Set Nova2 = CommandBars("Officír").Controls.Add(Type:=msoControlButton)
    With Nova2
        .FaceId = 668
        .Style = msoButtonIcon
        .TooltipText = "Objekt na střed"
        .Enabled = True
        .OnAction = "ObjektNaStred"
    End With

 

    Set Nova3 = CommandBars("Officír").Controls.Add(Type:=msoControlButton)
    With Nova3
        .FaceId = 665
        .Style = msoButtonIcon
        .TooltipText = "Objekt do pravého horního rohu odstavce"
        .Enabled = True
        .OnAction = "ObjektDopravaNahoru"
    End With

 

    Set Nova4 = CommandBars("Officír").Controls.Add(Type:=msoControlButton)
    With Nova4
        .FaceId = 41
        .Style = msoButtonIcon
        .TooltipText = "Objekt doleva"
        .Enabled = True
        .OnAction = "ObjektDoleva"
    End With

 

    Set Nova5 = CommandBars("Officír").Controls.Add(Type:=msoControlButton)
    With Nova5
        .FaceId = 39
        .Style = msoButtonIcon
        .TooltipText = "Objekt doprava"
        .Enabled = True
        .OnAction = "ObjektDoprava"
    End With

 

    Set Nova7 = CommandBars("Officír").Controls.Add(Type:=msoControlButton)
    With Nova7
        .FaceId = 223
        .Style = msoButtonIcon
        .TooltipText = "Otitulkovat obrázek"
        .Enabled = True
        .OnAction = "OtitulkovatObrazek"
    End With

 

    Set Nova6 = CommandBars("Officír").Controls.Add(Type:=msoControlButton)
    With Nova6
        .FaceId = 37
        .Style = msoButtonIcon
        .TooltipText = "Aktualizace panelu"
        .Enabled = True
        .OnAction = "AktualizacePanelOfficir"
    End With

 

    Set Nova = CommandBars("Officír").Controls.Add(Type:=msoControlButton)
    With Nova
        .FaceId = 358
        .Caption = "Odstranit panel"
        .Style = msoButtonIcon
        .Enabled = True
        .OnAction = "OdstranPanelOfficir"
    End With

 

    Application.ScreenUpdating = True
End Sub

 

Sub OdstranPanelOfficir()
    On Error Resume Next
    CommandBars("Officír").Delete
End Sub

 

Sub AktualizacePanelOfficir()
    Application.ScreenUpdating = False
    If IsEmpty(Slozka) Then
        VypisSlozky
    Else
        VypisSlozky (Slozka)
    End If
    Titulek
    Application.ScreenUpdating = True
End Sub

 

Sub SeskupitObjekty()
    On Error Resume Next
    Selection.ShapeRange.Group
End Sub

 

Sub RozdelitObjekty()
    On Error Resume Next
    Selection.ShapeRange.Ungroup
End Sub

 

Sub Titulek()
    CommandBars("Officír").Controls(2).TooltipText = "Seznam obrázků ve složce " & Slozka
End Sub
Sub MeritkoObrazky()
    Procenta = CommandBars("Officír").Controls(3).List(CommandBars("Officír").Controls(3).ListIndex)
    ObrMeritko = Left(Procenta, Len(Procenta) - 1) / 100
    On Error Resume Next
    If Selection.Type = wdSelectionShape Then
        Selection.ShapeRange.ScaleHeight ObrMeritko, True
        Selection.ShapeRange.ScaleWidth ObrMeritko, True
    End If
End Sub

 

Sub VlozZeSeznamuObr()
    Dim NovyObrazek As Shape
    Dim NovyTextBox As Shape
    Set NovyObrazek = ActiveDocument.Shapes.AddPicture(Slozka & CommandBars("Officír").Controls(2).List(CommandBars("Officír").Controls(2).ListIndex), True, False, , , , , Selection.Range)
    With NovyObrazek
        .RelativeHorizontalPosition = wdRelativeHorizontalPositionPage
        .RelativeVerticalPosition = wdRelativeVerticalPositionPage
        .ScaleHeight ObrMeritko, True
        .ScaleWidth ObrMeritko, True
        .LockAnchor = False
        .AlternativeText = Slozka & CommandBars("Officír").Controls(2).List(CommandBars("Officír").Controls(2).ListIndex)
    End With
    Set NovyTextBox = ActiveDocument.Shapes.AddTextbox _
            (Orientation:=msoTextOrientationHorizontal, _
            Left:=NovyObrazek.Left, Top:=NovyObrazek.Top + NovyObrazek.Height, Width:=NovyObrazek.Width, Height:=10)
    With NovyTextBox
        .ZOrder msoSendToBack
        .Line.Visible = msoFalse
        .TextFrame.MarginTop = 6
        .TextFrame.MarginBottom = 3
        .TextFrame.MarginLeft = 0
        .TextFrame.MarginRight = 0
        .TextFrame.AutoSize = True
        .TextFrame.WordWrap = True
        .TextFrame.TextRange.Text = "Obr."
        .LockAnchor = False
    End With
    ActiveDocument.Shapes.Range(Array(NovyObrazek.Name, NovyTextBox.Name)).Select
End Sub
Private Function QuickSort(vArray As Variant, inLow As Long, inHi As Long)
    Dim pivot As Variant
    Dim tmpSwap As Variant
    Dim tmpLow As Long
    Dim tmpHi As Long
    tmpLow = inLow
    tmpHi = inHi
    pivot = vArray((inLow + inHi) \ 2)
    While (tmpLow <= tmpHi)
        While (vArray(tmpLow) < pivot And tmpLow < inHi)
            tmpLow = tmpLow + 1
        Wend
        While (pivot < vArray(tmpHi) And tmpHi > inLow)
            tmpHi = tmpHi - 1
        Wend
        If (tmpLow <= tmpHi) Then
            tmpSwap = vArray(tmpLow)
            vArray(tmpLow) = vArray(tmpHi)
            vArray(tmpHi) = tmpSwap
            tmpLow = tmpLow + 1
            tmpHi = tmpHi - 1
        End If
    Wend
    If (inLow < tmpHi) Then QuickSort vArray, inLow, tmpHi
    If (tmpLow < inHi) Then QuickSort vArray, tmpLow, inHi
End Function