Dobrý den,

potřeboval bych pomoci s opravou VBA kódu na 64bitové systémy. Nepomohl by prosím někdo? Jde konkrétně o tučné řádky.
 
[QUOTE=VBA kód]
Public PoleSouboru()Public Slozka As StringPublic ObrMeritkoPublic 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 LongEnd TypePrivate Declare Function SHGetPathFromIDList Lib "shell32.dll" Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) As LongPrivate Declare Function SHBrowseForFolder Lib "shell32.dll" Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As LongDim 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 IfEnd 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 = TrueEnd 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 = TrueEnd Sub
 
Sub OdstranPanelOfficir()    On Error Resume Next    CommandBars("Officír").DeleteEnd Sub
 
Sub AktualizacePanelOfficir()    Application.ScreenUpdating = False    If IsEmpty(Slozka) Then        VypisSlozky    Else        VypisSlozky (Slozka)    End If    Titulek    Application.ScreenUpdating = TrueEnd Sub
 
Sub SeskupitObjekty()    On Error Resume Next    Selection.ShapeRange.GroupEnd Sub
 
Sub RozdelitObjekty()    On Error Resume Next    Selection.ShapeRange.UngroupEnd Sub
 
Sub Titulek()    CommandBars("Officír").Controls(2).TooltipText = "Seznam obrázků ve složce " & SlozkaEnd SubSub 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 IfEnd 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)).SelectEnd SubPrivate 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, inHiEnd Function
[/QUOTE]
 
Předem děkuju za případnou pomoc PepaR2010-09-05 07:56:42