Message 1 of 4
My code
Not applicable
09-24-2002
12:08 AM
- Mark as New
- Bookmark
- Subscribe
- Mute
- Subscribe to RSS Feed
- Permalink
- Report
Frank,
Here is my sub which does the work. The myApp part was a try to avoid using
ThisDrawing...
Michel.
Private Sub cmdScan_Click()
Dim i As Long
Dim FileNumber As Integer
Dim strname As String
Dim myApp As AutoCAD.AcadApplication
On Error GoTo err_bloc
If List1.ListCount = 0 Then Exit Sub
Me.MousePointer = fmMousePointerHourGlass
Me.hide
FileNumber = FreeFile ' Get unused file number.
Open thePath & "SigaScan_" & Date & ".txt" For Output As #FileNumber
Print #FileNumber, "Répertoire (serveur): " & thePath & vbCrLf
Set myApp = ThisDrawing.Application
For i = 0 To List1.ListCount - 1
myApp.Documents.Open thePath & List1.List(i)
myApp.ZoomExtents
Print #FileNumber, myApp.Caption
myApp.ActiveDocument.Close False
Next i
Close #FileNumber ' Close file
Me.Show
defaut_bloc:
Me.MousePointer = fmMousePointerDefault
Set myApp = Nothing
Exit Sub
err_bloc:
Select Case Err.Number
Case 76
MsgBox "Oops!"
Resume defaut_bloc
Case Else
MsgBox "Erreur: " & Err.Number
Resume defaut_bloc
End Select
End Sub
Here is my sub which does the work. The myApp part was a try to avoid using
ThisDrawing...
Michel.
Private Sub cmdScan_Click()
Dim i As Long
Dim FileNumber As Integer
Dim strname As String
Dim myApp As AutoCAD.AcadApplication
On Error GoTo err_bloc
If List1.ListCount = 0 Then Exit Sub
Me.MousePointer = fmMousePointerHourGlass
Me.hide
FileNumber = FreeFile ' Get unused file number.
Open thePath & "SigaScan_" & Date & ".txt" For Output As #FileNumber
Print #FileNumber, "Répertoire (serveur): " & thePath & vbCrLf
Set myApp = ThisDrawing.Application
For i = 0 To List1.ListCount - 1
myApp.Documents.Open thePath & List1.List(i)
myApp.ZoomExtents
Print #FileNumber, myApp.Caption
myApp.ActiveDocument.Close False
Next i
Close #FileNumber ' Close file
Me.Show
defaut_bloc:
Me.MousePointer = fmMousePointerDefault
Set myApp = Nothing
Exit Sub
err_bloc:
Select Case Err.Number
Case 76
MsgBox "Oops!"
Resume defaut_bloc
Case Else
MsgBox "Erreur: " & Err.Number
Resume defaut_bloc
End Select
End Sub