 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
|