Attribute VB_Name = "Module1"
'Support of creating input for Fortran programs.
'Read column width from validation rule and round up to multiples of default width
Option Explicit
Public X As New Class1
Sub Auto_Open()
Application.DisplayStatusBar = True
Application.StatusBar = "Automatikus indítás" & vbTab & "Personal"
Set X.App = Application
End Sub
Function round_up_width(v As Validation, W_def As Integer, W_col As Integer) As Integer
With v
W_col = W_def
On Error GoTo 1
If v.Type = xlValidateTextLength Then
Select Case .Operator
Case xlBetween
W_col = Val(.Formula2)
Case xlLess
W_col = Val(.Formula1)
Case xlLessEqual
W_col = Val(.Formula1)
Case xlGreater
W_col = Val(.Formula1) + 1
Case xlGreaterEqual
W_col = Val(.Formula1)
Case xlEqual
W_col = Val(.Formula1)
Case Else
W_col = W_def
End Select
If (W_col Mod W_def > 0) Then
W_col = ((W_col \W_def) + 1) * W_def
End If
Else
W_col = W_def
End If
1:
round_up_width = W_col \W_def
End With
End Function
Function Max(a As Integer, b As Integer) As Integer
If b > a Then Max = b Else Max = a
End Function
Sub Read12x12()
Attribute Read12x12.VB_Description = "Open a text file and make 12 columns each having 12 characters and format them with Courier New and width=15 Macro recorded 2004.10.14 by Nagy Ferenc"
Attribute Read12x12.VB_ProcData.VB_Invoke_Func = "R\n14"
'
' Read12x12 Macro
' Open a text file and make 12 columns each having 12 characters and format them with Courier New and width=15 Macro recorded 2004.10.14 by Nagy Ferenc
'
' Keyboard Shortcut: Ctrl+Shift+R
'
Dim filename As Variant
filename = Application.GetOpenFilename( _
"Data files, *.inp;*.txt, Header files, *.hdr, Log files, *.log, Result files, *.prn, Summary files, *.sum, " & _
"All files, *.*", _
1, "Select a text file")
If (filename <> False) Then
ReadGiven12x12 filename
End If
End Sub
Sub ReadGiven12x12(filename As Variant)
Workbooks.OpenText filename:=filename, _
Origin:=xlWindows, _
StartRow:=1, DataType:=xlFixedWidth, _
FieldInfo:=Array(Array(0, xlGeneralFormat), Array(12, xlGeneralFormat), Array(24, xlGeneralFormat), Array(36, xlGeneralFormat), Array(48, xlGeneralFormat), _
Array(60, xlGeneralFormat), Array(72, xlGeneralFormat), Array(84, xlGeneralFormat), Array(96, xlGeneralFormat), Array(108, xlGeneralFormat), _
Array(120, xlGeneralFormat), Array(132, xlGeneralFormat)), _
TrailingMinusNumbers:=False
Columns("A:L").Select
With Selection.Font
.Name = "Courier New"
.FontStyle = "Normál"
.Size = 9
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = xlAutomatic
End With
Selection.ColumnWidth = 13
With Selection.Validation
.Delete
.Add Type:=xlValidateTextLength, AlertStyle:=xlValidAlertStop, _
Operator:=xlBetween, Formula1:="0", Formula2:="12"
.IgnoreBlank = False
.InCellDropdown = True
.InputTitle = "Enter data"
.ErrorTitle = "Invalid"
.InputMessage = "Give at most 12 characters"
.ErrorMessage = "Longer than 12 characters"
.ShowInput = True
.ShowError = True
End With
With ActiveWorkbook.CustomDocumentProperties
.Add Name:="Beatrice", _
LinkToContent:=False, _
Type:=msoPropertyTypeNumber, _
Value:=1212
End With
End Sub
Sub SaveWint()
Attribute SaveWint.VB_Description = "Macro recorded 2004.10.14 by Nagy Ferenc"
Attribute SaveWint.VB_ProcData.VB_Invoke_Func = "S\n14"
'
' SaveWint Macro
' Macro recorded 2004.10.14 by Nagy Ferenc
' Save Workbook as windows text
' Keyboard Shortcut: Ctrl+Shift+S
'
Dim I_row As Integer, J_col As Integer, K_col As Integer, n_empty_lines As Integer
Dim vege As Boolean, s As String, q As String
Dim W_col As Integer
Dim cheese As Boolean
Dim filename As Variant
Dim s_value As String
Const m_empty_lines = 30 'Stop if the number of consecutive empty lines exceeds this value.
Const W_def = 12'Default column width
Const M_col = 12 'Number of evaluated columns
Const S_coml = W_def * M_col 'Default width of the command files
filename = Application.GetSaveAsFilename(ActiveWorkbook.Name, _
"Data files, *.inp;*.txt, Header files, *.hdr, Log files, *.log, Result files, *.prn, Summary files, *.sum, " & _
"All files, *.*", _
0, "Save workbook as")
If filename <> False Then
3: On Error GoTo 1
Open filename For Output As #1 ' Open file for output.
Width #1, S_coml ' Set output line width to S_coml
On Error GoTo 2
I_row = 0
n_empty_lines = 0
Do
I_row = I_row + 1
s = String(S_coml, " ")
J_col = 1
cheese = False
Do
K_col = round_up_width(Application.ActiveSheet.Cells(I_row, J_col).Validation, W_def, W_col)
If K_col > 1 Then
'Debug.Print "Széles cella:", I_row, J_col, "Lépés="; K_col, "Max. hossz="; .Formula2
End If
s_value = CStr(Application.ActiveSheet.Cells(I_row, J_col).Value)
If (Len(s_value) > 0) Then
s = Left(s, (J_col - 1) * W_def) & Left(s_value & String(W_col, ""), W_col)
Else
cheese = True
End If
Select Case Trim(UCase(s_value))
Case Chr(26), "END", "QUIT"
vege = True
End Select
J_col = J_col + K_col
Loop Until (J_col > M_col)
Print #1, RTrim(s)
If (Len(LTrim(RTrim(s))) = 0) Then
n_empty_lines = n_empty_lines + 1
'Debug.Print n_empty_lines; ". üres sor"
Else
n_empty_lines = 0
End If
Debug.Print I_row, "<------------><------------><------------><------------><------------><------------><------------><------------><------------><------------>"
Debug.Print I_row, RTrim(s), "Lyukacsos=", cheese, "Vége=", vege
Loop Until vege Or (n_empty_lines > m_empty_lines)
Close #1 ' Close file.
If n_empty_lines > m_empty_lines Then
MsgBox "Number of allowed consecutive empty lines >" & m_empty_lines, vbInformation + vbOKOnly, "File closed"
Else
MsgBox "A cell contained '" & s_value & "'", vbInformation + vbOKOnly, "File closed"
End If
ActiveWorkbook.Saved = True
'Debug.Print Filename; " bézárva", n_empty_lines; ". üres sor egymás után", q, "cellát talált="; vege
End If
Exit Sub
1: If MsgBox(Err.Description & vbCrLf & "Megkísérli a mentést más néven?", _
vbCritical + vbRetryCancel, "Foglalt fájlnév vagy más hiba") = vbRetry Then
Close #1
Err.Clear
GoTo 3
End If
2: If MsgBox(Err.Description & vbCrLf & "Megkísérli a mentést más néven?", _
vbCritical + vbRetryCancel, "Írási hiba") = vbRetry Then
Close #1
Err.Clear
GoTo 3
End If
End Sub
Sub ChangeValidation()
Attribute ChangeValidation.VB_Description = "Macro recorded 2004.10.14 by Nagy Ferenc\nChanging validation rules of the active cell"
Attribute ChangeValidation.VB_ProcData.VB_Invoke_Func = "V\n14"
'
' ChangeValidation Macro
' Macro recorded 2004.10.14 by Nagy Ferenc Changing validation rules of the active cell
'
' Keyboard Shortcut: Ctrl+Shift+V
'
With Selection.Validation
.Delete
.Add Type:=xlValidateTextLength, AlertStyle:=xlValidAlertWarning, _
Operator:=xlBetween, Formula1:="0", Formula2:="24"
.IgnoreBlank = False
.InCellDropdown = True
.InputTitle = "Enter data"
.ErrorTitle = "Invalid"
.InputMessage = "Give at most 24 characters"
.ErrorMessage = "Longer than 24 characters"
.ShowInput = True
.ShowError = True
End With
End Sub
Sub Send_Selection_via_ClipBoard()
Attribute Send_Selection_via_ClipBoard.VB_Description = "Macro recorded 2004.10.14 by Nagy Ferenc\nSend selection via Clipboard to the program next with Alt-Tab"
Attribute Send_Selection_via_ClipBoard.VB_ProcData.VB_Invoke_Func = "B\n14"
'
' Send_Selection_via_ClipBoard Macro
' Macro recorded 2004.10.14 by Nagy Ferenc Send selection via Clipboard to the program next with Alt-Tab
'
' Keyboard Shortcut: Ctrl+Shift+B
Const m_empty_lines = 30'Stop if the number of consecutive empty lines exceeds this value.
Const W_def = 12 'Default column width
Const M_col = 12'Number of evaluated columns
Const S_coml = W_def * M_col 'Default width of the command files
Dim I_row As Integer, J_col As Integer, K_col As Integer, W_col As Integer
Dim s As String
Dim c As Object, r As Object
Set r = Selection
ActiveWorkbook.ActiveSheet.Cells(1, M_col + 1) = ""
Debug.Print "Sorok száma=", r.Rows.Count, "oszlopok száma=", r.Columns.Count
Debug.Print "Első cella értéke=", r.Cells(1, 1).Value
Debug.Print "Utolsó cella értéke=", r.Cells(r.Rows.Count, r.Columns.Count).Value
For I_row = 1 To r.Rows.Count
s = String(S_coml, "")
J_col = 1
Do
Set c = r.Cells(I_row, J_col)
K_col = round_up_width(c.Validation, W_def, W_col)
If (Len(CStr(r.Cells(I_row, J_col).Value)) > 0) Then
s = Left(s, (J_col - 1) * W_def) & Left(CStr(c.Value) & String(W_col, ""), W_col)
End If
J_col = J_col + K_col
Loop Until (J_col > r.Columns.Count)
ActiveWorkbook.ActiveSheet.Cells(1, M_col + 1).Value = _
ActiveWorkbook.ActiveSheet.Cells(1, M_col + 1).Value & s & vbCrLf
Next I_row
ActiveWorkbook.ActiveSheet.Cells(1, M_col + 1).Copy
SendKeys "%{TAB}% EP", True
End Sub
Attribute VB_Name = "Module1"
'Support of creating input for Fortran programs.
'Read column width from validation rule and round up to multiples of default width
Option Explicit
Public X As New Class1
Sub Auto_Open()
Application.DisplayStatusBar = True
Application.StatusBar = "Automatikus indítás" & vbTab & "Personal"
Set X.App = Application
End Sub
Function round_up_width(v As Validation, W_def As Integer, W_col As Integer) As Integer
With v
W_col = W_def
On Error GoTo 1
If v.Type = xlValidateTextLength Then
Select Case .Operator
Case xlBetween
W_col = Val(.Formula2)
Case xlLess
W_col = Val(.Formula1)
Case xlLessEqual
W_col = Val(.Formula1)
Case xlGreater
W_col = Val(.Formula1) + 1
Case xlGreaterEqual
W_col = Val(.Formula1)
Case xlEqual
W_col = Val(.Formula1)
Case Else
W_col = W_def
End Select
If (W_col Mod W_def > 0) Then
W_col = ((W_col \W_def) + 1) * W_def
End If
Else
W_col = W_def
End If
1:
round_up_width = W_col \W_def
End With
End Function
Function Max(a As Integer, b As Integer) As Integer
If b > a Then Max = b Else Max = a
End Function
Sub Read12x12()
Attribute Read12x12.VB_Description = "Open a text file and make 12 columns each having 12 characters and format them with Courier New and width=15 Macro recorded 2004.10.14 by Nagy Ferenc"
Attribute Read12x12.VB_ProcData.VB_Invoke_Func = "R\n14"
'
' Read12x12 Macro
' Open a text file and make 12 columns each having 12 characters and format them with Courier New and width=15 Macro recorded 2004.10.14 by Nagy Ferenc
'
' Keyboard Shortcut: Ctrl+Shift+R
'
Dim filename As Variant
filename = Application.GetOpenFilename( _
"Data files, *.inp;*.txt, Header files, *.hdr, Log files, *.log, Result files, *.prn, Summary files, *.sum, " & _
"All files, *.*", _
1, "Select a text file")
If (filename <> False) Then
ReadGiven12x12 filename
End If
End Sub
Sub ReadGiven12x12(filename As Variant)
Workbooks.OpenText filename:=filename, _
Origin:=xlWindows, _
StartRow:=1, DataType:=xlFixedWidth, _
FieldInfo:=Array(Array(0, xlGeneralFormat), Array(12, xlGeneralFormat), Array(24, xlGeneralFormat), Array(36, xlGeneralFormat), Array(48, xlGeneralFormat), _
Array(60, xlGeneralFormat), Array(72, xlGeneralFormat), Array(84, xlGeneralFormat), Array(96, xlGeneralFormat), Array(108, xlGeneralFormat), _
Array(120, xlGeneralFormat), Array(132, xlGeneralFormat)), _
TrailingMinusNumbers:=False
Columns("A:L").Select
With Selection.Font
.Name = "Courier New"
.FontStyle = "Normál"
.Size = 9
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = xlAutomatic
End With
Selection.ColumnWidth = 13
With Selection.Validation
.Delete
.Add Type:=xlValidateTextLength, AlertStyle:=xlValidAlertStop, _
Operator:=xlBetween, Formula1:="0", Formula2:="12"
.IgnoreBlank = False
.InCellDropdown = True
.InputTitle = "Enter data"
.ErrorTitle = "Invalid"
.InputMessage = "Give at most 12 characters"
.ErrorMessage = "Longer than 12 characters"
.ShowInput = True
.ShowError = True
End With
With ActiveWorkbook.CustomDocumentProperties
.Add Name:="Beatrice", _
LinkToContent:=False, _
Type:=msoPropertyTypeNumber, _
Value:=1212
End With
End Sub
Sub SaveWint()
Attribute SaveWint.VB_Description = "Macro recorded 2004.10.14 by Nagy Ferenc"
Attribute SaveWint.VB_ProcData.VB_Invoke_Func = "S\n14"
'
' SaveWint Macro
' Macro recorded 2004.10.14 by Nagy Ferenc
' Save Workbook as windows text
' Keyboard Shortcut: Ctrl+Shift+S
'
Dim I_row As Integer, J_col As Integer, K_col As Integer, n_empty_lines As Integer
Dim vege As Boolean, s As String, q As String
Dim W_col As Integer
Dim cheese As Boolean
Dim filename As Variant
Dim s_value As String
Const m_empty_lines = 30'Stop if the number of consecutive empty lines exceeds this value.
Const W_def = 12 'Default column width
Const M_col = 12'Number of evaluated columns
Const S_coml = W_def * M_col 'Default width of the command files
filename = Application.GetSaveAsFilename(ActiveWorkbook.Name, _
"Data files, *.inp;*.txt, Header files, *.hdr, Log files, *.log, Result files, *.prn, Summary files, *.sum, " & _
"All files, *.*", _
0, "Save workbook as")
If filename <> False Then
3: On Error GoTo 1
Open filename For Output As #1' Open file for output.
Width #1, S_coml ' Set output line width to S_coml
On Error GoTo 2
I_row = 0
n_empty_lines = 0
Do
I_row = I_row + 1
s = String(S_coml, "")
J_col = 1
cheese = False
Do
K_col = round_up_width(Application.ActiveSheet.Cells(I_row, J_col).Validation, W_def, W_col)
If K_col > 1Then
'Debug.Print "Széles cella:", I_row, J_col, "Lépés="; K_col, "Max. hossz="; .Formula2
End If
s_value = CStr(Application.ActiveSheet.Cells(I_row, J_col).Value)
If (Len(s_value) > 0) Then
s = Left(s, (J_col - 1) * W_def) & Left(s_value & String(W_col, " "), W_col)
Else
cheese = True
End If
Select Case Trim(UCase(s_value))
Case Chr(26), "END", "QUIT"
vege = True
End Select
J_col = J_col + K_col
Loop Until (J_col > M_col)
Print #1, RTrim(s)
If (Len(LTrim(RTrim(s))) = 0) Then
n_empty_lines = n_empty_lines + 1
'Debug.Print n_empty_lines; ". üres sor"
Else
n_empty_lines = 0
End If
Debug.Print I_row, "<------------><------------><------------><------------><------------><------------><------------><------------><------------><------------>"
Debug.Print I_row, RTrim(s), "Lyukacsos=", cheese, "Vége=", vege
Loop Until vege Or (n_empty_lines > m_empty_lines)
Close #1' Close file.
If n_empty_lines > m_empty_lines Then
MsgBox "Number of allowed consecutive empty lines >" & m_empty_lines, vbInformation + vbOKOnly, "File closed"
Else
MsgBox "A cell contained '" & s_value & "'", vbInformation + vbOKOnly, "File closed"
End If
ActiveWorkbook.Saved = True
'Debug.Print Filename; " bézárva", n_empty_lines; ". üres sor egymás után", q, "cellát talált="; vege
End If
Exit Sub
1: If MsgBox(Err.Description & vbCrLf & "Megkísérli a mentést más néven?", _
vbCritical + vbRetryCancel, "Foglalt fájlnév vagy más hiba") = vbRetry Then
Close #1
Err.Clear
GoTo 3
End If
2: If MsgBox(Err.Description & vbCrLf & "Megkísérli a mentést más néven?", _
vbCritical + vbRetryCancel, "Írási hiba") = vbRetry Then
Close #1
Err.Clear
GoTo 3
End If
End Sub
Sub ChangeValidation()
Attribute ChangeValidation.VB_Description = "Macro recorded 2004.10.14 by Nagy Ferenc\nChanging validation rules of the active cell"
Attribute ChangeValidation.VB_ProcData.VB_Invoke_Func = "V\n14"
'
' ChangeValidation Macro
' Macro recorded 2004.10.14 by Nagy Ferenc Changing validation rules of the active cell
'
' Keyboard Shortcut: Ctrl+Shift+V
'
With Selection.Validation
.Delete
.Add Type:=xlValidateTextLength, AlertStyle:=xlValidAlertWarning, _
Operator:=xlBetween, Formula1:="0", Formula2:="24"
.IgnoreBlank = False
.InCellDropdown = True
.InputTitle = "Enter data"
.ErrorTitle = "Invalid"
.InputMessage = "Give at most 24 characters"
.ErrorMessage = "Longer than 24 characters"
.ShowInput = True
.ShowError = True
End With
End Sub
Sub Send_Selection_via_ClipBoard()
Attribute Send_Selection_via_ClipBoard.VB_Description = "Macro recorded 2004.10.14 by Nagy Ferenc\nSend selection via Clipboard to the program next with Alt-Tab"
Attribute Send_Selection_via_ClipBoard.VB_ProcData.VB_Invoke_Func = "B\n14"
'
' Send_Selection_via_ClipBoard Macro
' Macro recorded 2004.10.14 by Nagy Ferenc Send selection via Clipboard to the program next with Alt-Tab
'
' Keyboard Shortcut: Ctrl+Shift+B
Const m_empty_lines = 30 'Stop if the number of consecutive empty lines exceeds this value.
Const W_def = 12'Default column width
Const M_col = 12 'Number of evaluated columns
Const S_coml = W_def * M_col 'Default width of the command files
Dim I_row As Integer, J_col As Integer, K_col As Integer, W_col As Integer
Dim s As String
Dim c As Object, r As Object
Set r = Selection
ActiveWorkbook.ActiveSheet.Cells(1, M_col + 1) = ""
Debug.Print "Sorok száma=", r.Rows.Count, "oszlopok száma=", r.Columns.Count
Debug.Print "Első cella értéke=", r.Cells(1, 1).Value
Debug.Print "Utolsó cella értéke=", r.Cells(r.Rows.Count, r.Columns.Count).Value
For I_row = 1 To r.Rows.Count
s = String(S_coml, " ")
J_col = 1
Do
Set c = r.Cells(I_row, J_col)
K_col = round_up_width(c.Validation, W_def, W_col)
If (Len(CStr(r.Cells(I_row, J_col).Value)) > 0) Then
s = Left(s, (J_col - 1) * W_def) & Left(CStr(c.Value) & String(W_col, " "), W_col)
End If
J_col = J_col + K_col
Loop Until (J_col > r.Columns.Count)
ActiveWorkbook.ActiveSheet.Cells(1, M_col + 1).Value = _
ActiveWorkbook.ActiveSheet.Cells(1, M_col + 1).Value & s & vbCrLf
Next I_row
ActiveWorkbook.ActiveSheet.Cells(1, M_col + 1).Copy
SendKeys "%{TAB}% EP", True
End Sub