Hot News:

Mit Unterstützung durch:

   Foren auf CAD.de
  AutoCAD VBA
  Programmabbruch / x64 VBA

Antwort erstellen  Neues Thema erstellen
CAD.de Login | Logout | Profil | Profil bearbeiten | Registrieren | Voreinstellungen | Hilfe | Suchen

Anzeige:
Darstellung des Themas zum Ausdrucken. Bitte dann die Druckfunktion des Browsers verwenden. | Suche nach Beiträgen nächster neuer Beitrag | nächster älterer Beitrag
  
Gut zu wissen: Hilfreiche Tipps und Tricks aus der Praxis prägnant, und auf den Punkt gebracht für Autodesk Produkte
  
PNY präsentiert die neue NVIDIA RTX A400 und die A1000 Grafikkarte, eine Pressemitteilung
Autor Thema:  Programmabbruch / x64 VBA (1934 mal gelesen)
Dirk.B
Mitglied
Tischler / Leiter Arbeitsvorbereitung


Sehen Sie sich das Profil von Dirk.B an!   Senden Sie eine Private Message an Dirk.B  Schreiben Sie einen Gästebucheintrag für Dirk.B

Beiträge: 534
Registriert: 25.11.2003

 erstellt am: 02. Apr. 2012 08:32    Editieren oder löschen Sie diesen Beitrag!  <-- editieren / zitieren -->   Antwort mit Zitat in Fett Antwort mit kursivem Zitat    Unities abgeben: 1 Unity (wenig hilfreich, aber dennoch)2 Unities3 Unities4 Unities5 Unities6 Unities7 Unities8 Unities9 Unities10 Unities

x64_VBA_Task_Prozess_01.jpg
 
Guten Morgen zusammen!

Ich habe seit der Umstellung auf AutoCAD 2012 mit einigen meiner Programme das Problem, dass sie plötzlich abbrechen so das nur noch die User - Maske auf dem Bildschirm erscheint und ich nicht weiterarbeiten kann.
Erst nach dem ich dann den VBA - Editor über den Prozess im Task- Manager beende und AutoCAD neu starte läuft wieder alles.

Kennt einer von euch das Problem?
Was kann ich da machen?

------------------
Gruß

Dirk

Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP

Dirk.B
Mitglied
Tischler / Leiter Arbeitsvorbereitung


Sehen Sie sich das Profil von Dirk.B an!   Senden Sie eine Private Message an Dirk.B  Schreiben Sie einen Gästebucheintrag für Dirk.B

Beiträge: 534
Registriert: 25.11.2003

AutoCAD 2021/2022
CAD+T
HP ZBook 15 G4, 64-bit,
WIN 10 Pro

erstellt am: 23. Mai. 2012 09:25    Editieren oder löschen Sie diesen Beitrag!  <-- editieren / zitieren -->   Antwort mit Zitat in Fett Antwort mit kursivem Zitat    Unities abgeben: 1 Unity (wenig hilfreich, aber dennoch)2 Unities3 Unities4 Unities5 Unities6 Unities7 Unities8 Unities9 Unities10 Unities

Verweise.jpg

UserForm1.jpg
 
Guten Morgen zusammen!

Ich komme mit meinem Problem dem Programmabbruch nicht weiter.

Mit meinem Tool hole ich mir aus einer Datenbank Informationen, mit den ich
unser Zeichnungsschriftfeld (Blockattribute) füllen kann.
So weit so gut.

Hin und wieder kommt es dabei allerdings zu einem Programmabbruch in sofern,
dass ich die Toolmaske ausfüllen kann und nach bem Buttonclick die Daten nicht
übergeben werden.
AutoCAD gibt dann "Fehler bei der Ausführung" aus.

Ruf ich mein Tool anschließend wieder auf, erschein es zwar auch, allerdings in der Optik
der UserForm1 des VB-Editors.

Diese Maske läßt sich dann aber leider nicht schließen oder beenden, sondern erst über den Task- Manager
Prozess beenden, siehe Trade vorher.

Woran kann das liegen?

Für Hilfe wäre ich sehr dankbar.

------------------
Gruß

Dirk

Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP

Carsten1210
Mitglied
staatl. geprüfter Holztechniker


Sehen Sie sich das Profil von Carsten1210 an!   Senden Sie eine Private Message an Carsten1210  Schreiben Sie einen Gästebucheintrag für Carsten1210

Beiträge: 1360
Registriert: 24.07.2002

 erstellt am: 23. Mai. 2012 11:32    Editieren oder löschen Sie diesen Beitrag!  <-- editieren / zitieren -->   Antwort mit Zitat in Fett Antwort mit kursivem Zitat    Unities abgeben: 1 Unity (wenig hilfreich, aber dennoch)2 Unities3 Unities4 Unities5 Unities6 Unities7 Unities8 Unities9 Unities10 Unities Nur für Dirk.B 10 Unities + Antwort hilfreich
Hi Dirk,

Am besten wäre es wenn man den Code zum testen hätte.

Gruß, Carsten

Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP

Dirk.B
Mitglied
Tischler / Leiter Arbeitsvorbereitung


Sehen Sie sich das Profil von Dirk.B an!   Senden Sie eine Private Message an Dirk.B  Schreiben Sie einen Gästebucheintrag für Dirk.B

Beiträge: 534
Registriert: 25.11.2003

AutoCAD 2021/2022
CAD+T
HP ZBook 15 G4, 64-bit,
WIN 10 Pro

erstellt am: 23. Mai. 2012 14:52    Editieren oder löschen Sie diesen Beitrag!  <-- editieren / zitieren -->   Antwort mit Zitat in Fett Antwort mit kursivem Zitat    Unities abgeben: 1 Unity (wenig hilfreich, aber dennoch)2 Unities3 Unities4 Unities5 Unities6 Unities7 Unities8 Unities9 Unities10 Unities
Hi Carsten!

Wie gehts?

Das mit der Bereitstellung des Code zum testen, macht wegen der Datenbankanbindung wenig Sinn.
Hier mal die wesentlichen Auszüge aus meinem Programm:

Modul:

Code:

Option Explicit

Public AttWert As Variant
Public Color1 As Variant

Sub User_Dialog()
'##--Variablenfestlegung--!!!
Dim sset As AcadSelectionSet
Dim BlockObj As AcadObject
Dim BlockEnt As Variant
Dim minPkt As Variant
Dim maxPkt As Variant
Dim BlockData(1) As Variant
Dim BlockType(1) As Integer
BlockType(0) = 0                      'Suche ElemBlockEnttyp
BlockData(0) = "INSERT"                'Blockreferenz
BlockType(1) = 2                      'Suche Attribut, Blockname
BlockData(1) = "Hoffmann_Schriftfeld,Hoffmann_Interior_Schriftfeld,Hoffmann_Interior_Schriftfeld_englisch"  'Name des Blockes

'##--per If ... Then die Fehlerroutine steuern--!!!
If ThisDrawing.ActiveSpace = acModelSpace Then
    MsgBox "Dieses Tool ist nur im Papierbereich einsetzbar.", 64, "Hinweis"
    '--Ist der Modelbereich aktiv wird das Programm abgebrochen--!
    Exit Sub
Else
    On Error GoTo 0
    ThisDrawing.ActiveSpace = acPaperSpace
    ThisDrawing.ActiveLayout = ThisDrawing.ActiveLayout
   
    On Error Resume Next
    Set sset = ActiveDocument.SelectionSets.Add("Temp")
    If Err <> 0 Then
        Set sset = ActiveDocument.SelectionSets("Temp")
    End If
   
    On Error GoTo 0
    ReDim minPkt(0 To 2) As Double
    ReDim maxPkt(0 To 2) As Double
    minPkt = ThisDrawing.GetVariable("ExtMin")
    maxPkt = ThisDrawing.GetVariable("ExtMax")
   
    sset.Select acSelectionSetWindow, minPkt, maxPkt, BlockType, BlockData
   
    If sset.Count = 0 Then
        MsgBox "Kein Schriftfeld vorhanden", 64, "Hinweis"
        '--Ist der Papierbereich aktiv aber kein Schriftfeld vorhanden--!
        '--wird das Programm abgebrochen--------------------------------!
        Exit Sub
    Else
        For Each BlockEnt In sset
            Set BlockObj = BlockEnt
            If BlockObj.ObjectName = "AcDbBlockReference" Then
                If BlockObj.HasAttributes Then
                    AttWert = BlockObj.GetAttributes
                End If
            End If
        Next BlockEnt
       
        sset.Clear
        sset.Delete
    End If
StartMask.Show
End If
End Sub

Public Function RegRead(Path As String) As String
Dim ws As Object
    On Error GoTo ErrHandler
    Set ws = CreateObject("WScript.Shell")
    RegRead = ws.RegRead(Path)
Exit Function
ErrHandler:
    RegRead = ""
End Function

Public Function RegWrite( _
    ByVal Path As String, _
    ByVal Value As String, _
    Optional _
    ByVal Typ As String = "REG_SZ") As Boolean
Dim ws As Object
    On Error GoTo ErrHandler
    Set ws = CreateObject("WScript.Shell")
    ws.RegWrite Path, Value, Typ
    RegWrite = True
Exit Function
ErrHandler:
    RegWrite = False
End Function

Public Function BrowseForFolder1() As String
Dim oShell As Object
Dim oFolder As Object
    Set oShell = CreateObject("Shell.Application")
    Set oFolder = oShell.BrowseForFolder(0, "Bitte einen Ordner auswählen", 1)
    If Not oFolder Is Nothing Then
        BrowseForFolder1 = oFolder.Self.Path
    End If
End Function

Public Function BrowseForFolder2() As String
Dim oShell As Object
Dim oFolder As Object
Dim StartFile As Variant

StartFile = Optionen.TBBlockVerzeichnis.Text & "\"

    Set oShell = CreateObject("Shell.Application")
    Set oFolder = oShell.BrowseForFolder(0, "Bitte einen Ordner auswählen", 1, StartFile)
    If Not oFolder Is Nothing Then
        BrowseForFolder2 = oFolder.Self.Path
    End If
End Function

Sub ButtonUser(MyUser As CommandButton)
With MyUser
    .Picture = StartMask.ImageList1.ListImages(17).Picture
    .PicturePosition = fmPicturePositionAboveCenter
    .BackStyle = fmBackStyleTransparent
End With
End Sub

Sub ButtonDate(MyDate As CommandButton)
With MyDate
    .Picture = StartMask.ImageList1.ListImages(18).Picture
    .PicturePosition = fmPicturePositionAboveCenter
    .BackStyle = fmBackStyleTransparent
End With
End Sub

Sub TBNOTCHANGE(MyBox As TextBox)
Color1 = RGB(245, 251, 203) 'beige
With MyBox
    .BackColor = Color1
    .Enabled = False
End With
End Sub

UserForm1:

Code:

Option Explicit

Private Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hwnd As Long, _
ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, _
ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long

Public Color1 As Variant
Public Color2 As Variant
Public Color3 As Variant

Public acad As Object
Public doc As Object
Public ms As Object
Public ss As Object
Public ssnew As Object
Public MsgBoxResp As Integer

Public Filter As String

Const pi = 3.14159

Function dtr(a As Double) As Double
    dtr = (a / 180) * pi
End Function

Private Sub cmd_GEZNAME_Click()
    TB_GEZNAME.SetFocus
    Perso.Show
End Sub
Private Sub cmd_BAEDNAME1_Click()
    TB_BAEDNAME1.SetFocus
    Perso.Show
End Sub
Private Sub cmd_BAEDNAME2_Click()
    TB_BAEDNAME2.SetFocus
    Perso.Show
End Sub
Private Sub cmd_BAEDNAME3_Click()
    TB_BAEDNAME3.SetFocus
    Perso.Show
End Sub
Private Sub cmd_BAEDNAME4_Click()
    TB_BAEDNAME4.SetFocus
    Perso.Show
End Sub
Private Sub cmd_BAEDNAME5_Click()
    TB_BAEDNAME5.SetFocus
    Perso.Show
End Sub
Private Sub cmd_BAEDNAME6_Click()
    TB_BAEDNAME6.SetFocus
    Perso.Show
End Sub
Private Sub cmd_BAEDNAME7_Click()
    TB_BAEDNAME7.SetFocus
    Perso.Show
End Sub

Private Sub cmd_GEZDAM_Click()
    TB_GEZDAM.SetFocus
    Kalender01.Show
End Sub
Private Sub cmd_BAEDAM1_Click()
    TB_BAEDAM1.SetFocus
    Kalender01.Show
End Sub
Private Sub cmd_BAEDAM2_Click()
    TB_BAEDAM2.SetFocus
    Kalender01.Show
End Sub
Private Sub cmd_BAEDAM3_Click()
    TB_BAEDAM3.SetFocus
    Kalender01.Show
End Sub
Private Sub cmd_BAEDAM4_Click()
    TB_BAEDAM4.SetFocus
    Kalender01.Show
End Sub
Private Sub cmd_BAEDAM5_Click()
    TB_BAEDAM5.SetFocus
    Kalender01.Show
End Sub
Private Sub cmd_BAEDAM6_Click()
    TB_BAEDAM6.SetFocus
    Kalender01.Show
End Sub
Private Sub cmd_BAEDAM7_Click()
    TB_BAEDAM7.SetFocus
    Kalender01.Show
End Sub

Private Sub TB_Filter_Change()
    TB_Filter.Text = Replace(TB_Filter.Text, "*", "&")
End Sub

Private Sub cmdSuchen_Click()

Filter = TB_Filter.Text
Filter = Replace(Filter, "*", "%")

If TB_Filter.Text = "" Then GoTo MyErrorHandler

Dim Cn As New ADODB.Connection
Dim Rs As New ADODB.Recordset
Dim LItem As ListItem

With Cn
    .CursorLocation = adUseClient

'###--Hier die Datenbankverküpfung
End With

'.....

With ListView1
    .ListItems.Clear
    .ColumnHeaders.Clear
    .View = lvwReport
    .SmallIcons = ImageList1
    .Sorted = True
End With

With ListView1.ColumnHeaders
    .Add , , "Status", 13                            'Status
    .Add , , "Ba-Nr", 60                            'Vorgangsnummer
    .Add , , "Position", 40                          'Auftragspositionsnummer
    .Add , , "Objekt-Bezeichnung", 200              'Objektbezeichnung
    .Add , , "Positions-Bezeichnung", 140            'Positionsbezeichnung
    .Add , , "Projektleitung", 70                    'Projektleitung
    .Add , , "Montagebeginn", 60                    'Montagebeginn
    .Add , , "Vermerk", 60                          'Vermerk
End With

'Rs.MoveFirst

Do Until Rs.EOF
    Set LItem = ListView1.ListItems.Add()
    LItem.Text = ""                                    'Status
    LItem.SubItems(1) = (Rs!AUF_NR & "")                'Vorgangsnummer
    LItem.SubItems(2) = (Rs!AUF_POS & "")              'Auftragspositionsnummer
    LItem.SubItems(3) = (Rs!AUF_BEZEICHNUNG & "")      'Objektbezeichnung
    LItem.SubItems(4) = (Rs!AUF_POS_BEZ & "")          'Positionsbezeichnung
    LItem.SubItems(5) = (Rs!SACHBEARBEITER & "")        'Projektleitung
    LItem.SubItems(6) = (Rs!AUF_MONTDATUM & "")        'Montagebeginn
    LItem.SubItems(7) = (Rs!AUF_TERMIN_VERMERK & "")    'Vermerk
    If Len(LItem.SubItems(7)) > 0 Then
        LItem.SmallIcon = 1
    End If
    Rs.MoveNext
Loop
Rs.Close
Set Rs = Nothing
Cn.Close
Set Cn = Nothing

LB_LV_Anzahl.Caption = "Anzahl der gefundenen Datensätze = " & ListView1.ListItems.Count

Exit Sub
MyErrorHandler:
    MsgBox "Es wurde kein Suchkreterium eingegeben", 64, "Hinweis"

End Sub

Private Sub cmdUebergabe_Click()
    UpdateAttrib 0, StartMask.TB_BBVH1.Text
    UpdateAttrib 1, StartMask.TB_BBVH2.Text
    UpdateAttrib 2, StartMask.TB_GEZDAM.Text
    UpdateAttrib 3, StartMask.TB_GEZNAME.Text
    UpdateAttrib 4, StartMask.TB_BBESCHREIB.Text
    UpdateAttrib 5, StartMask.TB_BBESCHREIB1.Text
    UpdateAttrib 6, StartMask.TB_BBESCHREIB2.Text
    UpdateAttrib 7, StartMask.TB_BBESCHREIB3.Text
   
    UpdateAttrib 8, StartMask.TB_BAUFTRAG.Text
    UpdateAttrib 9, StartMask.TB_BLATT.Text
    UpdateAttrib 10, StartMask.TB_BAEDAM1.Text
    UpdateAttrib 11, StartMask.TB_BAEDNAME1.Text
    UpdateAttrib 12, StartMask.TB_BAEDAM2.Text
    UpdateAttrib 13, StartMask.TB_BAEDNAME2.Text
    UpdateAttrib 14, StartMask.TB_BAEDAM3.Text
    UpdateAttrib 15, StartMask.TB_BAEDNAME3.Text
    UpdateAttrib 16, StartMask.TB_BAEDAM4.Text
    UpdateAttrib 17, StartMask.TB_BAEDNAME4.Text
    UpdateAttrib 18, StartMask.TB_BAEDAM5.Text
    UpdateAttrib 19, StartMask.TB_BAEDNAME5.Text
    UpdateAttrib 20, StartMask.TB_BAEDAM6.Text
    UpdateAttrib 21, StartMask.TB_BAEDNAME6.Text
    UpdateAttrib 22, StartMask.TB_BAEDAM7.Text
    UpdateAttrib 23, StartMask.TB_BAEDNAME7.Text
    UpdateAttrib 24, StartMask.TB_LYBEZEICH.Text
    UpdateAttrib 25, StartMask.TB_BETAUFTRAG.Text
    UpdateAttrib 26, StartMask.TB_BETAUFTRAG1.Text
Unload Me
End

End Sub

Sub UpdateAttrib(TagNumber As Integer, BTextString As String)
'--Attributswert auf Nullwert prüfen--!!!
If BTextString = "" Then
    AttWert(TagNumber).TextString = "-"
Else
    AttWert(TagNumber).TextString = BTextString
End If
End Sub

Public Sub UserForm_Initialize()

On Error Resume Next

Me.Hide

StartMask.TB_BBVH1.Text = Strings.LTrim(AttWert(0).TextString)
StartMask.TB_BBVH2.Text = Strings.LTrim(AttWert(1).TextString)
StartMask.TB_GEZDAM.Text = Strings.LTrim(AttWert(2).TextString)
StartMask.TB_GEZNAME.Text = Strings.LTrim(AttWert(3).TextString)
StartMask.TB_BBESCHREIB.Text = Strings.LTrim(AttWert(4).TextString)
StartMask.TB_BBESCHREIB1.Text = Strings.LTrim(AttWert(5).TextString)
StartMask.TB_BBESCHREIB2.Text = Strings.LTrim(AttWert(6).TextString)
StartMask.TB_BBESCHREIB3.Text = Strings.LTrim(AttWert(7).TextString)

StartMask.TB_BAUFTRAG.Text = Strings.LTrim(AttWert(8).TextString)
StartMask.TB_BLATT.Text = Strings.LTrim(AttWert(9).TextString)
StartMask.TB_BAEDAM1.Text = Strings.LTrim(AttWert(10).TextString)
StartMask.TB_BAEDNAME1.Text = Strings.LTrim(AttWert(11).TextString)
StartMask.TB_BAEDAM2.Text = Strings.LTrim(AttWert(12).TextString)
StartMask.TB_BAEDNAME2.Text = Strings.LTrim(AttWert(13).TextString)
StartMask.TB_BAEDAM3.Text = Strings.LTrim(AttWert(14).TextString)
StartMask.TB_BAEDNAME3.Text = Strings.LTrim(AttWert(15).TextString)
StartMask.TB_BAEDAM4.Text = Strings.LTrim(AttWert(16).TextString)
StartMask.TB_BAEDNAME4.Text = Strings.LTrim(AttWert(17).TextString)
StartMask.TB_BAEDAM5.Text = Strings.LTrim(AttWert(18).TextString)
StartMask.TB_BAEDNAME5.Text = Strings.LTrim(AttWert(19).TextString)
StartMask.TB_BAEDAM6.Text = Strings.LTrim(AttWert(20).TextString)
StartMask.TB_BAEDNAME6.Text = Strings.LTrim(AttWert(21).TextString)
StartMask.TB_BAEDAM7.Text = Strings.LTrim(AttWert(22).TextString)
StartMask.TB_BAEDNAME7.Text = Strings.LTrim(AttWert(23).TextString)
StartMask.TB_LYBEZEICH.Text = Strings.LTrim(AttWert(24).TextString)
StartMask.TB_BETAUFTRAG.Text = Strings.LTrim(AttWert(25).TextString)
StartMask.TB_BETAUFTRAG1.Text = Strings.LTrim(AttWert(26).TextString)

Call ButtonUser(cmd_GEZNAME)
Call ButtonUser(cmd_BAEDNAME1)
Call ButtonUser(cmd_BAEDNAME2)
Call ButtonUser(cmd_BAEDNAME3)
Call ButtonUser(cmd_BAEDNAME4)
Call ButtonUser(cmd_BAEDNAME5)
Call ButtonUser(cmd_BAEDNAME6)
Call ButtonUser(cmd_BAEDNAME7)

Call ButtonDate(cmd_GEZDAM)
Call ButtonDate(cmd_BAEDAM1)
Call ButtonDate(cmd_BAEDAM2)
Call ButtonDate(cmd_BAEDAM3)
Call ButtonDate(cmd_BAEDAM4)
Call ButtonDate(cmd_BAEDAM5)
Call ButtonDate(cmd_BAEDAM6)
Call ButtonDate(cmd_BAEDAM7)

Call TBNOTCHANGE(TB_Z_NAME)
Call TBNOTCHANGE(TB_BAUFTRAG)
Call TBNOTCHANGE(TB_BETAUFTRAG)
Call TBNOTCHANGE(TB_BETAUFTRAG1)
Call TBNOTCHANGE(TB_BLATT)
Call TBNOTCHANGE(TB_LYBEZEICH)
Call TBNOTCHANGE(TB_BBVH1)

Color1 = RGB(241, 201, 70)  'gelb/grün
Color2 = RGB(255, 31, 31)  'rot
Color3 = RGB(112, 112, 112) 'grau

ComboBox1.Clear

With ListView1
    .ListItems.Clear
    .ColumnHeaders.Clear
    .View = lvwReport
End With

With ListView1.ColumnHeaders
    .Add , , "Status", 13                            'Status
    .Add , , "Ba-Nr", 60                            'Vorgangsnummer
    .Add , , "Position", 40                          'Auftragspositionsnummer
    .Add , , "Objekt-Bezeichnung", 200              'Objektbezeichnung
    .Add , , "Positions-Bezeichnung", 140            'Positionsbezeichnung
    .Add , , "Projektleitung", 70                    'Projektleitung
    .Add , , "Montagebeginn", 60                    'Montagebeginn
    .Add , , "Vermerk", 60                          'Vermerk
End With

Dim a(3) As String
Dim I As Integer
a(1) = ListView1.ColumnHeaders(2)
a(2) = ListView1.ColumnHeaders(4)
a(3) = ListView1.ColumnHeaders(5)

For I = 1 To UBound(a)
    ComboBox1.AddItem a(I)
Next I
ComboBox1.Text = ComboBox1.List(0)

Dim n As String
Dim ALayout As AcadLayout

Set ALayout = ThisDrawing.ActiveLayout

n = ThisDrawing.Layouts.Count - 1

TB_BLATT.Text = ALayout.TabOrder & " / " & n
TB_LYBEZEICH.Text = ThisDrawing.ActiveLayout.Name
With TB_Filter
    .Locked = False
End With

With cmdEnde
    .Caption = "Abbrechen / Beenden"
    .Picture = ImageList1.ListImages(2).Picture
    .PicturePosition = fmPicturePositionLeftCenter
End With

With cmdInfo
    .Caption = ""
    .Picture = ImageList1.ListImages(4).Picture
    .PicturePosition = fmPicturePositionCenter
End With

With cmdSuchen
    .Caption = ""
    .Picture = ImageList1.ListImages(16).Picture
    .PicturePosition = fmPicturePositionLeftCenter
End With

'With cmdVerzeichnis
'    .Picture = ImageList1.ListImages(3).Picture
'    .PicturePosition = fmPicturePositionCenter
'End With

With cmdOptionen
    .Caption = ""
    .Picture = ImageList1.ListImages(3).Picture
    .PicturePosition = fmPicturePositionLeftCenter
    .Visible = False
End With

With cmdUebergabe
    .Caption = "  Erfassungen abspeichern"
    .Picture = ImageList1.ListImages(1).Picture
    .PicturePosition = fmPicturePositionLeftCenter
    .BackColor = Color1
End With

With cmdUmschalt
    .Caption = ""
    .Picture = ImageList1.ListImages(13).Picture
    .PicturePosition = fmPicturePositionLeftCenter
End With

With ImageBorm
    .Picture = ImageList1.ListImages(15).Picture
    .PictureAlignment = fmPictureAlignmentCenter
    .PictureSizeMode = fmPictureSizeModeZoom
    .BackColor = StartMask.BackColor
    .BorderStyle = fmBorderStyleNone
End With

With cmdDBConect
    .Caption = ""
    .Picture = ImageList1.ListImages(15).Picture
    .PicturePosition = fmPicturePositionLeftCenter
End With

StatusBar1.Panels(1).Text = VBE.activevbproject.FileName

'--Anzahl dergefundenen Datensätze anzeigen
LB_LV_Anzahl.Caption = ""
'--Datenbankpfad für den Registryeintrag festlegen
Dim regpfad As String
Dim Wert As String
    regpfad = "HKEY_CURRENT_USER\Software\Autodesk\DB_Tuning\BlockV3\DB_Pfad"
'    StartMask.TextBox1.Text = RegRead(regpfad)

'--MyErrorHandler--!!! '????noch nicht definiert????
'Exit Sub
'MyErrorHandler1:
'    MsgBox "Dieses Tool ist nur im Layout - Papierbereich einsetzbar.", 64, "Hinweis"

'MyErrorHandler2:
'    MsgBox "Es ist kein Schriftfeldblock vorhanden.", 64, "Hinweis"

End Sub

------------------
Gruß

Dirk

Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP

Stelli1
Moderator
Verm.-Ing.


Sehen Sie sich das Profil von Stelli1 an!   Senden Sie eine Private Message an Stelli1  Schreiben Sie einen Gästebucheintrag für Stelli1

Beiträge: 1526
Registriert: 17.08.2005

Map 2000-2014, Rasterdesign,
MapGuide, Autodesk Topobase,
VS6, VS.net 2013

erstellt am: 23. Mai. 2012 17:07    Editieren oder löschen Sie diesen Beitrag!  <-- editieren / zitieren -->   Antwort mit Zitat in Fett Antwort mit kursivem Zitat    Unities abgeben: 1 Unity (wenig hilfreich, aber dennoch)2 Unities3 Unities4 Unities5 Unities6 Unities7 Unities8 Unities9 Unities10 Unities Nur für Dirk.B 10 Unities + Antwort hilfreich
Hallo Dirk,

das kann man so einfach nicht sagen. Wenn es an der Datenbankverbindung liegt, hast du alles ausgelassen.

Code:
With Cn
    .CursorLocation = adUseClient

'###--Hier die Datenbankverküpfung
End With

Da sollte doch in der Connection ein LockType drin sein, zumindest wenn mehrere darauf zugreifen.
Wie füllst du das Recordset.

Und ich würde an deiner Stelle erst mal das ON ERROR RESUME NEXT entfernen. Da weisst du doch nie wo der Hammer hängt.

Wilfried Stelberg

------------------
Warum lisp'eln wenn's auch anders geht. 
www.ib-stelberg.de

Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP

Dirk.B
Mitglied
Tischler / Leiter Arbeitsvorbereitung


Sehen Sie sich das Profil von Dirk.B an!   Senden Sie eine Private Message an Dirk.B  Schreiben Sie einen Gästebucheintrag für Dirk.B

Beiträge: 534
Registriert: 25.11.2003

 erstellt am: 24. Mai. 2012 13:57    Editieren oder löschen Sie diesen Beitrag!  <-- editieren / zitieren -->   Antwort mit Zitat in Fett Antwort mit kursivem Zitat    Unities abgeben: 1 Unity (wenig hilfreich, aber dennoch)2 Unities3 Unities4 Unities5 Unities6 Unities7 Unities8 Unities9 Unities10 Unities
Hallo Wilfried!

Hier der Teil Datenbankanbindung.
(Datenbank Microsoft SQLSERVER 2008)

Code:

Private Sub cmdSuchen_Click()

Filter = TB_Filter.Text
Filter = Replace(Filter, "*", "%")

If TB_Filter.Text = "" Then GoTo MyErrorHandler

Dim Cn As New ADODB.Connection
Dim Rs As New ADODB.Recordset
Dim LItem As ListItem

With Cn
    .CursorLocation = adUseClient
    .Provider = "XXXXXXXX"
    .ConnectionString = "Data Source='XXXXXXXX'; Initial Catalog='XXXXXXXXX';User ID='XXX';Password='XXX'"
    .Open
End With

With Rs
    .CursorType = adOpenKeyset
    .LockType = adLockPessimistic
   
    Select Case ComboBox1.ListIndex
        Case 0
            .Open "SELECT AUF_STAMM.AUF_NR, AUF_STAMM.AUF_POS, AUF_STAMM.AUF_BEZEICHNUNG, _
            AUF_STAMM.AUF_POS_BEZ, ST_SACHBEARBEITER.SACHBEARBEITER, AUF_STAMM.AUF_MONTDATUM, _
            AUF_STAMM.AUF_TERMIN_VERMERK FROM AUF_STAMM, ST_SACHBEARBEITER _
            WHERE ST_SACHBEARBEITER.SACHBEARBEITER_ID = AUF_STAMM.SACHBEARBEITER_ID _
            AND AUF_NR LIKE '" & Filter & "'", Cn
        Case 1
            .Open "SELECT AUF_STAMM.AUF_NR, AUF_STAMM.AUF_POS, AUF_STAMM.AUF_BEZEICHNUNG, _
            AUF_STAMM.AUF_POS_BEZ, ST_SACHBEARBEITER.SACHBEARBEITER, AUF_STAMM.AUF_MONTDATUM, _
            AUF_STAMM.AUF_TERMIN_VERMERK FROM AUF_STAMM, ST_SACHBEARBEITER _
            WHERE ST_SACHBEARBEITER.SACHBEARBEITER_ID = AUF_STAMM.SACHBEARBEITER_ID _
            AND AUF_BEZEICHNUNG LIKE '" & Filter & "'", Cn
        Case 2
            .Open "SELECT AUF_STAMM.AUF_NR, AUF_STAMM.AUF_POS, AUF_STAMM.AUF_BEZEICHNUNG, _
            AUF_STAMM.AUF_POS_BEZ, ST_SACHBEARBEITER.SACHBEARBEITER, AUF_STAMM.AUF_MONTDATUM, _
            AUF_STAMM.AUF_TERMIN_VERMERK FROM AUF_STAMM, ST_SACHBEARBEITER WHERE _
            ST_SACHBEARBEITER.SACHBEARBEITER_ID = AUF_STAMM.SACHBEARBEITER_ID _
            AND AUF_POS_BEZ LIKE '" & Filter & "'", Cn
    End Select
End With

With ListView1
    .ListItems.Clear
    .ColumnHeaders.Clear
    .View = lvwReport
    .SmallIcons = ImageList1
    .Sorted = True
End With

With ListView1.ColumnHeaders
    .Add , , "Status", 13
    .Add , , "Ba-Nr", 60
    .Add , , "Position", 40
    .Add , , "Objekt-Bezeichnung", 200
    .Add , , "Positions-Bezeichnung", 140
    .Add , , "Projektleitung", 70
    .Add , , "Montagebeginn", 60
    .Add , , "Vermerk", 60
End With

Do Until Rs.EOF
    Set LItem = ListView1.ListItems.Add()
    LItem.Text = ""
    LItem.SubItems(1) = (Rs!AUF_NR & "")
    LItem.SubItems(2) = (Rs!AUF_POS & "")
    LItem.SubItems(3) = (Rs!AUF_BEZEICHNUNG & "")
    LItem.SubItems(4) = (Rs!AUF_POS_BEZ & "")
    LItem.SubItems(5) = (Rs!SACHBEARBEITER & "")
    LItem.SubItems(6) = (Rs!AUF_MONTDATUM & "")
    LItem.SubItems(7) = (Rs!AUF_TERMIN_VERMERK & "")
    If Len(LItem.SubItems(7)) > 0 Then
        LItem.SmallIcon = 1
    End If
    Rs.MoveNext
Loop
Rs.Close
Set Rs = Nothing
Cn.Close
Set Cn = Nothing

Exit Sub
MyErrorHandler:
    MsgBox "Es wurde kein Suchkreterium eingegeben", 64, "Hinweis"

End Sub

Das mit dem ON ERROR RESUME NEXT habe ich gemacht, jedoch ohne Wirkung.


------------------
Gruß

Dirk

Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP

Anzeige.:

Anzeige: (Infos zum Werbeplatz >>)

Darstellung des Themas zum Ausdrucken. Bitte dann die Druckfunktion des Browsers verwenden. | Suche nach Beiträgen

nächster neuerer Beitrag | nächster älterer Beitrag
Antwort erstellen


Diesen Beitrag mit Lesezeichen versehen ... | Nach anderen Beiträgen suchen | CAD.de-Newsletter

Administrative Optionen: Beitrag schliessen | Archivieren/Bewegen | Beitrag melden!
Fragen und Anregungen: Kritik-Forum | Neues aus der Community: Community-Forum

(c)2025 CAD.de | Impressum | Datenschutz