Microsoft Office Excel ® Kod Kılavuzu

Microsoft Office Excel® Code Guide

20 Nisan 2012 Cuma

RegOpenKeyA & RegSetValueEx Functions


'UserForm1

'A. Available References List
'1) Name: VBA, Description: Visual Basic For Applications, FullPath: C:\Program Files (x86)\Common Files\Microsoft Shared\VBA\VBA6\VBE6.DLL
'2) Name: Excel, Description: Microsoft Excel 11.0 Object Library, FullPath: C:\Program Files (x86)\Microsoft Office\OFFICE11\EXCEL.EXE
'3) Name: stdole, Description: OLE Automation, FullPath: C:\Windows\SysWOW64\stdole2.tlb
'4) Name: Office, Description: Microsoft Office 11.0 Object Library, FullPath: C:\Program Files (x86)\Common Files\Microsoft Shared\OFFICE11\MSO.DLL
'5) Name: MSForms, Description: Microsoft Forms 2.0 Object Library, FullPath: C:\Windows\SysWOW64\FM20.DLL
'B. Available Tools List
'1) İmage1, Label1, Label2
'2) Label3
'3) Image2
'4) Label4, Label5, CommandButton1, CommandButton2
'C. Additional References List
'1) C:\Windows\System32\advapi32.dll
Option Explicit
Private i As Single
Private ii As Single
Private Nesne As OLEObject
Private No As Double
Private Type GUID
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(0 To 7) As Byte
End Type
Private GD As GUID
Private Type uPicDesc
Size As Long
Type As Long
hPic As Long
hPal As Long
End Type
Private PD As uPicDesc
Private Declare Function IsClipboardFormatAvailable Lib "user32" (ByVal wFormat As Integer) As Long
Private Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function GetClipboardData Lib "user32" (ByVal wFormat As Integer) As Long
Private Declare Function CloseClipboard Lib "user32" () As Long
Private Declare Function OleCreatePictureIndirect Lib "olepro32.dll" (PicDesc As uPicDesc, RefIID As GUID, ByVal fPictureOwnsHandle As Long, IPic As IPicture) As Long
Private Declare Function CopyEnhMetaFile Lib "gdi32" Alias "CopyEnhMetaFileA" (ByVal hemfSrc As Long, ByVal lpszFile As String) As Long
Private Declare Function CopyImage Lib "user32" (ByVal handle As Long, ByVal un1 As Long, ByVal n1 As Long, ByVal n2 As Long, ByVal un2 As Long) As Long
Private Tablo As Long
Private Tip As Long
Private Kopya As Long
Private IP As IPictureDisp
Private Alan
Private Declare Function RegOpenKeyA Lib "advapi32.dll" (ByVal Key As Long, ByVal subKey As String, NewKey As Long) As Long
Private Declare Function RegSetValueEx Lib "advapi32.dll" Alias "RegSetValueExA" (ByVal hkey As Long, ByVal lpValueName As String, ByVal Reserved As Long, ByVal dwType As Long, lpData As Any, ByVal cbData As Long) As Long
Private Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hkey As Long) As Long
Private DP As String 'Default Printer
Private OF As String 'Out File
Private RR As Long 'Registre Result
Private MR As Long 'My Result
Private CU As Long 'Current User
Private PP As String 'PDF Path
Private Const RS As Long = 1 'Reg Size
Private Sub UserForm_Initialize()
On Error Resume Next
Me.Caption = "[PBİD®] RegOpenKeyA & RegSetValueEx Functions"
Call Ekran_Kur
End Sub
Private Sub CommandButton1_Click()
On Error Resume Next
Call Make_Report
DoEvents
Call Print_Options(Range("A1:F26").Address)
DoEvents
Call Make_Picture(Range("A1:F26").Address)
End Sub
Private Sub CommandButton2_Click()
On Error Resume Next
Call PrintPDF_Byadvapi32
End Sub
Private Sub PrintPDF_Byadvapi32()
On Error Resume Next
Sheets(1).Select
CU = &H80000001
DP = Application.ActivePrinter
PP = ActiveWorkbook.Path & Application.PathSeparator
OF = PP & Left(ActiveWorkbook.Name, Len(ActiveWorkbook.Name) - 4) & ".pdf"
Label5.Caption = OF
RR = RegOpenKeyA(CU, "Software\Adobe\Acrobat Distiller\PrinterJobControl", MR)
RR = RegSetValueEx(MR, Application.Path & "\Excel.exe", 0&, RS, ByVal OF, Len(OF))
RR = RegCloseKey(MR)
ThisWorkbook.ActiveSheet.PrintOut copies:=1, ActivePrinter:="Adobe PDF"
Application.ActivePrinter = DP
End Sub
Private Sub PrintPDF_Byuser32()
On Error Resume Next
Application.ActivePrinter = "Adobe PDF on Ne00:"
ActiveWindow.SelectedSheets.PrintOut copies:=1, ActivePrinter:="Adobe PDF on Ne00:", Collate:=True
End Sub
Private Sub Make_Report()
On Error Resume Next
Sheets(1).Select
ActiveSheet.Unprotect
ActiveSheet.DrawingObjects.Select
Selection.Delete
Cells.Select
Selection.Delete Shift:=xlUp
Range("A1").Select
Columns("A:A").ColumnWidth = 8
Columns("B:B").ColumnWidth = 60
Columns("C:C").ColumnWidth = 8
Columns("D:D").ColumnWidth = 12
Columns("E:E").ColumnWidth = 16
Columns("F:F").ColumnWidth = 16
Rows("1:26").RowHeight = 15
Rows("4:4").RowHeight = 6
Rows("5:5").RowHeight = 21
Rows("26:26").RowHeight = 21
Set Nesne = ActiveSheet.OLEObjects.Add(ClassType:="Forms.Image.1", Link:=False, DisplayAsIcon:=False, Left:=0.75, Top:=0.75, Width:=44.75, Height:=44.75)
With Nesne.Object
.Picture = Resim(URL3)
.PictureAlignment = fmPictureAlignmentCenter
.PictureSizeMode = fmPictureSizeModeStretch
.PictureTiling = False
End With
DoEvents
With Range("A1:F26").Interior
.ColorIndex = 2
.Pattern = xlSolid
End With
With Range("B1")
.Font.Bold = True
.Font.ColorIndex = 9
.Value = " ABC Company"
End With
With Range("B2")
.Font.Bold = True
.Font.ColorIndex = 9
.Value = " DEF Project"
End With
With Range("B3")
.Font.Bold = True
.Font.ColorIndex = 9
.Value = " GHI Report"
End With
With Range("F3")
.Font.Bold = True
.Font.ColorIndex = 9
.Value = VBA.Now
.Interior.ColorIndex = 36
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
Call Draw_Frame(.Address)
End With
With Range("A5:F5")
.Font.Bold = True
.Font.ColorIndex = 9
.Cells(1, 1).Value = "ID"
.Cells(1, 2).Value = "ID Name"
.Cells(1, 3).Value = "Unit"
.Cells(1, 4).Value = "Unit Amount"
.Cells(1, 5).Value = "Unit Price"
.Cells(1, 6).Value = "Unit Total"
.Interior.ColorIndex = 36
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
Call Draw_Frame(.Address)
With .Borders(xlInsideVertical)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
End With
With Range("A6:F25")
For i = 1 To 20
For ii = 1 To 6
If 4 > ii Then
.Cells(i, ii).Locked = False
.Cells(i, ii).Font.ColorIndex = 5
.Cells(i, ii).Font.Bold = False
If ii = 1 Then
.Cells(i, ii).Value = VBA.Rnd(10) * 400
.Cells(i, ii).NumberFormat = "00|00|00"
.Cells(i, ii).HorizontalAlignment = xlCenter
.Cells(i, ii).VerticalAlignment = xlBottom
End If
If ii = 2 Then
.Cells(i, ii).Value = VBA.Format(.Cells(i, ii - 1).Value, "00|00|00") & " Ünite Name"
.Cells(i, ii).HorizontalAlignment = xlLeft
.Cells(i, ii).VerticalAlignment = xlBottom
End If
If ii = 3 Then
No = VBA.Round(VBA.Rnd * 9, 0)
If No = 0 Then No = 1
.Cells(i, ii).Value = VBA.Switch(No = 1, "M", No = 2, "Mt", No = 3, "M2", No = 4, "M3", No = 5, "Litre", No = 6, "Kg", No = 7, "Number", No = 8, "LamSum", No = 9, "MxH")
.Cells(i, ii).HorizontalAlignment = xlCenter
.Cells(i, ii).VerticalAlignment = xlBottom
End If
End If
If ii = 4 Or ii = 5 Then
.Cells(i, ii).Locked = False
.Cells(i, ii).Font.ColorIndex = 5
.Cells(i, ii).Font.Bold = False
.Cells(i, ii).NumberFormat = "#,##0.00"
.Cells(i, ii).Value = VBA.Rnd * 1000
End If
If ii = 6 Then
.Cells(i, ii).FormulaR1C1 = "=RC[-2]*RC[-1]"
.Cells(i, ii).Font.ColorIndex = 1
.Cells(i, ii).Font.Bold = False
.Cells(i, ii).NumberFormat = "#,##0.00"
End If
Next ii
Next i
Call Draw_Frame(.Address)
With .Borders(xlInsideVertical)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With .Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
End With
With Range("A26:E26")
.Font.Bold = True
.Font.ColorIndex = 9
.Cells(1, 1).Value = "Grand Total"
.Interior.ColorIndex = 36
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.WrapText = True
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = True
.ReadingOrder = xlContext
.MergeCells = True
Call Draw_Frame(.Address)
End With
With Range("F26")
.Font.Bold = True
.Font.ColorIndex = 9
.Cells(1, 1).FormulaR1C1 = "=SUM(R[-20]C:R[-1]C)"
.Interior.ColorIndex = 36
.HorizontalAlignment = xlRight
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
Call Draw_Frame(.Address)
End With
Call Draw_Frame(Range("F5:F26").Address)
ActiveSheet.Protect
End Sub
Private Sub Draw_Frame(ByVal Alan As String)
On Error Resume Next
With Range(Alan)
With .Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Weight = xlMedium
.ColorIndex = xlAutomatic
End With
With .Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlMedium
.ColorIndex = xlAutomatic
End With
With .Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlMedium
.ColorIndex = xlAutomatic
End With
With .Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlMedium
.ColorIndex = xlAutomatic
End With
End With
End Sub
Private Sub Print_Options(ByVal hAdres As String)
On Error Resume Next
ActiveSheet.PageSetup.PrintArea = hAdres
With ActiveSheet.PageSetup
.LeftHeader = ""
.CenterHeader = ""
.RightHeader = ""
.LeftFooter = "&F&A"
.CenterFooter = ""
.RightFooter = "[PBİD®]"
.LeftMargin = 14
.RightMargin = 14
.TopMargin = 28
.BottomMargin = 14
.HeaderMargin = 0
.FooterMargin = 0
.PrintHeadings = False
.PrintGridlines = False
.PrintComments = xlPrintNoComments
.PrintQuality = 600
.CenterHorizontally = True
.CenterVertically = True
.Orientation = xlLandscape
.Draft = False
.PaperSize = xlPaperA4
.FirstPageNumber = xlAutomatic
.Order = xlDownThenOver
.BlackAndWhite = False
.Zoom = False
.FitToPagesWide = 1
.FitToPagesTall = 1
.PrintErrors = xlPrintErrorsDisplayed
End With
Range("F3").Select
End Sub
Sub Make_Picture(ByVal hAdres As String)
On Error Resume Next
Set Alan = Sheets(1).Range(hAdres)
SavePicture Resim_Yap(Alan), ThisWorkbook.Path & "\Alan1.jpg"
Image2.Picture = LoadPicture(ThisWorkbook.Path & "\Alan1.jpg")
VBA.Kill ThisWorkbook.Path & "\Alan1.jpg"
Set IP = Nothing
End Sub
Private Function Resim_Yap(Kaynak) As IPictureDisp
On Error GoTo Hata
Kaynak.CopyPicture
Tip = IIf(IsClipboardFormatAvailable(2) <> 0, 2, 14)
If IsClipboardFormatAvailable(Tip) <> 0 Then
If OpenClipboard(0) > 0 Then
Tablo = GetClipboardData(Tip)
If Tip = 2 Then
Kopya = CopyImage(Tablo, 0, 0, 0, &H4)
Else
Kopya = CopyEnhMetaFile(Tablo, vbNullString)
End If
CloseClipboard
If Tablo <> 0 Then
With GD
.Data1 = &H7BF80980
.Data2 = &HBF32
.Data3 = &H101A
.Data4(0) = &H8B
.Data4(1) = &HBB
.Data4(2) = &H0
.Data4(3) = &HAA
.Data4(4) = &H0
.Data4(5) = &H30
.Data4(6) = &HC
.Data4(7) = &HAB
End With
With PD
.Size = Len(PD)
.Type = IIf(Tip = 2, 1, 4)
.hPic = Kopya
End With
OleCreatePictureIndirect PD, GD, True, IP
Set Resim_Yap = IP
End If
End If
End If
Exit Function
Hata:
Set Resim_Yap = Nothing
End Function
Private Sub Ekran_Kur()
On Error Resume Next
With Me
.BackColor = vbWhite
.Height = 368
.Width = 448
.Picture = Resim(URL1)
.PictureAlignment = fmPictureAlignmentCenter
.PictureSizeMode = fmPictureSizeModeClip
.PictureTiling = True
.SpecialEffect = fmSpecialEffectFlat
With Image1
.Top = 6
.Left = 6
.Height = 24
.Width = 24
.BackStyle = fmBackStyleTransparent
.BorderStyle = fmBorderStyleSingle
.BorderColor = vbBlue
.Picture = Resim(URL2)
.PictureAlignment = fmPictureAlignmentCenter
.PictureSizeMode = fmPictureSizeModeClip
.PictureTiling = False
End With
With Label1
.Left = 36
.Top = 6
.Height = 12
.Width = 420
.Caption = "Mustafa ULUSARAÇ"
.BorderStyle = fmBorderStyleNone
.SpecialEffect = fmSpecialEffectFlat
.BackStyle = fmBackStyleTransparent
.Font.Bold = True
.Font.Name = "Arial"
.ForeColor = vbBlue
End With
With Label2
.Left = 36
.Top = 18
.Height = 12
.Width = 420
.Caption = "01ulusarac@superonline.com"
.BorderStyle = fmBorderStyleNone
.SpecialEffect = fmSpecialEffectFlat
.BackStyle = fmBackStyleTransparent
.Font.Bold = True
.Font.Name = "Arial"
.ForeColor = vbBlue
End With
With Label3
.Left = 6
.Top = 36
.Height = 12
.Width = 432
.Caption = "Report Picture"
.SpecialEffect = fmSpecialEffectEtched
.BackStyle = fmBackStyleTransparent
.ForeColor = &H808000
End With
With Image2
.Top = 48
.Left = 6
.Height = 270
.Width = 432
.BackStyle = fmBackStyleTransparent
.Picture = Nothing
.PictureAlignment = fmPictureAlignmentCenter
.PictureSizeMode = fmPictureSizeModeStretch
.PictureTiling = False
.SpecialEffect = fmSpecialEffectEtched
End With
With Label4
.Left = 6
.Top = 324
.Height = 18
.Width = 54
.Caption = "Report File"
.SpecialEffect = fmSpecialEffectEtched
.BackStyle = fmBackStyleTransparent
.ForeColor = &H808000
End With
With Label5
.Left = 60
.Top = 324
.Height = 18
.Width = 264
.Caption = ""
.SpecialEffect = fmSpecialEffectEtched
.BackStyle = fmBackStyleTransparent
.ForeColor = &H808000
End With
With CommandButton1
.Left = 330
.Top = 324
.Height = 18
.Width = 54
.Caption = "Make Report"
.BackStyle = fmBackStyleTransparent
.ForeColor = &H808000
End With
With CommandButton2
.Left = 384
.Top = 324
.Height = 18
.Width = 54
.Caption = "Print to PDF"
.BackStyle = fmBackStyleTransparent
.ForeColor = &H808000
End With
End With
End Sub

'Module1

Option Explicit
Public Declare Function CLSIDFromString Lib "ole32" (ByVal lpstrCLSID As Long, lpCLSID As Any) As Long
Public Declare Function OleLoadPicturePath Lib "oleaut32" (ByVal szURLorPath As Long, ByVal punkCaller As Long, ByVal dwReserved As Long, ByVal clrReserved As OLE_COLOR, ByRef riid As Any, ByRef ppvRet As Any) As Long
Public IPic(15) As Byte
Public Const ClsID As Variant = "{7BF80980-BF32-101A-8BBB-00AA00300CAB}"
Public Const URL1 As String = "http://2.bp.blogspot.com/-G3KDFVP7V0Q/TcUhtYtMifI/AAAAAAAACw0/Ta6mFpFJtZ8/s1600/39.bmp"
Public Const URL2 As String = "http://2.bp.blogspot.com/_hsHTxo_5L8E/S78EbvJyhRI/AAAAAAAACS0/txbOQ1qubg8/s1600/PB%C4%B0D_jpg.jpg"
Public Const URL3 As String = "http://4.bp.blogspot.com/-bcs-JKecB0w/To74rY0qhXI/AAAAAAAAC3w/r1Rvc8D7A_Q/s1600/excel_2003.bmp"
Public URL As String
Sub Form_Aç() 'Open UserForm
On Error Resume Next
UserForm1.Show 0
End Sub
Public Function Resim(URL) As Picture 'Picture load frome web address...
On Error Resume Next
CLSIDFromString StrPtr(ClsID), IPic(0)
OleLoadPicturePath StrPtr(URL), 0&, 0&, 0&, IPic(0), Resim
End Function
'Sub References_List()
'On Error Resume Next
'Dim Eleman, No
'No = 1
'For Each Eleman In ThisWorkbook.VBProject.References
'Sheets(1).Cells(No, 1) = No & ") Name: "
'Sheets(1).Cells(No, 2) = Eleman.Name
'Sheets(1).Cells(No, 3) = ", Description: "
'Sheets(1).Cells(No, 4) = Eleman.Description
'Sheets(1).Cells(No, 5) = ", FullPath: "
'Sheets(1).Cells(No, 6) = Eleman.FullPath
'No = No + 1
'Next Eleman
'End Sub

Hiç yorum yok:

Blog Arşivi

Bu gadget'ta bir hata oluştu

Bu Blogda Ara

Contributor

Contributor
Mustafa ULUSARAÇ İstanbul, TÜRKİYE
free counters
T. C. Central Bank Indicative Exchange Rates
Currency Exchange Rate Widget,Currency Converter Widget
Borsa İstanbul