Fix Bad Hatch Patterns (2k2,k4)

Problems with your concrete & gravel hatch patterns not displaying correctly?

I found a nice article @ cadalyst and decided to try to convert it to VBA. I couldn't really find the equivilant to "hatchedit" in the model, so i played around with some of the methods. I found that by rescaling the hatch and re-evaluating it, it will display correctly. If anyone has suggestions on better code, feel free to jump in

Code:

Sub Fix_Hatch()
On Error GoTo my_ERROR
Dim oEnt As AcadEntity
Dim vPT As Variant
Dim vOldSnapBase As Variant
Dim dblPatternScale As Double
Dim vTempSnapBase(0 To 1) As Double

' GET OLD SNAP BASE
vOldSnapBase = ThisDrawing.GetVariable("SNAPBASE")
' SELECT HATCH TO UPDATE
Set oEnt = EntSel("Select Hatch Pattern To Fix:")
If Not oEnt Is Nothing Then
If TypeOf oEnt Is AcadHatch Then
' CREATE TEMP SNAP BASE NEAR HATCH PATTERN
vTempSnapBase(0) = vPT(0)
vTempSnapBase(1) = vPT(1)
ThisDrawing.SetVariable "SNAPBASE", vTempSnapBase
' UPDATE HATCH PATTERN
dblPatternScale = oEnt.PatternScale
oEnt.PatternScale = dblPatternScale * 1.1
oEnt.PatternScale = dblPatternScale
oEnt.Evaluate
' RESTORE GOOD SNAP BASE POINT
ThisDrawing.SetVariable "SNAPBASE", vOldSnapBase
Else
MsgBox oEnt.ObjectName & " not supported.  Please choose a hatch pattern to update.", vbCritical + vbOKOnly, "Invalid Object Selected"
End If 'WRONG OBJECT TYPE
End If 'NOTHING SELECTED
my_EXIT:
ThisDrawing.SetVariable "SNAPBASE", vOldSnapBase
Exit Sub
my_ERROR:
MsgBox "Unable to update hatch pattern" & vbNewLine & _
Err.Number & Err.Description
Err.Clear

Resume my_EXIT
End Sub

(from: http://new.cadalyst.com/newsline/issue.cfm?issue=200418#6)

Code:

(defun c:hpf (/ om sb pt)
(setq om (getvar"osmode"))
(setvar "osmode" 15359)
(setq pt (getpoint"\nSnap to Any Point on Broken Hatch Pattern: "))
(command "snapbase" pt)
(command"hatchedit" pt "" "" "" "")
(setvar "osmode" om)
(command "snapbase" sb)
(princ)
)