VBA kód napsal(a):
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
|