+ Reply to Thread
Page 2 of 2 FirstFirst 1 2
Results 11 to 12 of 12
  1. #11
    Forum Newbie
    Using
    Map 3D 2016
    Join Date
    Apr 2016
    Posts
    8

    Default

    Registered forum members do not see this ad.

    This is the Module attached to the Create xlxs Button.

    The purpose is to take attribute information and concatenate those into 1 column titled "Description", and then have the drawing number attribute fill the second column titled "Drawing No.".

    For ease of use in the Drawing index Table that is in AutoCAD, I also have blank rows and underlined Subheadings in the Parent Workbook which I add as required.

    As an example, CROSS SECTIONS, would be manually added above a number of cross section drawings, then a blank row and underlined subheading of the next subcategory of Typical Details.
    This is the new feature I was initially trying to add to the workbook, as previously it was just a spreadsheet to populate title blocks. The Drawing index had to be typed manually as MText in the drawing, and needed to be manually updated as the Drawing register changed.

    I would like to be able to carry across the Underlined text and have the Table in AutoCAD have the text style of iso. Iso didn't seem to work, but isocp did. The Underlines are lost.

    This is also just a copy and paste collage of code, that gave satisfactory results in achieving what I wanted to do.
    For the Two weeks that it worked, I was pretty happy with what I had done as a VBA novice.

    Obviously not good enough to put on the fridge, but IT IS my first attempt...



    Sub SaveAsXLXS()
    '
    ' export Macro


    Dim wbS As Workbook, wbT As Workbook
    Dim wsS As Worksheet, wsT As Worksheet


    Set wbS = ThisWorkbook 'workbook that holds this code
    Set wsS = wbS.Worksheets("DRAWING INDEX")

    wsS.Copy
    Set wbT = ActiveWorkbook 'assign reference asap

    Set wsT = wbT.Worksheets("DRAWING INDEX")
    wsT.Name = "DRAWING INDEX" 'rename sheet

    MsgBox wbS.path, , "PATH"


    'Test to see if the folder path exists.


    Dim FolderPath As String

    FolderPath = wbS.path
    If Right(FolderPath, 1) <> "\" Then
    FolderPath = FolderPath & "\"
    End If

    If Dir(FolderPath, vbDirectory) <> vbNullString Then
    MsgBox "Folder exists"
    Else
    MsgBox "Folder doesn't exist"
    End If


    'test if file exists


    Dim filePath As String
    Dim TestStr As String

    filePath = wbS.path & "\DRAWING INDEX.xlsx"

    MsgBox filePath, , "FILE PATH"

    TestStr = ""
    On Error Resume Next
    TestStr = Dir(filePath)

    MsgBox TestStr & "String Empty", , "Test string equals " & TestStr

    On Error GoTo 0
    If TestStr = "" Then
    MsgBox "File doesn't exist", , "String Empty"
    Else
    MsgBox "File exist", , "TestStr = " & TestStr
    End If





    'Test if file is open

    MsgBox "Is Drawing Open?", vbOKOnly, "TEST"


    If bIsBookOpen("DRAWING INDEX.xlsx") Then

    MsgBox ("DRAWING INDEX.xlsx is open!" & chr13 + "CLOSE THE SPREADSHEET and TRY AGAIN"), , "DRAWING INDEX IS OPEN"

    ActiveWorkbook.Close SaveChanges:=False


    Exit Sub



    Else

    MsgBox "The Book is not open!", , "DRAWING INDEX IS NOT OPEN"

    End If



    'save new workbook

    wbT.SaveAs filename:=wbS.path & "\DRAWING INDEX", FileFormat:=51, CreateBackup:=False

    Application.DisplayAlerts = False

    Application.ScreenUpdating = False


    'MsgBox ActiveWorkbook.FullName

    'MsgBox ActiveWorkbook.Path

    Sheets("DRAWING INDEX").Select
    Range("A2:B2").Select
    Selection.UnMerge

    Range("A3").Select
    activecell.FormulaR1C1 = "DESCRIPTION"
    Selection.Font.Underline = xlUnderlineStyleSingle

    Range("B3").Select
    activecell.FormulaR1C1 = "DRAWING No."
    Selection.Font.Underline = xlUnderlineStyleSingle

    Range("A2").Select
    activecell.FormulaR1C1 = "DRAWING INDEX"
    Selection.Font.Underline = xlUnderlineStyleSingle

    '
    ' DELETE BUTTON
    '
    ActiveSheet.Shapes.Range(Array("Button 1")).Select
    Selection.DELETE

    ' DELETE ROW 1

    Rows("1:1").Select
    Selection.DELETE Shift:=xlUp

    ' SAVE AND CLOSE

    ActiveWorkbook.Save
    ActiveWorkbook.Close

    Application.DisplayAlerts = False

    Application.ScreenUpdating = False

    ' MESSAGE BOX

    strName = wbS.path & "\DRAWING INDEX.xlsx"

    MsgBox "File has been Created and Saved as:" & vbCr & strName, , "COPY & SAVE REPORT"

    End Sub

    Sub CommandButton2_Click()


    'CLEAR DRAWING INDEX

    Sheets("DRAWING INDEX").Select

    ' resize_page Macro
    '

    Cells.Select
    Selection.ClearContents
    Selection.ClearFormats
    Cells.Select
    Selection.RowHeight = 15
    Cells.Select
    Selection.ColumnWidth = 8

    Selection.UnMerge
    Range("A1").Select

    'SELECT MRWA SHEET

    Sheets("MRWA").Select


    Range("F4:F100,E4:E100,C4:C100").Copy Destination:=Worksheets("Drawing Index").Range("A4")

    Sheets("Drawing Index").Range("A4:A100").Copy Destination:=Worksheets("Drawing Index").Range("E4")

    Sheets("Drawing Index").Range("C4:C100").Cut Destination:=Worksheets("Drawing Index").Range("A4")




    Sheets("Drawing Index").Range("A2").Value = "DRAWING INDEX"
    'Selection.Font.UNDERLINE = xlUnderlineStyleSingle

    Sheets("Drawing Index").Range("A3").Value = "DESCRIPTION"
    'Selection.Font.UNDERLINE = xlUnderlineStyleSingle

    Sheets("Drawing Index").Range("E3").Value = "DRAWING No."
    'Selection.Font.UNDERLINE = xlUnderlineStyleSingle
    Sheets("Drawing Index").Select
    Range("A3").Select
    'ActiveCell.FormulaR1C1 = "DESCRIPTION"
    Selection.Font.Underline = xlUnderlineStyleSingle

    Range("E3").Select
    'ActiveCell.FormulaR1C1 = "DRAWING No."
    Selection.Font.Underline = xlUnderlineStyleSingle


    Range("A2").Select
    'ActiveCell.FormulaR1C1 = "DRAWING INDEX"
    Selection.Font.Underline = xlUnderlineStyleSingle

    Sheets("Drawing Index").Select

    Range("A:C").EntireColumn.AutoFit


    Call CONCAT3

    Call COPYPASTE

    Call resize

    Call MERGEDEL

    Call SaveAsXLXS

    End Sub



    Sub CONCAT3()
    ' Insert column

    Columns("A:A").Select
    Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove

    ''CONCATANATION

    With Range("A100", Range("A" & Rows.Count).End(xlUp))
    .Offset(, 0).FormulaR1C1 = "=ConcatenateRange(RC[1]:RC[2],"" - "" )"

    End With

    End Sub

    Sub COPYPASTE()


    '

    ' COPYPASTE Macro

    Range("A4:A100").Select
    Selection.Copy

    Range("B4:B100").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=False

    Columns("A:A").Select
    Application.CutCopyMode = False
    Selection.DELETE Shift:=xlToLeft

    Columns("E:E").Select
    Selection.Cut
    Columns("B:B").Select
    ActiveSheet.Paste

    Columns("B:B").EntireColumn.AutoFit
    Columns("A:A").EntireColumn.AutoFit

    End Sub


    Sub MERGEDEL()

    ' MERGEDEL Macro



    Range("A2:B2").Select
    With Selection
    .HorizontalAlignment = xlCenter
    .VerticalAlignment = xlCenter
    .WrapText = False
    .Orientation = 0
    .AddIndent = False
    .IndentLevel = 0
    .ShrinkToFit = False
    .ReadingOrder = xlContext
    .MergeCells = False
    End With
    Selection.MERGE

    Range("A1:B1").Select
    With Selection
    .HorizontalAlignment = xlCenter
    .VerticalAlignment = xlCenter
    .WrapText = False
    .Orientation = 0
    .AddIndent = False
    .IndentLevel = 0
    .ShrinkToFit = False
    .ReadingOrder = xlContext
    .MergeCells = False
    End With
    Selection.MERGE

    Range("B3:B100").Select
    With Selection
    .HorizontalAlignment = xlCenter
    .VerticalAlignment = xlCenter
    End With
    Selection.MERGE True

    End Sub




    Function ConcatenateRange(Parts As Range, Separator As String) ' Build a single string from a passed range with a
    ' passed separator between each value

    Dim strTemp As String, sepTemp As String
    ' declare strTemp and sepTemp as Strings. A String is a data type.

    Dim Cell As Range
    ' declares cell as variable to store a cell reference


    Dim cnt As Integer
    ' declares variable cnt and stores result as an Integer value


    strTemp = ""
    ' defines the String strTemp as blank


    For Each Cell In Parts.Cells
    If Cell.Value = "" Or Cell.Value = 0 Then
    ' If value of cell is blank or = 0
    sepTemp = ""
    ' the variable sepTemp will be stored as blank
    Else
    'If value of cell is not blank or = 0
    sepTemp = Separator
    ' the variable sepTemp will store the separator defined by the user
    End If
    If Len(strTemp) = 0 Then
    ' if the length of the variable stored in strTemp = 0
    strTemp = CStr(Cell.Value)
    ' the variable strTemp will be equal to the value of the current cell.
    Else
    ' if the stored variable strTemp is not equal to 0
    strTemp = strTemp & sepTemp & CStr(Cell.Value)
    ' the variable strTemp will equal the current cell value and concatenate with the user defined separator
    End If
    Next Cell
    ConcatenateRange = strTemp
    End Function

    Sub resize()
    '

    ' text_style Macro
    '

    '
    Columns("A:A").Select
    With Selection.Font
    .Name = "Calibri"
    .FontStyle = "Regular"
    .Size = 11
    .Strikethrough = False
    .Superscript = False
    .Subscript = False
    .OutlineFont = False
    .Shadow = False
    .ThemeColor = xlThemeColorLight1
    .TintAndShade = 0
    .ThemeFont = xlThemeFontMinor
    End With

    With Selection
    .HorizontalAlignment = xlLeft
    .WrapText = False
    .Orientation = 0
    .AddIndent = False
    .IndentLevel = 0
    .ShrinkToFit = False
    .ReadingOrder = xlContext
    End With

    With Selection
    .VerticalAlignment = xlCenter
    .WrapText = False
    .Orientation = 0
    .AddIndent = False
    .IndentLevel = 0
    .ShrinkToFit = False
    .ReadingOrder = xlContext
    End With


    Range("A2:B2").Select
    With Selection.Font
    .Name = "Calibri"
    .FontStyle = "Regular"
    .Size = 12
    .Strikethrough = False
    .Superscript = False
    .Subscript = False
    .OutlineFont = False
    .Shadow = False
    .ThemeColor = xlThemeColorLight1
    .TintAndShade = 0
    .ThemeFont = xlThemeFontMinor
    End With

    ' resize Macro
    '
    '
    Rows("1:100").Select
    Selection.RowHeight = 15

    Range("A3").Select
    With Selection
    .HorizontalAlignment = xlLeft
    .VerticalAlignment = xlCenter
    .WrapText = False
    .Orientation = 0
    .AddIndent = False
    .IndentLevel = 0
    .ShrinkToFit = False
    .ReadingOrder = xlContext
    .MergeCells = False
    End With
    Range("B4:B99").Select
    With Selection
    .HorizontalAlignment = xlCenter
    .VerticalAlignment = xlCenter
    .WrapText = False
    .Orientation = 0
    .AddIndent = False
    .IndentLevel = 0
    .ShrinkToFit = False
    .ReadingOrder = xlContext
    .MergeCells = False
    End With

    ' autofit

    Range("A3:B100").Select
    Selection.Columns.AutoFit

    Rows("1:1").Select
    Selection.RowHeight = 40

    Rows("2:2").Select
    Selection.RowHeight = 20

    Rows("3:3").Select
    Selection.RowHeight = 18

    Rows("4:99").Select
    Selection.RowHeight = 15

    Columns("C:F").Select
    Selection.Columns.AutoFit

    Columns("C:C").Select
    Selection.ColumnWidth = 8

    ActiveWindow.Zoom = 100

    End Sub

  2. #12
    Forum Newbie
    Using
    Map 3D 2016
    Join Date
    Apr 2016
    Posts
    8

    Default

    Registered forum members do not see this ad.

    I was thinking this morning whether the encoding format may have changed, and if so, what effect could it have?

    What is the best format to use? Unicode, UTF8, UTF7, UTF16, UTF32, ASCII, or ANSI?
    I'm assuming ASCII?

    Something may have been saved in UTF8, or maybe cutting and pasting from the internet has included some hidden characters perhaps?

    How can I check, and correct any issues relating to this?

    What is best practice?

Similar Threads

  1. Replies: 3
    Last Post: 16th Jun 2014, 01:50 pm
  2. Error: bad argument value: string position out of range 72
    By Oliver_cook1 in forum AutoCAD Bugs, Error Messages & Quirks
    Replies: 0
    Last Post: 13th Mar 2014, 11:15 am
  3. ; error: bad argument type: VLA-OBJECT
    By Jef! in forum AutoCAD Bugs, Error Messages & Quirks
    Replies: 18
    Last Post: 22nd Oct 2010, 07:39 pm
  4. IF and COND argument as a range in lisp.
    By NYATI in forum AutoLISP, Visual LISP & DCL
    Replies: 11
    Last Post: 22nd Sep 2010, 10:43 am
  5. using or within vl-string-position
    By TuFoFi in forum AutoLISP, Visual LISP & DCL
    Replies: 2
    Last Post: 21st Jan 2006, 08:43 pm

Tags for this Thread

Bookmarks

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts