I'm using AutoCAD 2013 and I want to import block from another file. I wrote the code below:
Dim Zero(0 To 2) As Double
Dim i As Integer
For i = 0 To 2
Zero(i) = 0
Next i
Dim BlockRef As AcadBlockReference
FileToInsert = "D:\blocks.dwg"
Set BlockRef = ThisDrawing.ModelSpace.InsertBlock(Zero, FileToInsert, 1#, 1#, 1#, 0)
but I get the following error:
Run-time error '-2145386390 (8020006a)'
No database
I find it very strange because the same code worked a week ago and I did't touch none of the files since then...
If I open blocks.dwg there are a few blocks in it, just as they should.
If I comment out this part of the code, the same error seems to move to the next
Set ... = ThisDrawing.ModelSpace. ...
I would very much appreciate your help,
Špela
If the drawing already contains the block, you need to call InsertBlock with the block name only. Something like this:
Dim exist as Boolean
exist = False
For i = 0 To ThisDrawing.Blocks.Count - 1
If StrComp(ThisDrawing.Blocks.Item(i).Name, "blocks", vbTextCompare) = 0 Then
exist = True
Exit For
End If
Next i
ThisDrawing.ModelSpace.InsertBlock(point, IIf(exist, "blocks", "D:\blocks.dwg"), 1, 1, 1, 0)
Related
I have an Access tool/database with external database (ODBC) connections. It's purpose is to review call logs for issues and the user will decide the severity based on the contents of a message.
I have an idea, to assist the review, using VBA. I created an with about 50 strings, and compare that to a field (memo format) in a form (bound to a table column). I want the routine to ONLY highlight the matching portion of the string.
An example is:
If the array string contains "Repor", it will change the font size and color of only those letters within the memo field Like Reported, . with be larger font and different color
I can successfully do this in Excel VBA with this section of code below ("findar" is a pre-built array, rng1 is the designated range)
For i = LBound(findar) To UBound(findar)
For Each rngcell In rng1
startPos = 0
startPos = InStr(rngcell, findar(i))
If InStr(rngcell, findar(i)) <> 0 Then
rngcell.Characters(startPos, Len(findar(i))).Font.Color = vbBlue
rngcell.Characters(startPos, Len(findar(i))).Font.Size = 18
End If
Next rngcell
Next I
"Character", apparently doesn't exist in Access, so I'm trying this, triggered in the "Got Focus" event: It fails with RunTime error 13. I'm certain this is doable, but apparently not by me.....
Dim i As Integer
Dim startpos As Long
'findar is an array
'incident text is inside the form field
findar = Array("returned", "failed") 'real array is about 50 strings
inctext = Me.txtincidentdesc
lngred = RGB(255, 0, 0)
lngblack = RGB(0, 0, 0)
'reset to default
Me.txtincidentdesc.FontBold = False
Me.txtincidentdesc.ForeColor = lngblack
Me.txtincidentdesc.FontSize = 10
startpos = 0
For i = LBound(findar) To UBound(findar)
With Me.txtincidentdesc
If InStr(inctext, findar(i)) <> 0 Then
SelStart = InStr(inctext, findar(i))
SelLength = Len(findar(i))
txtincidentdesc(Mid(inctext, SelStart, SelLength)).ForeColor = lngred 'fails here RunTime error 13
' Me.txtincidentdesc.ForeColor = lngred ' this works fine
' Me.txtincidentdesc.FontSize = 20 'this works fine
End If
End With
Next
End Sub
I've also considered using a recordset and compare that against the memo field but that also failed. Thanks for any input or help on this. Maybe I'm just approaching it wrong
Mark
I have a userform which contains a number of checkboxes from 1 to 100. I have written some very simple code so that when you submit the form it creates a binary string that represents the state of those 100 checkboxes, where 0 is false and 1 is true. The code to do this is here:
Private Sub BusRulesSubmit_Click()
Dim myBinaryString As String
Dim nm As String
Dim c As Control
For busRuleIdx = 1 To 100
nm = "CheckBox" & busRuleIdx
Set c = Controls(nm)
If c.Value = True Then
myBinaryString = myBinaryString & "1"
Else
myBinaryString = myBinaryString & "0"
End If
Next
msgBox myBinaryString
End Sub
I now want to open this Userform from another form, where I have a similar binary string, and use this string to set the values of the checkboxes to true or false as appropariate. However I am having issues when setting my control. The code is here:
Private Sub populateBusRules()
Dim c As Control
Dim myBRBinary As String
myBRBinary = "000000000011100000000000000000000000000000000000000000000000000000000010000000000000000000000000000"
For busRuleIdx = 1 To 100
nm = "BusinessRules.CheckBox" & busRuleIdx
Set c = Controls(nm)
If Mid(myBRBinary, buRuleIdx - 1, 1) = 1 Then
c.Value = True
Else
c.Value = False
End If
Next
End Sub
When I run the above, I get a runtime error "Could not find the specified object" and when going to debug it highlights this problem where the code states "Set c = Controls(nm)" - and I can see that it is failing in the first round of the loop i.e. where nm = "BusinessRules.CheckBox1"
Interestingly if I run the code "Set c = Controls(BusinessRules.CheckBox1)" I get no such issue.
Any help would be much appreciated.
Thanks,
Paul.
I think the BusinessRules is giving you the issue. In the Controls collection, there is no Control named "BusinessRules.CheckBox1", only one named "CheckBox1" within the BusinessRules.Controls collection. Assuming there aren't other issues mentioned in the comments above (like the form being closed before this is called), then this should fix your issue
I have some problems with my excel VBA code, it does not work and yes, I do not know why...
I want to add each Record number once in a collection. My code looks like this:
For i = 1 To lo.ListRows.Count
Count = 1
Do While recordList.Count >= Count
recordFound = False
If lo.ListColumns("Record").DataBodyRange.Rows(i) = recordList(Count) Then
recordFound = True
End If
If recordFound = False Then
recordList.Add (lo.ListColumns("Record").DataBodyRange.Rows(i))
End If
Count = Count + 1
Loop
Next
What it does now, it returns empty collection...
Whould be great if you could help me guys!
There is no real need to test the Collection to see if the item exists if you give it a key.
You can code something like:
On Error Resume Next
For I = 1 To lo.ListRows.Count
With lo.ListColumns("Record").DataBodyRange.Rows(I)
RecordList.Add Item:=.Value, Key:=CStr(.Value)
End With
Next I
On Error GoTo 0
Adding an item with the same key will cause the operation to be rejected. If you are concerned about other errors than the duplicate key error, you can always check the error number in the inline code and branch depending on the results.
I haven't been able to test this with the reference to lo but it works with a reference to a range
Dim objDictionary As Object
Dim dictionaryKey As Variant
Dim i As Long
Set objDictionary = CreateObject("Scripting.Dictionary")
For i = 1 To lo.ListRows
objDictionary.Item(CStr(lo.ListColumns("Record").DataBodyRange.Rows(i))) = objDictionary.Item(CStr(lo.ListColumns("Record").DataBodyRange.Rows(i))) + 1
Next i
For Each dictionaryKey In objDictionary.keys
' Do something
Next dictionaryKey
I have used a dictionary object instead of a normal collection object as it should do what you are trying to do. Because the item is incremented each time, you can also return the count of each item by using
objDictionary.item(dictionaryKey)
I have a loop that can look like this:
For Each article In artAll
Next
or like this:
For i = 0 To Ubound(artAll)
Next
When the array length is 0, I get an error message. What is a good way to skip the loop when the array is empty? I suspect that I should use
On Error Goto
but I need help finalizing a solution.
If Len(Join(artAll, "")) = 0 Then
'your for loops here
Should work
I use this function to test for empty arrays:
Public Function isArrayEmpty(parArray As Variant) As Boolean
'Returns false if not an array or dynamic array that has not been initialised (ReDim) or has been erased (Erase)
If IsArray(parArray) = False Then isArrayEmpty = True
On Error Resume Next
If UBound(parArray) < LBound(parArray) Then isArrayEmpty = True: Exit Function Else: isArrayEmpty = False
End Function
Then in your main code:
If isArrayEmpty(yourArray) Then
'do something - typically:
MsgBox "Empty Array"
Exit Function
End If
For i = LBound(yourArray,1) To UBound(yourArray,1)
'do something
Next i
I like the solution given by #Dan but thought I would throw out there how I would normally handle an undimensionalized array:
Dim lngUboundTest As Long
lngUboundTest = -1
On Error Resume Next
lngUboundTest = UBound(artAll)
On Error GoTo 0
If lngUboundTest >= 0 Then
'Your loop...
This is an old question, but I found this solution to the problem, and it could be helpful to others:
If (Not myArray) = True Then
'Undimensionalized array. Respond as needed.
Else
'Array isn't empty, you can run your loop.
End If
It helped my out in a recent project, and found it to be very handy.
I found this thread looking for a solution to a problem where looping through a multidimensional array would fail if a dimensioned element was empty. I created the array by looping through a source that could have up to 6 datasets. Then after processing I would repeat this 19 more times.
Dim varDeskData As Variant
Dim varDesk As Variant
ReDim varDesk(1 To 6)
For y = 1 To 6
ReDim varDeskData(1 To 4)
varDeskData(1) = "nifty integer from source(y)"
varDeskData(2) = "nifty string from source(y)"
varDeskData(3) = "another nifty string from source(y)"
varDeskData(4) = "another nifty string from source(y)"
varDesk(y) = varDeskData
Next y
When I ran the following, I would get the first three processed but then it would fail on the fourth, because I had only loaded three into the parent array:
For y = 1 To 6
If varDesk(y)(1) > 0 Then
... do nifty stuff ...
End If
End If
Using the IsEmpty procedure on the top level elements of the parent array fixed this:
For y = 1 To 6
If IsEmpty(varDesk(y)) = False Then
If varDesk(y)(1) > 0 Then
... do nifty stuff ...
End If
End If
End If
I have a VBA macro that uses Microsoft MapPoint to calculate the distance between two locations for each record in my spreadsheet. I have about 120,000 records to process. The program runs smoothly for about 10,000 iterations then returns a Type Mismatch error where I define the MapPoint locations in my error handler. At which point, I select 'Debug' and then resume execution without editing any code, and it will run successfully for another 10,000 or so records before the same thing happens again.
I've checked my data, and I can't see why there would be a type mismatch, or for that matter why the code would choke on a record one time, and then, without resetting anything, handle the same record upon resuming. Any idea why this would happen?
For reference,
- column M contains locations of the form "X County, ST"
- column AN contains a separate location as ZIP
- column G contains the same location data as AN but in the form "X County, ST"
Sub distance_from_res()
Dim oApp As MapPoint.Application
Dim k As Long
Dim count As Long
Dim errors As Long
k = 0
count = Sheets("i1_20041").Range("A2", Sheets("i1_20041").Range("A2").End(xlDown)).count
errors = 0
Set oApp = CreateObject("MapPoint.Application.NA.11")
oApp.Visible = False
Set objMap = oApp.NewMap
Dim objRes As MapPoint.Location
Dim objFish As MapPoint.Location
'Error executes code at 'LocError' and then returns to point of error.
On Error GoTo LocError
Do While k < count
If Sheets("i1_20041").Range("M2").Offset(k, 0) <> "" Then
'Sets MapPoint locations as [County],[State] from Excel sheet columns "INT_CNTY_ST" and "ZIP".
Set objRes = objMap.FindResults(Sheets("i1_20041").Range("AN2").Offset(k, 0)).Item(1)
Set objFish = objMap.FindResults(Sheets("i1_20041").Range("M2").Offset(k, 0)).Item(1)
'Calculates distance between two locations and prints it in appropriate cell in Column AO.
Sheets("i1_20041").Range("AO2").Offset(k, 0) = objRes.DistanceTo(objFish)
Else
errors = errors + 1
End If
k = k + 1
Loop
'Displays appropriate message at termination of program.
If errors = 0 Then
MsgBox ("All distance calculations were successful!")
Else
MsgBox ("Complete! Distance could not be calculated for " & errors & " of " & count & " records.")
End If
Exit Sub
LocError:
If Sheets("i1_20041").Range("G2").Offset(k, 0) = "" Then
errors = errors + 1
Else
'THIS IS WHERE THE ERROR OCCURS!
Set objRes = objMap.FindResults(Sheets("i1_20041").Range("G2").Offset(k, 0)).Item(1)
Set objFish = objMap.FindResults(Sheets("i1_20041").Range("M2").Offset(k, 0)).Item(1)
'Calculates distance between two locations and prints it in appropriate cell in Column AO.
Sheets("i1_20041").Range("AO2").Offset(k, 0) = objRes.DistanceTo(objFish)
End If
k = k + 1
Resume
End Sub
UPDATE:
I incorporated most of the suggestions from #winwaed and #Mike D, and my code is now more accurate and doesn't choke on errors. However, the old problem reared its head in a new form. Now, after around 10,000 iterations, the code continues but prints the distance of the ~10,000th record for every record afterwards. I can restart the code at the trouble point, and it will find the distances normally for those records. Why would this happen? I've posted my updated code below.
Sub distance_from_res()
Dim oApp As MapPoint.Application
Dim k As Long
Dim rc As Long
Dim errors As Long
Dim dist As Double
Dim zipRes As Range
Dim coRes As Range
Dim coInt As Range
Dim distR As Range
Set zipRes = Sheets("Sheet1").Range("C2")
Set coRes = Sheets("Sheet1").Range("B2")
Set coInt = Sheets("Sheet1").Range("E2")
Set distR = Sheets("Sheet1").Range("G2")
k = 0
rc = Sheets("Sheet1").Range("F2", Sheets("Sheet1").Range("F2").End(xlDown)).Count
errors = 0
'Start MapPoint application.
Set oApp = CreateObject("MapPoint.Application.NA.11")
oApp.Visible = False
Set objMap = oApp.NewMap
Dim objResultsRes As MapPoint.FindResults
Dim objResultsInt As MapPoint.FindResults
Dim objRes As MapPoint.Location
Dim objInt As MapPoint.Location
Do While k < rc
'Check results for Res Zip Code. If good, set first result to objRes. If not, check results for Res County,ST. If good, set first result to objRes. Else, set objRes to Nothing.
Set objResultsRes = objMap.FindResults(zipRes.Offset(k, 0))
If objResultsRes.ResultsQuality = geoFirstResultGood Then
Set objRes = objResultsRes.Item(1)
Else
Set objResultsRes = Nothing
Set objResultsRes = objMap.FindResults(coRes.Offset(k, 0))
If objResultsRes.ResultsQuality = geoFirstResultGood Then
Set objRes = objResultsRes.Item(1)
Else
If objResultsRes.ResultsQuality = geoAmbiguousResults Then
Set objRes = objResultsRes.Item(1)
Else
Set objRes = Nothing
End If
End If
End If
Set objResultsInt = objMap.FindResults(coInt.Offset(k, 0))
If objResultsInt.ResultsQuality = geoFirstResultGood Then
Set objInt = objResultsInt.Item(1)
Else
If objResultsInt.ResultsQuality = geoAmbiguousResults Then
Set objInt = objResultsInt.Item(1)
Else
Set objInt = Nothing
End If
End If
On Error GoTo ErrDist
distR.Offset(k, 0) = objRes.DistanceTo(objInt)
k = k + 1
Loop
Exit Sub
ErrDist:
errors = errors + 1
Resume Next
End Sub
You are constructing a somewhat complex range object (Range -> Offset -> Item). DIM temporary range objects and do it in steps so you can see where exactly the problem occurs
tmpR1 = Sheets("i1_20041").Range("G2")
tmpR2 = tmpR1.Offset(k,0)
then examine the .Count property of the .FindResult before you try accessing Item(1) .... maybe this item doesn't exist ?!?
Debug.Print objMap.FindResult(tmpR2).Count
Hint:
looking at your code, I observe that you use a variable "count". This variable name overlaps with the "Count" property in your second line of code - that's why the "Count" keyword at the end of the statement is printed all lowercase. It's not got anything to do with the errors (we pretend ;-) ), but bad style anyway.
MikeD is right with your dangerous FindResults() calls. However, there is a better way to check the results. The "FindResults collection" isn't a pure collection but includes an extra properties called "ResultsQuality". Docs are here:
http://msdn.microsoft.com/en-us/library/aa493061.aspx
Resultsquality returns a GeoFindResultsQuality enumeration. You want to check for the values geoAllResultsGood and geFirstResultGood. All other results should give an error of some result. Note that your existing code would work find with (for example) Ambiguous Results, even though it is unlikely the first result is the correct one. Also it might match on State or Zipcode (because that is the best it can find) whcih give you an erroneous result. Using ResultsQuality, you can detect this.
I would still check the value of Count as an additional check.
Note that your code is calculating straight line (Great Circle) distances. As such the bottleneck will be the geocoding (FindResults). If you are using the same locations a lot, then a caching mechanism could greatly speed things up.
If you want to calculate driving distances, then there are a number of products on the market for this (yes I wrote two of them!).