vbscript 结构化输出

untitled
Function sc(s1, Optional s2 = "", Optional s3 = "", Optional s4 = "", Optional s5 = "", Optional s6 = "", Optional s7 = "", Optional s8 = "", Optional s9 = "", Optional s10 = "", Optional s11 = "", Optional s12 = "", Optional s13 = "", Optional s14 = "", Optional s15 = "", Optional s16 = "", Optional s17 = "", Optional s18 = "", Optional s19 = "", Optional s20 = "")
    arr1 = Array(s1, s2, s3, s4, s5, s6, s7, s8, s9, s10, s11, s12, s13, s14, s15, s16, s17, s18, s19, s20)
'    For i = 0 To UBound(arr1)
'        If arr1(i) = 34 Or arr1(i) = 43 Then arr1(i) = Chr(34)
'    Next
    sc = Join(arr1, "")
End Function
Function cs(a1, Optional a2 = "", Optional a3 = "", Optional a4 = "", Optional a5 = "", Optional a6 = "", Optional a7 = "", Optional a8 = "")
    Debug.Print Join(Array(a1, a2, a3, a4, a5, a6, a7, a8), " ")
End Function

vbscript expt2txt

expt2txt
function expt2txt(rb,optional re = "",optional cb_s = "a",optional ce_s = "" optional path1="",optional fn = "")
        REM rb = 2
        REM re = 5
        REM cb = "a"
        REM ce = "d"
		If re = "" Then r_e = Cells(65536, 1).End(xlUp).row
		If ce_s = "" Then c_e_s = Split(Cells(1, Cells(65536, 1).End(xlToLeft).colmun).Address, "$")(1)
		'-----
REM Dim I As Integer, J As Long, RW As Long
Str1 = ""
For I = rb To re
    arr1 = Range(cb_s & I & ":" & ce_s & I)
	REM for each s1 in arr1
		REM if instr(s1,chr(13)) then
			REM s1 = chr(34) & s1 & chr(34)
			
		REM end if
	REM next
    Str1 = Str1 + Join(Application.Index(arr1, , , 1), Chr(9))
    If I <> re Then Str1 = Str1 + Chr(13)
Next I
save2(str1,path1,fn)
End function
function save2(str1,path1,fn,optional ts1 = "")
If path1 = "" Then path1 = ThisWorkbook.path
If fn = "" Then fn = "expt1"
if ts1 = "" then ts1 = Format(Date, "yymmdd_HHMMSS")
fn = fn & "-" & ts1 & ".txt"
Open path1 & "\" & fn For Output As 1
Print #1, Str1
Close 1
REM MsgBox "数据导出完毕!", vbOKOnly, "导出成功"
end function

function expt2json(rb,optional re = "",optional cb_s = "a",optional ce_s = "" optional path1="",optional fn = "")










end function


' 另一种写法
rc = Application.Max(Range("A" & Rows.Count).End(xlUp).Row, Range("B" & Rows.Count).End(xlUp).Row)

Strtemp = ""
For Each rg In Range("A1:B" & rc)
    If rg.Row <= rc Then
        If rg.Column = 1 Then
            Strtemp = Strtemp & rg.Value & vbTab
        Else
            Strtemp = Strtemp & rg.Value & vbCrLf
        End If
    
    End If
Next

vbscript arr_col2 untest

arr_col2
function arr_col2(str1,r1)
	Dim arr_tmp()
    ReDim arr_tmp(r1, 1 To 1)
    For ii = 1 To UBound(arr_tmp)
        arr_tmp(ii, 1) = Str1
    Next
	arr_col2 = arr_tmp
end function

vbscript sorted2未测试

sorted2
Function sorted2(arr_str1, _
    Optional ByVal rb = "", Optional ByVal re = "", _
    Optional ByVal c_b_s = "a", Optional ByVal c_e_s = "", _
    Optional ByVal r_refer = 1, Optional ByVal sh_to = "")
    '---
    'arg:r_refer,为arr_str1的所在的行,默认为第一行
    '---
    If sh_to = "" Then sh_to = ActiveSheet.Name
    Set sh1 = Sheets(sh_to)
    '---
    Application.ScreenUpdating = False
    '---
    sh1.Activate
    ActiveSheet.Sort.SortFields.Clear
    If rb = "" Then rb = 2
    If re = "" Then re = Cells(65536, 1).End(xlUp).row
    If c_e_s = "" Then c_e_s = Split(Cells(1, Cells(1, 50).End(xlToLeft).Column).Address, "$")(1)
    arr1 = Split(arr_str1, "  ")
    For Each i In arr1
        order1 = 1
        If Right(i, 1) = "↓" Then
            order1 = 2
        End If
        i = Replace(i, "↓", "")
        ActiveSheet.Sort.SortFields.Add Key:=Range(fc_s(i, r_refer) & ":" & fc_s(i, r_refer)) _
            , SortOn:=xlSortOnValues, Order:=order1, DataOption:=xlSortNormal
    Next
    '---
    '判断c_b_s、c_e_s,都是否是数字,如果是就转为字母
    If IsNumeric(c_b_s) Then c_b_s = Split(Cells(1, c_b_s).Address, "$")(1)
    If IsNumeric(c_e_s) Then c_e_s = Split(Cells(1, c_e_s).Address, "$")(1)
    '---
    With ActiveSheet.Sort
        .SetRange Range(c_b_s & rb & ":" & c_e_s & re)
        .Header = xlNo
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    Application.ScreenUpdating = True
End Function

vbscript TEMPPATH

TempPath
' get a temp path
dim tempPath as string = System.IO.Path.GetTempPath()

vbscript 事件示例

EventsExample
'Bucket.vb

Public Class Bucket
    Public Capacity As Integer
    Public CurrentLevel As Integer

    Public Event Full()
    Public Event Overflowing(ByVal sender As System.Object)

    Public Sub New()
        Capacity = 3
        CurrentLevel = 0
    End Sub

    Public Sub Add()
        CurrentLevel += 1
        If CurrentLevel = Capacity Then
            RaiseEvent Full()
        ElseIf CurrentLevel > Capacity Then
            RaiseEvent Overflowing(Me)
        End If
    End Sub

End Class



'Form1.vb

Public Class Form1
    Dim WithEvents myBucket As Bucket

    Private Sub btnAddOne_Click(sender As Object, e As EventArgs) Handles btnAddOne.Click
        myBucket.Add()
    End Sub

    Private Sub Form1_Load(sender As Object, e As EventArgs) Handles Me.Load
        myBucket = New Bucket
    End Sub

    Private Sub myBucketFullHandler() Handles myBucket.Full
        MessageBox.Show("Full")
    End Sub

    Private Sub myBucketOverflowingHander(ByVal sender As Object) Handles myBucket.Overflowing
        Dim bkt As Bucket
        bkt = DirectCast(sender, Bucket)
        MessageBox.Show("Capacity: " & bkt.Capacity & "  Level: " & bkt.CurrentLevel)
    End Sub

End Class

vbscript 插入返回参数

InsertwithReturnParameter
 Public Function InsertLog(_machineName As String) As Integer
  Dim fmt As New dbFunction 
  Dim newID As Integer = -1

  Dim constr As String = myconnectionstring
        Using con As New MySqlConnection(constr)
            Using cmd As New MySqlCommand("UpdateProgressLog_Insert", con)
                cmd.CommandType = CommandType.StoredProcedure
                cmd.Parameters.AddWithValue("@_startDateTime", DateTime.Now)
                cmd.Parameters("@_startDateTime").Direction = ParameterDirection.Input
                cmd.Parameters.AddWithValue("@_endDateTime", Nothing)
                cmd.Parameters("@_endDateTime").Direction = ParameterDirection.Input
                cmd.Parameters.AddWithValue("@_machinename", _machineName)
                cmd.Parameters("@_machinename").Direction = ParameterDirection.Input
                cmd.Parameters.AddWithValue("@_lastID", newID)
                cmd.Parameters("@_lastID").Direction = ParameterDirection.Output

                con.Open()

                cmd.ExecuteNonQuery()

                If IsDBNull(cmd.Parameters("@_lastID").Value) Then
                    newID = -1
                Else
                    newID = fmt.ConvertdbToInteger(cmd.Parameters("@_lastID").Value)
                End If

            End Using
        End Using

        Return newID
    End Function

vbscript 数据库获取所有表

DatabaseGetAllTable
Public Function GetAllTable(_includeRetired As Boolean) As DataTable
  Dim db As New dbFunctions
  Dim table As New DataTable
  Dim myAdapter As New MySqlDataAdapter
  Dim retired As Integer = 0

  If _includeRetired = True Then retired = 1

  Dim constr As String = MyConnectionString
  Using con As New MySqlConnection(constr)
    Using cmd As New MySqlCommand("Customers_GetAll", con)
    cmd.CommandType = CommandType.StoredProcedure
    cmd.Parameters.AddWithValue("@_includeRetired", retired)

    myAdapter.SelectCommand = cmd
    myAdapter.Fill(table)

  End Using
End Using

Return table
End Function

vbscript 使用查询

UsingQuery
Public Function Delete(ID As Integer) As Integer
    Dim Sql As New StringBuilder
    Dim result As Integer

    Sql.Append("Delete from Master ")
    Sql.Append("Where ID = @ID")

    Using SQLConnection As New MySqlConnection(MyConnectionString)
        Using sqlCommand As New MySqlCommand()
            With sqlCommand
                .CommandText = Sql.ToString
                .Connection = SQLConnection
                .CommandType = CommandType.Text
                .Parameters.AddWithValue("@ID", ID)

            End With
            Try
                SQLConnection.Open()
                result = sqlCommand.ExecuteNonQuery()

            Catch ex As MySqlException
                result = 0
            Finally
                SQLConnection.Close()
            End Try
        End Using
    End Using

    Return result
End Function

vbscript 数据库更新

DatabaseUpdate
Public Sub Update(_dto As UserDTO)
    Using con As New MySqlConnection(MyConnectionString)
        Using cmd As New MySqlCommand("User_Update", con)
            cmd.CommandType = CommandType.StoredProcedure
            cmd.Parameters.AddWithValue("@_id", _dto.ID)
            cmd.Parameters.AddWithValue("@_usertype", _dto.UserType)
            cmd.Parameters.AddWithValue("@_firstName", _dto.FirstName)
            cmd.Parameters.AddWithValue("@_lastName", _dto.LastName)
            con.Open()
            cmd.ExecuteNonQuery()
        End Using
    End Using
End Sub