PC Open 19/pcopen19.iso/Imag/IMAGINE/CUSTOM.Z/PATTERN.BAS

BASIC Source File | 1997-03-27 | 23.4 KB | 562 lines

Attribute VB_Name = "modPattern"
Option Explicit
'This data type is for each pass in the Hatch Pattern
Type PassData
    dRotation As Double
    dXOrigin As Double
    dYOrigin As Double
    dSpacing As Double
    dShift As Double
    DashGap(20) As Double
    DashCount As Double
End Type
'this data type is for storing all the data necessary for a Hatch pattern in one variable
Type HatchData
    HatchName As String
    HatchDescription As String
    Pass(100) As PassData
    NumPasses As Integer
End Type
Public gHatchArray(500) As HatchData
Public gpatFileName As String
Public gNumberOfHatches As Integer
Const mCOMMENTLINE = 1
Const mPATTERNNAME = 2
Const mVECTORLINE = 3
Const ERRORLINE = 4
Public gNumItemsInGrid As Integer
Public gfrmPattern As Form
Public gobjBook As Object
Dim mobjUnitsOfMeasure As Object
Declare Function WinHelp Lib "user32" Alias "WinHelpA" (ByVal hwnd As Long, ByVal lpHelpFile As String, ByVal wCommand As Long, ByVal dwData As Long) As Long
'
' This is the main module for the macro project.  It includes constants and Windows API
' declarations needed for the macro.
'
'
' Declare the rectangle type for use in GetWindowRect
'
Type RectType
    iLeft As Long
    iTop As Long
    iright As Long
    ibottom As Long
End Type
'
' Declare the Windows function that allows us to center a form either on the screen
' or within the application.
'
Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As RectType) As Long

'Declares and constant for getting the locale information
Public Const LOCALE_SDECIMAL = &HE
Declare Function GetLocaleInfo Lib "kernel32" Alias "GetLocaleInfoA" (ByVal Locale As Long, ByVal LCType As Long, ByVal lpLCData As String, ByVal cchData As Long) As Long
Declare Function GetUserDefaultLCID Lib "kernel32" () As Long


'
' This is the main function which is the entry point for the OLE server.
' Only initialization logic which is common to all macros in this server
' should be placed in this subroutine.
'
Sub main()
End Sub
'
' This function centers a form either on the screen if the hWndParent is 0 or within
' the parent.  Copied from VBProgrammers Journal OCT 95 and modified for our needs.
'
Sub CenterForm(ByVal hWndParent As Long, frmForm As Form)

    Dim iLeft As Long
    Dim iTop As Long
    Dim iMidX As Long
    Dim iMidY As Long
    Dim rcParent As RectType

    'Find the ideal center point
    If hWndParent = 0 Then
        ' No parent, center over the screen using the screen object
        iMidX = Screen.Width / 2
        iMidY = Screen.Height / 2
    Else
        ' Center within the form's parent
        Call GetWindowRect(hWndParent, rcParent)

        ' in calculating mid x it seems to me that we should left*twipsX and right*twipsX
        ' rather than right*twipsY
        iMidX = ((rcParent.iLeft * Screen.TwipsPerPixelX) + _
                 (rcParent.iright * Screen.TwipsPerPixelY)) / 2
        iMidY = ((rcParent.iTop * Screen.TwipsPerPixelY) + _
                 (rcParent.ibottom * Screen.TwipsPerPixelY)) / 2

        ' If the application is maximized or the app for some reason returns all 0 in the
        ' rectangle type, then center on the screen
        If (rcParent.iLeft = 0 And rcParent.iright = 0 And _
            rcParent.iTop = 0 And rcParent.ibottom = 0) Then
            iMidX = Screen.Width / 2
            iMidY = Screen.Height / 2
        End If
    End If


    ' Find the form's upper left based on that
    iLeft = iMidX - (frmForm.Width / 2)
    iTop = iMidY - (frmForm.Height / 2)

    ' If the form is outside the screen, move it inside
    If iLeft < 0 Then
        iLeft = 0
    ElseIf (iLeft + frmForm.Width) > Screen.Width Then
        iLeft = Screen.Width - frmForm.Width
    End If

    If iTop < 0 Then
        iTop = 0
    ElseIf (iTop + frmForm.Height) > Screen.Height Then
        iTop = Screen.Height - frmForm.Height
    End If

    ' Move the form to its new position
    frmForm.Move iLeft, iTop
End Sub
Public Function GetLineType(TextLine As String) As Integer
'This function returns one of the following types
'mCOMMENTLINE = 1
'mPATTERNNAME = 2
'mVECTORLINE = 3
'ERRORLINE = 4
Dim tempstring As String
Dim startLook As Integer
Dim commapos As Integer
Dim i As Integer
    If InStr(TextLine, ";") Then
        GetLineType = mCOMMENTLINE
    ElseIf InStr(TextLine, "*") Then
        GetLineType = mPATTERNNAME
    Else
        'test to see if there are four commas in the string
        startLook = 1
        For i = 1 To 4
            commapos = InStr(startLook, TextLine, ",", 0)
            If commapos = 0 Then
                Exit For
            Else
                startLook = commapos
            End If
        Next i
        If i < 4 Then
            GetLineType = ERRORLINE
        Else
            GetLineType = mVECTORLINE
        End If

    End If
End Function

Public Sub CreateHatchArray()
'Parses the .pat file and fills up the gHatchData Array
    Dim MyChar As String
    Dim hatchnum As Integer
    Dim oldhatchnum As Integer
    Dim NotCR As Boolean
    Dim i As Integer
    Dim LineData(1000) As String
    Dim tempstring As String
    Dim checkstring As String
    Dim teststring As String
    Dim testpass As PassData
    Dim passnum As Integer
    Open gpatFileName For Input As #1
    NotCR = True
    Set mobjUnitsOfMeasure = gfrmPattern.igCommand1.Application.ActiveBook.UnitsOfMeasure
    While Not EOF(1)
        NotCR = True
        While NotCR And Not EOF(1)
            MyChar = Input(1, #1)
            If MyChar = Chr(13) Then
                'check the line type
                If GetLineType(tempstring) = mPATTERNNAME Then
                    'Break the line into Description and Name Parts and pass them to the
                    'global structure gHatchArray
                    tempstring = Right(tempstring, Len(tempstring) - 2)
                    gHatchArray(hatchnum).HatchName = Left(tempstring, InStr(tempstring, ",") - 1)
                    gHatchArray(hatchnum).HatchDescription = LTrim(Right(tempstring, Len(tempstring) - InStr(tempstring, ",")))
                    gHatchArray(oldhatchnum).NumPasses = passnum
                    oldhatchnum = hatchnum
                    hatchnum = hatchnum + 1
                    passnum = 0
                ElseIf GetLineType(tempstring) = mVECTORLINE Then
                    '
                    gHatchArray(oldhatchnum).Pass(passnum) = ParseVectorLine(tempstring)
                    passnum = passnum + 1
                End If
                NotCR = False
                teststring = tempstring
                tempstring = ""
            Else
                tempstring = tempstring + MyChar
                checkstring = tempstring
            End If
        Wend
        gHatchArray(oldhatchnum).NumPasses = passnum

    Wend
    'test to see if the last line grabbed when EOF marker was found was a vectorline
    If GetLineType(checkstring) = mVECTORLINE Then
        'add the additional line to the gHatchArray
        passnum = passnum + 1
        gHatchArray(oldhatchnum).Pass(passnum) = ParseVectorLine(checkstring)
        gHatchArray(oldhatchnum).NumPasses = passnum
    End If
    Close #1
    gNumberOfHatches = hatchnum - 1
    Set mobjUnitsOfMeasure = Nothing
End Sub
Function ParseVectorLine(linestring As String) As PassData
'This Function parses a line from the .pat file which has data for 1 pass.
'It returns it as type PassData
    Dim tempstring As String
    Dim numstring As String
    Dim testbit As Boolean
    Dim dashnum As Integer
    Dim temparray(20) As Double
    Dim j As Integer
    Dim i As Integer
    Dim dashgapcount As Integer
    Dim PreviousNegative As Boolean
    Dim lReturnValue As Long
    Dim sDecimalDelimiter As String * 10
    Dim sDelimiter As String
    Dim lDelimiterBuffer As Long
    Dim lLocaleID As Long
    Dim thickstring As String
    'dRotation As Double
    'dXOrigin As Double
    'dYOrigin As Double
    'dSpacing As Double
    'dShift As Double
    'DashGap(20) As Double
    'DashCount As integer
    tempstring = Trim(linestring)

    'Find decimal delimiter for this OS
    lLocaleID = GetUserDefaultLCID
    lDelimiterBuffer = Len(sDecimalDelimiter)
    lReturnValue = GetLocaleInfo(lLocaleID, LOCALE_SDECIMAL, sDecimalDelimiter, lDelimiterBuffer)

    If lReturnValue = 0 Then
        MsgBox "Error has occured while retrieving locale information.  Unable to continue.", vbExclamation
    Else
        sDelimiter = Left(sDecimalDelimiter, lReturnValue - 1)
    End If

    testbit = True
    With mobjUnitsOfMeasure
    'loop thru 5 times to set .dRotation .dXOrigin .dYOrigin .dSpacing .dShift for ParseVectorLine
        For i = 1 To 5
            tempstring = Trim(tempstring)
            'Sometimes there is no dashgap pattern, so we have to check for commas on the 5th pass
            If InStr(tempstring, ",") Then
                numstring = Left(tempstring, InStr(tempstring, ",") - 1)
            Else
                numstring = tempstring
                testbit = False
            End If

            If lReturnValue <> 0 Then
                numstring = ConvertDecimalDelimiter(Trim(numstring), sDelimiter)
            End If


            tempstring = Right(tempstring, Len(tempstring) - InStr(tempstring, ","))
            If i = 1 Then
                ParseVectorLine.dRotation = .ParseUnit(igUnitAngle, _
                                                numstring & " " & gfrmPattern.cmbAngle.Text)
            ElseIf i = 2 Then
                ParseVectorLine.dXOrigin = .ParseUnit(igUnitDistance, _
                                                numstring & " " & gfrmPattern.cmbLength.Text)
            ElseIf i = 3 Then
                ParseVectorLine.dYOrigin = .ParseUnit(igUnitDistance, _
                                                numstring & " " & gfrmPattern.cmbLength.Text)
            ElseIf i = 4 Then
                ParseVectorLine.dShift = .ParseUnit(igUnitDistance, _
                                                numstring & " " & gfrmPattern.cmbLength.Text)
            Else
                ParseVectorLine.dSpacing = .ParseUnit(igUnitDistance, _
                                                numstring & " " & gfrmPattern.cmbLength.Text)
                ' Enter a loop to fill up a temporary dashgap array
                ' If there are items for dashgap, check for commas so you know you've got the last item
                While testbit
                    If InStr(tempstring, ",") Then
                        numstring = Left(tempstring, InStr(tempstring, ",") - 1)
                    Else
                        numstring = tempstring
                        testbit = False
                    End If

                    If lReturnValue <> 0 Then
                        numstring = ConvertDecimalDelimiter(Trim(numstring), sDelimiter)
                    End If

                    temparray(dashnum) = Format(numstring)
                    tempstring = Right(tempstring, Len(tempstring) - InStr(tempstring, ","))
                    dashnum = dashnum + 1
                Wend
                'If there are values in temparray, further parse to fix for Imagineer's dashgap
                If dashnum <> 0 Then
                    For j = 0 To dashnum - 1
                        'test the value of the item in temparray entry act accordingly
                        If j = 0 Then
                            If temparray(0) < 0 Then 'negative
                                'Create a zero length dash
                                ParseVectorLine.DashGap(0) = 0
                                'take the absolute value and create the first gap
                                ParseVectorLine.DashGap(1) = _
                                        .ParseUnit(igUnitDistance, _
                                                CStr(Abs(temparray(0))) & _
                                                            gfrmPattern.cmbLength.Text)
                                PreviousNegative = True
                                dashgapcount = 2
                            ElseIf temparray(0) = 0 Then 'zero
                                'Convert line thickness to use proper locale decimal delimiter.
                                If lReturnValue <> 0 Then
                                    thickstring = ConvertDecimalDelimiter(Trim(gfrmPattern.cmbThick.Text), sDelimiter)
                                End If

                                'Create a Dot Dash.  This should be equal to the thickness of a line
                                ParseVectorLine.DashGap(0) = _
                                        .ParseUnit(igUnitDistance, _
                                                    thickstring)
                                dashgapcount = 1
                            Else 'Create a Dash
                                ParseVectorLine.DashGap(0) = _
                                                .ParseUnit(igUnitDistance, _
                                                            CStr(Abs(temparray(0))) & " " & gfrmPattern.cmbLength.Text)
                                dashgapcount = 1
                            End If
                        Else
                            'test to see if value for temparray is negative (indicating a gap)
                            If temparray(j) < 0 Then
                                'test to see if previous value was negative
                                If PreviousNegative Then
                                    ' add temparray value to the previous gap
                                    ParseVectorLine.DashGap(dashgapcount - 1) = _
                                        .ParseUnit(igUnitDistance, _
                                                CStr(Abs(temparray(j))) & _
                                                            gfrmPattern.cmbLength.Text)
                                Else
                                    'create a new gap
                                    ParseVectorLine.DashGap(dashgapcount) = _
                                                    .ParseUnit(igUnitDistance, _
                                                            CStr(Abs(temparray(j))) & _
                                                                gfrmPattern.cmbLength.Text)
                                    dashgapcount = dashgapcount + 1
                                End If
                                PreviousNegative = True
                            ElseIf temparray(j) > 0 Then 'dash
                                'test to see if previous value was negative
                                If PreviousNegative Then
                                    'create a new dash
                                    ParseVectorLine.DashGap(dashgapcount) = _
                                                    .ParseUnit(igUnitDistance, _
                                                        CStr(Abs(temparray(j))) & _
                                                            gfrmPattern.cmbLength.Text)
                                    dashgapcount = dashgapcount + 1
                                Else
                                    'add temparray value to the previous dash
                                    ParseVectorLine.DashGap(dashgapcount - 1) = _
                                                    .ParseUnit(igUnitDistance, _
                                                        CStr(Abs(temparray(j))) & _
                                                            gfrmPattern.cmbLength.Text)
                                End If
                                PreviousNegative = False
                            Else
                                'test to see if previous value was negative
                                If PreviousNegative Then
                                    'create a new dash dot
                                    ParseVectorLine.DashGap(dashgapcount) = _
                                        .ParseUnit(igUnitDistance, _
                                                    gfrmPattern.cmbThick.Text)
                                    dashgapcount = dashgapcount + 1
                                End If
                                PreviousNegative = False
                            End If
                        End If
                    Next j
                    'Test to see if there are an even number of dashes and gaps
                    If (dashgapcount) Mod 2 > 0 Then
                        'odd number therefore add a zero length gap to the end
                        ParseVectorLine.DashGap(dashgapcount) = 0
                        dashgapcount = dashgapcount + 1
                    End If
                    ParseVectorLine.DashCount = dashgapcount
                Else
                    ParseVectorLine.DashCount = 0
                End If

            End If
        Next i
    End With

End Function

Sub TestParser(hatchitem As HatchData)
'This is designed to make sure we're passing good data to the HatchPatternStyles Object
    Dim i As Integer
    Dim j As Integer
    Dim tempstring As String
    Debug.Print hatchitem.HatchName & "," & hatchitem.HatchDescription & "," & hatchitem.NumPasses
    For i = 0 To hatchitem.NumPasses - 1
        tempstring = ""
        For j = 0 To hatchitem.Pass(i).DashCount - 1
            tempstring = tempstring & hatchitem.Pass(i).DashGap(j) & ","
        Next j
        Debug.Print hatchitem.Pass(i).dRotation & "," & _
                    hatchitem.Pass(i).dXOrigin & "," & _
                    hatchitem.Pass(i).dYOrigin & "," & _
                    hatchitem.Pass(i).dSpacing & "," & _
                    hatchitem.Pass(i).dShift & "," & _
                    "\\" & tempstring
    Next i

End Sub
Sub AddPattern(hatchitem As HatchData)
'Adds a fill pattern to the Active Imagineer Book
    Dim i As Integer
    Dim j As Integer
    Dim ObjHatchStyle As Object
    Dim objFillStyle As Object
    Dim LineIndex As Integer
    Dim tempstring As String
    Dim sDashTypeName As String
    Dim lReturnValue As Long
    Dim sDecimalDelimiter As String * 10
    Dim sDelimiter As String
    Dim lDelimiterBuffer As Long
    Dim lLocaleID As Long
    Dim numstring As String


    sDashTypeName = ""

    'Find decimal delimiter for this OS
    lLocaleID = GetUserDefaultLCID
    lDelimiterBuffer = Len(sDecimalDelimiter)
    lReturnValue = GetLocaleInfo(lLocaleID, LOCALE_SDECIMAL, sDecimalDelimiter, lDelimiterBuffer)

    If lReturnValue = 0 Then
        MsgBox "Error has occured while retrieving locale information.  Unable to continue.", vbExclamation
    Else
        sDelimiter = Left(sDecimalDelimiter, lReturnValue - 1)
    End If

    'Test to see if the file style exists and prompt appropriately
    With gobjBook
        For Each objFillStyle In .FillStyles
            If LCase(objFillStyle.Name) = LCase(hatchitem.HatchName) Then
                If MsgBox("The " & hatchitem.HatchName & " pattern already exists in the Active Book.  Do you wish to Overwrite?", _
                            vbYesNo, "AutoCAD Pattern Conversion") = vbYes Then
                    'remove the hatch
                    tempstring = objFillStyle.Name
                    .FillStyles.Remove tempstring
                    .HatchPatternStyles.Remove tempstring
                    Exit For
                Else

                    Exit Sub
                End If
            End If
        Next

        Set ObjHatchStyle = .HatchPatternStyles.Add(hatchitem.HatchName, "")
        ObjHatchStyle.Units = 11 ' Means Paper which will be the default eventually
        ' Create a fill style object that will have the hatch as its pattern name.
        Set objFillStyle = .FillStyles.Add(hatchitem.HatchName, "")
        objFillStyle.PatternName = ObjHatchStyle.Name
        objFillStyle.Units = ObjHatchStyle.Units
        objFillStyle.Color = -2 ' Transparent
        objFillStyle.FillBackground = False


        If lReturnValue <> 0 Then
            numstring = ConvertDecimalDelimiter(gfrmPattern.cmbThick.Text, sDelimiter)
        End If

        For i = 0 To hatchitem.NumPasses - 1

           LineIndex = ObjHatchStyle.AddHatch(hatchitem.Pass(i).dRotation, _
                                    hatchitem.Pass(i).dXOrigin, _
                                    hatchitem.Pass(i).dYOrigin, _
                                    hatchitem.Pass(i).dSpacing, _
                                    hatchitem.Pass(i).dShift, _
                                    igBlackColor, _
                                    .UnitsOfMeasure.ParseUnit(igUnitDistance, _
                                                        numstring), _
                                    sDashTypeName)
            If hatchitem.Pass(i).DashCount > 0 Then
                ObjHatchStyle.SetDashGap LineIndex, hatchitem.Pass(i).DashCount, hatchitem.Pass(i).DashGap
            End If
        Next i
    End With
End Sub

Public Function ConvertDecimalDelimiter(sNumber As String, sDecimalDelimiter As String) As String
    Dim sInteger As String
    Dim sFractional As String
    Dim nPosition As Integer

    nPosition = InStr(sNumber, ".")
    If nPosition <> 0 Then
        sInteger = Left(sNumber, nPosition - 1)
        sFractional = Right(sNumber, Len(sNumber) - nPosition)
        ConvertDecimalDelimiter = sInteger & sDecimalDelimiter & sFractional
    Else
        ConvertDecimalDelimiter = sNumber
    End If


End Function

Public Sub CheckIfValidLocale()
    Dim lLocaleID As Long
    Dim lDelimiterBuffer As Long
    Dim lReturnValue As Long
    Dim sDecimalDelimiter As String * 10
    Dim sDelimiter As String
    Dim dTempValue As Double
    Dim sDistance As String
    Dim sErrorMsg As String

    'Find decimal delimiter for this OS
    lLocaleID = GetUserDefaultLCID
    lDelimiterBuffer = Len(sDecimalDelimiter)
    lReturnValue = GetLocaleInfo(lLocaleID, LOCALE_SDECIMAL, sDecimalDelimiter, lDelimiterBuffer)

    If lReturnValue <> 0 Then
        sDelimiter = Left(sDecimalDelimiter, lReturnValue - 1)
        sDistance = ConvertDecimalDelimiter("1.0", sDelimiter)

        Set mobjUnitsOfMeasure = gfrmPattern.igCommand1.Application.ActiveBook.UnitsOfMeasure

        On Error GoTo ErrorHandler

        'Make sure that we can parse distances
        sErrorMsg = "Warning - For this sample to work properly the Length Units and Angle Units on the main form must be translated to match the current locale of this operating system."
        dTempValue = mobjUnitsOfMeasure.ParseUnit(igUnitDistance, sDistance & " " & gfrmPattern.cmbLength.Text)

        'Make sure that we can parse angles
        sErrorMsg = "Warning - For this sample to work properly the Angle Units on the main form must be translated to match the current locale of this operating system."
        dTempValue = mobjUnitsOfMeasure.ParseUnit(igUnitAngle, "90 " & gfrmPattern.cmbAngle.Text)

        Set mobjUnitsOfMeasure = Nothing
        On Error GoTo 0
        Exit Sub
    End If

ErrorHandler:
    Set mobjUnitsOfMeasure = Nothing
    MsgBox sErrorMsg, vbCritical
    Exit Sub

End Sub