Diskuzní fórum a databáze tipů a utilit pro AutoCAD, Inventor, Revit a další produkty Autodesk - od firmy Arkance Systems [www.cadforum.cz]
CZ | SK | EN | DE
Přihlášení
či registrace
   právě nás čte: 14078 
RSS kanál - CAD tipy RSS tipy
RSS diskuze

Diskuze Diskuzní fórum, poradna

 

NápovědaCAD diskuze, rady, výměna zkušeností

 
CAD Fórum - Homepage Veřejné diskuzní fórum k CAD aplikacím - ptejte se na libovolné otázky týkající se oboru CAx, podělte se o vaše znalosti a zkušenosti s programy AutoCAD, Inventor, Revit, Fusion 360, 3ds Max a s dalšími CAD aplikacemi. Zaregistrujte se nebo se přihlašte a zašlete váš příspěvek do odpovídajícího fóra. Viz další informace o CAD Fóru. Nechcete se registrovat? Zeptejte se v naší Facebook poradně.
Fórum nenahrazuje technický support firmy Arkance Systems (CAD Studio) - přímá podpora pro zákazníky funguje na helpdesk.cadstudio.cz
  FAQ FAQ  Prohledat fórum   Události   Registrovat Registrovat  Přihlásit Přihlásit

Téma uzavřenoOprava VBA kódu

 Odpovědět Odpovědět archiv
Autor
PepaR Zobrazit panel
CAD/BIM manager
CAD/BIM manager
Avatar

Přihlášen: 29.lis.2004
Lokalita: ČR (ZL)
Používám:
ruky a hlavu (občas ;)
Stav: Offline
Bodů: 6187
Přímý odkaz na tuto zprávu Téma: Oprava VBA kódu
    Zasláno: 03.zář.2010 v 22:58
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.
 
Původně odeslal(a) VBA kód 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
 
Předem děkuju za případnou pomoc
 


Upravil PepaR - 05.zář.2010 v 07:56
Zpět nahoru

Pro technickou podporu CAD
kontaktujte Helpdesk

Příbuzné CAD tipy:
Tip 9875:Nelze obnovit okno AutoCADu minimalizované v liště Windows.
Tip 2687:VIPJak vrátit souřadnici ukázaného bodu výkresu do VBA/ActiveX aplikace?
Tip 68:Nelze vložit autorizační kód; uživatel zkoušel US verzi AutoCADu 2000.
Tip 5647:AutoCAD Map mi nabízí několik souřadnicových systémů JTSK. Který je ten správný?
Tip 9321:VIPNefunguje mi VBA v Inventoru 2016, 2015, 2014 nebo 2013 - příčiny.
Tip 6790:VIPPřidání ikony vlastního příkazu/makra v Inventoru.


 Odpovědět Odpovědět

Přejít na fórum Oprávnění fóra Zobrazit panel



Stránka byla vygenerována za 1,109 sekund.