Microsoft Office Excel ® Kod Kılavuzu

Microsoft Office Excel® Code Guide

20 Şubat 2004 Cuma

Preview Windows MetaFile (AutoCat Files) On Excel


 
'UserForm1
 
'A) Windows XP® Office 2003® Normal Referance List
    'Visual Basic For Aplication
    'Microsoft Forms 2.0 Object Library
    'Microsoft Excel 11.0 Object Library
    'OLE Automation
    'Microsoft Office 11.0 Object Library
    'Microsoft Office Web Components 11.0
'B) UserForm1 E Eklenen Araçlar (Add Tools)
    'Frame1
    'Frame1\Image1, Label1, Label2
    'CommandButton1,Label4, Label5, Label6
    'Frame2
    'Frame2\Frame3
'C) If you drag the mouse over the picture (Frame2); appears Frame3
Option Explicit
Dim Yol
Dim Mercek As Double, Büyütme As Double
Dim ÇerçeveDüzenleme As New Class1
Private Sub UserForm_Initialize()
    On Error Resume Next
    Me.Caption = "[PBİD ®] Preview Windows MetaFile (Frome AutoCat Files) On Excel"
    Mercek = 4 '%400
    Büyütme = 0.4
    Call EkranDüzenle
    Application.Visible = False
    Application.VBE.MainWindow.Visible = False
    Set ÇerçeveDüzenleme.LogoYerleştir = Me
    Set ÇerçeveDüzenleme.Form1 = Me
End Sub
Private Sub UserForm_Activate()

    On Error Resume Next
    With Me
        .Top = (Application.Height - .Height) / 2
        .Left = (Application.Width - .Width) / 2
    End With
End Sub
Private Sub UserForm_Resize()

    On Error Resume Next
    With Me
        .Top = (Application.Height - .Height) / 2
        .Left = (Application.Width - .Width) / 2
    End With
    Call EkranDüzenle
End Sub
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)

    On Error Resume Next
    Application.Visible = True
    End
End Sub
Private Sub CommandButton1_Click()

    On Error GoTo Hata:
    Yol = Application.GetOpenFilename("Windows MetaFile Dosyaları(*.wmf;*.All),*.wmf;*.All", , "[PBİD®] Sayfaya eklenecek AutoCat Çizim Örneği seçimi...", , False)
    If Yol = False Then Exit Sub
    Label3.Caption = " Windows MetaFile: " & VBA.Trim(Yol)
    With Frame2
        .Picture = LoadPicture(VBA.Trim(Yol))
        .Zoom = 100
    End With
    Exit Sub
Hata:
End Sub
Private Sub Frame2_Zoom(Percent As Integer)

    On Error Resume Next
    Select Case Percent
    Case 10 To 400
        Frame2.ScrollWidth = VBA.Round(Frame2.Width * Percent / 100, 0)
        Frame2.ScrollHeight = VBA.Round(Frame2.Height * Percent / 100, 0)
    End Select
End Sub
Private Sub Frame2_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal y As Single) 'If you drag the mouse over the picture appears çerçeve3
    On Error Resume Next
    If Button = 1 Then
        Frame2.MousePointer = fmMousePointerCross
        With Frame3
            .BackColor = vbBlack
            .Width = Frame2.Width * Büyütme
            .Height = Frame2.Height * Büyütme
            .Left = Frame2.Width - 12 - .Width - Frame2.Left
            .Top = 6
            .SpecialEffect = 0
            .BorderStyle = 1
            .BorderColor = vbBlue
            .Picture = Frame2.Picture
            .PictureSizeMode = fmPictureSizeModeStretch
            .ScrollHeight = Frame2.ScrollHeight / (Frame2.Zoom / 100) * Mercek
            .ScrollWidth = Frame2.ScrollWidth / (Frame2.Zoom / 100) * Mercek
            .Zoom = 400
            .ScrollLeft = x / (Frame2.Zoom / 100) * Mercek
            .ScrollTop = y / (Frame2.Zoom / 100) * Mercek
            .Visible = True
        End With
        Label4.Caption = VBA.Round(x, 0)
        Label5.Caption = VBA.Round(y, 0)
        Label6.Caption = VBA.Format(Frame3.Zoom, "%#")
        DoEvents
    Else
        Frame2.MousePointer = fmMousePointerCross
        Frame3.Visible = False
        Label4.Caption = VBA.Round(x, 0)
        Label5.Caption = VBA.Round(y, 0)
        Label6.Caption = VBA.Format(Frame2.Zoom, "%#")
        DoEvents
    End If
End Sub
Sub Kapat()

    Set ÇerçeveDüzenleme.FormYokol = Me
    Unload Me
    Application.Visible = True
    ActiveWorkbook.Save
    'Application.Quit
End Sub
Sub EkranDüzenle()

    On Error Resume Next
    With Me
        .BackColor = &H8000000F
        With Frame1
            .Caption = ""
            .Top = -2
            .Left = -2
            .Height = 36
            .Width = Me.Width + 12
            .Picture = LoadPicture("C:\Documents and Settings\PC\Desktop\BLOGSPOT\zarifVİSTA.bmp")
            .PictureAlignment = fmPictureAlignmentTopLeft
            .PictureSizeMode = fmPictureSizeModeClip
            .PictureTiling = False
            With Image1
                .BackStyle = fmBackStyleTransparent
                .BorderColor = &HFF0000
                .BorderStyle = fmBorderStyleSingle
                .Top = 6
                .Left = 6
                .Height = 24
                .Width = 24
                If .Picture = vbNull Then .Picture = LoadPicture("C:\Documents and Settings\PC\Desktop\BLOGSPOT\Örnekİkonlar\PBİD.ico")
            End With
            With Label1
                .Caption = " " & "Mustafa ULUSARAÇ"
                .BackStyle = fmBackStyleTransparent
                .BorderStyle = fmBorderStyleNone
                .SpecialEffect = fmSpecialEffectFlat
                .Left = 30
                .Top = 6
                .Height = 12
                .Width = 198
                .Font.Bold = True
                .ForeColor = &HFF0000
            End With
            With Label2
                .Caption = " " & "
01ulusarac@superonline.com"
                .BackStyle = fmBackStyleTransparent
                .BorderStyle = fmBorderStyleNone
                .SpecialEffect = fmSpecialEffectFlat
                .Left = 30
                .Top = 18
                .Height = 12
                .Width = 198
                .Font.Bold = True
                .ForeColor = &HFF0000
            End With
        End With
        With Label3
            .Caption = " " & "
01ulusarac@superonline.com"
            .BackStyle = fmBackStyleTransparent
            .BorderStyle = fmBorderStyleNone
            .SpecialEffect = fmSpecialEffectEtched
            .Left = 6
            .Top = 42
            .Height = 18
            .Width = Me.Width - .Left - (36 * 3) - 24 - 6
            .Font.Bold = True
            .ForeColor = &HFF0000
        End With
        With Label4
            .Caption = ""
            .SpecialEffect = fmSpecialEffectEtched
            .Left = Label3.Left + Label3.Width
            .Top = 42
            .Height = 18
            .Width = 36
            .Font.Bold = True
            .ForeColor = &HFF0000
            .TextAlign = fmTextAlignCenter
        End With
        With Label5
            .Caption = ""
            .SpecialEffect = fmSpecialEffectEtched
            .Left = Label4.Left + Label4.Width
            .Top = 42
            .Height = 18
            .Width = 36
            .Font.Bold = True
            .ForeColor = &HFF0000
            .TextAlign = fmTextAlignCenter
        End With
        With Label6
            .Caption = ""
            .SpecialEffect = fmSpecialEffectEtched
            .Left = Label5.Left + Label5.Width
            .Top = 42
            .Height = 18
            .Width = 36
            .Font.Bold = True
            .ForeColor = &HFF0000
            .TextAlign = fmTextAlignCenter
        End With
        With CommandButton1
            .Top = 42
            .Height = 18
            .Width = 18
            .Left = Label6.Left + Label6.Width
            .Picture = Application.CommandBars.Item(3).Controls(2).Picture
        End With
        With Frame2
            .Caption = ""
            .Left = 6
            .Top = 60
            .Width = Me.Width - .Left - 12
            .Height = Me.Height - .Top - 24 - 6
            .ScrollBars = fmScrollBarsBoth
            .PictureSizeMode = fmPictureSizeModeStretch
            .BackColor = &H80000006
            .BorderStyle = fmBorderStyleSingle
            .BorderColor = vbBlue
            With Frame3
                .Caption = ""
                .Left = 6
                .Top = 6
                .Width = 36
                .Height = 36
                .ScrollBars = fmScrollBarsNone
                .PictureSizeMode = fmPictureSizeModeClip
                .BackColor = &H80000006
                .BorderStyle = fmBorderStyleSingle
                .BorderColor = vbBlue
            End With
        End With
    End With
End Sub
 
'Module1
 
Sub FormAç()
    On Error Resume Next
    Load UserForm1
End Sub
 
'Class1
 
Option Explicit
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal Class_Adı As String, ByVal Ekran_Adı As String) As Long
Private Declare Function FindWindowA Lib "user32" (ByVal Class_Adı As String, ByVal Ekran_Adı As String) As Long
Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal Pencere As Long, ByVal Koordinat As Long) As Long
Private Declare Function GetWindowLongA Lib "user32" (ByVal Pencere_Düzeni As Long, ByVal Koordinat As Long) As Long
Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal Pencere_Düzeni As Long, ByVal Koordinat As Long, ByVal Yeni_Boyut As Long) As Long
Private Declare Function SetWindowLongA Lib "user32" (ByVal Pencere As Long, ByVal Koordinat As Long, ByVal Yeni_Boyut As Long) As Long
Private Declare Function ShowWindow Lib "user32" (ByVal Pencere As Long, ByVal Eylem As Long) As Long
Private Declare Function DrawMenuBar Lib "user32" (ByVal Pencere As Long) As Long
Private Declare Function SetLayeredWindowAttributes Lib "user32" (ByVal Pencere As Long, ByVal Anahtar As Long, ByVal Yoğunluk As Byte, ByVal İkinci_İşaret As Long) As Long
Private Declare Function GetSystemMenu Lib "user32" (ByVal Pencere As Long, ByVal Eski_Durum As Long) As Long
Private Declare Function DeleteMenu Lib "user32" (ByVal FormMenü As Long, ByVal Pozisyon As Long, ByVal İlk_İşaret As Long) As Long
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal Pencere_Düzeni As Long, ByVal Mesaj As Long, ByVal Değişken1 As Long, Değişken2 As Any) As Long
Dim Çerçeve As Long, Tarz As Long, Logo As Long
Dim i As Integer, Derece As Double
Public Property Set LogoYerleştir(Form As Object)
    On Error Resume Next
    Logo = Form.Image1.Picture.Handle
    Çerçeve = FindWindow(vbNullString, Form.Caption)
    Call SendMessage(Çerçeve, &H80, 0&, ByVal Logo)
    Call SendMessage(Çerçeve, &H80, 1&, ByVal Logo)
End Property
Public Property Set Form1(Form As Object)

    On Error Resume Next
    Çerçeve = FindWindow(vbNullString, Form.Caption)
    Tarz = GetWindowLong(Çerçeve, (-16)) Or &H80000 Or &H20000 Or &H10000
    SetWindowLong Çerçeve, (-16), Tarz
    ShowWindow Çerçeve, 3 '5= Normal Açar
    DrawMenuBar Çerçeve
End Property
Public Property Set FormGörün(Form As Object)

    On Error Resume Next
    For i = 1 To 255
        SetWindowLong Çerçeve, (-20), GetWindowLong(Çerçeve, (-20)) Or &H80000
        SetLayeredWindowAttributes Çerçeve, 0, i, &H2
        Çerçeve = FindWindow(vbNullString, Form.Caption)
        Tarz = GetWindowLong(Çerçeve, (-16)) Or &H80000 Or &H20000 Or &H10000
        SetWindowLong Çerçeve, (-16), Tarz
        ShowWindow Çerçeve, 5 '3=Geniş Açar
        DrawMenuBar Çerçeve
        DoEvents
    Next i
End Property
Public Property Set FormYokol(Form As Object)

    On Error Resume Next
    For i = 1 To 255
        SetWindowLong Çerçeve, (-20), GetWindowLong(Çerçeve, (-20)) Or &H80000
        SetLayeredWindowAttributes Çerçeve, 0, (255 - i), &H2
        Çerçeve = FindWindow(vbNullString, Form.Caption)
        Tarz = GetWindowLong(Çerçeve, (-16)) Or &H80000 Or &H20000 Or &H10000
        SetWindowLong Çerçeve, (-16), Tarz
        ShowWindow Çerçeve, 5
        DrawMenuBar Çerçeve
        DoEvents
    Next i
End Property
Public Property Set FormManuelYokol(Form As Object)

    On Error Resume Next
    Derece = Form.Slider1.Value
    SetWindowLong Çerçeve, (-20), GetWindowLong(Çerçeve, (-20)) Or &H80000
    SetLayeredWindowAttributes Çerçeve, 0, (255 - Derece), &H2
    Çerçeve = FindWindow(vbNullString, Form.Caption)
    Tarz = GetWindowLong(Çerçeve, (-16)) Or &H80000 Or &H20000 Or &H10000
    SetWindowLong Çerçeve, (-16), Tarz
    ShowWindow Çerçeve, 5 '3
    DrawMenuBar Çerçeve
    DoEvents
End Property
Public Property Set KapatEtkili(Form As Object)

    On Error Resume Next
    DeleteMenu GetSystemMenu(FindWindow("ThunderDFrame", Form.Caption), 1), &HF060, 0&
    DrawMenuBar Çerçeve
End Property
Public Property Set KapatEtkisiz(Form As Object)

    On Error Resume Next
    DeleteMenu GetSystemMenu(FindWindow("ThunderDFrame", Form.Caption), 0), &HF060, 0&
    DrawMenuBar Çerçeve
End Property
 
 


1 yorum:

Adsız dedi ki...

Hello! Quick question that's totally off topic. Do you know how tto
make your site mobile friendly? My website looks weird when browsing from
my iphone4. I'm trying to find a template or plugin
that mighht be able to fix this problem. If you have
any recommendations, please share. Many thanks!


Here is my web page; christian divorce advice for women

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