VBA 常用

Public obSAS As New SAS.Workspace
Public obWorkspaceManager As New SASWorkspaceManager.WorkspaceManager
Public obConnection As New ADODB.Connection
Public obRecordSet As New ADODB.Recordset
'
Sub Load_Data_Info(ByVal strpath As String)
Dim errorString As String
Dim fso As Object
Dim folder As Object
Dim subfolder As Object
Dim file As Object
Set fso = CreateObject("scripting.filesystemobject") '创建FSO对象
Set folder = fso.getfolder(strpath)
Dim sasstr As String
sasstr = "libname hye """ & strpath & """;"
Dim sasdata As String
i = 0
For Each file In folder.Files '遍历根文件夹下的文件

strname = fso.getfilename(file)
If InStr(1, strname, ".sas7bdat") > 0 Then
i = i + 1
'Sheet1.ListBox1.AddItem Replace(strname, ".sas7bdat", "")
Sheet3.Cells(i + 1, 6) = Replace(strname, ".sas7bdat", "")
sasstr = sasstr & " proc contents data=hye." & Replace(strname, ".sas7bdat", "") & ";ods output Variables=need_" & Replace(strname, ".sas7bdat", "") & ";run; "
sasdata = sasdata & "need_" & Replace(strname, ".sas7bdat", "") & " "
End If

Next
sasstr = sasstr & "data work.need; set " & sasdata & ";run; "
Set fso = Nothing
Set folder = Nothing
Set obSAS = obWorkspaceManager.Workspaces.CreateWorkspaceByServer("MyWorkspaceName", VisibilityProcess, Nothing, "", "", errorString)
obSAS.LanguageService.Submit sasstr
obConnection.Open "provider=sas.iomprovider.1; SAS Workspace ID=" + obSAS.UniqueIdentifier
strsql = "select * from work.need"
Set obRecordSet = obConnection.Execute(strsql)
i = 0
Do While Not obRecordSet.EOF
i = i + 1
vstr = obRecordSet("Variable")
tstr = obRecordSet("type")
lenstr = obRecordSet("Len")
If obRecordSet.Fields.Count > 6 Then
labstr = obRecordSet("label")
Else
labstr = ""
End If
Sheet3.Cells(i, 1) = obRecordSet("Member")
Sheet3.Cells(i, 2) = vstr
Sheet3.Cells(i, 3) = labstr
Sheet3.Cells(i, 4) = lenstr
Sheet3.Cells(i, 5) = tstr

obRecordSet.MoveNext
Loop
obConnection.Close

obSAS.Close
Set obWorkspaceManager = Nothing
Set obSAS = Nothing

End Sub
'加载模板列表
Sub load_default_cfg()
Dim xmldoc As New MSXML.DOMDocument
xmldoc.Load ThisWorkbook.Path & "/cfg/template.xml"
Set Node_Root = xmldoc.DocumentElement

Dim xmlnode As MSXML.IXMLDOMElement


For i = 0 To Node_Root.SelectNodes("item").Length - 1
Set xmlnode = Node_Root.SelectNodes("item")(i)
Sheet1.Cells(i + 1, 1) = xmlnode.getAttribute("n")
Sheet1.Cells(i + 1, 1).ID = xmlnode.getAttribute("cfg")

Next
End Sub
'加载选好的某一模板
Sub load_template_cfg(ByVal cfgfile As String, ByVal sht As Worksheet)
Dim xmldoc As New MSXML.DOMDocument

xmldoc.Load ThisWorkbook.Path & "\cfg\" & cfgfile
Dim Node_Root As MSXML.IXMLDOMElement
Set Node_Root = xmldoc.DocumentElement

Dim onode, nodeitem, node_temp As MSXML.IXMLDOMElement
Set onode = Node_Root.SelectSingleNode("name")

sht.Name = onode.getAttribute("t")

'开始加载公共参数
sht.Cells(1, 1) = "公共参数"
sht.Cells(1, 2) = "参数值"

format_cell_head (sht.Cells(1, 1))
format_cell_head (sht.Cells(1, 2))

Dim i As Integer
i = 2
For Each node_temp In Node_Root.SelectNodes("pub/item")
sht.Cells(i, 1) = node_temp.getAttribute("t")
sht.Cells(i, 2).Name = node_temp.getAttribute("n")
If node_temp.getAttribute("dt") = "date" Then
common.Add_Button sht.Cells(i, 2), "date"
End If
i = i + 1
Next

format_border range("A1:B" & i - 1)

'结束加载公共参数

i = i + 1 '增加一行空行


'开始加载测试点
j = i
sht.Cells(i, 1) = "测试点"
sht.Cells(i, 2) = "描述/参数值"
format_cell_head (sht.Cells(i, 1))
format_cell_head (sht.Cells(i, 2))

i = i + 1
For Each node_temp In Node_Root.SelectNodes("tests/test")
sht.Cells(i, 1) = node_temp.getAttribute("t")
sht.Cells(i, 1).Font.Bold = True
i = i + 1
For Each nodeitem In node_temp.SelectNodes("item")
sht.Cells(i, 1) = nodeitem.getAttribute("t")
sht.Cells(i, 2).Name = nodeitem.getAttribute("n")
If nodeitem.getAttribute("dt") = "date" Then
common.Add_Button sht.Cells(i, 2), "date"
End If

If nodeitem.getAttribute("dt") = "table" Then
common.Add_Button sht.Cells(i, 2), "table"
End If
i = i + 1
Next
i = i + 1
Next

format_border range("A" & j & ":B" & i - 2)
'结束加载测试点

range("A1:B" & i).RowHeight = 20
range("A1").Select
Application.ScreenUpdating = True
Add_MonthView
ThisWorkbook.Save
End Sub
'格式表头
Sub format_cell_head(ByVal ocell As Variant)
With ocell.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 49407
.TintAndShade = 0
.PatternTintAndShade = 0
End With
ocell.Font.Bold = True
If ocell.Column = 1 Then
ocell.ColumnWidth = 18
Else
ocell.ColumnWidth = 40
End If
End Sub
'格式化选定区域的边框
Sub format_border(ByVal range As Variant)
range.Select
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
End Sub
Function GetTempName(ByVal node As MSXML.IXMLDOMElement) As String
GetTempName = node.getAttribute("t")
End Function
Function GetTempFile(ByVal node As MSXML.IXMLDOMElement) As String
GetTempFile = node.getAttribute("template")
End Function
Sub loadpublic(ByVal node As MSXML.IXMLDOMElement)

End Sub
'判断指定名称的工作表是否存在
Function SheetExist(shtName As String) As Boolean
Dim sht As Object
On Error Resume Next
Set sht = Worksheets(shtName)
If Err.Number = 0 Then SheetExist = True
Set sht = Nothing
End Function
'添加新的工作表
Function AddWorksheet(shtName As String) As Worksheet
Dim sht As Worksheet
With ThisWorkbook
Set sht = .Worksheets.Add(After:=.Sheets(.Sheets.Count))
sht.Name = shtName

Set AddWorksheet = sht
End With
Set sht = Nothing
End Function
'为新建的sheet 加载双击事件
Sub Add_WorkSheet_Duoble_Click(ByVal sht As Variant)
ShtCodeName = sht.CodeName
With ThisWorkbook.VBProject.VBComponents.Item(ShtCodeName).codeModule
.InsertLines 1, "Private Sub Worksheet_BeforeDoubleClick(ByVal Target As range, Cancel As Boolean)"
.InsertLines 2, " common.Cell_DoubleClick Target "
.InsertLines 3, "End Sub"
End With
End Sub
'模板sheet里面的cell双击事件
Sub Cell_DoubleClick(ByVal target As range)
'MsgBox Target.Name.Name
target.Value = target.Cells.ID

End Sub
Sub Add_Button(ByVal target As range, ByVal dt As String)
On Error Resume Next
Dim selbut As New OLEObject


Set selbut = ThisWorkbook.ActiveSheet.OLEObjects.Add(ClassType:="Forms.CommandButton.1", _
Left:=target.Left + target.Width - 32, Top:=target.Top + 1, Width:=30, Height:=18)
selbut.Name = "but_" & target.Name.Name
selbut.Object.Caption = "选择"
If dt = "date" Then
With ThisWorkbook.VBProject.VBComponents.Item(ActiveSheet.CodeName).codeModule
.InsertLines 4, "private sub " & selbut.Name & "_Click()"
.InsertLines 5, " common.show_monthview " & target.row & "," & target.Column & ""
.InsertLines 6, "end sub"
End With
End If

If dt = "table" Then
With ThisWorkbook.VBProject.VBComponents.Item(ActiveSheet.CodeName).codeModule
.InsertLines 16, "private sub " & selbut.Name & "_Click()"
.InsertLines 17, " common.Show_Table_Info " & target.row & "," & target.Column & ""
.InsertLines 18, "end sub"
End With
End If


End Sub
Sub Add_MonthView()
Dim mv As New OLEObject
Set mv = ActiveSheet.OLEObjects.Add(ClassType:="MSComCtl2.MonthView.2", Left:=200, Top:=200, Width:=250.5, Height:=133.5)
mv.Object.TitleBackColor = &HFF8080
mv.Visible = False
mv.Name = "mv1"

With ThisWorkbook.VBProject.VBComponents.Item(ActiveSheet.CodeName).codeModule

.InsertLines 7, "Private Sub mv1_DateDblClick(ByVal DateDblClicked As Date)"
.InsertLines 8, " mv1.visible=false "
.InsertLines 9, "End Sub"
.InsertLines 11, "Private Sub mv1_LostFocus()"
.InsertLines 12, " mv1.visible=false "
.InsertLines 13, "End Sub"

End With
End Sub
'显示日期控件
Sub Show_Monthview(ByVal row As Integer, col As Integer)
Set ocell = Cells(row, col)
Dim mv As OLEObject
Set mv = ThisWorkbook.ActiveSheet.OLEObjects("mv1")
mv.Visible = True

mv.LinkedCell = GetColumnLetter(ocell.Column) & ocell.row

If ocell.Value <> "" Then
mv.Object.Value = ocell.Value
Else
mv.Object.Value = Date
End If
mv.Left = ocell.Left
mv.Top = ocell.Top + 20
Application.ScreenUpdating = True
End Sub
Sub Show_Table_Info(ByVal row As Integer, col As Integer)
SelTableField.TextBox2.Value = row & "," & col
SelTableField.Show 1
End Sub
Function GetColumnLetter(iCol As Integer) As String
GetColumnLetter = VBA.Split(Cells(1, iCol).Address, "$")(1)
End Function