使用VB 新增 刪除登錄子機碼和登錄值

位於： Windows — admin @ 4:39 下午
新增
WSHShell.RegWrite “HKEY_CLASSES_ROOT\lnkfile\IsShortcut”, “”, “REG_SZ”

刪除
WSHShell.RegDelete “HKEY_CLASSES_ROOT\lnkfile\IsShortcut”, “”, “REG_SZ”

VB6 - 模擬按鍵&滑鼠 (keybd_event , mouse_event)

VB6 - 模擬按鍵&滑鼠 (keybd_event , mouse_event)
位於： Windows — admin @ 10:33 上午
‘宣告API
Private Declare Sub keybd_event Lib “user32″ (ByVal bVk As Byte, ByVal Scan As Byte, ByVal dwFlags As Long, ByVal dwExtraInfo As Long) ‘模擬鍵盤
Private Declare Sub mouse_event Lib “user32″ (ByVal dwFlags As Long, ByVal dx As Long, ByVal dy As Long, ByVal cButtons As Long, ByVal dwExtraInfo As Long) ‘模擬滑鼠

Private Const MOUSEEVENTF_ABSOLUTE = &H8000 ‘
Private Const MOUSEEVENTF_LEFTDOWN = &H2 ‘模擬鼠標左鍵按下
Private Const MOUSEEVENTF_LEFTUP = &H4 ‘模擬鼠標左鍵抬起
Private Const MOUSEEVENTF_MIDDLEDOWN = &H20 ‘模擬鼠標中鍵按下
Private Const MOUSEEVENTF_MIDDLEUP = &H40 ‘模擬鼠標中鍵抬起
Private Const MOUSEEVENTF_MOVE = &H1 ‘移動鼠標
Private Const MOUSEEVENTF_RIGHTDOWN = &H8 ‘模擬鼠標右鍵按下
Private Const MOUSEEVENTF_RIGHTUP = &H10 ‘模擬鼠標右鍵抬起
Private Const KEYEVENTF_KEYUP = &H2 ‘模擬鍵盤按下鍵

‘使用方法例子
mouse_event MOUSEEVENTF_LEFTDOWN Or MOUSEEVENTF_LEFTUP, 0, 0, 0, 0 ‘按下滑鼠左鍵下上
keybd_event 8, KEYEVENTF_KEYUP, 0, 0 ‘ 8 = 按下Enter鍵

建立AccessDB

Option Explicit

Private Sub CreateAccDB(ByVal MdbFileName As String) ' 建立 MDB
CreateObject("DAO.DBEngine.36").CreateDatabase _
MdbFileName, ";LANGID=0x0404;CP=950;COUNTRY=0"
End Sub


Private Sub Command1_Click()
Dim strMDBfile As String

strMDBfile = "C:\report\Test.mdb"
If Dir(strMDBfile) = "" Then CreateAccDB strMDBfile
If Dir(strMDBfile) <> "" Then MsgBox "建立完成"

CreateTable2 strMDBfile


End Sub

Sub CreateTable(strMDBfile As String)
Dim cn As ADODB.Connection
Set cn = CreateObject("ADODB.Connection")
Dim rs As ADODB.Recordset
Dim strSql As String
Dim Tbl As New Table
Dim Cat As ADOX.Catalog
Dim i As Integer
'Set Tbl = CreateObject("Table")
Set Cat = CreateObject("ADOX.Catalog")
With cn
.ConnectionString = "provider=sqloledb.1;persist security info=false;user id=sa;password=i513;initial catalog=apcb;data source=apcb08"
.Open
End With

strSql = "select * from K_HubMtl_Stocks"

Set rs = cn.Execute(strSql)

'Dim Tbl As New Table
'Dim Cat As New ADOX.Catalog

Cat.ActiveConnection = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & strMDBfile & ";"
Tbl.Name = "MyTable"
For i = 0 To rs.Fields.Count - 1
Tbl.Columns.Append rs.Fields(i).Name, adVarWChar, 200
'Select Case rs.Fields(i).Type
' Case 2
' Tbl.Columns.Append rs.Fields(i).Name, adInteger
'Case 135
' Tbl.Columns.Append rs.Fields(i).Name, adDate
' Case 200
' Tbl.Columns.Append rs.Fields(i).Name, adVarChar, rs.Fields(i).DefinedSize
'Case 131
' Tbl.Columns.Append rs.Fields(i).Name, adNumeric, rs.Fields(i).DefinedSize

'End Select
Next i

Cat.Tables.Append Tbl

'塞資料


cn.Close
Set rs = Nothing
Set cn = Nothing
Set Tbl = Nothing
Set Cat = Nothing
End Sub

Sub CreateTable2(strMDBfile As String)
Dim cn As ADODB.Connection
Set cn = CreateObject("ADODB.Connection")

Dim rs As ADODB.Recordset

Dim strSql As String

With cn
.ConnectionString = "provider=sqloledb.1;persist security info=false;user id=sa;password=i513;initial catalog=apcb;data source=apcb08"
.Open
End With

With Adodc1
.ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & strMDBfile & ";"
.RecordSource = "select * from MyTable"
End With


strSql = "select * from K_HubMtl_Stocks"

Set rs = cn.Execute(strSql)


'以下在用迴圈把資料add到acess裡面...
With rs
Do
Adodc1.Recordset.AddNew .Fields(0).Name, .Fields(0).Value
.MoveNext
While Not .EOF
End With

cn.Close
Set rs = Nothing
Set cn = Nothing
End Sub

如何用VBA or VB6將Excel資料匯出到Access 資料庫

Sub test()
Dim cn As Object
Dim rs As Object
Dim rs2 As Object
Dim i As Long
Dim iCount As Long
Set cn = CreateObject("adodb.connection")
Set rs = CreateObject("adodb.recordset")
Set rs2 = CreateObject("adodb.recordset")
cn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=c:\temp\db1.mdb;Persist Security Info=False"
rs.cursorlocation = 3
rs.Open "Select * From NewData", cn, 1, 3
For i = 1 To 65535
iCount = 0
If Range("A" & i).Text <> "" Then
If rs2.State = 1 Then rs2.Close
rs2.cursorlocation = 3
rs2.Open "Select * From NewData where [編號]=" & Range("A" & i).Text, cn, 0, 1 '數字要這樣
'rs2.Open "Select * From NewData where 編號='" & Range("A" & i).Text & "'", cn, 0, 1 '文字改這樣
iCount = rs2.RecordCount
End If
If iCount = 0 Then
rs.addnew
rs("編號") = IIf(Range("A" & i).Text = "", Null, Range("A" & i).Text)
End If
rs("名稱") = IIf(Range("B" & i).Text = "", Null, Range("B" & i).Text)
rs("數量") = IIf(Range("C" & i).Text = "", Null, Range("C" & i).Text)
If rs("編號") & "" = "" And rs("名稱") & "" = "" And rs("數量") & "" = "" Then
rs.cancelupdate
Exit For
End If
rs.Update
Next
End Sub

用VB開啟檔案(IE,記事本)

Set ob = CreateObject("WScript.Shell")
ob.Run "Notepad D:\SKBANK\SendMail\HRPL.htm"
ob.Run "IEXPLORE " + App.Path + "\HRPL.htm"

用VB控制Excel

Dim ExcelApp As Excel.Application

Set ExcelApp = CreateObject("Excel.Application")
With ExcelApp
.Application.DisplayAlerts = False '抑制刪除警告提示訊息
.Workbooks.Open FileName:=App.Path + "\Sample.xls"
.Visible = True

.Workbooks.Open FileName:=strFileName + ".xls"

.Range("D" + CStr(i)).Select
strTmp = .ActiveCell.FormulaR1C1

.Range("A3:S" + CStr(i)).Select
.Selection.Copy
.Windows("Sample.xls").Activate
.Range("A" + CStr(m)).Select
.ActiveSheet.Paste
.Windows(FileName + ".xls").Close

.ActiveSheet.PageSetup.PrintArea = "$D$1:$K$" + CStr(m - 1)

.Columns("T:T").Select
.Selection.WrapText = True

'另存新檔
.ActiveWorkbook.SaveAs FileName:=App.Path + "\Merge.xls",FileFormat:=xlNormal, Password:="", WriteResPassword:="", ReadOnlyRecommended:=False, CreateBackup:=False
'關閉檔案
.ActiveWindow.Close

Set ExcelApp = Nothing

用VB控制ADODB.Connection

Set cnKPI = New ADODB.Connection

cnSQL = "Provider=SQLOLEDB.1;Persist Security Info=False;" & _
"USER ID = sa;password=xxxxx;initial catalog=KPxxxS;" & _
"Data Source=maxx05kxxxb"

cnKPI.ConnectionString = cnSQL

cnKPI.Open

用VB控制OutLookExchange發信

Dim olApp As Object
Dim Itm As Object


Dim FileName As String
Dim strBody As String

Set olApp = CreateObject("Outlook.Application")
Set Itm = olApp.CreateItem(0)
With Itm
.Subject = "薪資清冊及其它"
.To = strMail
.Body = "薪資清冊及其它"

.Attachments.Add strFileName1
.Attachments.Add strFileName2
'直接發信
' .Send
'儲存
' .Save
'啟動視窗

.Display

用VB控制FileSystem--開啟,建立文字檔

Dim fs, FileName, txtf
Set fs = CreateObject("Scripting.FileSystemObject")
FileName = "D:\Bank\" + strFileName

If fs.FileExists(FileName) Then
'資料加在文字檔後面
Set txtf = fs.OpenTextFile(FileName, 8, False)
Else
Set txtf = fs.CreateTextFile(FileName, True)
End If
txtf.WriteLine CStr(strString)
Set fs = Nothing
'刪除檔案
fs.DeleteFile (strFileName)